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

1.1       harris41    1: #!/usr/bin/perl
                      2: # The LearningOnline Network
                      3: # searchcat.pl "Search Catalog" batch script
1.16      harris41    4: #
1.73    ! raeburn     5: # $Id: searchcat.pl,v 1.72 2007/01/01 21:23:10 raeburn 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.17      harris41   71: 
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.56      matthew    77: 
1.63      matthew    78: use Apache::lonnet();
1.62      matthew    79: 
1.55      matthew    80: use File::Find;
1.1       harris41   81: 
1.56      matthew    82: #
                     83: # Set up configuration options
1.63      matthew    84: my ($simulate,$oneuser,$help,$verbose,$logfile,$debug);
1.56      matthew    85: GetOptions (
                     86:             'help'     => \$help,
                     87:             'simulate' => \$simulate,
                     88:             'only=s'   => \$oneuser,
                     89:             'verbose=s'  => \$verbose,
                     90:             'debug' => \$debug,
                     91:             );
                     92: 
                     93: if ($help) {
                     94:     print <<"ENDHELP";
                     95: $0
                     96: Rebuild and update the LON-CAPA metadata database. 
                     97: Options:
                     98:     -help          Print this help
                     99:     -simulate      Do not modify the database.
                    100:     -only=user     Only compute for the given user.  Implies -simulate   
                    101:     -verbose=val   Sets logging level, val must be a number
                    102:     -debug         Turns on debugging output
                    103: ENDHELP
                    104:     exit 0;
                    105: }
                    106: 
                    107: if (! defined($debug)) {
                    108:     $debug = 0;
                    109: }
                    110: 
                    111: if (! defined($verbose)) {
                    112:     $verbose = 0;
                    113: }
                    114: 
                    115: if (defined($oneuser)) {
                    116:     $simulate=1;
                    117: }
                    118: 
1.55      matthew   119: ##
                    120: ## Use variables for table names so we can test this routine a little easier
1.69      raeburn   121: my %oldnames = (
                    122:                  'metadata'    => 'metadata',
                    123:                  'portfolio'   => 'portfolio_metadata',
                    124:                  'access'      => 'portfolio_access',
                    125:                  'addedfields' => 'portfolio_addedfields',
                    126:                );
                    127: 
                    128: my %newnames;
                    129: # new table names -  append pid to have unique temporary tables
                    130: foreach my $key (keys(%oldnames)) {
                    131:     $newnames{$key} = 'new'.$oldnames{$key}.$$;
                    132: }
1.45      www       133: 
1.55      matthew   134: #
                    135: # Only run if machine is a library server
1.63      matthew   136: exit if ($Apache::lonnet::perlvar{'lonRole'} ne 'library');
1.55      matthew   137: #
                    138: #  Make sure this process is running from user=www
                    139: my $wwwid=getpwnam('www');
                    140: if ($wwwid!=$<) {
1.63      matthew   141:     my $emailto="$Apache::lonnet::perlvar{'lonAdmEMail'},$Apache::lonnet::perlvar{'lonSysEMail'}";
                    142:     my $subj="LON: $Apache::lonnet::perlvar{'lonHostID'} User ID mismatch";
1.55      matthew   143:     system("echo 'User ID mismatch. searchcat.pl must be run as user www.' |\
1.63      matthew   144:  mail -s '$subj' $emailto > /dev/null");
1.55      matthew   145:     exit 1;
                    146: }
                    147: #
                    148: # Let people know we are running
1.63      matthew   149: open(LOG,'>>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/logs/searchcat.log');
1.56      matthew   150: &log(0,'==== Searchcat Run '.localtime()."====");
1.57      matthew   151: 
                    152: 
1.56      matthew   153: if ($debug) {
                    154:     &log(0,'simulating') if ($simulate);
                    155:     &log(0,'only processing user '.$oneuser) if ($oneuser);
                    156:     &log(0,'verbosity level = '.$verbose);
                    157: }
1.55      matthew   158: #
                    159: # Connect to database
                    160: my $dbh;
1.63      matthew   161: if (! ($dbh = DBI->connect("DBI:mysql:loncapa","www",$Apache::lonnet::perlvar{'lonSqlAccess'},
1.55      matthew   162:                           { RaiseError =>0,PrintError=>0}))) {
1.56      matthew   163:     &log(0,"Cannot connect to database!");
1.55      matthew   164:     die "MySQL Error: Cannot connect to database!\n";
                    165: }
                    166: # This can return an error and still be okay, so we do not bother checking.
                    167: # (perhaps it should be more robust and check for specific errors)
1.69      raeburn   168: foreach my $key (keys(%newnames)) {
                    169:     if ($newnames{$key} ne '') {
                    170:         $dbh->do('DROP TABLE IF EXISTS '.$newnames{$key});
                    171:     }
                    172: }
                    173: 
1.55      matthew   174: #
1.69      raeburn   175: # Create the new metadata and portfolio tables
                    176: foreach my $key (keys(%newnames)) {
                    177:     if ($newnames{$key} ne '') { 
                    178:         my $request =
                    179:              &LONCAPA::lonmetadata::create_metadata_storage($newnames{$key},$oldnames{$key});
                    180:         $dbh->do($request);
                    181:         if ($dbh->err) {
                    182:             $dbh->disconnect();
                    183:             &log(0,"MySQL Error Create: ".$dbh->errstr);
                    184:             die $dbh->errstr;
                    185:         }
                    186:     }
1.55      matthew   187: }
1.69      raeburn   188: 
1.55      matthew   189: #
                    190: # find out which users we need to examine
1.63      matthew   191: my @domains = sort(&Apache::lonnet::current_machine_domains());
                    192: &log(9,'domains ="'.join('","',@domains).'"');
1.62      matthew   193: 
                    194: foreach my $dom (@domains) {
                    195:     &log(9,'domain = '.$dom);
1.63      matthew   196:     opendir(RESOURCES,"$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom");
1.62      matthew   197:     my @homeusers = 
                    198:         grep {
1.63      matthew   199:             &ishome("$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom/$_");
1.62      matthew   200:         } grep { 
                    201:             !/^\.\.?$/;
                    202:         } readdir(RESOURCES);
                    203:     closedir RESOURCES;
                    204:     &log(5,'users = '.$dom.':'.join(',',@homeusers));
                    205:     #
                    206:     if ($oneuser) {
                    207:         @homeusers=($oneuser);
                    208:     }
                    209:     #
                    210:     # Loop through the users
                    211:     foreach my $user (@homeusers) {
                    212:         &log(0,"=== User: ".$user);
                    213:         &process_dynamic_metadata($user,$dom);
                    214:         #
                    215:         # Use File::Find to get the files we need to read/modify
                    216:         find(
                    217:              {preprocess => \&only_meta_files,
                    218:               #wanted     => \&print_filename,
                    219:               #wanted     => \&log_metadata,
                    220:               wanted     => \&process_meta_file,
1.66      albertel  221:               no_chdir   => 1,
1.63      matthew   222:              }, join('/',($Apache::lonnet::perlvar{'lonDocRoot'},'res',$dom,$user)) );
1.62      matthew   223:     }
1.69      raeburn   224:     # Search for public portfolio files
                    225:     my %portusers;
                    226:     if ($oneuser) {
                    227:         %portusers = (
                    228:                         $oneuser => '',
                    229:                        );
                    230:     } else {
                    231:         my $dir = $Apache::lonnet::perlvar{lonUsersDir}.'/'.$dom;
                    232:         &descend_tree($dir,0,\%portusers);
                    233:     }
                    234:     foreach my $uname (keys(%portusers)) {
                    235:         my $urlstart = '/uploaded/'.$dom.'/'.$uname;
                    236:         my $pathstart = &propath($dom,$uname).'/userfiles';
1.70      albertel  237:         my $is_course = &Apache::lonnet::is_course($dom,$uname);
1.69      raeburn   238:         my $curr_perm = &Apache::lonnet::get_portfile_permissions($dom,$uname);
                    239:         my %access = &Apache::lonnet::get_access_controls($curr_perm);
                    240:         foreach my $file (keys(%access)) { 
                    241:             my ($group,$url,$fullpath);
                    242:             if ($is_course) {
                    243:                 ($group, my ($path)) = ($file =~ /^(\w+)(\/.+)$/);
1.72      raeburn   244:                 $fullpath = $pathstart.'/groups/'.$group.'/portfolio'.$path;
1.69      raeburn   245:                 $url = $urlstart.'/groups/'.$group.'/portfolio'.$path;
                    246:             } else {
                    247:                 $fullpath = $pathstart.'/portfolio'.$file;
1.72      raeburn   248:                 $url = $urlstart.'/portfolio'.$file;
1.69      raeburn   249:             }
                    250:             if (ref($access{$file}) eq 'HASH') {
                    251:                 &process_portfolio_access_data($url,$access{$file});
                    252:             }
                    253:             &process_portfolio_metadata($url,$fullpath,$is_course,$dom,
                    254:                                         $uname,$group);
                    255:         }
                    256:     }
1.55      matthew   257: }
1.69      raeburn   258: 
1.55      matthew   259: #
1.69      raeburn   260: # Rename the tables
1.56      matthew   261: if (! $simulate) {
1.69      raeburn   262:     foreach my $key (keys(%oldnames)) {
                    263:         if (($oldnames{$key} ne '') && ($newnames{$key} ne '')) {
                    264:             $dbh->do('DROP TABLE IF EXISTS '.$oldnames{$key});
                    265:             if (! $dbh->do('RENAME TABLE '.$newnames{$key}.' TO '.$oldnames{$key})) {
                    266:                 &log(0,"MySQL Error Rename: ".$dbh->errstr);
                    267:                 die $dbh->errstr;
                    268:             } else {
                    269:                 &log(1,"MySQL table rename successful for $key.");
                    270:             }
                    271:         }
1.56      matthew   272:     }
1.55      matthew   273: }
                    274: if (! $dbh->disconnect) {
1.56      matthew   275:     &log(0,"MySQL Error Disconnect: ".$dbh->errstr);
1.55      matthew   276:     die $dbh->errstr;
                    277: }
                    278: ##
                    279: ## Finished!
