Annotation of loncom/metadata_database/searchcat.pl, revision 1.82

1.1       harris41    1: #!/usr/bin/perl
                      2: # The LearningOnline Network
                      3: # searchcat.pl "Search Catalog" batch script
1.16      harris41    4: #
1.82    ! raeburn     5: # $Id: searchcat.pl,v 1.81 2013/08/22 09:30:21 bisitz Exp $
1.16      harris41    6: #
                      7: # Copyright Michigan State University Board of Trustees
                      8: #
1.29      albertel    9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
1.16      harris41   10: #
1.29      albertel   11: # LON-CAPA is free software; you can redistribute it and/or modify
1.16      harris41   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: #
1.29      albertel   16: # LON-CAPA is distributed in the hope that it will be useful,
1.16      harris41   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
1.29      albertel   22: # along with LON-CAPA; if not, write to the Free Software
1.16      harris41   23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     24: #
                     25: # /home/httpd/html/adm/gpl.txt
                     26: #
1.29      albertel   27: # http://www.lon-capa.org/
1.16      harris41   28: #
                     29: ###
1.33      matthew    30: 
1.32      www        31: =pod
1.1       harris41   32: 
1.32      www        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'
1.48      www        59: F<nohist_resevaldata.db> database file in order to store it in MySQL.
1.32      www        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
1.1       harris41   66: 
1.45      www        67: use strict;
1.55      matthew    68: use DBI;
1.17      harris41   69: use lib '/home/httpd/lib/perl/';
1.55      matthew    70: use LONCAPA::lonmetadata;
1.76      albertel   71: use LONCAPA;
1.56      matthew    72: use Getopt::Long;
1.1       harris41   73: use IO::File;
                     74: use HTML::TokeParser;
1.21      www        75: use GDBM_File;
1.24      www        76: use POSIX qw(strftime mktime);
1.80      raeburn    77: use Mail::Send;
1.81      bisitz     78: use Apache::loncommon();
1.56      matthew    79: 
1.63      matthew    80: use Apache::lonnet();
1.62      matthew    81: 
1.55      matthew    82: use File::Find;
1.1       harris41   83: 
1.56      matthew    84: #
                     85: # Set up configuration options
1.63      matthew    86: my ($simulate,$oneuser,$help,$verbose,$logfile,$debug);
1.56      matthew    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: 
1.55      matthew   121: ##
                    122: ## Use variables for table names so we can test this routine a little easier
1.69      raeburn   123: my %oldnames = (
                    124:                  'metadata'    => 'metadata',
                    125:                  'portfolio'   => 'portfolio_metadata',
                    126:                  'access'      => 'portfolio_access',
                    127:                  'addedfields' => 'portfolio_addedfields',
1.78      raeburn   128:                  'allusers'    => 'allusers',
1.69      raeburn   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: }
1.45      www       136: 
1.55      matthew   137: #
                    138: # Only run if machine is a library server
1.63      matthew   139: exit if ($Apache::lonnet::perlvar{'lonRole'} ne 'library');
1.78      raeburn   140: my $hostid = $Apache::lonnet::perlvar{'lonHostID'};
                    141: 
1.55      matthew   142: #
                    143: #  Make sure this process is running from user=www
                    144: my $wwwid=getpwnam('www');
                    145: if ($wwwid!=$<) {
1.63      matthew   146:     my $emailto="$Apache::lonnet::perlvar{'lonAdmEMail'},$Apache::lonnet::perlvar{'lonSysEMail'}";
                    147:     my $subj="LON: $Apache::lonnet::perlvar{'lonHostID'} User ID mismatch";
1.55      matthew   148:     system("echo 'User ID mismatch. searchcat.pl must be run as user www.' |\
1.63      matthew   149:  mail -s '$subj' $emailto > /dev/null");
1.55      matthew   150:     exit 1;
                    151: }
                    152: #
                    153: # Let people know we are running
1.63      matthew   154: open(LOG,'>>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/logs/searchcat.log');
1.56      matthew   155: &log(0,'==== Searchcat Run '.localtime()."====");
1.57      matthew   156: 
                    157: 
