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

1.1       harris41    1: #!/usr/bin/perl
                      2: # The LearningOnline Network
                      3: # searchcat.pl "Search Catalog" batch script
1.16      harris41    4: #
1.50    ! www         5: # $Id: searchcat.pl,v 1.49 2003/12/25 15:20:00 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.47      www       286:         "count INTEGER UNSIGNED, ".
                    287:         "course INTEGER UNSIGNED, course_list TEXT, ".
                    288:         "goto INTEGER UNSIGNED, goto_list TEXT, ".
                    289:         "comefrom INTEGER UNSIGNED, comefrom_list TEXT, ".
1.48      www       290:         "sequsage INTEGER UNSIGNED, sequsage_list TEXT, ".
1.47      www       291:         "stdno INTEGER UNSIGNED, stdno_list TEXT, ".
                    292: 	"avetries FLOAT, avetries_list TEXT, ".
                    293:         "difficulty FLOAT, difficulty_list TEXT, ".
1.49      www       294: 	"clear FLOAT, technical FLOAT, correct FLOAT, helpful FLOAT, depth FLOAT, ".
                    295: 	"comments TEXT, ".
1.47      www       296:         "FULLTEXT idx_title (title), ".
1.31      harris41  297:         "FULLTEXT idx_author (author), FULLTEXT idx_subject (subject), ".
                    298:         "FULLTEXT idx_url (url), FULLTEXT idx_keywords (keywords), ".
                    299:         "FULLTEXT idx_version (version), FULLTEXT idx_notes (notes), ".
                    300:         "FULLTEXT idx_abstract (abstract), FULLTEXT idx_mime (mime), ".
                    301:         "FULLTEXT idx_language (language), FULLTEXT idx_owner (owner), ".
1.47      www       302:         "FULLTEXT idx_copyright (copyright)) ".
                    303:         "TYPE=MyISAM";
1.31      harris41  304:     # It would sure be nice to have some logging mechanism.
1.47      www       305:     unless ($dbh->do($make_metadata_table)) {
                    306: 	print LOG "\nMySQL Error Create: ".$dbh->errstr."\n";
                    307: 	die $dbh->errstr;
                    308:     }
1.31      harris41  309: }
1.27      www       310: 
1.31      harris41  311: # ------------------------------------------------------------- get .meta files
                    312: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
1.33      matthew   313: my @homeusers = grep {
                    314:     &ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")
                    315:     } grep {!/^\.\.?$/} readdir(RESOURCES);
1.31      harris41  316: closedir RESOURCES;
1.34      matthew   317: 
                    318: #
                    319: # Create the statement handlers we need
                    320: 
                    321: my $insert_sth = $dbh->prepare
1.47      www       322:     ("INSERT INTO newmetadata VALUES (".
1.34      matthew   323:      "?,".   # title
                    324:      "?,".   # author
                    325:      "?,".   # subject
1.47      www       326:      "?,".   # declutter url
1.34      matthew   327:      "?,".   # version
                    328:      "?,".   # current
                    329:      "?,".   # notes
                    330:      "?,".   # abstract
                    331:      "?,".   # mime
                    332:      "?,".   # language
                    333:      "?,".   # creationdate
                    334:      "?,".   # revisiondate
                    335:      "?,".   # owner
1.47      www       336:      "?,".   # copyright
1.50    ! www       337:      "?,".   # dependencies
1.47      www       338:      "?,".   # count
                    339:      "?,".   # course
                    340:      "?,".   # course_list
                    341:      "?,".   # goto
                    342:      "?,".   # goto_list
                    343:      "?,".   # comefrom
                    344:      "?,".   # comefrom_list
                    345:      "?,".   # usage
                    346:      "?,".   # usage_list
                    347:      "?,".   # stdno
                    348:      "?,".   # stdno_list
                    349:      "?,".   # avetries
                    350:      "?,".   # avetries_list
                    351:      "?,".   # difficulty
1.49      www       352:      "?,".   # difficulty_list
                    353:      "?,".   # clear
                    354:      "?,".   # technical
                    355:      "?,".   # correct
                    356:      "?,".   # helpful
                    357:      "?,".   # depth
                    358:      "?".    # comments
1.48      www       359:      ")"
1.34      matthew   360:      );
                    361: 