1.56      matthew   280: &log(0,"==== Searchcat completed ".localtime()." ====");
1.55      matthew   281: close(LOG);
1.21      www       282: 
1.55      matthew   283: &write_type_count();
                    284: &write_copyright_count();
1.36      www       285: 
1.55      matthew   286: exit 0;
1.28      harris41  287: 
1.56      matthew   288: ##
                    289: ## Status logging routine.  Inputs: $level, $message
                    290: ## 
                    291: ## $level 0 should be used for normal output and error messages
                    292: ##
                    293: ## $message does not need to end with \n.  In the case of errors
                    294: ## the message should contain as much information as possible to
                    295: ## help in diagnosing the problem.
                    296: ##
                    297: sub log {
                    298:     my ($level,$message)=@_;
                    299:     $level = 0 if (! defined($level));
                    300:     if ($verbose >= $level) {
                    301:         print LOG $message.$/;
                    302:     }
                    303: }
                    304: 
1.69      raeburn   305: sub descend_tree {
                    306:     my ($dir,$depth,$alldomusers) = @_;
                    307:     if (-d $dir) {
                    308:         opendir(DIR,$dir);
                    309:         my @contents = grep(!/^\./,readdir(DIR));
                    310:         closedir(DIR);
                    311:         $depth ++;
                    312:         foreach my $item (@contents) {
                    313:             if ($depth < 4) {
                    314:                 &descend_tree($dir.'/'.$item,$depth,$alldomusers);
                    315:             } else {
                    316:                 if (-e $dir.'/'.$item.'/file_permissions.db') {
                    317:                  
                    318:                     $$alldomusers{$item} = '';
                    319:                 }
                    320:             }       
                    321:         }
                    322:     } 
                    323: }
                    324: 
                    325: sub process_portfolio_access_data {
                    326:     my ($url,$access_hash) = @_;
                    327:     foreach my $key (keys(%{$access_hash})) {
                    328:         my $acc_data;
                    329:         $acc_data->{url} = $url;
                    330:         $acc_data->{keynum} = $key;
                    331:         my ($num,$scope,$end,$start) =
                    332:                         ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
1.73    ! raeburn   333:         next if (($scope ne 'public') && ($scope ne 'guest'));
1.69      raeburn   334:         $acc_data->{scope} = $scope;
                    335:         if ($end != 0) {
1.71      raeburn   336:             $acc_data->{end} = &LONCAPA::lonmetadata::sqltime($end);
1.69      raeburn   337:         }
1.71      raeburn   338:         $acc_data->{start} = &LONCAPA::lonmetadata::sqltime($start);
1.69      raeburn   339:         if (! $simulate) {
                    340:             my ($count,$err) =
                    341:               &LONCAPA::lonmetadata::store_metadata($dbh,
                    342:                                                 $newnames{'access'},
                    343:                                                 'portfolio_access',$acc_data);
                    344:             if ($err) {
                    345:                 &log(0,"MySQL Error Insert: ".$err);
                    346:             }
                    347:             if ($count < 1) {
                    348:                 &log(0,"Unable to insert record into MySQL database for $url");
                    349:             }
                    350:         }
                    351:     }
                    352: }
                    353: 
                    354: sub process_portfolio_metadata {
                    355:     my ($url,$fullpath,$is_course,$dom,$uname,$group) = @_;
                    356:     my ($ref,$crs,$addedfields) = &portfolio_metadata($fullpath,$dom,$uname,
                    357:                                                       $group);
                    358:     &getfiledates($ref,$fullpath);
                    359:     if ($is_course) {
                    360:         $ref->{'groupname'} = $group;
                    361:     }
                    362:     my %Data;
                    363:     if (ref($ref) eq 'HASH') {
                    364:         %Data = %{$ref};
                    365:     }
                    366:     %Data = (
                    367:              %Data,
                    368:              'url'=>$url,
                    369:              'version'=>'current',
                    370:     );
                    371:     if (! $simulate) {
                    372:         my ($count,$err) =
                    373:          &LONCAPA::lonmetadata::store_metadata($dbh,
                    374:                                                $newnames{'portfolio'},
                    375:                                                'portfolio_metadata',\%Data);
                    376:         if ($err) {
                    377:             &log(0,"MySQL Error Insert: ".$err);
                    378:         }
                    379:         if ($count < 1) {
                    380:             &log(0,"Unable to insert record into MySQL portfolio_metadata database table for $url");
                    381:         }
                    382:         if (ref($addedfields) eq 'HASH') {
                    383:             if (keys(%{$addedfields}) > 0) {
                    384:                 foreach my $key (keys(%{$addedfields})) {
                    385:                     my $added_data = {
                    386:                                 'url'   => $url,
                    387:                                 'field' => $key,
                    388:                                 'value' => $addedfields->{$key},
                    389:                                 'courserestricted' => $crs,
                    390:                     };
                    391:                     ($count,$err) = &LONCAPA::lonmetadata::store_metadata($dbh,
                    392:                                             $newnames{'addedfields'},
                    393:                                             'portfolio_addedfields',
                    394:                                             $added_data);
                    395:                     if ($err) {
                    396:                         &log(0,"MySQL Error Insert: ".$err);
                    397:                     }
                    398:                     if ($count < 1) {
                    399:                         &log(0,"Unable to insert record into MySQL portfolio_addedfields database table for url = $url and field = $key");
                    400:                     }
                    401:                 }
                    402:             }
                    403:         }
                    404:     }
                    405:     return;
                    406: }
                    407: 
1.55      matthew   408: ########################################################
                    409: ########################################################
                    410: ###                                                  ###
                    411: ###          File::Find support routines             ###
                    412: ###                                                  ###
                    413: ########################################################
                    414: ########################################################
                    415: ##
                    416: ## &only_meta_files
                    417: ##
                    418: ## Called by File::Find.
                    419: ## Takes a list of files/directories in and returns a list of files/directories
                    420: ## to search.
                    421: sub only_meta_files {
                    422:     my @PossibleFiles = @_;
                    423:     my @ChosenFiles;
                    424:     foreach my $file (@PossibleFiles) {
                    425:         if ( ($file =~ /\.meta$/ &&            # Ends in meta
                    426:               $file !~ /\.\d+\.[^\.]+\.meta$/  # is not for a prior version
1.67      albertel  427:              ) || (-d $File::Find::dir."/".$file )) { # directories are okay
1.55      matthew   428:                  # but we do not want /. or /..
                    429:             push(@ChosenFiles,$file);
                    430:         }
1.38      www       431:     }
1.55      matthew   432:     return @ChosenFiles;
1.38      www       433: }
                    434: 
1.55      matthew   435: ##
                    436: ##
                    437: ## Debugging routines, use these for 'wanted' in the File::Find call
                    438: ##
                    439: sub print_filename {
                    440:     my ($file) = $_;
                    441:     my $fullfilename = $File::Find::name;
1.56      matthew   442:     if ($debug) {
                    443:         if (-d $file) {
                    444:             &log(5," Got directory ".$fullfilename);
                    445:         } else {
                    446:             &log(5," Got file ".$fullfilename);
                    447:         }
1.38      www       448:     }
1.55      matthew   449:     $_=$file;
1.38      www       450: }
1.28      harris41  451: 
1.55      matthew   452: sub log_metadata {
                    453:     my ($file) = $_;
                    454:     my $fullfilename = $File::Find::name;
                    455:     return if (-d $fullfilename); # No need to do anything here for directories
1.56      matthew   456:     if ($debug) {
                    457:         &log(6,$fullfilename);
1.69      raeburn   458:         my $ref = &metadata($fullfilename);
1.56      matthew   459:         if (! defined($ref)) {
                    460:             &log(6,"    No data");
                    461:             return;
                    462:         }
                    463:         while (my($key,$value) = each(%$ref)) {
                    464:             &log(6,"    ".$key." => ".$value);
                    465:         }
                    466:         &count_copyright($ref->{'copyright'});
1.55      matthew   467:     }
                    468:     $_=$file;
1.31      harris41  469: }
1.21      www       470: 
1.55      matthew   471: ##
                    472: ## process_meta_file
                    473: ##   Called by File::Find. 
                    474: ##   Only input is the filename in $_.  
                    475: sub process_meta_file {
                    476:     my ($file) = $_;
1.56      matthew   477:     my $filename = $File::Find::name; # full filename
1.55      matthew   478:     return if (-d $filename); # No need to do anything here for directories
                    479:     #
1.56      matthew   480:     &log(3,$filename) if ($debug);
1.55      matthew   481:     #
1.69      raeburn   482:     my $ref = &metadata($filename);
1.55      matthew   483:     #
                    484:     # $url is the original file url, not the metadata file
1.61      matthew   485:     my $target = $filename;
                    486:     $target =~ s/\.meta$//;
                    487:     my $url='/res/'.&declutter($target);
1.56      matthew   488:     &log(3,"    ".$url) if ($debug);
1.55      matthew   489:     #
                    490:     # Ignore some files based on their metadata
                    491:     if ($ref->{'obsolete'}) { 
1.56      matthew   492:         &log(3,"obsolete") if ($debug);
1.55      matthew   493:         return; 
                    494:     }
                    495:     &count_copyright($ref->{'copyright'});
                    496:     if ($ref->{'copyright'} eq 'private') { 
1.56      matthew   497:         &log(3,"private") if ($debug);
1.55      matthew   498:         return; 
                    499:     }
                    500:     #
                    501:     # Find the dynamic metadata
                    502:     my %dyn;
                    503:     if ($url=~ m:/default$:) {
                    504:         $url=~ s:/default$:/:;
1.56      matthew   505:         &log(3,"Skipping dynamic data") if ($debug);
1.55      matthew   506:     } else {
1.56      matthew   507:         &log(3,"Retrieving dynamic data") if ($debug);
                    508:         %dyn=&get_dynamic_metadata($url);
1.55      matthew   509:         &count_type($url);
                    510:     }
1.69      raeburn   511:     &getfiledates($ref,$target);
1.55      matthew   512:     #
                    513:     my %Data = (
                    514:                 %$ref,
                    515:                 %dyn,
                    516:                 'url'=>$url,
                    517:                 'version'=>'current');
1.56      matthew   518:     if (! $simulate) {
1.69      raeburn   519:         my ($count,$err) = 
                    520:           &LONCAPA::lonmetadata::store_metadata($dbh,$newnames{'metadata'},
                    521:                                                 'metadata',\%Data);
1.56      matthew   522:         if ($err) {
                    523:             &log(0,"MySQL Error Insert: ".$err);
                    524:         }
                    525:         if ($count < 1) {
                    526:             &log(0,"Unable to insert record into MySQL database for $url");
                    527:         }
1.55      matthew   528:     }
                    529:     #
                    530:     # Reset $_ before leaving
                    531:     $_ = $file;
                    532: }
                    533: 
                    534: ########################################################
                    535: ########################################################
                    536: ###                                                  ###
                    537: ###  &metadata($uri)                                 ###
                    538: ###   Retrieve metadata for the given file           ###
                    539: ###                                                  ###
                    540: ########################################################
                    541: ########################################################
                    542: sub metadata {
1.69      raeburn   543:     my ($uri) = @_;
1.55      matthew   544:     my %metacache=();
                    545:     $uri=&declutter($uri);
                    546:     my $filename=$uri;
                    547:     $uri=~s/\.meta$//;
                    548:     $uri='';
                    549:     if ($filename !~ /\.meta$/) { 
                    550:         $filename.='.meta';
                    551:     }
1.63      matthew   552:     my $metastring=&getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$filename);
1.55      matthew   553:     return undef if (! defined($metastring));
                    554:     my $parser=HTML::TokeParser->new(\$metastring);
                    555:     my $token;
                    556:     while ($token=$parser->get_token) {
                    557:         if ($token->[0] eq 'S') {
                    558:             my $entry=$token->[1];
                    559:             my $unikey=$entry;
                    560:             if (defined($token->[2]->{'part'})) { 
                    561:                 $unikey.='_'.$token->[2]->{'part'}; 
                    562:             }
                    563:             if (defined($token->[2]->{'name'})) { 
                    564:                 $unikey.='_'.$token->[2]->{'name'}; 
                    565:             }
                    566:             if ($metacache{$uri.'keys'}) {
                    567:                 $metacache{$uri.'keys'}.=','.$unikey;
                    568:             } else {
                    569:                 $metacache{$uri.'keys'}=$unikey;
                    570:             }
                    571:             foreach ( @{$token->[3]}) {
                    572:                 $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
1.69      raeburn   573:             }
1.55      matthew   574:             if (! ($metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry))){
                    575:                 $metacache{$uri.''.$unikey} = 
                    576:                     $metacache{$uri.''.$unikey.'.default'};
                    577:             }
                    578:         } # End of ($token->[0] eq 'S')
                    579:     }
                    580:     return \%metacache;