1.56      matthew   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: }
1.55      matthew   163: #
                    164: # Connect to database
                    165: my $dbh;
1.63      matthew   166: if (! ($dbh = DBI->connect("DBI:mysql:loncapa","www",$Apache::lonnet::perlvar{'lonSqlAccess'},
1.55      matthew   167:                           { RaiseError =>0,PrintError=>0}))) {
1.56      matthew   168:     &log(0,"Cannot connect to database!");
1.55      matthew   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)
1.69      raeburn   173: foreach my $key (keys(%newnames)) {
                    174:     if ($newnames{$key} ne '') {
                    175:         $dbh->do('DROP TABLE IF EXISTS '.$newnames{$key});
                    176:     }
                    177: }
                    178: 
1.55      matthew   179: #
1.77      raeburn   180: # Create the new metadata, portfolio and allusers tables
1.69      raeburn   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:     }
1.55      matthew   192: }
1.69      raeburn   193: 
1.55      matthew   194: #
                    195: # find out which users we need to examine
1.63      matthew   196: my @domains = sort(&Apache::lonnet::current_machine_domains());
                    197: &log(9,'domains ="'.join('","',@domains).'"');
1.62      matthew   198: 
                    199: foreach my $dom (@domains) {
                    200:     &log(9,'domain = '.$dom);
1.63      matthew   201:     opendir(RESOURCES,"$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom");
1.62      matthew   202:     my @homeusers = 
                    203:         grep {
1.63      matthew   204:             &ishome("$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom/$_");
1.62      matthew   205:         } grep { 
                    206:             !/^\.\.?$/;
                    207:         } readdir(RESOURCES);
                    208:     closedir RESOURCES;
                    209:     &log(5,'users = '.$dom.':'.join(',',@homeusers));
                    210:     #
                    211:     if ($oneuser) {
                    212:         @homeusers=($oneuser);
                    213:     }
1.80      raeburn   214: 
1.62      matthew   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,
1.66      albertel  227:               no_chdir   => 1,
1.63      matthew   228:              }, join('/',($Apache::lonnet::perlvar{'lonDocRoot'},'res',$dom,$user)) );
1.62      matthew   229:     }
1.77      raeburn   230:     # Search for all users and public portfolio files
1.78      raeburn   231:     my (%allusers,%portusers,%courses);
1.69      raeburn   232:     if ($oneuser) {
                    233:         %portusers = (
                    234:                         $oneuser => '',
                    235:                        );
1.77      raeburn   236:         %allusers = (
                    237:                         $oneuser => '',
                    238:                        );
1.78      raeburn   239:         %courses = &courseiddump($dom,'.',1,'.','.',$oneuser,undef,
                    240:                                  undef,'.');
1.69      raeburn   241:     } else {
1.78      raeburn   242:         # get courseIDs for domain on current machine
                    243:         %courses=&Apache::lonnet::courseiddump($dom,'.',1,'.','.','.',1,[$hostid],'.');
1.69      raeburn   244:         my $dir = $Apache::lonnet::perlvar{lonUsersDir}.'/'.$dom;
1.77      raeburn   245:         &descend_tree($dom,$dir,0,\%portusers,\%allusers);
1.69      raeburn   246:     }
                    247:     foreach my $uname (keys(%portusers)) {
                    248:         my $urlstart = '/uploaded/'.$dom.'/'.$uname;
                    249:         my $pathstart = &propath($dom,$uname).'/userfiles';
1.78      raeburn   250:         my $is_course = '';
                    251:         if (exists($courses{$dom.'_'.$uname})) {
                    252:             $is_course = 1;
                    253:         }
1.69      raeburn   254:         my $curr_perm = &Apache::lonnet::get_portfile_permissions($dom,$uname);
                    255:         my %access = &Apache::lonnet::get_access_controls($curr_perm);
1.75      raeburn   256:         foreach my $file (keys(%access)) {
1.69      raeburn   257:             my ($group,$url,$fullpath);
                    258:             if ($is_course) {
                    259:                 ($group, my ($path)) = ($file =~ /^(\w+)(\/.+)$/);
1.72      raeburn   260:                 $fullpath = $pathstart.'/groups/'.$group.'/portfolio'.$path;
1.69      raeburn   261:                 $url = $urlstart.'/groups/'.$group.'/portfolio'.$path;
                    262:             } else {
                    263:                 $fullpath = $pathstart.'/portfolio'.$file;
1.72      raeburn   264:                 $url = $urlstart.'/portfolio'.$file;
1.69      raeburn   265:             }
                    266:             if (ref($access{$file}) eq 'HASH') {
1.75      raeburn   267:                 my %portaccesslog = 
                    268:                     &LONCAPA::lonmetadata::process_portfolio_access_data($dbh,
                    269:                            $simulate,\%newnames,$url,$fullpath,$access{$file});
                    270:                 &portfolio_logging(%portaccesslog);
1.69      raeburn   271:             }
1.75      raeburn   272:             my %portmetalog = &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,$simulate,\%newnames,$url,$fullpath,$is_course,$dom,$uname,$group);
                    273:             &portfolio_logging(%portmetalog);
1.69      raeburn   274:         }
                    275:     }
1.79      raeburn   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:     }
1.77      raeburn   291:     # Update allusers
                    292:     foreach my $uname (keys(%allusers)) {
1.78      raeburn   293:         next if (exists($courses{$dom.'_'.$uname}));
1.77      raeburn   294:         my %userdata = 
                    295:             &Apache::lonnet::get('environment',['firstname','lastname',
                    296:                 'middlename','generation','id','permanentemail'],$dom,$uname);
1.79      raeburn   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:         
1.77      raeburn   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:     }
1.79      raeburn   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) {
1.80      raeburn   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);
1.82    ! raeburn   377:                     $msg->add('From','www@'.$hostname);
1.80      raeburn   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:                     }
1.79      raeburn   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:     }
1.55      matthew   396: }
1.69      raeburn   397: 
1.55      matthew   398: #
1.69      raeburn   399: # Rename the tables
1.56      matthew   400: if (! $simulate) {
1.69      raeburn   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:         }
1.56      matthew   411:     }
1.55      matthew   412: }
                    413: if (! $dbh->disconnect) {
1.56      matthew   414:     &log(0,"MySQL Error Disconnect: ".$dbh->errstr);
1.55      matthew   415:     die $dbh->errstr;
                    416: }
                    417: ##
                    418: ## Finished!
1.56      matthew   419: &log(0,"==== Searchcat completed ".localtime()." ====");
1.55      matthew   420: close(LOG);
1.21      www       421: 
1.55      matthew   422: &write_type_count();
                    423: &write_copyright_count();
1.36      www       424: 
1.55      matthew   425: exit 0;
1.28      harris41  426: 
1.56      matthew   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: 
1.75      raeburn   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: 
1.69      raeburn   455: sub descend_tree {
1.77      raeburn   456:     my ($dom,$dir,$depth,$allportusers,$alldomusers) = @_;
1.69      raeburn   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) {
1.77      raeburn   464:                 &descend_tree($dom,$dir.'/'.$item,$depth,$allportusers,$alldomusers);
1.69      raeburn   465:             } else {
                    466:                 if (-e $dir.'/'.$item.'/file_permissions.db') {
1.78      raeburn   467:                     $$allportusers{$item} = '';
1.77      raeburn   468:                 }
1.78      raeburn   469:                 if (-e $dir.'/'.$item.'/passwd') {
1.69      raeburn   470:                     $$alldomusers{$item} = '';
                    471:                 }
                    472:             }       
                    473:         }
                    474:     } 
                    475: }
                    476: 
1.55      matthew   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
1.67      albertel  496:              ) || (-d $File::Find::dir."/".$file )) { # directories are okay
1.55      matthew   497:                  # but we do not want /. or /..
                    498:             push(@ChosenFiles,$file);
                    499:         }
1.38      www       500:     }
1.55      matthew   501:     return @ChosenFiles;
1.38      www       502: }
                    503: 