1.31      harris41  362: foreach my $user (@homeusers) {
                    363:     print LOG "\n=== User: ".$user."\n\n";
1.44      www       364: 
1.31      harris41  365:     my $prodir=&propath($perlvar{'lonDefDomain'},$user);
1.33      matthew   366:     # Use find.pl
1.31      harris41  367:     undef @metalist;
                    368:     @metalist=();
                    369:     &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
1.33      matthew   370:     # -- process each file to get metadata and put into search catalog SQL
                    371:     # database.  Also, check to see if already there.
                    372:     # I could just delete (without searching first), but this works for now.
                    373:     foreach my $m (@metalist) {
                    374:         print LOG "- ".$m."\n";
                    375:         my $ref=&metadata($m);
1.41      www       376:         my $m2='/res/'.&declutter($m);
                    377:         $m2=~s/\.meta$//;
1.40      www       378:  	if ($ref->{'obsolete'}) { print LOG "obsolete\n"; next; }
                    379: 	if ($ref->{'copyright'} eq 'private') { print LOG "private\n"; next; }
1.47      www       380:         my %dyn=&dynamicmeta($m2);
1.38      www       381: 	&count($m2);
1.47      www       382:         unless ($insert_sth->execute(
                    383: 			     $ref->{'title'},
1.34      matthew   384:                              $ref->{'author'},
                    385:                              $ref->{'subject'},
                    386:                              $m2,
                    387:                              $ref->{'keywords'},
                    388:                              'current',
                    389:                              $ref->{'notes'},
                    390:                              $ref->{'abstract'},
                    391:                              $ref->{'mime'},
                    392:                              $ref->{'language'},
                    393:                              sqltime($ref->{'creationdate'}),
                    394:                              sqltime($ref->{'lastrevisiondate'}),
                    395:                              $ref->{'owner'},
1.47      www       396:                              $ref->{'copyright'},
1.50    ! www       397: 			     $ref->{'dependencies'},
1.47      www       398: 			     $dyn{'count'},
                    399: 			     $dyn{'course'},
                    400: 			     $dyn{'course_list'},
                    401: 			     $dyn{'goto'},
                    402: 			     $dyn{'goto_list'},
                    403: 			     $dyn{'comefrom'},
                    404: 			     $dyn{'comefrom_list'},
                    405: 			     $dyn{'usage'},
                    406: 			     $dyn{'usage_list'},
                    407: 			     $dyn{'stdno'},
                    408: 			     $dyn{'stdno_list'},
                    409: 			     $dyn{'avetries'},
                    410: 			     $dyn{'avetries_list'},
                    411: 			     $dyn{'difficulty'},
1.49      www       412: 			     $dyn{'difficulty_list'},			     
                    413: 			     $dyn{'clear'},
                    414: 			     $dyn{'technical'},
                    415: 			     $dyn{'correct'},
                    416: 			     $dyn{'helpful'},
                    417: 			     $dyn{'depth'},
                    418: 			     $dyn{'comments'}			     
1.47      www       419: 			     )) {
                    420: 	    print LOG "\nMySQL Error Insert: ".$dbh->errstr."\n";
                    421: 	    die $dbh->errstr;
                    422: 	}
1.34      matthew   423:         $ref = undef;
1.31      harris41  424:     }
                    425: }
                    426: # --------------------------------------------------- Close database connection
1.47      www       427: $dbh->do("DROP TABLE IF EXISTS metadata");
                    428: unless ($dbh->do("RENAME TABLE newmetadata TO metadata")) {
                    429:     print LOG "\nMySQL Error Rename: ".$dbh->errstr."\n";
                    430:     die $dbh->errstr;
                    431: }
                    432: unless ($dbh->disconnect) {
                    433:     print LOG "\nMySQL Error Disconnect: ".$dbh->errstr."\n";
                    434:     die $dbh->errstr;
                    435: }
1.31      harris41  436: print LOG "\n==== Searchcat completed ".localtime()." ====\n";
                    437: close(LOG);
1.36      www       438: &writesimple();
1.38      www       439: &writecount();
1.31      harris41  440: exit 0;
1.33      matthew   441: 
                    442: 
                    443: 