1.31      harris41  581: }
1.28      harris41  582: 
1.69      raeburn   583: ###############################################################
                    584: ###############################################################
                    585: ###                                                         ###
                    586: ###  &portfolio_metadata($filepath,$dom,$uname,$group) ###
                    587: ###   Retrieve metadata for the given file                  ###
                    588: ###   Returns array -                                       ###
                    589: ###      contains reference to metadatahash and             ###
                    590: ###         optional reference to addedfields hash          ###
                    591: ###                                                         ###
                    592: ###############################################################
                    593: ###############################################################
                    594: sub portfolio_metadata {
                    595:     my ($fullpath,$dom,$uname,$group)=@_;
                    596:     my ($mime) = ( $fullpath=~/\.(\w+)$/ );
                    597:     my %metacache=();
                    598:     if ($fullpath !~ /\.meta$/) {
                    599:         $fullpath .= '.meta';
                    600:     }
                    601:     my (@standard_fields,%addedfields);
                    602:     my $colsref = 
                    603:        $LONCAPA::lonmetadata::Portfolio_metadata_table_description;
                    604:     if (ref($colsref) eq 'ARRAY') {
                    605:         my @columns = @{$colsref};
                    606:         foreach my $coldata (@columns) {
                    607:             push(@standard_fields,$coldata->{'name'});
                    608:         }
                    609:     }
                    610:     my $metastring=&getfile($fullpath);
                    611:     if (! defined($metastring)) {
                    612:         $metacache{'keys'}= 'owner,domain,mime';
                    613:         $metacache{'owner'} = $uname.':'.$dom;
                    614:         $metacache{'domain'} = $dom;
                    615:         $metacache{'mime'} = $mime;
                    616:         if (defined($group)) {
                    617:             $metacache{'keys'} .= ',courserestricted';
                    618:             $metacache{'courserestricted'} = 'course.'.$dom.'_'.$uname;
                    619:         } 
                    620:     } else {
                    621:         my $parser=HTML::TokeParser->new(\$metastring);
                    622:         my $token;
                    623:         while ($token=$parser->get_token) {
                    624:             if ($token->[0] eq 'S') {
                    625:                 my $entry=$token->[1];
                    626:                 if ($metacache{'keys'}) {
                    627:                     $metacache{'keys'}.=','.$entry;
                    628:                 } else {
                    629:                     $metacache{'keys'}=$entry;
                    630:                 }
                    631:                 my $value = $parser->get_text('/'.$entry);
                    632:                 if (!grep(/^\Q$entry\E$/,@standard_fields)) {
                    633:                     my $clean_value = lc($value);
                    634:                     $clean_value =~ s/\s/_/g;
                    635:                     if ($clean_value ne $entry) {
                    636:                         if (defined($addedfields{$entry})) {
                    637:                             $addedfields{$entry} .=','.$value;
                    638:                         } else {
                    639:                             $addedfields{$entry} = $value;
                    640:                         }
                    641:                     }
                    642:                 } else {
                    643:                     $metacache{$entry} = $value;
                    644:                 }
                    645:             }
                    646:         } # End of ($token->[0] eq 'S')
                    647:     }
                    648:     if (keys(%addedfields) > 0) {
                    649:         foreach my $key (sort keys(%addedfields)) {
                    650:             $metacache{'addedfieldnames'} .= $key.',';
                    651:             $metacache{'addedfieldvalues'} .= $addedfields{$key}.'&&&';
                    652:         }
                    653:         $metacache{'addedfieldnames'} =~ s/,$//;
                    654:         $metacache{'addedfieldvalues'} =~ s/\&\&\&$//;
                    655:         if ($metacache{'keys'}) {
                    656:             $metacache{'keys'}.=',addedfieldnames';
                    657:         } else {
                    658:             $metacache{'keys'}='addedfieldnames';
                    659:         }
                    660:         $metacache{'keys'}.=',addedfieldvalues';
                    661:     }
                    662:     return (\%metacache,$metacache{'courserestricted'},\%addedfields);
                    663: }
                    664: 
