--- loncom/metadata_database/searchcat.pl 2004/01/05 15:54:22 1.54
+++ loncom/metadata_database/searchcat.pl 2004/04/08 15:57:32 1.55
@@ -2,7 +2,7 @@
# The LearningOnline Network
# searchcat.pl "Search Catalog" batch script
#
-# $Id: searchcat.pl,v 1.54 2004/01/05 15:54:22 www Exp $
+# $Id: searchcat.pl,v 1.55 2004/04/08 15:57:32 matthew Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -66,189 +66,33 @@ and correct user experience.
use strict;
+use DBI;
use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;
+use LONCAPA::lonmetadata;
use IO::File;
use HTML::TokeParser;
-use DBI;
use GDBM_File;
use POSIX qw(strftime mktime);
+use File::Find;
-require "find.pl";
-
-my @metalist;
-
-my $simplestatus='';
-my %countext=();
-
-# ----------------------------------------------------- write out simple status
-sub writesimple {
- open(SMP,'>/home/httpd/html/lon-status/mysql.txt');
- print SMP $simplestatus."\n";
- close(SMP);
-}
-
-sub writecount {
- open(RSMP,'>/home/httpd/html/lon-status/rescount.txt');
- foreach (keys %countext) {
- print RSMP $_.'='.$countext{$_}.'&';
- }
- print RSMP 'time='.time."\n";
- close(RSMP);
-}
-
-# -------------------------------------- counts files with different extensions
-sub count {
- my $file=shift;
- $file=~/\.(\w+)$/;
- my $ext=lc($1);
- if (defined($countext{$ext})) {
- $countext{$ext}++;
- } else {
- $countext{$ext}=1;
- }
-}
-# ----------------------------------------------------- Un-Escape Special Chars
-
-sub unescape {
- my $str=shift;
- $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
- return $str;
-}
-
-# -------------------------------------------------------- Escape Special Chars
+##
+## Use variables for table names so we can test this routine a little easier
+my $oldname = 'metadata';
+my $newname = 'newmetadata';
-sub escape {
- my $str=shift;
- $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
- return $str;
-}
-
-# ------------------------------------------- Code to evaluate dynamic metadata
-
-sub dynamicmeta {
- my $url=&declutter(shift);
- $url=~s/\.meta$//;
- my %returnhash=(
- 'count' => 0,
- 'course' => 0,
- 'course_list' => '',
- 'avetries' => 'NULL',
- 'avetries_list' => '',
- 'stdno' => 0,
- 'stdno_list' => '',
- 'usage' => 0,
- 'usage_list' => '',
- 'goto' => 0,
- 'goto_list' => '',
- 'comefrom' => 0,
- 'comefrom_list' => '',
- 'difficulty' => 'NULL',
- 'difficulty_list' => '',
- 'clear' => 'NULL',
- 'technical' => 'NULL',
- 'correct' => 'NULL',
- 'helpful' => 'NULL',
- 'depth' => 'NULL',
- 'comments' => ''
- );
- my ($adomain,$aauthor)=($url=~/^(\w+)\/(\w+)\//);
- my $prodir=&propath($adomain,$aauthor);
-
-# Get metadata except counts
- if (tie(my %evaldata,'GDBM_File',
- $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) {
- my %sum=();
- my %cnt=();
- my %concat=();
- my %listitems=(
- 'course' => 'add',
- 'goto' => 'add',
- 'comefrom' => 'add',
- 'avetries' => 'avg',
- 'stdno' => 'add',
- 'difficulty' => 'avg',
- 'clear' => 'avg',
- 'technical' => 'avg',
- 'helpful' => 'avg',
- 'correct' => 'avg',
- 'depth' => 'avg',
- 'comments' => 'app',
- 'usage' => 'cnt'
- );
-
- my $regexp=$url;
- $regexp=~s/(\W)/\\$1/g;
- $regexp='___'.$regexp.'___([a-z]+)$';
- while (my ($esckey,$value)=each %evaldata) {
- my $key=&unescape($esckey);
- if ($key=~/$regexp/) {
- my ($item,$purl,$cat)=split(/___/,$key);
- if (defined($cnt{$cat})) { $cnt{$cat}++; } else { $cnt{$cat}=1; }
- unless ($listitems{$cat} eq 'app') {
- if (defined($sum{$cat})) {
- $sum{$cat}+=&unescape($evaldata{$esckey});
- $concat{$cat}.=','.$item;
- } else {
- $sum{$cat}=&unescape($evaldata{$esckey});
- $concat{$cat}=$item;
- }
- } else {
- if (defined($sum{$cat})) {
- if ($evaldata{$esckey}=~/\w/) {
- $sum{$cat}.='
'.&unescape($evaldata{$esckey});
- }
- } else {
- $sum{$cat}=''.&unescape($evaldata{$esckey});
- }
- }
- }
- }
- untie(%evaldata);
-# transfer gathered data to returnhash, calculate averages where applicable
- while (my $cat=each(%cnt)) {
- if ($cnt{$cat} eq 'nan') { next; }
- if ($sum{$cat} eq 'nan') { next; }
- if ($listitems{$cat} eq 'avg') {
- if ($cnt{$cat}) {
- $returnhash{$cat}=int(($sum{$cat}/$cnt{$cat})*100.0+0.5)/100.0;
- } else {
- $returnhash{$cat}='NULL';
- }
- } elsif ($listitems{$cat} eq 'cnt') {
- $returnhash{$cat}=$cnt{$cat};
- } else {
- $returnhash{$cat}=$sum{$cat};
- }
- $returnhash{$cat.'_list'}=$concat{$cat};
- }
- }
-# get count
- if (tie(my %evaldata,'GDBM_File',
- $prodir.'/nohist_accesscount.db',&GDBM_READER(),0640)) {
- my $escurl=&escape($url);
- if (! exists($evaldata{$escurl})) {
- $returnhash{'count'}=0;
- } else {
- $returnhash{'count'}=$evaldata{$escurl};
- }
- untie %evaldata;
- }
- return %returnhash;
-}
-
-# --------------- Read loncapa_apache.conf and loncapa.conf and get variables
+#
+# Read loncapa_apache.conf and loncapa.conf
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
my %perlvar=%{$perlvarref};
undef $perlvarref;
-delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed
-
-# ------------------------------------- Only run if machine is a library server
-exit unless $perlvar{'lonRole'} eq 'library';
-
-# ----------------------------- Make sure this process is running from user=www
-
+delete $perlvar{'lonReceipt'}; # remove since sensitive (really?) & not needed
+#
+# Only run if machine is a library server
+exit if ($perlvar{'lonRole'} ne 'library');
+#
+# Make sure this process is running from user=www
my $wwwid=getpwnam('www');
if ($wwwid!=$<) {
my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
@@ -257,278 +101,446 @@ if ($wwwid!=$<) {
mailto $emailto -s '$subj' > /dev/null");
exit 1;
}
-
-
-# ---------------------------------------------------------- We are in business
-
+#
+# Let people know we are running
open(LOG,'>'.$perlvar{'lonDaemons'}.'/logs/searchcat.log');
-print LOG '==== Searchcat Run '.localtime()."====\n\n";
-$simplestatus='time='.time.'&';
+print LOG '==== Searchcat Run '.localtime()."====\n";
+#
+# Connect to database
my $dbh;
-# ------------------------------------- Make sure that database can be accessed
-{
- unless (
- $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
- ) {
- print LOG "Cannot connect to database!\n";
- $simplestatus.='mysql=defunct';
- &writesimple();
- exit;
- }
-
-# Make temporary table
- $dbh->do("DROP TABLE IF EXISTS newmetadata");
- my $make_metadata_table = "CREATE TABLE IF NOT EXISTS newmetadata (".
- "title TEXT, author TEXT, subject TEXT, url TEXT, keywords TEXT, ".
- "version TEXT, notes TEXT, abstract TEXT, mime TEXT, language TEXT, ".
- "creationdate DATETIME, lastrevisiondate DATETIME, owner TEXT, ".
- "copyright TEXT, dependencies TEXT, ".
- "modifyinguser TEXT, authorspace TEXT, ".
- "lowestgradelevel INTEGER UNSIGNED, highestgradelevel INTEGER UNSIGNED, ".
- "standards TEXT, ".
- "count INTEGER UNSIGNED, ".
- "course INTEGER UNSIGNED, course_list TEXT, ".
- "goto INTEGER UNSIGNED, goto_list TEXT, ".
- "comefrom INTEGER UNSIGNED, comefrom_list TEXT, ".
- "sequsage INTEGER UNSIGNED, sequsage_list TEXT, ".
- "stdno INTEGER UNSIGNED, stdno_list TEXT, ".
- "avetries FLOAT, avetries_list TEXT, ".
- "difficulty FLOAT, difficulty_list TEXT, ".
- "clear FLOAT, technical FLOAT, correct FLOAT, helpful FLOAT, depth FLOAT, ".
- "comments TEXT, ".
-# For backward compatibility, only insert new fields below
-# ...
-# For backward compatibility, end new fields above
- "FULLTEXT idx_title (title), ".
- "FULLTEXT idx_author (author), FULLTEXT idx_subject (subject), ".
- "FULLTEXT idx_url (url), FULLTEXT idx_keywords (keywords), ".
- "FULLTEXT idx_notes (notes), ".
- "FULLTEXT idx_abstract (abstract), FULLTEXT idx_mime (mime), ".
- "FULLTEXT idx_owner (owner), ".
- "FULLTEXT idx_standards (standards))".
- "TYPE=MyISAM";
- # It would sure be nice to have some logging mechanism.
- unless ($dbh->do($make_metadata_table)) {
- print LOG "\nMySQL Error Create: ".$dbh->errstr."\n";
- die $dbh->errstr;
- }
+if (! ($dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},
+ { RaiseError =>0,PrintError=>0}))) {
+ print LOG "Cannot connect to database!\n";
+ die "MySQL Error: Cannot connect to database!\n";
+}
+# This can return an error and still be okay, so we do not bother checking.
+# (perhaps it should be more robust and check for specific errors)
+$dbh->do('DROP TABLE IF EXISTS '.$newname);
+#
+# Create the new table
+my $request = &LONCAPA::lonmetadata::create_metadata_storage($newname);
+$dbh->do($request);
+if ($dbh->err) {
+ $dbh->disconnect();
+ print LOG "\nMySQL Error Create: ".$dbh->errstr."\n";
+ die $dbh->errstr;
}
-
-# ------------------------------------------------------------- get .meta files
+#
+# find out which users we need to examine
opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
-my @homeusers = grep {
- &ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")
- } grep {!/^\.\.?$/} readdir(RESOURCES);
+my @homeusers =
+ grep {
+ &ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_");
+ } grep {
+ !/^\.\.?$/;
+ } readdir(RESOURCES);
closedir RESOURCES;
-
#
-# Create the statement handlers we need
-
-my $insert_sth = $dbh->prepare
- ("INSERT INTO newmetadata VALUES (".
- "?,". # title
- "?,". # author
- "?,". # subject
- "?,". # declutter url
- "?,". # version
- "?,". # current
- "?,". # notes
- "?,". # abstract
- "?,". # mime
- "?,". # language
- "?,". # creationdate
- "?,". # revisiondate
- "?,". # owner
- "?,". # copyright
- "?,". # dependencies
- "?,". # modifyinguser
- "?,". # authorspace
- "?,". # lowestgradelevel
- "?,". # highestgradelevel
- "?,". # standards
- "?,". # count
- "?,". # course
- "?,". # course_list
- "?,". # goto
- "?,". # goto_list
- "?,". # comefrom
- "?,". # comefrom_list
- "?,". # usage
- "?,". # usage_list
- "?,". # stdno
- "?,". # stdno_list
- "?,". # avetries
- "?,". # avetries_list
- "?,". # difficulty
- "?,". # difficulty_list
- "?,". # clear
- "?,". # technical
- "?,". # correct
- "?,". # helpful
- "?,". # depth
- "?". # comments
- ")"
- );
-
+# Loop through the users
foreach my $user (@homeusers) {
- print LOG "\n=== User: ".$user."\n\n";
-
+ print LOG "=== User: ".$user."\n";
my $prodir=&propath($perlvar{'lonDefDomain'},$user);
- # Use find.pl
- undef @metalist;
- @metalist=();
- &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
- # -- process each file to get metadata and put into search catalog SQL
- # database. Also, check to see if already there.
- # I could just delete (without searching first), but this works for now.
- foreach my $m (@metalist) {
- print LOG "- ".$m."\n";
- my $ref=&metadata($m);
- my $m2='/res/'.&declutter($m);
- $m2=~s/\.meta$//;
- if ($ref->{'obsolete'}) { print LOG "obsolete\n"; next; }
- if ($ref->{'copyright'} eq 'private') { print LOG "private\n"; next; }
- my %dyn=();
- if ($m2=~/\/default$/) {
- $m2=~s/\/default$/\//;
- } else {
- %dyn=&dynamicmeta($m2);
- &count($m2);
- }
- unless ($insert_sth->execute(
- $ref->{'title'},
- $ref->{'author'},
- $ref->{'subject'},
- $m2,
- $ref->{'keywords'},
- 'current',
- $ref->{'notes'},
- $ref->{'abstract'},
- $ref->{'mime'},
- $ref->{'language'},
- sqltime($ref->{'creationdate'}),
- sqltime($ref->{'lastrevisiondate'}),
- $ref->{'owner'},
- $ref->{'copyright'},
- $ref->{'dependencies'},
- $ref->{'modifyinguser'},
- $ref->{'authorspace'},
- $ref->{'lowestgradelevel'},
- $ref->{'highestgradelevel'},
- $ref->{'standards'},
- $dyn{'count'},
- $dyn{'course'},
- $dyn{'course_list'},
- $dyn{'goto'},
- $dyn{'goto_list'},
- $dyn{'comefrom'},
- $dyn{'comefrom_list'},
- $dyn{'usage'},
- $dyn{'usage_list'},
- $dyn{'stdno'},
- $dyn{'stdno_list'},
- $dyn{'avetries'},
- $dyn{'avetries_list'},
- $dyn{'difficulty'},
- $dyn{'difficulty_list'},
- $dyn{'clear'},
- $dyn{'technical'},
- $dyn{'correct'},
- $dyn{'helpful'},
- $dyn{'depth'},
- $dyn{'comments'}
- )) {
- print LOG "\nMySQL Error Insert: ".$dbh->errstr."\n";
- die $dbh->errstr;
- }
- $ref = undef;
- }
+ #
+ # Use File::Find to get the files we need to read/modify
+ find(
+ {preprocess => \&only_meta_files,
+# wanted => \&print_filename,
+# wanted => \&log_metadata,
+ wanted => \&process_meta_file,
+ },
+ "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
}
-# --------------------------------------------------- Close database connection
-$dbh->do("DROP TABLE IF EXISTS metadata");
-unless ($dbh->do("RENAME TABLE newmetadata TO metadata")) {
- print LOG "\nMySQL Error Rename: ".$dbh->errstr."\n";
+#
+# Rename the table
+$dbh->do('DROP TABLE IF EXISTS '.$oldname);
+if (! $dbh->do('RENAME TABLE '.$newname.' TO '.$oldname)) {
+ print LOG "MySQL Error Rename: ".$dbh->errstr."\n";
die $dbh->errstr;
}
-unless ($dbh->disconnect) {
- print LOG "\nMySQL Error Disconnect: ".$dbh->errstr."\n";
+if (! $dbh->disconnect) {
+ print LOG "MySQL Error Disconnect: ".$dbh->errstr."\n";
die $dbh->errstr;
}
-print LOG "\n==== Searchcat completed ".localtime()." ====\n";
+##
+## Finished!
+print LOG "==== Searchcat completed ".localtime()." ====\n";
close(LOG);
-&writesimple();
-&writecount();
+
+&write_type_count();
+&write_copyright_count();
+
exit 0;
+########################################################
+########################################################
+### ###
+### File::Find support routines ###
+### ###
+########################################################
+########################################################
+##
+## &only_meta_files
+##
+## Called by File::Find.
+## Takes a list of files/directories in and returns a list of files/directories
+## to search.
+sub only_meta_files {
+ my @PossibleFiles = @_;
+ my @ChosenFiles;
+ foreach my $file (@PossibleFiles) {
+ if ( ($file =~ /\.meta$/ && # Ends in meta
+ $file !~ /\.\d+\.[^\.]+\.meta$/ # is not for a prior version
+ ) || (-d $file )) { # directories are okay
+ # but we do not want /. or /..
+ push(@ChosenFiles,$file);
+ }
+ }
+ return @ChosenFiles;
+}
+
+##
+##
+## Debugging routines, use these for 'wanted' in the File::Find call
+##
+sub print_filename {
+ my ($file) = $_;
+ my $fullfilename = $File::Find::name;
+ if (-d $file) {
+ print LOG " Got directory ".$fullfilename."\n";
+ } else {
+ print LOG " Got file ".$fullfilename."\n";
+ }
+ $_=$file;
+}
+sub log_metadata {
+ my ($file) = $_;
+ my $fullfilename = $File::Find::name;
+ return if (-d $fullfilename); # No need to do anything here for directories
+ print LOG $fullfilename."\n";
+ my $ref=&metadata($fullfilename);
+ if (! defined($ref)) {
+ print LOG " No data\n";
+ return;
+ }
+ while (my($key,$value) = each(%$ref)) {
+ print LOG " ".$key." => ".$value."\n";
+ }
+ &count_copyright($ref->{'copyright'});
+ $_=$file;
+}
-# =============================================================================
-# ---------------------------------------------------------------- Get metadata
-# significantly altered from subroutine present in lonnet
+##
+## process_meta_file
+## Called by File::Find.
+## Only input is the filename in $_.
+sub process_meta_file {
+ my ($file) = $_;
+ my $filename = $File::Find::name;
+ return if (-d $filename); # No need to do anything here for directories
+ #
+ print LOG $filename."\n";
+ #
+ my $ref=&metadata($filename);
+ #
+ # $url is the original file url, not the metadata file
+ my $url='/res/'.&declutter($filename);
+ $url=~s/\.meta$//;
+ print LOG " ".$url."\n";
+ #
+ # Ignore some files based on their metadata
+ if ($ref->{'obsolete'}) {
+ print LOG "obsolete\n";
+ return;
+ }
+ &count_copyright($ref->{'copyright'});
+ if ($ref->{'copyright'} eq 'private') {
+ print LOG "private\n";
+ return;
+ }
+ #
+ # Find the dynamic metadata
+ my %dyn;
+ if ($url=~ m:/default$:) {
+ $url=~ s:/default$:/:;
+ } else {
+ # %dyn=&dynamicmeta($url);
+ &count_type($url);
+ }
+ #
+ $ref->{'creationdate'} = &sqltime($ref->{'creationdate'});
+ $ref->{'lastrevisiondate'} = &sqltime($ref->{'lastrevisiondate'});
+ my %Data = (
+ %$ref,
+ %dyn,
+ 'url'=>$url,
+ 'version'=>'current');
+ my ($count,$err) = &LONCAPA::lonmetadata::store_metadata($dbh,$newname,
+ \%Data);
+ if ($err) {
+ print LOG "\nMySQL Error Insert: ".$err."\n";
+ die $err;
+ }
+ if ($count < 1) {
+ print LOG "Unable to insert record into MySQL database for $url\n";
+ die "Unable to insert record into MySQl database for $url";
+ } else {
+ print LOG "Count = ".$count."\n";
+ }
+ #
+ # Reset $_ before leaving
+ $_ = $file;
+}
+
+########################################################
+########################################################
+### ###
+### &metadata($uri) ###
+### Retrieve metadata for the given file ###
+### ###
+########################################################
+########################################################
sub metadata {
- my ($uri,$what)=@_;
+ my ($uri)=@_;
my %metacache=();
$uri=&declutter($uri);
my $filename=$uri;
$uri=~s/\.meta$//;
$uri='';
- unless ($metacache{$uri.'keys'}) {
- unless ($filename=~/\.meta$/) { $filename.='.meta'; }
- my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
- my $parser=HTML::TokeParser->new(\$metastring);
- my $token;
- while ($token=$parser->get_token) {
- if ($token->[0] eq 'S') {
- my $entry=$token->[1];
- my $unikey=$entry;
- if (defined($token->[2]->{'part'})) {
- $unikey.='_'.$token->[2]->{'part'};
- }
- if (defined($token->[2]->{'name'})) {
- $unikey.='_'.$token->[2]->{'name'};
- }
- if ($metacache{$uri.'keys'}) {
- $metacache{$uri.'keys'}.=','.$unikey;
+ if ($filename !~ /\.meta$/) {
+ $filename.='.meta';
+ }
+ my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
+ return undef if (! defined($metastring));
+ my $parser=HTML::TokeParser->new(\$metastring);
+ my $token;
+ while ($token=$parser->get_token) {
+ if ($token->[0] eq 'S') {
+ my $entry=$token->[1];
+ my $unikey=$entry;
+ if (defined($token->[2]->{'part'})) {
+ $unikey.='_'.$token->[2]->{'part'};
+ }
+ if (defined($token->[2]->{'name'})) {
+ $unikey.='_'.$token->[2]->{'name'};
+ }
+ if ($metacache{$uri.'keys'}) {
+ $metacache{$uri.'keys'}.=','.$unikey;
+ } else {
+ $metacache{$uri.'keys'}=$unikey;
+ }
+ foreach ( @{$token->[3]}) {
+ $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
+ }
+ if (! ($metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry))){
+ $metacache{$uri.''.$unikey} =
+ $metacache{$uri.''.$unikey.'.default'};
+ }
+ } # End of ($token->[0] eq 'S')
+ }
+ return \%metacache;
+}
+
+##
+## &getfile($filename)
+## Slurps up an entire file into a scalar.
+## Returns undef if the file does not exist
+sub getfile {
+ my $file = shift();
+ if (! -e $file ) {
+ return undef;
+ }
+ my $fh=IO::File->new($file);
+ my $contents = '';
+ while (<$fh>) {
+ $contents .= $_;
+ }
+ return $contents;
+}
+
+########################################################
+########################################################
+### ###
+### Dynamic Metadata ###
+### ###
+########################################################
+########################################################
+sub dynamicmeta {
+ my $url = &declutter(shift());
+ $url =~ s/\.meta$//;
+ my %data = ('count' => 0,
+ 'course' => 0,
+ 'course_list' => '',
+ 'avetries' => 'NULL',
+ 'avetries_list' => '',
+ 'stdno' => 0,
+ 'stdno_list' => '',
+ 'usage' => 0,
+ 'usage_list' => '',
+ 'goto' => 0,
+ 'goto_list' => '',
+ 'comefrom' => 0,
+ 'comefrom_list' => '',
+ 'difficulty' => 'NULL',
+ 'difficulty_list' => '',
+ 'sequsage' => '0',
+ 'sequsage_list' => '',
+ 'clear' => 'NULL',
+ 'technical' => 'NULL',
+ 'correct' => 'NULL',
+ 'helpful' => 'NULL',
+ 'depth' => 'NULL',
+ 'comments' => '',
+ );
+ my ($dom,$auth)=($url=~/^(\w+)\/(\w+)\//);
+ my $prodir=&propath($dom,$auth);
+ #
+ # Get metadata except counts
+ my %evaldata;
+ if (! tie(%evaldata,'GDBM_File',
+ $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) {
+ return (undef);
+ }
+ my %sum=();
+ my %count=();
+ my %concat=();
+ my %listitems=(
+ 'course' => 'add',
+ 'goto' => 'add',
+ 'comefrom' => 'add',
+ 'avetries' => 'average',
+ 'stdno' => 'add',
+ 'difficulty' => 'average',
+ 'clear' => 'average',
+ 'technical' => 'average',
+ 'helpful' => 'average',
+ 'correct' => 'average',
+ 'depth' => 'average',
+ 'comments' => 'append',
+ 'usage' => 'count'
+ );
+ #
+ my $regexp=$url;
+ $regexp=~s/(\W)/\\$1/g;
+ $regexp='___'.$regexp.'___([a-z]+)$';
+ while (my ($esckey,$value)=each %evaldata) {
+ my $key=&unescape($esckey);
+ if ($key=~/$regexp/) {
+ my ($item,$purl,$cat)=split(/___/,$key);
+ $count{$cat}++;
+ if ($listitems{$cat} ne 'append') {
+ if (defined($sum{$cat})) {
+ $sum{$cat}+=&unescape($value);
+ $concat{$cat}.=','.$item;
} else {
- $metacache{$uri.'keys'}=$unikey;
+ $sum{$cat}=&unescape($value);
+ $concat{$cat}=$item;
}
- map {
- $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
- } @{$token->[3]};
- unless (
- $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
- ) { $metacache{$uri.''.$unikey}=
- $metacache{$uri.''.$unikey.'.default'};
- }
+ } else {
+ if (defined($sum{$cat})) {
+ if ($evaldata{$esckey}=~/\w/) {
+ $sum{$cat}.='
'.&unescape($evaldata{$esckey});
+ }
+ } else {
+ $sum{$cat}=''.&unescape($evaldata{$esckey});
+ }
}
}
}
- return \%metacache;
+ untie(%evaldata);
+ # transfer gathered data to returnhash, calculate averages where applicable
+ my %returnhash;
+ while (my $cat=each(%count)) {
+ if ($count{$cat} eq 'nan') { next; }
+ if ($sum{$cat} eq 'nan') { next; }
+ if ($listitems{$cat} eq 'average') {
+ if ($count{$cat}) {
+ $returnhash{$cat}=int(($sum{$cat}/$count{$cat})*100.0+0.5)/100.0;
+ } else {
+ $returnhash{$cat}='NULL';
+ }
+ } elsif ($listitems{$cat} eq 'count') {
+ $returnhash{$cat}=$count{$cat};
+ } else {
+ $returnhash{$cat}=$sum{$cat};
+ }
+ $returnhash{$cat.'_list'}=$concat{$cat};
+ }
+ #
+ # get count
+ if (tie(my %evaldata,'GDBM_File',
+ $prodir.'/nohist_accesscount.db',&GDBM_READER(),0640)) {
+ my $escurl=&escape($url);
+ if (! exists($evaldata{$escurl})) {
+ $returnhash{'count'}=0;
+ } else {
+ $returnhash{'count'}=$evaldata{$escurl};
+ }
+ untie %evaldata;
+ }
+ return %returnhash;
}
-# ------------------------------------------------------------ Serves up a file
-# returns either the contents of the file or a -1
-sub getfile {
+########################################################
+########################################################
+### ###
+### Counts ###
+### ###
+########################################################
+########################################################
+{
+
+my %countext;
+
+sub count_type {
my $file=shift;
- if (! -e $file ) { return -1; };
- my $fh=IO::File->new($file);
- my $a='';
- while (<$fh>) { $a .=$_; }
- return $a;
+ $file=~/\.(\w+)$/;
+ my $ext=lc($1);
+ $countext{$ext}++;
}
-# ------------------------------------------------------------- Declutters URLs
-sub declutter {
- my $thisfn=shift;
- $thisfn=~s/^$perlvar{'lonDocRoot'}//;
- $thisfn=~s/^\///;
- $thisfn=~s/^res\///;
- return $thisfn;
+sub write_type_count {
+ open(RESCOUNT,'>/home/httpd/html/lon-status/rescount.txt');
+ while (my ($extension,$count) = each(%countext)) {
+ print RESCOUNT $extension.'='.$count.'&';
+ }
+ print RESCOUNT 'time='.time."\n";
+ close(RESCOUNT);
}
-# --------------------------------------- Is this the home server of an author?
-# (copied from lond, modification of the return value)
+} # end of scope for %countext
+
+{
+
+my %copyrights;
+
+sub count_copyright {
+ $copyrights{@_[0]}++;
+}
+
+sub write_copyright_count {
+ open(COPYCOUNT,'>/home/httpd/html/lon-status/copyrightcount.txt');
+ while (my ($copyright,$count) = each(%copyrights)) {
+ print COPYCOUNT $copyright.'='.$count.'&';
+ }
+ print COPYCOUNT 'time='.time."\n";
+ close(COPYCOUNT);
+}
+
+} # end of scope for %copyrights
+
+########################################################
+########################################################
+### ###
+### Miscellanous Utility Routines ###
+### ###
+########################################################
+########################################################
+##
+## &ishome($username)
+## Returns 1 if $username is a LON-CAPA author, 0 otherwise
+## (copied from lond, modification of the return value)
sub ishome {
my $author=shift;
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
@@ -541,8 +553,10 @@ sub ishome {
}
}
-# -------------------------------------------- Return path to profile directory
-# (copied from lond)
+##
+## &propath($udom,$uname)
+## Returns the path to the users LON-CAPA directory
+## (copied from lond)
sub propath {
my ($udom,$uname)=@_;
$udom=~s/\W//g;
@@ -553,44 +567,60 @@ sub propath {
return $proname;
}
-# ---------------------------- convert 'time' format into a datetime sql format
+##
+## &sqltime($timestamp)
+##
+## Convert perl $timestamp to MySQL time. MySQL expects YYYY-MM-DD HH:MM:SS
+##
sub sqltime {
- my $time=&unsqltime(@_[0]);
- unless ($time) { return 'NULL'; }
- my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
- localtime($time);
- $mon++; $year+=1900;
- return "$year-$mon-$mday $hour:$min:$sec";
+ my ($time) = @_;
+ my $mysqltime;
+ if ($time =~
+ /(\d+)-(\d+)-(\d+) # YYYY-MM-DD
+ \s # a space
+ (\d+):(\d+):(\d+) # HH:MM::SS
+ /x ) {
+ # Some of the .meta files have the time in mysql
+ # format already, so just make sure they are 0 padded and
+ # pass them back.
+ $mysqltime = sprintf('%04d-%02d-%02d %02d:%02d:%02d',
+ $1,$2,$3,$4,$5,$6);
+ } elsif ($time =~ /^\d+$/) {
+ my @TimeData = gmtime($time);
+ # Alter the month to be 1-12 instead of 0-11
+ $TimeData[4]++;
+ # Alter the year to be from 0 instead of from 1900
+ $TimeData[5]+=1900;
+ $mysqltime = sprintf('%04d-%02d-%02d %02d:%02d:%02d',
+ @TimeData[5,4,3,2,1,0]);
+ } else {
+ print LOG " Unable to decode time ".$time."\n";
+ $mysqltime = 0;
+ }
+ return $mysqltime;
}
-sub maketime {
- my %th=@_;
- return POSIX::mktime(($th{'seconds'},$th{'minutes'},$th{'hours'},
- $th{'day'},$th{'month'}-1,
- $th{'year'}-1900,0,0,$th{'dlsav'}));
+##
+## &declutter($filename)
+## Given a filename, returns a url for the filename.
+sub declutter {
+ my $thisfn=shift;
+ $thisfn=~s/^$perlvar{'lonDocRoot'}//;
+ $thisfn=~s/^\///;
+ $thisfn=~s/^res\///;
+ return $thisfn;
}
-
-#########################################
-#
-# Retro-fixing of un-backward-compatible time format
-
-sub unsqltime {
- my $timestamp=shift;
- if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {
- $timestamp=&maketime('year'=>$1,'month'=>$2,'day'=>$3,
- 'hours'=>$4,'minutes'=>$5,'seconds'=>$6);
- }
- return $timestamp;
+##
+## Escape / Unescape special characters
+sub unescape {
+ my $str=shift;
+ $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
+ return $str;
}
-# ----------------- Code to enable 'find' subroutine listing of the .meta files
-
-no strict "vars";
-
-sub wanted {
- (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
- -f _ &&
- /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
- push(@metalist,"$dir/$_");
+sub escape {
+ my $str=shift;
+ $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
+ return $str;
}