--- loncom/metadata_database/searchcat.pl 2002/05/11 21:28:20 1.17 +++ loncom/metadata_database/searchcat.pl 2016/01/31 21:25:49 1.84 @@ -2,7 +2,7 @@ # The LearningOnline Network # searchcat.pl "Search Catalog" batch script # -# $Id: searchcat.pl,v 1.17 2002/05/11 21:28:20 harris41 Exp $ +# $Id: searchcat.pl,v 1.84 2016/01/31 21:25:49 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -26,173 +26,873 @@ # # http://www.lon-capa.org/ # -# YEAR=2001 -# 04/14/2001, 04/16/2001 Scott Harrison -# -# YEAR=2002 -# 05/11/2002 Scott Harrison -# ### -# This script goes through a LON-CAPA resource -# directory and gathers metadata. -# The metadata is entered into a SQL database. +=pod -use lib '/home/httpd/lib/perl/'; -use LONCAPA::Configuration; +=head1 NAME + +B - put authoritative filesystem data into sql database. + +=head1 SYNOPSIS + +Ordinarily this script is to be called from a loncapa cron job +(CVS source location: F; typical +filesystem installation location: F). + +Here is the cron job entry. + +C<# Repopulate and refresh the metadata database used for the search catalog.> +C<10 1 * * 7 www /home/httpd/perl/searchcat.pl> + +This script only allows itself to be run as the user C. + +=head1 DESCRIPTION + +This script goes through a loncapa resource directory and gathers metadata. +The metadata is entered into a SQL database. + +This script also does general database maintenance such as reformatting +the C table if it is deprecated. + +This script evaluates dynamic metadata from the authors' +F database file in order to store it in MySQL. + +This script is playing an increasingly important role for a loncapa +library server. The proper operation of this script is critical for a smooth +and correct user experience. + +=cut +use strict; +use DBI; +use lib '/home/httpd/lib/perl/'; +use LONCAPA::lonmetadata; +use LONCAPA; +use Getopt::Long; use IO::File; use HTML::TokeParser; -use DBI; +use GDBM_File; +use POSIX qw(strftime mktime); +use Mail::Send; +use Apache::loncommon(); + +use Apache::lonnet(); + +use File::Find; + +# +# Set up configuration options +my ($simulate,$oneuser,$help,$verbose,$logfile,$debug); +GetOptions ( + 'help' => \$help, + 'simulate' => \$simulate, + 'only=s' => \$oneuser, + 'verbose=s' => \$verbose, + 'debug' => \$debug, + ); + +if ($help) { + print <<"ENDHELP"; +$0 +Rebuild and update the LON-CAPA metadata database. +Options: + -help Print this help + -simulate Do not modify the database. + -only=user Only compute for the given user. Implies -simulate + -verbose=val Sets logging level, val must be a number + -debug Turns on debugging output +ENDHELP + exit 0; +} + +if (! defined($debug)) { + $debug = 0; +} + +if (! defined($verbose)) { + $verbose = 0; +} -my @metalist; -# ----------------- Code to enable 'find' subroutine listing of the .meta files -require "find.pl"; -sub wanted { - (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && - -f _ && - /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ && - push(@metalist,"$dir/$_"); -} - -# ------------------------- Read access.conf and loncapa.conf and get variables -my $perlvarref=LONCAPA::Configuration::read_conf('access.conf','loncapa.conf'); -my %perlvar=%{$perlvarref}; -undef $perlvarref; # remove since sensitive and not needed -delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed +if (defined($oneuser)) { + $simulate=1; +} + +## +## Use variables for table names so we can test this routine a little easier +my %oldnames = ( + 'metadata' => 'metadata', + 'portfolio' => 'portfolio_metadata', + 'access' => 'portfolio_access', + 'addedfields' => 'portfolio_addedfields', + 'allusers' => 'allusers', + ); + +my %newnames; +# new table names - append pid to have unique temporary tables +foreach my $key (keys(%oldnames)) { + $newnames{$key} = 'new'.$oldnames{$key}.$$; +} + +# +# Only run if machine is a library server +exit if ($Apache::lonnet::perlvar{'lonRole'} ne 'library'); +my $hostid = $Apache::lonnet::perlvar{'lonHostID'}; + +# +# Make sure this process is running from user=www +my $wwwid=getpwnam('www'); +if ($wwwid!=$<) { + my $emailto="$Apache::lonnet::perlvar{'lonAdmEMail'},$Apache::lonnet::perlvar{'lonSysEMail'}"; + my $subj="LON: $Apache::lonnet::perlvar{'lonHostID'} User ID mismatch"; + system("echo 'User ID mismatch. searchcat.pl must be run as user www.' |\ + mail -s '$subj' $emailto > /dev/null"); + exit 1; +} +# +# Let people know we are running +open(LOG,'>>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/logs/searchcat.log'); +&log(0,'==== Searchcat Run '.localtime()."===="); -# ------------------------------------- Only run if machine is a library server -exit unless $perlvar{'lonRole'} eq 'library'; +if ($debug) { + &log(0,'simulating') if ($simulate); + &log(0,'only processing user '.$oneuser) if ($oneuser); + &log(0,'verbosity level = '.$verbose); +} +# +# 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 "Cannot connect to database!\n"; - exit; +if (! ($dbh = DBI->connect("DBI:mysql:loncapa","www",$Apache::lonnet::perlvar{'lonSqlAccess'}, + { RaiseError =>0,PrintError=>0}))) { + &log(0,"Cannot connect to database!"); + 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) +foreach my $key (keys(%newnames)) { + if ($newnames{$key} ne '') { + $dbh->do('DROP TABLE IF EXISTS '.$newnames{$key}); + } +} + +# +# Create the new metadata, portfolio and allusers tables +foreach my $key (keys(%newnames)) { + if ($newnames{$key} ne '') { + my $request = + &LONCAPA::lonmetadata::create_metadata_storage($newnames{$key},$oldnames{$key}); + $dbh->do($request); + if ($dbh->err) { + $dbh->disconnect(); + &log(0,"MySQL Error Create: ".$dbh->errstr); + die $dbh->errstr; + } + } +} + +# +# find out which users we need to examine +my @domains = sort(&Apache::lonnet::current_machine_domains()); +&log(9,'domains ="'.join('","',@domains).'"'); + +foreach my $dom (@domains) { + &log(9,'domain = '.$dom); + opendir(RESOURCES,"$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom"); + my @homeusers = + grep { + &ishome("$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom/$_"); + } grep { + !/^\.\.?$/; + } readdir(RESOURCES); + closedir RESOURCES; + &log(5,'users = '.$dom.':'.join(',',@homeusers)); + # + if ($oneuser) { + @homeusers=($oneuser); + } + + # + # Loop through the users + foreach my $user (@homeusers) { + &log(0,"=== User: ".$user); + &process_dynamic_metadata($user,$dom); + # + # 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, + no_chdir => 1, + }, join('/',($Apache::lonnet::perlvar{'lonDocRoot'},'res',$dom,$user)) ); + } + # Search for all users and public portfolio files + my (%allusers,%portusers,%courses); + if ($oneuser) { + %portusers = ( + $oneuser => '', + ); + %allusers = ( + $oneuser => '', + ); + %courses = &courseiddump($dom,'.',1,'.','.',$oneuser,undef, + undef,'.'); + } else { + # get courseIDs for domain on current machine + %courses=&Apache::lonnet::courseiddump($dom,'.',1,'.','.','.',1,[$hostid],'.'); + my $dir = $Apache::lonnet::perlvar{lonUsersDir}.'/'.$dom; + &descend_tree($dom,$dir,0,\%portusers,\%allusers); + } + foreach my $uname (keys(%portusers)) { + my $urlstart = '/uploaded/'.$dom.'/'.$uname; + my $pathstart = &propath($dom,$uname).'/userfiles'; + my $is_course = ''; + if (exists($courses{$dom.'_'.$uname})) { + $is_course = 1; + } + my $curr_perm = &Apache::lonnet::get_portfile_permissions($dom,$uname); + my %access = &Apache::lonnet::get_access_controls($curr_perm); + foreach my $file (keys(%access)) { + my ($group,$url,$fullpath); + if ($is_course) { + ($group, my ($path)) = ($file =~ /^(\w+)(\/.+)$/); + $fullpath = $pathstart.'/groups/'.$group.'/portfolio'.$path; + $url = $urlstart.'/groups/'.$group.'/portfolio'.$path; + } else { + $fullpath = $pathstart.'/portfolio'.$file; + $url = $urlstart.'/portfolio'.$file; + } + if (ref($access{$file}) eq 'HASH') { + my %portaccesslog = + &LONCAPA::lonmetadata::process_portfolio_access_data($dbh, + $simulate,\%newnames,$url,$fullpath,$access{$file}); + &portfolio_logging(%portaccesslog); + } + my %portmetalog = &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,$simulate,\%newnames,$url,$fullpath,$is_course,$dom,$uname,$group); + &portfolio_logging(%portmetalog); + } + } + my %duplicates; + my %names_by_id = ( + id => {}, + clickers => {}, + ); + my %ids_by_name = ( + id => {}, + clickers => {}, + ); + my %idstodelete = ( + id => {}, + clickers => {}, + ); + my %idstoadd = ( + id => {}, + clickers => {}, + ); + my %namespace = ( + id => 'ids', + clickers => 'clickers', + ); + my %idtext = ( + id => 'employee/student IDs', + clickers => 'clicker IDs', + ); + unless ($simulate || $oneuser) { + foreach my $key ('id','clickers') { + my $hashref = &tie_domain_hash($dom,$namespace{$key},&GDBM_WRCREAT()); + if (ref($hashref) eq 'HASH') { + while (my ($id,$unamestr) = each(%{$hashref}) ) { + $id = &unescape($id); + $unamestr = &unescape($unamestr); + if ($key eq 'clickers') { + my @unames = split(/,/,$unamestr); + foreach my $uname (@unames) { + push(@{$ids_by_name{$key}{$uname}},$id); + } + $names_by_id{$key}{$id} = $unamestr; + } else { + $names_by_id{$key}{$id} = $unamestr; + push(@{$ids_by_name{$key}{$unamestr}},$id); + } + } + &untie_domain_hash($hashref); + } + } + } + # Update allusers + foreach my $uname (keys(%allusers)) { + next if (exists($courses{$dom.'_'.$uname})); + my %userdata = + &Apache::lonnet::get('environment',['firstname','lastname', + 'middlename','generation','id','permanentemail','clickers'], + $dom,$uname); + unless ($simulate || $oneuser) { + foreach my $key ('id','clickers') { + my %addid = (); + if ($userdata{$key} ne '') { + my $idfromenv = $userdata{$key}; + if ($key eq 'id') { + $idfromenv=~tr/A-Z/a-z/; + $addid{$idfromenv} = 1; + } else { + $idfromenv =~ s/^\s+//; + $idfromenv =~ s/\s+$//; + map { $addid{$_} = 1; } split(/,/,$idfromenv); + } + } + if (ref($ids_by_name{$key}{$uname}) eq 'ARRAY') { + if (scalar(@{$ids_by_name{$key}{$uname}}) > 1) { + &log(0,"Multiple $idtext{$key} found in $namespace{$key}.db for $uname:$dom -- ". + join(', ',@{$ids_by_name{$key}{$uname}})); + } + foreach my $id (@{$ids_by_name{$key}{$uname}}) { + if ($addid{$id}) { + delete($addid{$id}); + } else { + if ($key eq 'id') { + $idstodelete{$key}{$id} = $uname; + } else { + $idstodelete{$key}{$id} .= $uname.','; + } + } + } + } + if (keys(%addid)) { + foreach my $id (keys(%addid)) { + if ($key eq 'id') { + if (exists($idstoadd{$key}{$id})) { + push(@{$duplicates{$id}},$uname); + } else { + $idstoadd{$key}{$id} = $uname; + } + } else { + $idstoadd{$key}{$id} .= $uname.','; + } + } + } + } + } + + $userdata{'username'} = $uname; + $userdata{'domain'} = $dom; + my %alluserslog = + &LONCAPA::lonmetadata::process_allusers_data($dbh,$simulate, + \%newnames,$uname,$dom,\%userdata); + foreach my $item (keys(%alluserslog)) { + &log(0,$alluserslog{$item}); + } + } + unless ($simulate || $oneuser) { + foreach my $key ('id','clickers') { + if (keys(%{$idstodelete{$key}}) > 0) { + my %resulthash; + if ($key eq 'id') { + %resulthash = &Apache::lonnet::iddel($dom,$idstodelete{$key},$hostid,$namespace{$key}); + } else { + foreach my $delid (sort(keys(%{$idstodelete{$key}}))) { + $idstodelete{$key}{$delid} =~ s/,$//; + } + %resulthash = &Apache::lonnet::iddel($dom,$idstodelete{$key},$hostid,$namespace{$key}); + } + if ($resulthash{$hostid} eq 'ok') { + foreach my $id (sort(keys(%{$idstodelete{$key}}))) { + &log(0,"Record deleted from $namespace{$key}.db for $dom -- $id => ".$idstodelete{$key}{$id}); + } + } else { + &log(0,"Error: '$resulthash{$hostid}' occurred when attempting to delete records from $namespace{$key}.db for $dom"); + } + } + if (keys(%{$idstoadd{$key}}) > 0) { + my $idmessage = ''; + my %newids; + if ($key eq 'id') { + foreach my $addid (sort(keys(%{$idstoadd{$key}}))) { + if ((exists($names_by_id{$key}{$addid})) && ($names_by_id{$key}{$addid} ne $idstoadd{$key}{$addid}) && !($idstodelete{$key}{$addid})) { + &log(0,"Two usernames associated with a single ID $addid in domain: $dom: $names_by_id{$key}{$addid} (current) and $idstoadd{$key}{$addid}\n"); + $idmessage .= "$addid,$names_by_id{$key}{$addid},$idstoadd{$key}{$addid}\n"; + } else { + $newids{$addid} = $idstoadd{$key}{$addid}; + } + } + } else { + foreach my $addid (sort(keys(%{$idstoadd{$key}}))) { + $idstoadd{$key}{$addid} =~ s/,$//; + $newids{$addid} = $idstoadd{$key}{$addid}; + } + } + if (keys(%newids) > 0) { + my $putresult; + if ($key eq 'clickers') { + $putresult = &Apache::lonnet::updateclickers($dom,'add',\%newids,$hostid); + } else { + $putresult = &Apache::lonnet::put_dom($namespace{$key},\%newids,$dom,$hostid); + } + if ($putresult eq 'ok') { + foreach my $id (sort(keys(%newids))) { + &log(0,"Record added to $namespace{$key}.db for $dom -- $id => ".$newids{$id}); + } + } else { + &log(0,"Error: '$putresult' occurred when attempting to add records to $namespace{$key}.db for $dom"); + } + } + if ($idmessage) { + my $to = &Apache::loncommon::build_recipient_list(undef,'idconflictsmail',$dom); + if ($to ne '') { + my $msg = new Mail::Send; + $msg->to($to); + $msg->subject('LON-CAPA studentIDs conflict'); + my $lonhost = $Apache::lonnet::perlvar{'lonHostID'}; + my $hostname = &Apache::lonnet::hostname($lonhost); + my $replytoaddress = 'do-not-reply@'.$hostname; + $msg->add('Reply-to',$replytoaddress); + $msg->add('From','www@'.$hostname); + $msg->add('Content-type','text/plain; charset=UTF-8'); + if (my $fh = $msg->open()) { + print $fh + 'The following IDs are used for more than one user in your domain:'."\n". + 'Each row contains: Student/Employee ID, Current username in ids.db file, '. + 'Additional username'."\n\n". + $idmessage; + $fh->close; + } + } + } + } + } + if (keys(%duplicates) > 0) { + foreach my $id (sort(keys(%duplicates))) { + if (ref($duplicates{$id}) eq 'ARRAY') { + &log(0,"Duplicate IDs found for entries to add to ids.db in $dom -- $id => ".join(',',@{$duplicates{$id}})); + } + } + } } } -# ------------------------------------------------------------- get .meta files -opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}"); -my @homeusers=grep - {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")} - grep {!/^\.\.?$/} readdir(RESOURCES); -closedir RESOURCES; -foreach my $user (@homeusers) { - &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) { - my $ref=&metadata($m); - my $m2='/res/'.&declutter($m); - $m2=~s/\.meta$//; - my $q2="select * from metadata where url like binary '$m2'"; - my $sth = $dbh->prepare($q2); - $sth->execute(); - my $r1=$sth->fetchall_arrayref; - if (@$r1) { - $sth=$dbh->prepare("delete from metadata where url like binary '$m2'"); - $sth->execute(); - } - $sth=$dbh->prepare('insert into metadata values ('. - '"'.delete($ref->{'title'}).'"'.','. - '"'.delete($ref->{'author'}).'"'.','. - '"'.delete($ref->{'subject'}).'"'.','. - '"'.$m2.'"'.','. - '"'.delete($ref->{'keywords'}).'"'.','. - '"'.'current'.'"'.','. - '"'.delete($ref->{'notes'}).'"'.','. - '"'.delete($ref->{'abstract'}).'"'.','. - '"'.delete($ref->{'mime'}).'"'.','. - '"'.delete($ref->{'language'}).'"'.','. - '"'.sqltime(delete($ref->{'creationdate'})).'"'.','. - '"'.sqltime(delete($ref->{'lastrevisiondate'})).'"'.','. - '"'.delete($ref->{'owner'}).'"'.','. - '"'.delete($ref->{'copyright'}).'"'.')'); - $sth->execute(); -} - -# ----------------------------------------------------------- Clean up database -# Need to, perhaps, remove stale SQL database records. -# ... not yet implemented +# +# Rename the tables +if (! $simulate) { + foreach my $key (keys(%oldnames)) { + if (($oldnames{$key} ne '') && ($newnames{$key} ne '')) { + $dbh->do('DROP TABLE IF EXISTS '.$oldnames{$key}); + if (! $dbh->do('RENAME TABLE '.$newnames{$key}.' TO '.$oldnames{$key})) { + &log(0,"MySQL Error Rename: ".$dbh->errstr); + die $dbh->errstr; + } else { + &log(1,"MySQL table rename successful for $key."); + } + } + } +} +if (! $dbh->disconnect) { + &log(0,"MySQL Error Disconnect: ".$dbh->errstr); + die $dbh->errstr; +} +## +## Finished! +&log(0,"==== Searchcat completed ".localtime()." ===="); +close(LOG); + +&write_type_count(); +&write_copyright_count(); + +exit 0; + +## +## Status logging routine. Inputs: $level, $message +## +## $level 0 should be used for normal output and error messages +## +## $message does not need to end with \n. In the case of errors +## the message should contain as much information as possible to +## help in diagnosing the problem. +## +sub log { + my ($level,$message)=@_; + $level = 0 if (! defined($level)); + if ($verbose >= $level) { + print LOG $message.$/; + } +} -# --------------------------------------------------- Close database connection -$dbh->disconnect; +sub portfolio_logging { + my (%portlog) = @_; + foreach my $key (keys(%portlog)) { + if (ref($portlog{$key}) eq 'HASH') { + foreach my $item (keys(%{$portlog{$key}})) { + &log(0,$portlog{$key}{$item}); + } + } + } +} -# ---------------------------------------------------------------- Get metadata -# significantly altered from subroutine present in lonnet +sub descend_tree { + my ($dom,$dir,$depth,$allportusers,$alldomusers) = @_; + if (-d $dir) { + opendir(DIR,$dir); + my @contents = grep(!/^\./,readdir(DIR)); + closedir(DIR); + $depth ++; + foreach my $item (@contents) { + if (($depth < 4) && (length($item) == 1)) { + &descend_tree($dom,$dir.'/'.$item,$depth,$allportusers,$alldomusers); + } else { + if (-e $dir.'/'.$item.'/file_permissions.db') { + $$allportusers{$item} = ''; + } + if (-e $dir.'/'.$item.'/passwd') { + $$alldomusers{$item} = ''; + } + } + } + } +} + +######################################################## +######################################################## +### ### +### 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::Find::dir."/".$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 ($debug) { + if (-d $file) { + &log(5," Got directory ".$fullfilename); + } else { + &log(5," Got file ".$fullfilename); + } + } + $_=$file; +} + +sub log_metadata { + my ($file) = $_; + my $fullfilename = $File::Find::name; + return if (-d $fullfilename); # No need to do anything here for directories + if ($debug) { + &log(6,$fullfilename); + my $ref = &metadata($fullfilename); + if (! defined($ref)) { + &log(6," No data"); + return; + } + while (my($key,$value) = each(%$ref)) { + &log(6," ".$key." => ".$value); + } + &count_copyright($ref->{'copyright'}); + } + $_=$file; +} + +## +## process_meta_file +## Called by File::Find. +## Only input is the filename in $_. +sub process_meta_file { + my ($file) = $_; + my $filename = $File::Find::name; # full filename + return if (-d $filename); # No need to do anything here for directories + # + &log(3,$filename) if ($debug); + # + my $ref = &metadata($filename); + # + # $url is the original file url, not the metadata file + my $target = $filename; + $target =~ s/\.meta$//; + my $url='/res/'.&declutter($target); + &log(3," ".$url) if ($debug); + # + # Ignore some files based on their metadata + if ($ref->{'obsolete'}) { + &log(3,"obsolete") if ($debug); + return; + } + &count_copyright($ref->{'copyright'}); + if ($ref->{'copyright'} eq 'private') { + &log(3,"private") if ($debug); + return; + } + # + # Find the dynamic metadata + my %dyn; + if ($url=~ m:/default$:) { + $url=~ s:/default$:/:; + &log(3,"Skipping dynamic data") if ($debug); + } else { + &log(3,"Retrieving dynamic data") if ($debug); + %dyn=&get_dynamic_metadata($url); + &count_type($url); + } + &LONCAPA::lonmetadata::getfiledates($ref,$target); + # + my %Data = ( + %$ref, + %dyn, + 'url'=>$url, + 'version'=>'current'); + if (! $simulate) { + my ($count,$err) = + &LONCAPA::lonmetadata::store_metadata($dbh,$newnames{'metadata'}, + 'metadata',\%Data); + if ($err) { + &log(0,"MySQL Error Insert: ".$err); + } + if ($count < 1) { + &log(0,"Unable to insert record into MySQL database for $url"); + } + } + # + # Reset $_ before leaving + $_ = $file; +} + +######################################################## +######################################################## +### ### +### &metadata($uri) ### +### Retrieve metadata for the given file ### +### ### +######################################################## +######################################################## sub metadata { - my ($uri,$what)=@_; - my %metacache; + 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; - } else { - $metacache{$uri.'keys'}=$unikey; - } - map { - $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_}; - } @{$token->[3]}; - unless ( - $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry) - ) { $metacache{$uri.''.$unikey}= - $metacache{$uri.''.$unikey.'.default'}; - } - } - } + if ($filename !~ /\.meta$/) { + $filename.='.meta'; + } + my $metastring = + &LONCAPA::lonmetadata::getfile($Apache::lonnet::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; } -# ------------------------------------------------------------ Serves up a file -# returns either the contents of the file or a -1 -sub getfile { - my $file=shift; - if (! -e $file ) { return -1; }; - my $fh=IO::File->new($file); - my $a=''; - while (<$fh>) { $a .=$_; } - return $a +######################################################## +######################################################## +### ### +### Dynamic Metadata ### +### ### +######################################################## +######################################################## +## +## Dynamic metadata description (incomplete) +## +## For a full description of all fields, +## see LONCAPA::lonmetadata +## +## Field Type +##----------------------------------------------------------- +## count integer +## course integer +## course_list comma separated list of course ids +## avetries real +## avetries_list comma separated list of real numbers +## stdno real +## stdno_list comma separated list of real numbers +## usage integer +## usage_list comma separated list of resources +## goto scalar +## goto_list comma separated list of resources +## comefrom scalar +## comefrom_list comma separated list of resources +## difficulty real +## difficulty_list comma separated list of real numbers +## sequsage scalar +## sequsage_list comma separated list of resources +## clear real +## technical real +## correct real +## helpful real +## depth real +## comments html of all the comments made +## +{ + +my %DynamicData; +my %Counts; + +sub process_dynamic_metadata { + my ($user,$dom) = @_; + undef(%DynamicData); + undef(%Counts); + # + my $prodir = &propath($dom,$user); + # + # Read in the dynamic metadata + my %evaldata; + if (! tie(%evaldata,'GDBM_File', + $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) { + return 0; + } + # + %DynamicData = &LONCAPA::lonmetadata::process_reseval_data(\%evaldata); + untie(%evaldata); + $DynamicData{'domain'} = $dom; + #print('user = '.$user.' domain = '.$dom.$/); + # + # Read in the access count data + &log(7,'Reading access count data') if ($debug); + my %countdata; + if (! tie(%countdata,'GDBM_File', + $prodir.'/nohist_accesscount.db',&GDBM_READER(),0640)) { + return 0; + } + while (my ($key,$count) = each(%countdata)) { + next if ($key !~ /^$dom/); + $key = &unescape($key); + &log(8,' Count '.$key.' = '.$count) if ($debug); + $Counts{$key}=$count; + } + untie(%countdata); + if ($debug) { + &log(7,scalar(keys(%Counts)). + " Counts read for ".$user."@".$dom); + &log(7,scalar(keys(%DynamicData)). + " Dynamic metadata read for ".$user."@".$dom); + } + # + return 1; } -# ------------------------------------------------------------- Declutters URLs -sub declutter { - my $thisfn=shift; - $thisfn=~s/^$perlvar{'lonDocRoot'}//; - $thisfn=~s/^\///; - $thisfn=~s/^res\///; - return $thisfn; +sub get_dynamic_metadata { + my ($url) = @_; + $url =~ s:^/res/::; + my %data = &LONCAPA::lonmetadata::process_dynamic_metadata($url, + \%DynamicData); + # find the count + $data{'count'} = $Counts{$url}; + # + # Log the dynamic metadata + if ($debug) { + while (my($k,$v)=each(%data)) { + &log(8," ".$k." => ".$v); + } + } + return %data; } -# --------------------------------------- Is this the home server of an author? -# (copied from lond, modification of the return value) +} # End of %DynamicData and %Counts scope + +######################################################## +######################################################## +### ### +### Counts ### +### ### +######################################################## +######################################################## +{ + +my %countext; + +sub count_type { + my $file=shift; + $file=~/\.(\w+)$/; + my $ext=lc($1); + $countext{$ext}++; +} + +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); +} + +} # 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/; + $author=~s{/home/httpd/html/res/([^/]*)/([^/]*).*}{$1/$2}; my ($udom,$uname)=split(/\//,$author); my $proname=propath($udom,$uname); if (-e $proname) { @@ -202,22 +902,14 @@ sub ishome { } } -# -------------------------------------------- Return path to profile directory -# (copied from lond) -sub propath { - my ($udom,$uname)=@_; - $udom=~s/\W//g; - $uname=~s/\W//g; - my $subdir=$uname.'__'; - $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; - my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; - return $proname; -} - -# ---------------------------- convert 'time' format into a datetime sql format -sub sqltime { - my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = - localtime(@_[0]); - $mon++; $year+=1900; - return "$year-$mon-$mday $hour:$min:$sec"; +## +## &declutter($filename) +## Given a filename, returns a url for the filename. +sub declutter { + my $thisfn=shift; + $thisfn=~s/^$Apache::lonnet::perlvar{'lonDocRoot'}//; + $thisfn=~s/^\///; + $thisfn=~s/^res\///; + return $thisfn; } +