1.55      matthew   665: ##
                    666: ## &getfile($filename)
                    667: ##   Slurps up an entire file into a scalar.  
                    668: ##   Returns undef if the file does not exist
                    669: sub getfile {
                    670:     my $file = shift();
                    671:     if (! -e $file ) { 
                    672:         return undef; 
                    673:     }
                    674:     my $fh=IO::File->new($file);
                    675:     my $contents = '';
                    676:     while (<$fh>) { 
                    677:         $contents .= $_;
                    678:     }
                    679:     return $contents;
                    680: }
1.28      harris41  681: 
1.69      raeburn   682: ##
                    683: ## &getfiledates() 
                    684: ## Converts creationdate and modifieddates to SQL format 
                    685: ## Applies stat() to file to retrieve dates if missing
                    686: sub getfiledates {
                    687:     my ($ref,$target) = @_;
                    688:     if (! defined($ref->{'creationdate'}) ||
                    689:         $ref->{'creationdate'} =~ /^\s*$/) {
                    690:         $ref->{'creationdate'} = (stat($target))[9];
                    691:     }
                    692:     if (! defined($ref->{'lastrevisiondate'}) ||
                    693:         $ref->{'lastrevisiondate'} =~ /^\s*$/) {
                    694:         $ref->{'lastrevisiondate'} = (stat($target))[9];
                    695:     }
1.71      raeburn   696:     $ref->{'creationdate'}     = 
                    697:         &LONCAPA::lonmetadata::sqltime($ref->{'creationdate'});
                    698:     $ref->{'lastrevisiondate'} = 
                    699:         &LONCAPA::lonmetadata::sqltime($ref->{'lastrevisiondate'});
1.69      raeburn   700: }
                    701: 