1.55      matthew   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;
1.56      matthew   511:     if ($debug) {
                    512:         if (-d $file) {
                    513:             &log(5," Got directory ".$fullfilename);
                    514:         } else {
                    515:             &log(5," Got file ".$fullfilename);
                    516:         }
1.38      www       517:     }
1.55      matthew   518:     $_=$file;
1.38      www       519: }
1.28      harris41  520: 
1.55      matthew   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
1.56      matthew   525:     if ($debug) {
                    526:         &log(6,$fullfilename);
1.69      raeburn   527:         my $ref = &metadata($fullfilename);
1.56      matthew   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'});
1.55      matthew   536:     }
                    537:     $_=$file;
1.31      harris41  538: }
1.21      www       539: 
1.55      matthew   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) = $_;
1.56      matthew   546:     my $filename = $File::Find::name; # full filename
1.55      matthew   547:     return if (-d $filename); # No need to do anything here for directories
                    548:     #
1.56      matthew   549:     &log(3,$filename) if ($debug);
1.55      matthew   550:     #
1.69      raeburn   551:     my $ref = &metadata($filename);
1.55      matthew   552:     #
                    553:     # $url is the original file url, not the metadata file
1.61      matthew   554:     my $target = $filename;
                    555:     $target =~ s/\.meta$//;
                    556:     my $url='/res/'.&declutter($target);
1.56      matthew   557:     &log(3,"    ".$url) if ($debug);
1.55      matthew   558:     #
                    559:     # Ignore some files based on their metadata
                    560:     if ($ref->{'obsolete'}) { 
1.56      matthew   561:         &log(3,"obsolete") if ($debug);
1.55      matthew   562:         return; 
                    563:     }
                    564:     &count_copyright($ref->{'copyright'});
                    565:     if ($ref->{'copyright'} eq 'private') { 
1.56      matthew   566:         &log(3,"private") if ($debug);
1.55      matthew   567:         return; 
                    568:     }
                    569:     #
                    570:     # Find the dynamic metadata
                    571:     my %dyn;
                    572:     if ($url=~ m:/default$:) {
                    573:         $url=~ s:/default$:/:;
1.56      matthew   574:         &log(3,"Skipping dynamic data") if ($debug);
1.55      matthew   575:     } else {
1.56      matthew   576:         &log(3,"Retrieving dynamic data") if ($debug);
                    577:         %dyn=&get_dynamic_metadata($url);
1.55      matthew   578:         &count_type($url);
                    579:     }
1.75      raeburn   580:     &LONCAPA::lonmetadata::getfiledates($ref,$target);
1.55      matthew   581:     #
                    582:     my %Data = (
                    583:                 %$ref,
                    584:                 %dyn,
                    585:                 'url'=>$url,
                    586:                 'version'=>'current');
1.56      matthew   587:     if (! $simulate) {
1.69      raeburn   588:         my ($count,$err) = 
                    589:           &LONCAPA::lonmetadata::store_metadata($dbh,$newnames{'metadata'},
                    590:                                                 'metadata',\%Data);
1.56      matthew   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:         }
1.55      matthew   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 {
1.69      raeburn   612:     my ($uri) = @_;
1.55      matthew   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:     }
1.75      raeburn   621:     my $metastring = 
                    622:         &LONCAPA::lonmetadata::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$filename);
1.55      matthew   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]->{$_};
1.69      raeburn   643:             }
1.55      matthew   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;
1.31      harris41  651: }
1.28      harris41  652: 
1.55      matthew   653: ########################################################
                    654: ########################################################
                    655: ###                                                  ###
                    656: ###    Dynamic Metadata                              ###
                    657: ###                                                  ###
                    658: ########################################################
                    659: ########################################################
1.56      matthew   660: ##
1.58      www       661: ## Dynamic metadata description (incomplete)
                    662: ##
                    663: ## For a full description of all fields,
                    664: ## see LONCAPA::lonmetadata
1.56      matthew   665: ##
                    666: ##   Field             Type
                    667: ##-----------------------------------------------------------
                    668: ##   count             integer
                    669: ##   course            integer