1.31      harris41  444: # =============================================================================
1.1       harris41  445: 
1.31      harris41  446: # ---------------------------------------------------------------- Get metadata
                    447: # significantly altered from subroutine present in lonnet
                    448: sub metadata {
                    449:     my ($uri,$what)=@_;
1.47      www       450:     my %metacache=();
1.31      harris41  451:     $uri=&declutter($uri);
                    452:     my $filename=$uri;
                    453:     $uri=~s/\.meta$//;
                    454:     $uri='';
                    455:     unless ($metacache{$uri.'keys'}) {
                    456:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
                    457: 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
                    458:         my $parser=HTML::TokeParser->new(\$metastring);
                    459:         my $token;
                    460:         while ($token=$parser->get_token) {
1.33      matthew   461:             if ($token->[0] eq 'S') {
                    462:                 my $entry=$token->[1];
                    463:                 my $unikey=$entry;
                    464:                 if (defined($token->[2]->{'part'})) { 
                    465:                     $unikey.='_'.$token->[2]->{'part'}; 
                    466:                 }
                    467:                 if (defined($token->[2]->{'name'})) { 
                    468:                     $unikey.='_'.$token->[2]->{'name'}; 
                    469:                 }
                    470:                 if ($metacache{$uri.'keys'}) {
                    471:                     $metacache{$uri.'keys'}.=','.$unikey;
                    472:                 } else {
                    473:                     $metacache{$uri.'keys'}=$unikey;
                    474:                 }
                    475:                 map {
                    476:                     $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
                    477:                 } @{$token->[3]};
                    478:                 unless (
                    479:                         $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
                    480:                         ) { $metacache{$uri.''.$unikey}=
                    481:                                 $metacache{$uri.''.$unikey.'.default'};
                    482:                         }
                    483:             }
                    484:         }
1.31      harris41  485:     }
                    486:     return \%metacache;
                    487: }
1.28      harris41  488: 
1.31      harris41  489: # ------------------------------------------------------------ Serves up a file
                    490: # returns either the contents of the file or a -1
                    491: sub getfile {
1.33      matthew   492:     my $file=shift;
                    493:     if (! -e $file ) { return -1; };
                    494:     my $fh=IO::File->new($file);
                    495:     my $a='';
                    496:     while (<$fh>) { $a .=$_; }
                    497:     return $a;
1.31      harris41  498: }
1.28      harris41  499: 
1.31      harris41  500: # ------------------------------------------------------------- Declutters URLs
                    501: sub declutter {
                    502:     my $thisfn=shift;
                    503:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
                    504:     $thisfn=~s/^\///;
                    505:     $thisfn=~s/^res\///;
                    506:     return $thisfn;
                    507: }
1.28      harris41  508: 
1.31      harris41  509: # --------------------------------------- Is this the home server of an author?
                    510: # (copied from lond, modification of the return value)
                    511: sub ishome {
                    512:     my $author=shift;
                    513:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    514:     my ($udom,$uname)=split(/\//,$author);
                    515:     my $proname=propath($udom,$uname);
                    516:     if (-e $proname) {
                    517: 	return 1;
                    518:     } else {
                    519:         return 0;
                    520:     }
                    521: }
1.28      harris41  522: 
1.31      harris41  523: # -------------------------------------------- Return path to profile directory
                    524: # (copied from lond)
                    525: sub propath {
                    526:     my ($udom,$uname)=@_;
                    527:     $udom=~s/\W//g;
                    528:     $uname=~s/\W//g;
                    529:     my $subdir=$uname.'__';
                    530:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
                    531:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
                    532:     return $proname;
                    533: } 
1.28      harris41  534: 
1.31      harris41  535: # ---------------------------- convert 'time' format into a datetime sql format
                    536: sub sqltime {
1.13      harris41  537:     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
1.31      harris41  538: 	localtime(&unsqltime(@_[0]));
                    539:     $mon++; $year+=1900;
                    540:     return "$year-$mon-$mday $hour:$min:$sec";
                    541: }
1.28      harris41  542: 
1.31      harris41  543: sub maketime {
                    544:     my %th=@_;
1.33      matthew   545:     return POSIX::mktime(($th{'seconds'},$th{'minutes'},$th{'hours'},
                    546:                           $th{'day'},$th{'month'}-1,
                    547:                           $th{'year'}-1900,0,0,$th{'dlsav'}));
1.31      harris41  548: }
1.28      harris41  549: 
                    550: 
1.31      harris41  551: #########################################
                    552: #
                    553: # Retro-fixing of un-backward-compatible time format
1.28      harris41  554: 
1.31      harris41  555: sub unsqltime {
                    556:     my $timestamp=shift;
                    557:     if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {
1.33      matthew   558:         $timestamp=&maketime('year'=>$1,'month'=>$2,'day'=>$3,
                    559:                              'hours'=>$4,'minutes'=>$5,'seconds'=>$6);
1.31      harris41  560:     }
                    561:     return $timestamp;
                    562: }
1.28      harris41  563: 
1.45      www       564: # ----------------- Code to enable 'find' subroutine listing of the .meta files
                    565: 
                    566: no strict "vars";
                    567: 
                    568: sub wanted {
                    569:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
                    570:          -f _ &&
                    571:          /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
                    572:          push(@metalist,"$dir/$_");
                    573: }

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