1.55      matthew   702: ########################################################
                    703: ########################################################
                    704: ###                                                  ###
                    705: ###    Dynamic Metadata                              ###
                    706: ###                                                  ###
                    707: ########################################################
                    708: ########################################################
1.56      matthew   709: ##
1.58      www       710: ## Dynamic metadata description (incomplete)
                    711: ##
                    712: ## For a full description of all fields,
                    713: ## see LONCAPA::lonmetadata
1.56      matthew   714: ##
                    715: ##   Field             Type
                    716: ##-----------------------------------------------------------
                    717: ##   count             integer
                    718: ##   course            integer
1.58      www       719: ##   course_list       comma separated list of course ids
1.56      matthew   720: ##   avetries          real                                
1.58      www       721: ##   avetries_list     comma separated list of real numbers
1.56      matthew   722: ##   stdno             real
1.58      www       723: ##   stdno_list        comma separated list of real numbers
1.56      matthew   724: ##   usage             integer   
1.58      www       725: ##   usage_list        comma separated list of resources
1.56      matthew   726: ##   goto              scalar
1.58      www       727: ##   goto_list         comma separated list of resources
1.56      matthew   728: ##   comefrom          scalar
1.58      www       729: ##   comefrom_list     comma separated list of resources
1.56      matthew   730: ##   difficulty        real
1.58      www       731: ##   difficulty_list   comma separated list of real numbers
1.56      matthew   732: ##   sequsage          scalar
1.58      www       733: ##   sequsage_list     comma separated list of resources
1.56      matthew   734: ##   clear             real
                    735: ##   technical         real
                    736: ##   correct           real
                    737: ##   helpful           real
                    738: ##   depth             real
                    739: ##   comments          html of all the comments made
                    740: ##
                    741: {
                    742: 
                    743: my %DynamicData;
                    744: my %Counts;
                    745: 
                    746: sub process_dynamic_metadata {
                    747:     my ($user,$dom) = @_;
                    748:     undef(%DynamicData);
                    749:     undef(%Counts);
                    750:     #
                    751:     my $prodir = &propath($dom,$user);
1.55      matthew   752:     #
1.56      matthew   753:     # Read in the dynamic metadata
1.55      matthew   754:     my %evaldata;
                    755:     if (! tie(%evaldata,'GDBM_File',
                    756:               $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) {
1.56      matthew   757:         return 0;
1.55      matthew   758:     }
1.56      matthew   759:     #
1.57      matthew   760:     %DynamicData = &LONCAPA::lonmetadata::process_reseval_data(\%evaldata);
1.55      matthew   761:     untie(%evaldata);
1.62      matthew   762:     $DynamicData{'domain'} = $dom;
1.64      albertel  763:     #print('user = '.$user.' domain = '.$dom.$/);
1.56      matthew   764:     #
                    765:     # Read in the access count data
                    766:     &log(7,'Reading access count data') if ($debug);
                    767:     my %countdata;
                    768:     if (! tie(%countdata,'GDBM_File',
                    769:               $prodir.'/nohist_accesscount.db',&GDBM_READER(),0640)) {
                    770:         return 0;
                    771:     }
                    772:     while (my ($key,$count) = each(%countdata)) {
                    773:         next if ($key !~ /^$dom/);
                    774:         $key = &unescape($key);
                    775:         &log(8,'    Count '.$key.' = '.$count) if ($debug);
                    776:         $Counts{$key}=$count;
                    777:     }
                    778:     untie(%countdata);
                    779:     if ($debug) {
                    780:         &log(7,scalar(keys(%Counts)).
                    781:              " Counts read for ".$user."@".$dom);
                    782:         &log(7,scalar(keys(%DynamicData)).
                    783:              " Dynamic metadata read for ".$user."@".$dom);
                    784:     }
                    785:     #
                    786:     return 1;
                    787: }
                    788: 
                    789: sub get_dynamic_metadata {
                    790:     my ($url) = @_;
                    791:     $url =~ s:^/res/::;
1.57      matthew   792:     my %data = &LONCAPA::lonmetadata::process_dynamic_metadata($url,
                    793:                                                                \%DynamicData);
1.56      matthew   794:     # find the count
                    795:     $data{'count'} = $Counts{$url};
                    796:     #
                    797:     # Log the dynamic metadata
                    798:     if ($debug) {
                    799:         while (my($k,$v)=each(%data)) {
                    800:             &log(8,"    ".$k." => ".$v);
                    801:         }
1.44      www       802:     }
1.56      matthew   803:     return %data;
1.30      www       804: }
1.28      harris41  805: 
1.56      matthew   806: } # End of %DynamicData and %Counts scope
                    807: 
1.55      matthew   808: ########################################################
                    809: ########################################################
                    810: ###                                                  ###
                    811: ###   Counts                                         ###
                    812: ###                                                  ###
                    813: ########################################################
                    814: ########################################################
                    815: {
1.1       harris41  816: 
1.55      matthew   817: my %countext;
1.15      harris41  818: 
1.55      matthew   819: sub count_type {
                    820:     my $file=shift;
                    821:     $file=~/\.(\w+)$/;
                    822:     my $ext=lc($1);
                    823:     $countext{$ext}++;
1.31      harris41  824: }
1.1       harris41  825: 
1.55      matthew   826: sub write_type_count {
                    827:     open(RESCOUNT,'>/home/httpd/html/lon-status/rescount.txt');
                    828:     while (my ($extension,$count) = each(%countext)) {
                    829: 	print RESCOUNT $extension.'='.$count.'&';
1.47      www       830:     }
1.55      matthew   831:     print RESCOUNT 'time='.time."\n";
                    832:     close(RESCOUNT);
1.31      harris41  833: }
1.27      www       834: 
1.55      matthew   835: } # end of scope for %countext
1.34      matthew   836: 
1.55      matthew   837: {
1.34      matthew   838: 
1.55      matthew   839: my %copyrights;
1.44      www       840: 
1.55      matthew   841: sub count_copyright {
                    842:     $copyrights{@_[0]}++;
1.31      harris41  843: }
1.33      matthew   844: 
1.55      matthew   845: sub write_copyright_count {
                    846:     open(COPYCOUNT,'>/home/httpd/html/lon-status/copyrightcount.txt');
                    847:     while (my ($copyright,$count) = each(%copyrights)) {
                    848: 	print COPYCOUNT $copyright.'='.$count.'&';
1.31      harris41  849:     }
1.55      matthew   850:     print COPYCOUNT 'time='.time."\n";
                    851:     close(COPYCOUNT);
1.31      harris41  852: }
1.28      harris41  853: 
1.55      matthew   854: } # end of scope for %copyrights
1.28      harris41  855: 
1.55      matthew   856: ########################################################
                    857: ########################################################
                    858: ###                                                  ###
                    859: ###   Miscellanous Utility Routines                  ###
                    860: ###                                                  ###
                    861: ########################################################
                    862: ########################################################
                    863: ##
                    864: ## &ishome($username)
                    865: ##   Returns 1 if $username is a LON-CAPA author, 0 otherwise
                    866: ##   (copied from lond, modification of the return value)
1.31      harris41  867: sub ishome {
                    868:     my $author=shift;
                    869:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    870:     my ($udom,$uname)=split(/\//,$author);
                    871:     my $proname=propath($udom,$uname);
                    872:     if (-e $proname) {
                    873: 	return 1;
                    874:     } else {
                    875:         return 0;
                    876:     }
                    877: }
1.28      harris41  878: 
1.55      matthew   879: ##
                    880: ## &propath($udom,$uname)
                    881: ##   Returns the path to the users LON-CAPA directory
                    882: ##   (copied from lond)
1.31      harris41  883: sub propath {
                    884:     my ($udom,$uname)=@_;
                    885:     $udom=~s/\W//g;
                    886:     $uname=~s/\W//g;
                    887:     my $subdir=$uname.'__';
                    888:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
1.63      matthew   889:     my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
1.31      harris41  890:     return $proname;
                    891: } 
1.28      harris41  892: 
1.55      matthew   893: ##
                    894: ## &declutter($filename)
                    895: ##   Given a filename, returns a url for the filename.
                    896: sub declutter {
                    897:     my $thisfn=shift;
1.63      matthew   898:     $thisfn=~s/^$Apache::lonnet::perlvar{'lonDocRoot'}//;
1.55      matthew   899:     $thisfn=~s/^\///;
                    900:     $thisfn=~s/^res\///;
                    901:     return $thisfn;
1.31      harris41  902: }
1.28      harris41  903: 
1.55      matthew   904: ##
                    905: ## Escape / Unescape special characters
                    906: sub unescape {
                    907:     my $str=shift;
                    908:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    909:     return $str;
1.31      harris41  910: }
1.28      harris41  911: 
1.55      matthew   912: sub escape {
                    913:     my $str=shift;
                    914:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                    915:     return $str;
1.45      www       916: }

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