Return to searchcat.pl CVS log

Up to [LON-CAPA] / loncom / metadata_database

- Accommodate sub-directory structure of user directories containing dot(s)
  within the first three characters of the username.

    1: #!/usr/bin/perl
    2: # The LearningOnline Network
    3: # searchcat.pl "Search Catalog" batch script
    4: #
    5: # $Id: searchcat.pl,v 1.83 2016/01/27 22:22:59 raeburn Exp $
    6: #
    7: # Copyright Michigan State University Board of Trustees
    8: #
    9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
   10: #
   11: # LON-CAPA is free software; you can redistribute it and/or modify
   12: # it under the terms of the GNU General Public License as published by
   13: # the Free Software Foundation; either version 2 of the License, or
   14: # (at your option) any later version.
   15: #
   16: # LON-CAPA is distributed in the hope that it will be useful,
   17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   19: # GNU General Public License for more details.
   20: #
   21: # You should have received a copy of the GNU General Public License
   22: # along with LON-CAPA; if not, write to the Free Software
   23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   24: #
   25: # /home/httpd/html/adm/gpl.txt
   26: #
   27: # http://www.lon-capa.org/
   28: #
   29: ###
   30: 
   31: =pod
   32: 
   33: =head1 NAME
   34: 
   35: B<searchcat.pl> - put authoritative filesystem data into sql database.
   36: 
   37: =head1 SYNOPSIS
   38: 
   39: Ordinarily this script is to be called from a loncapa cron job
   40: (CVS source location: F<loncapa/loncom/cron/loncapa>; typical
   41: filesystem installation location: F</etc/cron.d/loncapa>).
   42: 
   43: Here is the cron job entry.
   44: 
   45: C<# Repopulate and refresh the metadata database used for the search catalog.>
   46: C<10 1 * * 7    www    /home/httpd/perl/searchcat.pl>
   47: 
   48: This script only allows itself to be run as the user C<www>.
   49: 
   50: =head1 DESCRIPTION
   51: 
   52: This script goes through a loncapa resource directory and gathers metadata.
   53: The metadata is entered into a SQL database.
   54: 
   55: This script also does general database maintenance such as reformatting
   56: the C<loncapa:metadata> table if it is deprecated.
   57: 
   58: This script evaluates dynamic metadata from the authors'
   59: F<nohist_resevaldata.db> database file in order to store it in MySQL.
   60: 
   61: This script is playing an increasingly important role for a loncapa
   62: library server.  The proper operation of this script is critical for a smooth
   63: and correct user experience.
   64: 
   65: =cut
   66: 
   67: use strict;
   68: use DBI;
   69: use lib '/home/httpd/lib/perl/';
   70: use LONCAPA::lonmetadata;
   71: use LONCAPA;
   72: use Getopt::Long;
   73: use IO::File;
   74: use HTML::TokeParser;
   75: use GDBM_File;
   76: use POSIX qw(strftime mktime);
   77: use Mail::Send;
   78: use Apache::loncommon();
   79: 
   80: use Apache::lonnet();
   81: 
   82: use File::Find;
   83: 
   84: #
   85: # Set up configuration options
   86: my ($simulate,$oneuser,$help,$verbose,$logfile,$debug);
   87: GetOptions (
   88:             'help'     => \$help,
   89:             'simulate' => \$simulate,
   90:             'only=s'   => \$oneuser,
   91:             'verbose=s'  => \$verbose,
   92:             'debug' => \$debug,
   93:             );
   94: 
   95: if ($help) {
   96:     print <<"ENDHELP";
   97: $0
   98: Rebuild and update the LON-CAPA metadata database. 
   99: Options:
  100:     -help          Print this help
  101:     -simulate      Do not modify the database.
  102:     -only=user     Only compute for the given user.  Implies -simulate   
  103:     -verbose=val   Sets logging level, val must be a number
  104:     -debug         Turns on debugging output
  105: ENDHELP
  106:     exit 0;
  107: }
  108: 
  109: if (! defined($debug)) {
  110:     $debug = 0;
  111: }
  112: 
  113: if (! defined($verbose)) {
  114:     $verbose = 0;
  115: }
  116: 
  117: if (defined($oneuser)) {
  118:     $simulate=1;
  119: }
  120: 
  121: ##
  122: ## Use variables for table names so we can test this routine a little easier
  123: my %oldnames = (
  124:                  'metadata'    => 'metadata',
  125:                  'portfolio'   => 'portfolio_metadata',
  126:                  'access'      => 'portfolio_access',
  127:                  'addedfields' => 'portfolio_addedfields',
  128:                  'allusers'    => 'allusers',
  129:                );
  130: 
  131: my %newnames;
  132: # new table names -  append pid to have unique temporary tables
  133: foreach my $key (keys(%oldnames)) {
  134:     $newnames{$key} = 'new'.$oldnames{$key}.$$;
  135: }
  136: 
  137: #
  138: # Only run if machine is a library server
  139: exit if ($Apache::lonnet::perlvar{'lonRole'} ne 'library');
  140: my $hostid = $Apache::lonnet::perlvar{'lonHostID'};
  141: 
  142: #
  143: #  Make sure this process is running from user=www
  144: my $wwwid=getpwnam('www');
  145: if ($wwwid!=$<) {
  146:     my $emailto="$Apache::lonnet::perlvar{'lonAdmEMail'},$Apache::lonnet::perlvar{'lonSysEMail'}";
  147:     my $subj="LON: $Apache::lonnet::perlvar{'lonHostID'} User ID mismatch";
  148:     system("echo 'User ID mismatch. searchcat.pl must be run as user www.' |\
  149:  mail -s '$subj' $emailto > /dev/null");
  150:     exit 1;
  151: }
  152: #
  153: # Let people know we are running
  154: open(LOG,'>>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/logs/searchcat.log');
  155: &log(0,'==== Searchcat Run '.localtime()."====");
  156: 
  157: 
  158: if ($debug) {
  159:     &log(0,'simulating') if ($simulate);
  160:     &log(0,'only processing user '.$oneuser) if ($oneuser);
  161:     &log(0,'verbosity level = '.$verbose);
  162: }
  163: #
  164: # Connect to database
  165: my $dbh;
  166: if (! ($dbh = DBI->connect("DBI:mysql:loncapa","www",$Apache::lonnet::perlvar{'lonSqlAccess'},
  167:                           { RaiseError =>0,PrintError=>0}))) {
  168:     &log(0,"Cannot connect to database!");
  169:     die "MySQL Error: Cannot connect to database!\n";
  170: }
  171: # This can return an error and still be okay, so we do not bother checking.
  172: # (perhaps it should be more robust and check for specific errors)
  173: foreach my $key (keys(%newnames)) {
  174:     if ($newnames{$key} ne '') {
  175:         $dbh->do('DROP TABLE IF EXISTS '.$newnames{$key});
  176:     }
  177: }
  178: 
  179: #
  180: # Create the new metadata, portfolio and allusers tables
  181: foreach my $key (keys(%newnames)) {
  182:     if ($newnames{$key} ne '') { 
  183:         my $request =
  184:              &LONCAPA::lonmetadata::create_metadata_storage($newnames{$key},$oldnames{$key});
  185:         $dbh->do($request);
  186:         if ($dbh->err) {
  187:             $dbh->disconnect();
  188:             &log(0,"MySQL Error Create: ".$dbh->errstr);
  189:             die $dbh->errstr;
  190:         }
  191:     }
  192: }
  193: 
  194: #
  195: # find out which users we need to examine
  196: my @domains = sort(&Apache::lonnet::current_machine_domains());
  197: &log(9,'domains ="'.join('","',@domains).'"');
  198: 
  199: foreach my $dom (@domains) {
  200:     &log(9,'domain = '.$dom);
  201:     opendir(RESOURCES,"$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom");
  202:     my @homeusers = 
  203:         grep {
  204:             &ishome("$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom/$_");
  205:         } grep { 
  206:             !/^\.\.?$/;
  207:         } readdir(RESOURCES);
  208:     closedir RESOURCES;
  209:     &log(5,'users = '.$dom.':'.join(',',@homeusers));
  210:     #
  211:     if ($oneuser) {
  212:         @homeusers=($oneuser);
  213:     }
  214: 
  215:     #
  216:     # Loop through the users
  217:     foreach my $user (@homeusers) {
  218:         &log(0,"=== User: ".$user);
  219:         &process_dynamic_metadata($user,$dom);
  220:         #
  221:         # Use File::Find to get the files we need to read/modify
  222:         find(
  223:              {preprocess => \&only_meta_files,
  224:               #wanted     => \&print_filename,
  225:               #wanted     => \&log_metadata,
  226:               wanted     => \&process_meta_file,
  227:               no_chdir   => 1,
  228:              }, join('/',($Apache::lonnet::perlvar{'lonDocRoot'},'res',$dom,$user)) );
  229:     }
  230:     # Search for all users and public portfolio files
  231:     my (%allusers,%portusers,%courses);
  232:     if ($oneuser) {
  233:         %portusers = (
  234:                         $oneuser => '',
  235:                        );
  236:         %allusers = (
  237:                         $oneuser => '',
  238:                        );
  239:         %courses = &courseiddump($dom,'.',1,'.','.',$oneuser,undef,
  240:                                  undef,'.');
  241:     } else {
  242:         # get courseIDs for domain on current machine
  243:         %courses=&Apache::lonnet::courseiddump($dom,'.',1,'.','.','.',1,[$hostid],'.');
  244:         my $dir = $Apache::lonnet::perlvar{lonUsersDir}.'/'.$dom;
  245:         &descend_tree($dom,$dir,0,\%portusers,\%allusers);
  246:     }
  247:     foreach my $uname (keys(%portusers)) {
  248:         my $urlstart = '/uploaded/'.$dom.'/'.$uname;
  249:         my $pathstart = &propath($dom,$uname).'/userfiles';
  250:         my $is_course = '';
  251:         if (exists($courses{$dom.'_'.$uname})) {
  252:             $is_course = 1;
  253:         }
  254:         my $curr_perm = &Apache::lonnet::get_portfile_permissions($dom,$uname);
  255:         my %access = &Apache::lonnet::get_access_controls($curr_perm);
  256:         foreach my $file (keys(%access)) {
  257:             my ($group,$url,$fullpath);
  258:             if ($is_course) {
  259:                 ($group, my ($path)) = ($file =~ /^(\w+)(\/.+)$/);
  260:                 $fullpath = $pathstart.'/groups/'.$group.'/portfolio'.$path;
  261:                 $url = $urlstart.'/groups/'.$group.'/portfolio'.$path;
  262:             } else {
  263:                 $fullpath = $pathstart.'/portfolio'.$file;
  264:                 $url = $urlstart.'/portfolio'.$file;
  265:             }
  266:             if (ref($access{$file}) eq 'HASH') {
  267:                 my %portaccesslog = 
  268:                     &LONCAPA::lonmetadata::process_portfolio_access_data($dbh,
  269:                            $simulate,\%newnames,$url,$fullpath,$access{$file});
  270:                 &portfolio_logging(%portaccesslog);
  271:             }
  272:             my %portmetalog = &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,$simulate,\%newnames,$url,$fullpath,$is_course,$dom,$uname,$group);
  273:             &portfolio_logging(%portmetalog);
  274:         }
  275:     }
  276:     my (%names_by_id,,%ids_by_name,%idstodelete,%idstoadd,%duplicates);
  277:     unless ($simulate || $oneuser) {
  278:         my $idshashref;
  279:         $idshashref = &tie_domain_hash($dom, "ids", &GDBM_WRCREAT());
  280:         if (ref($idshashref) eq 'HASH') {
  281:             %names_by_id = %{$idshashref};
  282:             while (my ($id,$uname) = each(%{$idshashref}) ) {
  283:                 $id = &unescape($id);
  284:                 $uname = &unescape($uname); 
  285:                 $names_by_id{$id} = $uname;
  286:                 push(@{$ids_by_name{$uname}},$id);
  287:             }
  288:             &untie_domain_hash($idshashref);
  289:         }
  290:     }
  291:     # Update allusers
  292:     foreach my $uname (keys(%allusers)) {
  293:         next if (exists($courses{$dom.'_'.$uname}));
  294:         my %userdata = 
  295:             &Apache::lonnet::get('environment',['firstname','lastname',
  296:                 'middlename','generation','id','permanentemail'],$dom,$uname);
  297:         unless ($simulate || $oneuser) {
  298:             my $addid;
  299:             if ($userdata{'id'} ne '') {
  300:                 $addid = $userdata{'id'};
  301:                 $addid=~tr/A-Z/a-z/;
  302:             }
  303:             if (exists($ids_by_name{$uname})) {
  304:                 if (ref($ids_by_name{$uname}) eq 'ARRAY') {
  305:                     if (scalar(@{$ids_by_name{$uname}}) > 1) {
  306:                         &log(0,"Multiple employee/student IDs found in ids.db for $uname:$dom -- ".join(', ',@{$ids_by_name{$uname}}));
  307:                     }
  308:                     foreach my $id (@{$ids_by_name{$uname}}) {
  309:                         if ($id eq $userdata{'id'}) {
  310:                             undef($addid);
  311:                         } else { 
  312:                             $idstodelete{$id} = $uname;
  313:                         }
  314:                     }
  315:                 }
  316:             }
  317:             if ($addid ne '') {
  318:                 if (exists($idstoadd{$addid})) {
  319:                     push(@{$duplicates{$addid}},$uname);
  320:                 } else {
  321:                     $idstoadd{$addid} = $uname;
  322:                 }
  323:             }
  324:         }
  325:         
  326:         $userdata{'username'} = $uname;
  327:         $userdata{'domain'} = $dom;
  328:         my %alluserslog = 
  329:             &LONCAPA::lonmetadata::process_allusers_data($dbh,$simulate,
  330:                 \%newnames,$uname,$dom,\%userdata);
  331:         foreach my $item (keys(%alluserslog)) {
  332:             &log(0,$alluserslog{$item});
  333:         }
  334:     }
  335:     unless ($simulate || $oneuser) {
  336:         if (keys(%idstodelete) > 0) {
  337:             my %resulthash = &Apache::lonnet::iddel($dom,\%idstodelete,$hostid);
  338:             if ($resulthash{$hostid} eq 'ok') {
  339:                 foreach my $id (sort(keys(%idstodelete))) {
  340:                     &log(0,"Record deleted from ids.db for $dom -- $id => ".$idstodelete{$id});
  341:                 }
  342:             } else {
  343:                 &log(0,"Error: '$resulthash{$hostid}' occurred when attempting to delete records from ids.db for $dom");
  344:             }
  345:         }
  346:         if (keys(%idstoadd) > 0) {
  347:             my $idmessage = '';
  348:             my %newids;
  349:             foreach my $addid (sort(keys(%idstoadd))) {
  350:                 if ((exists($names_by_id{$addid})) && ($names_by_id{$addid} ne $idstoadd{$addid})  && !($idstodelete{$addid})) {
  351:                     &log(0,"Two usernames associated with a single ID $addid in domain: $dom: $names_by_id{$addid} (current) and $idstoadd{$addid}\n");
  352:                     $idmessage .= "$addid,$names_by_id{$addid},$idstoadd{$addid}\n";
  353:                 } else {
  354:                     $newids{$addid} = $idstoadd{$addid};
  355:                 }
  356:             }
  357:             if (keys(%newids) > 0) {
  358:                 my $putresult = &Apache::lonnet::put_dom('ids',\%idstoadd,$dom,$hostid);
  359:                 if ($putresult eq 'ok') {
  360:                     foreach my $id (sort(keys(%idstoadd))) {
  361:                         &log(0,"Record added to ids.db for $dom -- $id => ".$idstoadd{$id});
  362:                     }
  363:                 } else {
  364:                     &log(0,"Error: '$putresult' occurred when attempting to add records to ids.db for $dom"); 
  365:                 }
  366:             }
  367:             if ($idmessage) {
  368:                 my $to = &Apache::loncommon::build_recipient_list(undef,'idconflictsmail',$dom);
  369:                 if ($to ne '') {
  370:                     my $msg = new Mail::Send;
  371:                     $msg->to($to);
  372:                     $msg->subject('LON-CAPA studentIDs conflict');
  373:                     my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
  374:                     my $hostname = &Apache::lonnet::hostname($lonhost);
  375:                     my $replytoaddress = 'do-not-reply@'.$hostname;
  376:                     $msg->add('Reply-to',$replytoaddress);
  377:                     $msg->add('From','www@'.$hostname);
  378:                     $msg->add('Content-type','text/plain; charset=UTF-8');
  379:                     if (my $fh = $msg->open()) {
  380:                         print $fh 
  381:                             'The following IDs are used for more than one user in your domain:'."\n".
  382:                             'Each row contains: Student/Employee ID, Current username in ids.db file, '.
  383:                             'Additional username'."\n\n".
  384:                             $idmessage;
  385:                         $fh->close;
  386:                     }
  387:                 }
  388:             }
  389:         }
  390:         if (keys(%duplicates) > 0) {
  391:             foreach my $id (sort(keys(%duplicates))) {
  392:                 &log(0,"Duplicate IDs found for entries to add to ids.db in $dom -- $id => $idstodelete{$id}");
  393:             }
  394:         }
  395:     }
  396: }
  397: 
  398: #
  399: # Rename the tables
  400: if (! $simulate) {
  401:     foreach my $key (keys(%oldnames)) {
  402:         if (($oldnames{$key} ne '') && ($newnames{$key} ne '')) {
  403:             $dbh->do('DROP TABLE IF EXISTS '.$oldnames{$key});
  404:             if (! $dbh->do('RENAME TABLE '.$newnames{$key}.' TO '.$oldnames{$key})) {
  405:                 &log(0,"MySQL Error Rename: ".$dbh->errstr);
  406:                 die $dbh->errstr;
  407:             } else {
  408:                 &log(1,"MySQL table rename successful for $key.");
  409:             }
  410:         }
  411:     }
  412: }
  413: if (! $dbh->disconnect) {
  414:     &log(0,"MySQL Error Disconnect: ".$dbh->errstr);
  415:     die $dbh->errstr;
  416: }
  417: ##
  418: ## Finished!
  419: &log(0,"==== Searchcat completed ".localtime()." ====");
  420: close(LOG);
  421: 
  422: &write_type_count();
  423: &write_copyright_count();
  424: 
  425: exit 0;
  426: 
  427: ##
  428: ## Status logging routine.  Inputs: $level, $message
  429: ## 
  430: ## $level 0 should be used for normal output and error messages
  431: ##
  432: ## $message does not need to end with \n.  In the case of errors
  433: ## the message should contain as much information as possible to
  434: ## help in diagnosing the problem.
  435: ##
  436: sub log {
  437:     my ($level,$message)=@_;
  438:     $level = 0 if (! defined($level));
  439:     if ($verbose >= $level) {
  440:         print LOG $message.$/;
  441:     }
  442: }
  443: 
  444: sub portfolio_logging {
  445:     my (%portlog) = @_;
  446:     foreach my $key (keys(%portlog)) {
  447:         if (ref($portlog{$key}) eq 'HASH') {
  448:             foreach my $item (keys(%{$portlog{$key}})) {
  449:                 &log(0,$portlog{$key}{$item});
  450:             }
  451:         }
  452:     }
  453: }
  454: 
  455: sub descend_tree {
  456:     my ($dom,$dir,$depth,$allportusers,$alldomusers) = @_;
  457:     if (-d $dir) {
  458:         opendir(DIR,$dir);
  459:         my @contents = grep(!/^\./,readdir(DIR));
  460:         closedir(DIR);
  461:         $depth ++;
  462:         foreach my $item (@contents) {
  463:             if (($depth < 4) && (length($item) == 1)) {
  464:                 &descend_tree($dom,$dir.'/'.$item,$depth,$allportusers,$alldomusers);
  465:             } else {
  466:                 if (-e $dir.'/'.$item.'/file_permissions.db') {
  467:                     $$allportusers{$item} = '';
  468:                 }
  469:                 if (-e $dir.'/'.$item.'/passwd') {
  470:                     $$alldomusers{$item} = '';
  471:                 }
  472:             }       
  473:         }
  474:     } 
  475: }
  476: 
  477: ########################################################
  478: ########################################################
  479: ###                                                  ###
  480: ###          File::Find support routines             ###
  481: ###                                                  ###
  482: ########################################################
  483: ########################################################
  484: ##
  485: ## &only_meta_files
  486: ##
  487: ## Called by File::Find.
  488: ## Takes a list of files/directories in and returns a list of files/directories
  489: ## to search.
  490: sub only_meta_files {
  491:     my @PossibleFiles = @_;
  492:     my @ChosenFiles;
  493:     foreach my $file (@PossibleFiles) {
  494:         if ( ($file =~ /\.meta$/ &&            # Ends in meta
  495:               $file !~ /\.\d+\.[^\.]+\.meta$/  # is not for a prior version
  496:              ) || (-d $File::Find::dir."/".$file )) { # directories are okay
  497:                  # but we do not want /. or /..
  498:             push(@ChosenFiles,$file);
  499:         }
  500:     }
  501:     return @ChosenFiles;
  502: }
  503: 
  504: ##
  505: ##
  506: ## Debugging routines, use these for 'wanted' in the File::Find call
  507: ##
  508: sub print_filename {
  509:     my ($file) = $_;
  510:     my $fullfilename = $File::Find::name;
  511:     if ($debug) {
  512:         if (-d $file) {
  513:             &log(5," Got directory ".$fullfilename);
  514:         } else {
  515:             &log(5," Got file ".$fullfilename);
  516:         }
  517:     }
  518:     $_=$file;
  519: }
  520: 
  521: sub log_metadata {
  522:     my ($file) = $_;
  523:     my $fullfilename = $File::Find::name;
  524:     return if (-d $fullfilename); # No need to do anything here for directories
  525:     if ($debug) {
  526:         &log(6,$fullfilename);
  527:         my $ref = &metadata($fullfilename);
  528:         if (! defined($ref)) {
  529:             &log(6,"    No data");
  530:             return;
  531:         }
  532:         while (my($key,$value) = each(%$ref)) {
  533:             &log(6,"    ".$key." => ".$value);
  534:         }
  535:         &count_copyright($ref->{'copyright'});
  536:     }
  537:     $_=$file;
  538: }
  539: 
  540: ##
  541: ## process_meta_file
  542: ##   Called by File::Find. 
  543: ##   Only input is the filename in $_.  
  544: sub process_meta_file {
  545:     my ($file) = $_;
  546:     my $filename = $File::Find::name; # full filename
  547:     return if (-d $filename); # No need to do anything here for directories
  548:     #
  549:     &log(3,$filename) if ($debug);
  550:     #
  551:     my $ref = &metadata($filename);
  552:     #
  553:     # $url is the original file url, not the metadata file
  554:     my $target = $filename;
  555:     $target =~ s/\.meta$//;
  556:     my $url='/res/'.&declutter($target);
  557:     &log(3,"    ".$url) if ($debug);
  558:     #
  559:     # Ignore some files based on their metadata
  560:     if ($ref->{'obsolete'}) { 
  561:         &log(3,"obsolete") if ($debug);
  562:         return; 
  563:     }
  564:     &count_copyright($ref->{'copyright'});
  565:     if ($ref->{'copyright'} eq 'private') { 
  566:         &log(3,"private") if ($debug);
  567:         return; 
  568:     }
  569:     #
  570:     # Find the dynamic metadata
  571:     my %dyn;
  572:     if ($url=~ m:/default$:) {
  573:         $url=~ s:/default$:/:;
  574:         &log(3,"Skipping dynamic data") if ($debug);
  575:     } else {
  576:         &log(3,"Retrieving dynamic data") if ($debug);
  577:         %dyn=&get_dynamic_metadata($url);
  578:         &count_type($url);
  579:     }
  580:     &LONCAPA::lonmetadata::getfiledates($ref,$target);
  581:     #
  582:     my %Data = (
  583:                 %$ref,
  584:                 %dyn,
  585:                 'url'=>$url,
  586:                 'version'=>'current');
  587:     if (! $simulate) {
  588:         my ($count,$err) = 
  589:           &LONCAPA::lonmetadata::store_metadata($dbh,$newnames{'metadata'},
  590:                                                 'metadata',\%Data);
  591:         if ($err) {
  592:             &log(0,"MySQL Error Insert: ".$err);
  593:         }
  594:         if ($count < 1) {
  595:             &log(0,"Unable to insert record into MySQL database for $url");
  596:         }
  597:     }
  598:     #
  599:     # Reset $_ before leaving
  600:     $_ = $file;
  601: }
  602: 
  603: ########################################################
  604: ########################################################
  605: ###                                                  ###
  606: ###  &metadata($uri)                                 ###
  607: ###   Retrieve metadata for the given file           ###
  608: ###                                                  ###
  609: ########################################################
  610: ########################################################
  611: sub metadata {
  612:     my ($uri) = @_;
  613:     my %metacache=();
  614:     $uri=&declutter($uri);
  615:     my $filename=$uri;
  616:     $uri=~s/\.meta$//;
  617:     $uri='';
  618:     if ($filename !~ /\.meta$/) { 
  619:         $filename.='.meta';
  620:     }
  621:     my $metastring = 
  622:         &LONCAPA::lonmetadata::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$filename);
  623:     return undef if (! defined($metastring));
  624:     my $parser=HTML::TokeParser->new(\$metastring);
  625:     my $token;
  626:     while ($token=$parser->get_token) {
  627:         if ($token->[0] eq 'S') {
  628:             my $entry=$token->[1];
  629:             my $unikey=$entry;
  630:             if (defined($token->[2]->{'part'})) { 
  631:                 $unikey.='_'.$token->[2]->{'part'}; 
  632:             }
  633:             if (defined($token->[2]->{'name'})) { 
  634:                 $unikey.='_'.$token->[2]->{'name'}; 
  635:             }
  636:             if ($metacache{$uri.'keys'}) {
  637:                 $metacache{$uri.'keys'}.=','.$unikey;
  638:             } else {
  639:                 $metacache{$uri.'keys'}=$unikey;
  640:             }
  641:             foreach ( @{$token->[3]}) {
  642:                 $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
  643:             }
  644:             if (! ($metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry))){
  645:                 $metacache{$uri.''.$unikey} = 
  646:                     $metacache{$uri.''.$unikey.'.default'};
  647:             }
  648:         } # End of ($token->[0] eq 'S')
  649:     }
  650:     return \%metacache;
  651: }
  652: 
  653: ########################################################
  654: ########################################################
  655: ###                                                  ###
  656: ###    Dynamic Metadata                              ###
  657: ###                                                  ###
  658: ########################################################
  659: ########################################################
  660: ##
  661: ## Dynamic metadata description (incomplete)
  662: ##
  663: ## For a full description of all fields,
  664: ## see LONCAPA::lonmetadata
  665: ##
  666: ##   Field             Type
  667: ##-----------------------------------------------------------
  668: ##   count             integer
  669: ##   course            integer
  670: ##   course_list       comma separated list of course ids
  671: ##   avetries          real                                
  672: ##   avetries_list     comma separated list of real numbers
  673: ##   stdno             real
  674: ##   stdno_list        comma separated list of real numbers
  675: ##   usage             integer   
  676: ##   usage_list        comma separated list of resources
  677: ##   goto              scalar
  678: ##   goto_list         comma separated list of resources
  679: ##   comefrom          scalar
  680: ##   comefrom_list     comma separated list of resources
  681: ##   difficulty        real
  682: ##   difficulty_list   comma separated list of real numbers
  683: ##   sequsage          scalar
  684: ##   sequsage_list     comma separated list of resources
  685: ##   clear             real
  686: ##   technical         real
  687: ##   correct           real
  688: ##   helpful           real
  689: ##   depth             real
  690: ##   comments          html of all the comments made
  691: ##
  692: {
  693: 
  694: my %DynamicData;
  695: my %Counts;
  696: 
  697: sub process_dynamic_metadata {
  698:     my ($user,$dom) = @_;
  699:     undef(%DynamicData);
  700:     undef(%Counts);
  701:     #
  702:     my $prodir = &propath($dom,$user);
  703:     #
  704:     # Read in the dynamic metadata
  705:     my %evaldata;
  706:     if (! tie(%evaldata,'GDBM_File',
  707:               $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) {
  708:         return 0;
  709:     }
  710:     #
  711:     %DynamicData = &LONCAPA::lonmetadata::process_reseval_data(\%evaldata);
  712:     untie(%evaldata);
  713:     $DynamicData{'domain'} = $dom;
  714:     #print('user = '.$user.' domain = '.$dom.$/);
  715:     #
  716:     # Read in the access count data
  717:     &log(7,'Reading access count data') if ($debug);
  718:     my %countdata;
  719:     if (! tie(%countdata,'GDBM_File',
  720:               $prodir.'/nohist_accesscount.db',&GDBM_READER(),0640)) {
  721:         return 0;
  722:     }
  723:     while (my ($key,$count) = each(%countdata)) {
  724:         next if ($key !~ /^$dom/);
  725:         $key = &unescape($key);
  726:         &log(8,'    Count '.$key.' = '.$count) if ($debug);
  727:         $Counts{$key}=$count;
  728:     }
  729:     untie(%countdata);
  730:     if ($debug) {
  731:         &log(7,scalar(keys(%Counts)).
  732:              " Counts read for ".$user."@".$dom);
  733:         &log(7,scalar(keys(%DynamicData)).
  734:              " Dynamic metadata read for ".$user."@".$dom);
  735:     }
  736:     #
  737:     return 1;
  738: }
  739: 
  740: sub get_dynamic_metadata {
  741:     my ($url) = @_;
  742:     $url =~ s:^/res/::;
  743:     my %data = &LONCAPA::lonmetadata::process_dynamic_metadata($url,
  744:                                                                \%DynamicData);
  745:     # find the count
  746:     $data{'count'} = $Counts{$url};
  747:     #
  748:     # Log the dynamic metadata
  749:     if ($debug) {
  750:         while (my($k,$v)=each(%data)) {
  751:             &log(8,"    ".$k." => ".$v);
  752:         }
  753:     }
  754:     return %data;
  755: }
  756: 
  757: } # End of %DynamicData and %Counts scope
  758: 
  759: ########################################################
  760: ########################################################
  761: ###                                                  ###
  762: ###   Counts                                         ###
  763: ###                                                  ###
  764: ########################################################
  765: ########################################################
  766: {
  767: 
  768: my %countext;
  769: 
  770: sub count_type {
  771:     my $file=shift;
  772:     $file=~/\.(\w+)$/;
  773:     my $ext=lc($1);
  774:     $countext{$ext}++;
  775: }
  776: 
  777: sub write_type_count {
  778:     open(RESCOUNT,'>/home/httpd/html/lon-status/rescount.txt');
  779:     while (my ($extension,$count) = each(%countext)) {
  780: 	print RESCOUNT $extension.'='.$count.'&';
  781:     }
  782:     print RESCOUNT 'time='.time."\n";
  783:     close(RESCOUNT);
  784: }
  785: 
  786: } # end of scope for %countext
  787: 
  788: {
  789: 
  790: my %copyrights;
  791: 
  792: sub count_copyright {
  793:     $copyrights{@_[0]}++;
  794: }
  795: 
  796: sub write_copyright_count {
  797:     open(COPYCOUNT,'>/home/httpd/html/lon-status/copyrightcount.txt');
  798:     while (my ($copyright,$count) = each(%copyrights)) {
  799: 	print COPYCOUNT $copyright.'='.$count.'&';
  800:     }
  801:     print COPYCOUNT 'time='.time."\n";
  802:     close(COPYCOUNT);
  803: }
  804: 
  805: } # end of scope for %copyrights
  806: 
  807: ########################################################
  808: ########################################################
  809: ###                                                  ###
  810: ###   Miscellanous Utility Routines                  ###
  811: ###                                                  ###
  812: ########################################################
  813: ########################################################
  814: ##
  815: ## &ishome($username)
  816: ##   Returns 1 if $username is a LON-CAPA author, 0 otherwise
  817: ##   (copied from lond, modification of the return value)
  818: sub ishome {
  819:     my $author=shift;
  820:     $author=~s{/home/httpd/html/res/([^/]*)/([^/]*).*}{$1/$2};
  821:     my ($udom,$uname)=split(/\//,$author);
  822:     my $proname=propath($udom,$uname);
  823:     if (-e $proname) {
  824: 	return 1;
  825:     } else {
  826:         return 0;
  827:     }
  828: }
  829: 
  830: ##
  831: ## &declutter($filename)
  832: ##   Given a filename, returns a url for the filename.
  833: sub declutter {
  834:     my $thisfn=shift;
  835:     $thisfn=~s/^$Apache::lonnet::perlvar{'lonDocRoot'}//;
  836:     $thisfn=~s/^\///;
  837:     $thisfn=~s/^res\///;
  838:     return $thisfn;
  839: }
  840: