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

1.1       harris41    1: #!/usr/bin/perl
                      2: # The LearningOnline Network
                      3: # searchcat.pl "Search Catalog" batch script
1.16      harris41    4: #
1.53    ! www         5: # $Id: searchcat.pl,v 1.52 2003/12/27 01:52:04 www 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;
                     68: 
1.17      harris41   69: use lib '/home/httpd/lib/perl/';
                     70: use LONCAPA::Configuration;
                     71: 
1.1       harris41   72: use IO::File;
                     73: use HTML::TokeParser;
1.6       harris41   74: use DBI;
1.21      www        75: use GDBM_File;
1.24      www        76: use POSIX qw(strftime mktime);
1.1       harris41   77: 
1.45      www        78: require "find.pl";
                     79: 
1.1       harris41   80: my @metalist;
1.21      www        81: 
1.45      www        82: my $simplestatus='';
1.38      www        83: my %countext=();
1.36      www        84: 
1.45      www        85: # ----------------------------------------------------- write out simple status
1.36      www        86: sub writesimple {
                     87:     open(SMP,'>/home/httpd/html/lon-status/mysql.txt');
                     88:     print SMP $simplestatus."\n";
                     89:     close(SMP);
                     90: }
1.28      harris41   91: 
1.38      www        92: sub writecount {
                     93:     open(RSMP,'>/home/httpd/html/lon-status/rescount.txt');
                     94:     foreach (keys %countext) {
                     95: 	print RSMP $_.'='.$countext{$_}.'&';
                     96:     }
                     97:     print RSMP 'time='.time."\n";
                     98:     close(RSMP);
                     99: }
                    100: 
1.45      www       101: # -------------------------------------- counts files with different extensions
1.38      www       102: sub count {
                    103:     my $file=shift;
                    104:     $file=~/\.(\w+)$/;
                    105:     my $ext=lc($1);
                    106:     if (defined($countext{$ext})) {
                    107: 	$countext{$ext}++;
                    108:     } else {
                    109: 	$countext{$ext}=1;
                    110:     }
                    111: }
1.31      harris41  112: # ----------------------------------------------------- Un-Escape Special Chars
1.28      harris41  113: 
1.31      harris41  114: sub unescape {
                    115:     my $str=shift;
1.21      www       116:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.31      harris41  117:     return $str;
                    118: }
1.21      www       119: 
1.31      harris41  120: # -------------------------------------------------------- Escape Special Chars
1.22      www       121: 
1.31      harris41  122: sub escape {
                    123:     my $str=shift;
1.22      www       124:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
1.31      harris41  125:     return $str;
                    126: }
1.28      harris41  127: 
1.31      harris41  128: # ------------------------------------------- Code to evaluate dynamic metadata
1.28      harris41  129: 
1.31      harris41  130: sub dynamicmeta {
1.30      www       131:     my $url=&declutter(shift);
                    132:     $url=~s/\.meta$//;
1.48      www       133:     my %returnhash=(
                    134: 		    'count' => 0,
                    135: 		    'course' => 0,
                    136: 		    'course_list' => '',
1.49      www       137: 		    'avetries' => 'NULL',
1.48      www       138: 		    'avetries_list' => '',
                    139: 		    'stdno' => 0,
                    140: 		    'stdno_list' => '',
                    141: 		    'usage' => 0,
                    142: 		    'usage_list' => '',
                    143: 		    'goto' => 0,
                    144: 		    'goto_list' => '',
                    145: 		    'comefrom' => 0,
                    146: 		    'comefrom_list' => '',
1.49      www       147: 		    'difficulty' => 'NULL',
                    148: 		    'difficulty_list' => '',
                    149:                     'clear' => 'NULL',
                    150:                     'technical' => 'NULL',
                    151: 		    'correct' => 'NULL',
                    152: 		    'helpful' => 'NULL',
                    153: 		    'depth' => 'NULL',
                    154: 		    'comments' => ''
1.48      www       155: 		    );
1.30      www       156:     my ($adomain,$aauthor)=($url=~/^(\w+)\/(\w+)\//);
1.31      harris41  157:     my $prodir=&propath($adomain,$aauthor);
1.45      www       158: 
1.44      www       159: # Get metadata except counts
1.45      www       160:     if (tie(my %evaldata,'GDBM_File',
1.44      www       161:             $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) {
                    162: 	my %sum=();
                    163: 	my %cnt=();
                    164: 	my %concat=();
                    165: 	my %listitems=(
                    166: 		       'course'       => 'add',
                    167: 		       'goto'         => 'add',
                    168: 		       'comefrom'     => 'add',
                    169: 		       'avetries'     => 'avg',
                    170: 		       'stdno'        => 'add',
                    171: 		       'difficulty'   => 'avg',
                    172: 		       'clear'        => 'avg',
                    173: 		       'technical'    => 'avg',
                    174: 		       'helpful'      => 'avg',
                    175: 		       'correct'      => 'avg',
                    176: 		       'depth'        => 'avg',
                    177: 		       'comments'     => 'app',
                    178: 		       'usage'        => 'cnt'
                    179: 		       );
                    180: 	
                    181: 	my $regexp=$url;
                    182: 	$regexp=~s/(\W)/\\$1/g;
                    183: 	$regexp='___'.$regexp.'___([a-z]+)$';
                    184: 	while (my ($esckey,$value)=each %evaldata) {
1.45      www       185: 	    my $key=&unescape($esckey);
1.44      www       186: 	    if ($key=~/$regexp/) {
1.45      www       187: 		my ($item,$purl,$cat)=split(/___/,$key);
1.44      www       188: 		if (defined($cnt{$cat})) { $cnt{$cat}++; } else { $cnt{$cat}=1; }
                    189: 		unless ($listitems{$cat} eq 'app') {
                    190: 		    if (defined($sum{$cat})) {
1.50      www       191: 			$sum{$cat}+=&unescape($evaldata{$esckey});
1.44      www       192: 			$concat{$cat}.=','.$item;
                    193: 		    } else {
1.50      www       194: 			$sum{$cat}=&unescape($evaldata{$esckey});
1.44      www       195: 			$concat{$cat}=$item;
                    196: 		    }
                    197: 		} else {
                    198: 		    if (defined($sum{$cat})) {
1.45      www       199: 			if ($evaldata{$esckey}=~/\w/) {
1.50      www       200: 			    $sum{$cat}.='<hr />'.&unescape($evaldata{$esckey});
1.44      www       201: 			}
                    202: 		    } else {
1.50      www       203: 			$sum{$cat}=''.&unescape($evaldata{$esckey});
1.44      www       204: 		    }
                    205: 		}
1.35      www       206: 	    }
1.44      www       207: 	}
                    208: 	untie(%evaldata);
1.45      www       209: # transfer gathered data to returnhash, calculate averages where applicable
                    210: 	while (my $cat=each(%cnt)) {
1.48      www       211: 	    if ($cnt{$cat} eq 'nan') { next; }
                    212: 	    if ($sum{$cat} eq 'nan') { next; }
1.45      www       213: 	    if ($listitems{$cat} eq 'avg') {
1.48      www       214: 		if ($cnt{$cat}) {
                    215: 		    $returnhash{$cat}=int(($sum{$cat}/$cnt{$cat})*100.0+0.5)/100.0;
                    216: 		} else {
                    217: 		    $returnhash{$cat}='NULL';
                    218: 		}
1.45      www       219: 	    } elsif ($listitems{$cat} eq 'cnt') {
                    220: 		$returnhash{$cat}=$cnt{$cat};
                    221: 	    } else {
                    222: 		$returnhash{$cat}=$sum{$cat};
                    223: 	    }
                    224: 	    $returnhash{$cat.'_list'}=$concat{$cat};
1.44      www       225: 	}
                    226:     }
                    227: # get count
1.45      www       228:     if (tie(my %evaldata,'GDBM_File',
1.44      www       229:             $prodir.'/nohist_accesscount.db',&GDBM_READER(),0640)) {
1.45      www       230: 	my $escurl=&escape($url);
                    231: 	if (! exists($evaldata{$escurl})) {
1.46      www       232: 	    $returnhash{'count'}=0;
1.44      www       233: 	} else {
1.45      www       234: 	    $returnhash{'count'}=$evaldata{$escurl};
1.44      www       235: 	}
                    236: 	untie %evaldata;
                    237:     }
                    238:     return %returnhash;
1.30      www       239: }
1.35      www       240:   
1.31      harris41  241: # ---------------  Read loncapa_apache.conf and loncapa.conf and get variables
                    242: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
                    243: my %perlvar=%{$perlvarref};
1.50      www       244: undef $perlvarref;
1.31      harris41  245: delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed
1.28      harris41  246: 
1.31      harris41  247: # ------------------------------------- Only run if machine is a library server
                    248: exit unless $perlvar{'lonRole'} eq 'library';
1.1       harris41  249: 
1.31      harris41  250: # ----------------------------- Make sure this process is running from user=www
1.15      harris41  251: 
1.31      harris41  252: my $wwwid=getpwnam('www');
                    253: if ($wwwid!=$<) {
1.45      www       254:     my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
                    255:     my $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
1.33      matthew   256:     system("echo 'User ID mismatch. searchcat.pl must be run as user www.' |\
1.31      harris41  257:  mailto $emailto -s '$subj' > /dev/null");
1.33      matthew   258:     exit 1;
1.31      harris41  259: }
1.1       harris41  260: 
1.27      www       261: 
1.31      harris41  262: # ---------------------------------------------------------- We are in business
1.27      www       263: 
1.31      harris41  264: open(LOG,'>'.$perlvar{'lonDaemons'}.'/logs/searchcat.log');
                    265: print LOG '==== Searchcat Run '.localtime()."====\n\n";
1.36      www       266: $simplestatus='time='.time.'&';
1.31      harris41  267: my $dbh;
                    268: # ------------------------------------- Make sure that database can be accessed
                    269: {
                    270:     unless (
                    271: 	    $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
                    272: 	    ) { 
                    273: 	print LOG "Cannot connect to database!\n";
1.36      www       274: 	$simplestatus.='mysql=defunct';
                    275: 	&writesimple();
1.31      harris41  276: 	exit;
                    277:     }
1.36      www       278: 
1.47      www       279: # Make temporary table
                    280:     $dbh->do("DROP TABLE IF EXISTS newmetadata");
                    281:     my $make_metadata_table = "CREATE TABLE IF NOT EXISTS newmetadata (".
1.31      harris41  282:         "title TEXT, author TEXT, subject TEXT, url TEXT, keywords TEXT, ".
                    283:         "version TEXT, notes TEXT, abstract TEXT, mime TEXT, language TEXT, ".
                    284:         "creationdate DATETIME, lastrevisiondate DATETIME, owner TEXT, ".
1.50      www       285:         "copyright TEXT, dependencies TEXT, ".
1.51      www       286: 	"modifyinguser TEXT, authorspace TEXT, ".
                    287: 	"lowestgradelevel INTEGER UNSIGNED, highestgradelevel INTEGER UNSIGNED, ".
                    288: 	"standards TEXT, ".
1.47      www       289:         "count INTEGER UNSIGNED, ".
                    290:         "course INTEGER UNSIGNED, course_list TEXT, ".
                    291:         "goto INTEGER UNSIGNED, goto_list TEXT, ".
                    292:         "comefrom INTEGER UNSIGNED, comefrom_list TEXT, ".
1.48      www       293:         "sequsage INTEGER UNSIGNED, sequsage_list TEXT, ".
1.47      www       294:         "stdno INTEGER UNSIGNED, stdno_list TEXT, ".
                    295: 	"avetries FLOAT, avetries_list TEXT, ".
                    296:         "difficulty FLOAT, difficulty_list TEXT, ".
1.49      www       297: 	"clear FLOAT, technical FLOAT, correct FLOAT, helpful FLOAT, depth FLOAT, ".
                    298: 	"comments TEXT, ".
1.53    ! www       299: # For backward compatibility, only insert new fields below
        !           300: # ...
        !           301: # For backward compatibility, end new fields above
1.47      www       302:         "FULLTEXT idx_title (title), ".
1.31      harris41  303:         "FULLTEXT idx_author (author), FULLTEXT idx_subject (subject), ".
                    304:         "FULLTEXT idx_url (url), FULLTEXT idx_keywords (keywords), ".
1.52      www       305:         "FULLTEXT idx_notes (notes), ".
1.31      harris41  306:         "FULLTEXT idx_abstract (abstract), FULLTEXT idx_mime (mime), ".
1.52      www       307:         "FULLTEXT idx_owner (owner), ".
                    308: 	"FULLTEXT idx_standards (standards))".
1.47      www       309:         "TYPE=MyISAM";
1.31      harris41  310:     # It would sure be nice to have some logging mechanism.
1.47      www       311:     unless ($dbh->do($make_metadata_table)) {
                    312: 	print LOG "\nMySQL Error Create: ".$dbh->errstr."\n";
                    313: 	die $dbh->errstr;
                    314:     }
1.31      harris41  315: }
1.27      www       316: 
1.31      harris41  317: # ------------------------------------------------------------- get .meta files
                    318: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
1.33      matthew   319: my @homeusers = grep {
                    320:     &ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")
                    321:     } grep {!/^\.\.?$/} readdir(RESOURCES);
1.31      harris41  322: closedir RESOURCES;
1.34      matthew   323: 
                    324: #
                    325: # Create the statement handlers we need
                    326: 
                    327: my $insert_sth = $dbh->prepare
1.47      www       328:     ("INSERT INTO newmetadata VALUES (".
1.34      matthew   329:      "?,".   # title
                    330:      "?,".   # author
                    331:      "?,".   # subject
1.47      www       332:      "?,".   # declutter url
1.34      matthew   333:      "?,".   # version
                    334:      "?,".   # current
                    335:      "?,".   # notes
                    336:      "?,".   # abstract
                    337:      "?,".   # mime
                    338:      "?,".   # language
                    339:      "?,".   # creationdate
                    340:      "?,".   # revisiondate
                    341:      "?,".   # owner
1.47      www       342:      "?,".   # copyright
1.50      www       343:      "?,".   # dependencies
1.51      www       344:      "?,".   # modifyinguser
                    345:      "?,".   # authorspace
                    346:      "?,".   # lowestgradelevel
                    347:      "?,".   # highestgradelevel
                    348:      "?,".   # standards
1.47      www       349:      "?,".   # count
                    350:      "?,".   # course
                    351:      "?,".   # course_list
                    352:      "?,".   # goto
                    353:      "?,".   # goto_list
                    354:      "?,".   # comefrom
                    355:      "?,".   # comefrom_list
                    356:      "?,".   # usage
                    357:      "?,".   # usage_list
                    358:      "?,".   # stdno
                    359:      "?,".   # stdno_list
                    360:      "?,".   # avetries
                    361:      "?,".   # avetries_list
                    362:      "?,".   # difficulty
1.49      www       363:      "?,".   # difficulty_list
                    364:      "?,".   # clear
                    365:      "?,".   # technical
                    366:      "?,".   # correct
                    367:      "?,".   # helpful
                    368:      "?,".   # depth
                    369:      "?".    # comments
1.48      www       370:      ")"
1.34      matthew   371:      );
                    372: 
1.31      harris41  373: foreach my $user (@homeusers) {
                    374:     print LOG "\n=== User: ".$user."\n\n";
1.44      www       375: 
1.31      harris41  376:     my $prodir=&propath($perlvar{'lonDefDomain'},$user);
1.33      matthew   377:     # Use find.pl
1.31      harris41  378:     undef @metalist;
                    379:     @metalist=();
                    380:     &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
1.33      matthew   381:     # -- process each file to get metadata and put into search catalog SQL
                    382:     # database.  Also, check to see if already there.
                    383:     # I could just delete (without searching first), but this works for now.
                    384:     foreach my $m (@metalist) {
                    385:         print LOG "- ".$m."\n";
                    386:         my $ref=&metadata($m);
1.41      www       387:         my $m2='/res/'.&declutter($m);
                    388:         $m2=~s/\.meta$//;
1.40      www       389:  	if ($ref->{'obsolete'}) { print LOG "obsolete\n"; next; }
                    390: 	if ($ref->{'copyright'} eq 'private') { print LOG "private\n"; next; }
1.47      www       391:         my %dyn=&dynamicmeta($m2);
1.38      www       392: 	&count($m2);
1.47      www       393:         unless ($insert_sth->execute(
                    394: 			     $ref->{'title'},
1.34      matthew   395:                              $ref->{'author'},
                    396:                              $ref->{'subject'},
                    397:                              $m2,
                    398:                              $ref->{'keywords'},
                    399:                              'current',
                    400:                              $ref->{'notes'},
                    401:                              $ref->{'abstract'},
                    402:                              $ref->{'mime'},
                    403:                              $ref->{'language'},
                    404:                              sqltime($ref->{'creationdate'}),
                    405:                              sqltime($ref->{'lastrevisiondate'}),
                    406:                              $ref->{'owner'},
1.47      www       407:                              $ref->{'copyright'},
1.50      www       408: 			     $ref->{'dependencies'},
1.51      www       409: 			     $ref->{'modifyinguser'},
                    410: 			     $ref->{'authorspace'},
                    411: 			     $ref->{'lowestgradelevel'},
                    412: 			     $ref->{'highestgradelevel'},
                    413: 			     $ref->{'standards'},
1.47      www       414: 			     $dyn{'count'},
                    415: 			     $dyn{'course'},
                    416: 			     $dyn{'course_list'},
                    417: 			     $dyn{'goto'},
                    418: 			     $dyn{'goto_list'},
                    419: 			     $dyn{'comefrom'},
                    420: 			     $dyn{'comefrom_list'},
                    421: 			     $dyn{'usage'},
                    422: 			     $dyn{'usage_list'},
                    423: 			     $dyn{'stdno'},
                    424: 			     $dyn{'stdno_list'},
                    425: 			     $dyn{'avetries'},
                    426: 			     $dyn{'avetries_list'},
                    427: 			     $dyn{'difficulty'},
1.49      www       428: 			     $dyn{'difficulty_list'},			     
                    429: 			     $dyn{'clear'},
                    430: 			     $dyn{'technical'},
                    431: 			     $dyn{'correct'},
                    432: 			     $dyn{'helpful'},
                    433: 			     $dyn{'depth'},
                    434: 			     $dyn{'comments'}			     
1.47      www       435: 			     )) {
                    436: 	    print LOG "\nMySQL Error Insert: ".$dbh->errstr."\n";
                    437: 	    die $dbh->errstr;
                    438: 	}
1.34      matthew   439:         $ref = undef;
1.31      harris41  440:     }
                    441: }
                    442: # --------------------------------------------------- Close database connection
1.47      www       443: $dbh->do("DROP TABLE IF EXISTS metadata");
                    444: unless ($dbh->do("RENAME TABLE newmetadata TO metadata")) {
                    445:     print LOG "\nMySQL Error Rename: ".$dbh->errstr."\n";
                    446:     die $dbh->errstr;
                    447: }
                    448: unless ($dbh->disconnect) {
                    449:     print LOG "\nMySQL Error Disconnect: ".$dbh->errstr."\n";
                    450:     die $dbh->errstr;
                    451: }
1.31      harris41  452: print LOG "\n==== Searchcat completed ".localtime()." ====\n";
                    453: close(LOG);
1.36      www       454: &writesimple();
1.38      www       455: &writecount();
1.31      harris41  456: exit 0;
1.33      matthew   457: 
                    458: 
                    459: 
1.31      harris41  460: # =============================================================================
1.1       harris41  461: 
1.31      harris41  462: # ---------------------------------------------------------------- Get metadata
                    463: # significantly altered from subroutine present in lonnet
                    464: sub metadata {
                    465:     my ($uri,$what)=@_;
1.47      www       466:     my %metacache=();
1.31      harris41  467:     $uri=&declutter($uri);
                    468:     my $filename=$uri;
                    469:     $uri=~s/\.meta$//;
                    470:     $uri='';
                    471:     unless ($metacache{$uri.'keys'}) {
                    472:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
                    473: 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
                    474:         my $parser=HTML::TokeParser->new(\$metastring);
                    475:         my $token;
                    476:         while ($token=$parser->get_token) {
1.33      matthew   477:             if ($token->[0] eq 'S') {
                    478:                 my $entry=$token->[1];
                    479:                 my $unikey=$entry;
                    480:                 if (defined($token->[2]->{'part'})) { 
                    481:                     $unikey.='_'.$token->[2]->{'part'}; 
                    482:                 }
                    483:                 if (defined($token->[2]->{'name'})) { 
                    484:                     $unikey.='_'.$token->[2]->{'name'}; 
                    485:                 }
                    486:                 if ($metacache{$uri.'keys'}) {
                    487:                     $metacache{$uri.'keys'}.=','.$unikey;
                    488:                 } else {
                    489:                     $metacache{$uri.'keys'}=$unikey;
                    490:                 }
                    491:                 map {
                    492:                     $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
                    493:                 } @{$token->[3]};
                    494:                 unless (
                    495:                         $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
                    496:                         ) { $metacache{$uri.''.$unikey}=
                    497:                                 $metacache{$uri.''.$unikey.'.default'};
                    498:                         }
                    499:             }
                    500:         }
1.31      harris41  501:     }
                    502:     return \%metacache;
                    503: }
1.28      harris41  504: 
1.31      harris41  505: # ------------------------------------------------------------ Serves up a file
                    506: # returns either the contents of the file or a -1
                    507: sub getfile {
1.33      matthew   508:     my $file=shift;
                    509:     if (! -e $file ) { return -1; };
                    510:     my $fh=IO::File->new($file);
                    511:     my $a='';
                    512:     while (<$fh>) { $a .=$_; }
                    513:     return $a;
1.31      harris41  514: }
1.28      harris41  515: 
1.31      harris41  516: # ------------------------------------------------------------- Declutters URLs
                    517: sub declutter {
                    518:     my $thisfn=shift;
                    519:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
                    520:     $thisfn=~s/^\///;
                    521:     $thisfn=~s/^res\///;
                    522:     return $thisfn;
                    523: }
1.28      harris41  524: 
1.31      harris41  525: # --------------------------------------- Is this the home server of an author?
                    526: # (copied from lond, modification of the return value)
                    527: sub ishome {
                    528:     my $author=shift;
                    529:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    530:     my ($udom,$uname)=split(/\//,$author);
                    531:     my $proname=propath($udom,$uname);
                    532:     if (-e $proname) {
                    533: 	return 1;
                    534:     } else {
                    535:         return 0;
                    536:     }
                    537: }
1.28      harris41  538: 
1.31      harris41  539: # -------------------------------------------- Return path to profile directory
                    540: # (copied from lond)
                    541: sub propath {
                    542:     my ($udom,$uname)=@_;
                    543:     $udom=~s/\W//g;
                    544:     $uname=~s/\W//g;
                    545:     my $subdir=$uname.'__';
                    546:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
                    547:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
                    548:     return $proname;
                    549: } 
1.28      harris41  550: 
1.31      harris41  551: # ---------------------------- convert 'time' format into a datetime sql format
                    552: sub sqltime {
1.13      harris41  553:     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
1.31      harris41  554: 	localtime(&unsqltime(@_[0]));
                    555:     $mon++; $year+=1900;
                    556:     return "$year-$mon-$mday $hour:$min:$sec";
                    557: }
1.28      harris41  558: 
1.31      harris41  559: sub maketime {
                    560:     my %th=@_;
1.33      matthew   561:     return POSIX::mktime(($th{'seconds'},$th{'minutes'},$th{'hours'},
                    562:                           $th{'day'},$th{'month'}-1,
                    563:                           $th{'year'}-1900,0,0,$th{'dlsav'}));
1.31      harris41  564: }
1.28      harris41  565: 
                    566: 
1.31      harris41  567: #########################################
                    568: #
                    569: # Retro-fixing of un-backward-compatible time format
1.28      harris41  570: 
1.31      harris41  571: sub unsqltime {
                    572:     my $timestamp=shift;
                    573:     if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {
1.33      matthew   574:         $timestamp=&maketime('year'=>$1,'month'=>$2,'day'=>$3,
                    575:                              'hours'=>$4,'minutes'=>$5,'seconds'=>$6);
1.31      harris41  576:     }
                    577:     return $timestamp;
                    578: }
1.28      harris41  579: 
1.45      www       580: # ----------------- Code to enable 'find' subroutine listing of the .meta files
                    581: 
                    582: no strict "vars";
                    583: 
                    584: sub wanted {
                    585:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
                    586:          -f _ &&
                    587:          /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
                    588:          push(@metalist,"$dir/$_");
                    589: }

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