1.58      www       670: ##   course_list       comma separated list of course ids
1.56      matthew   671: ##   avetries          real                                
1.58      www       672: ##   avetries_list     comma separated list of real numbers
1.56      matthew   673: ##   stdno             real
1.58      www       674: ##   stdno_list        comma separated list of real numbers
1.56      matthew   675: ##   usage             integer   
1.58      www       676: ##   usage_list        comma separated list of resources
1.56      matthew   677: ##   goto              scalar
1.58      www       678: ##   goto_list         comma separated list of resources
1.56      matthew   679: ##   comefrom          scalar
1.58      www       680: ##   comefrom_list     comma separated list of resources
1.56      matthew   681: ##   difficulty        real
1.58      www       682: ##   difficulty_list   comma separated list of real numbers
1.56      matthew   683: ##   sequsage          scalar
1.58      www       684: ##   sequsage_list     comma separated list of resources
1.56      matthew   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);
1.55      matthew   703:     #
1.56      matthew   704:     # Read in the dynamic metadata
1.55      matthew   705:     my %evaldata;
                    706:     if (! tie(%evaldata,'GDBM_File',
                    707:               $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) {
1.56      matthew   708:         return 0;
1.55      matthew   709:     }
1.56      matthew   710:     #
1.57      matthew   711:     %DynamicData = &LONCAPA::lonmetadata::process_reseval_data(\%evaldata);
1.55      matthew   712:     untie(%evaldata);
1.62      matthew   713:     $DynamicData{'domain'} = $dom;
1.64      albertel  714:     #print('user = '.$user.' domain = '.$dom.$/);
1.56      matthew   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/::;
1.57      matthew   743:     my %data = &LONCAPA::lonmetadata::process_dynamic_metadata($url,
                    744:                                                                \%DynamicData);
1.56      matthew   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:         }
1.44      www       753:     }
1.56      matthew   754:     return %data;
1.30      www       755: }
1.28      harris41  756: 
1.56      matthew   757: } # End of %DynamicData and %Counts scope
                    758: 
1.55      matthew   759: ########################################################
                    760: ########################################################
                    761: ###                                                  ###
                    762: ###   Counts                                         ###
                    763: ###                                                  ###
                    764: ########################################################
                    765: ########################################################
                    766: {
1.1       harris41  767: 
1.55      matthew   768: my %countext;
1.15      harris41  769: 
1.55      matthew   770: sub count_type {
                    771:     my $file=shift;
                    772:     $file=~/\.(\w+)$/;
                    773:     my $ext=lc($1);
                    774:     $countext{$ext}++;
1.31      harris41  775: }
1.1       harris41  776: 
1.55      matthew   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.'&';
1.47      www       781:     }
1.55      matthew   782:     print RESCOUNT 'time='.time."\n";
                    783:     close(RESCOUNT);
1.31      harris41  784: }
1.27      www       785: 
1.55      matthew   786: } # end of scope for %countext
1.34      matthew   787: 
1.55      matthew   788: {
1.34      matthew   789: 
1.55      matthew   790: my %copyrights;
1.44      www       791: 
1.55      matthew   792: sub count_copyright {
                    793:     $copyrights{@_[0]}++;
1.31      harris41  794: }
1.33      matthew   795: 
1.55      matthew   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.'&';
1.31      harris41  800:     }
1.55      matthew   801:     print COPYCOUNT 'time='.time."\n";
                    802:     close(COPYCOUNT);
1.31      harris41  803: }
1.28      harris41  804: 
1.55      matthew   805: } # end of scope for %copyrights
1.28      harris41  806: 
1.55      matthew   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)
1.31      harris41  818: sub ishome {
                    819:     my $author=shift;
1.76      albertel  820:     $author=~s{/home/httpd/html/res/([^/]*)/([^/]*).*}{$1/$2};
1.31      harris41  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: }
1.28      harris41  829: 
1.55      matthew   830: ##
                    831: ## &declutter($filename)
                    832: ##   Given a filename, returns a url for the filename.
                    833: sub declutter {
                    834:     my $thisfn=shift;
1.63      matthew   835:     $thisfn=~s/^$Apache::lonnet::perlvar{'lonDocRoot'}//;
1.55      matthew   836:     $thisfn=~s/^\///;
                    837:     $thisfn=~s/^res\///;
                    838:     return $thisfn;
1.31      harris41  839: }
1.28      harris41  840: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>