Return to searchcat.pl CVS log

Up to [LON-CAPA] / loncom / metadata_database

Indentation fix only.  No real code changes.  Move along.......

    1: #!/usr/bin/perl
    2: # The LearningOnline Network
    3: # searchcat.pl "Search Catalog" batch script
    4: #
    5: # $Id: searchcat.pl,v 1.33 2003/06/19 19:34:27 matthew Exp $
    6: #
    7: # Copyright Michigan State University Board of Trustees
    8: #
    9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
   10: #
   11: # LON-CAPA is free software; you can redistribute it and/or modify
   12: # it under the terms of the GNU General Public License as published by
   13: # the Free Software Foundation; either version 2 of the License, or
   14: # (at your option) any later version.
   15: #
   16: # LON-CAPA is distributed in the hope that it will be useful,
   17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   19: # GNU General Public License for more details.
   20: #
   21: # You should have received a copy of the GNU General Public License
   22: # along with LON-CAPA; if not, write to the Free Software
   23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   24: #
   25: # /home/httpd/html/adm/gpl.txt
   26: #
   27: # http://www.lon-capa.org/
   28: #
   29: ###
   30: 
   31: =pod
   32: 
   33: =head1 NAME
   34: 
   35: B<searchcat.pl> - put authoritative filesystem data into sql database.
   36: 
   37: =head1 SYNOPSIS
   38: 
   39: Ordinarily this script is to be called from a loncapa cron job
   40: (CVS source location: F<loncapa/loncom/cron/loncapa>; typical
   41: filesystem installation location: F</etc/cron.d/loncapa>).
   42: 
   43: Here is the cron job entry.
   44: 
   45: C<# Repopulate and refresh the metadata database used for the search catalog.>
   46: C<10 1 * * 7    www    /home/httpd/perl/searchcat.pl>
   47: 
   48: This script only allows itself to be run as the user C<www>.
   49: 
   50: =head1 DESCRIPTION
   51: 
   52: This script goes through a loncapa resource directory and gathers metadata.
   53: The metadata is entered into a SQL database.
   54: 
   55: This script also does general database maintenance such as reformatting
   56: the C<loncapa:metadata> table if it is deprecated.
   57: 
   58: This script evaluates dynamic metadata from the authors'
   59: F<nohist_resevaldata.db> database file in order to store it in MySQL, as
   60: well as to compress the filesize (add up all "count"-type metadata).
   61: 
   62: This script is playing an increasingly important role for a loncapa
   63: library server.  The proper operation of this script is critical for a smooth
   64: and correct user experience.
   65: 
   66: =cut
   67: 
   68: use lib '/home/httpd/lib/perl/';
   69: use LONCAPA::Configuration;
   70: 
   71: use IO::File;
   72: use HTML::TokeParser;
   73: use DBI;
   74: use GDBM_File;
   75: use POSIX qw(strftime mktime);
   76: 
   77: my @metalist;
   78: 
   79: 
   80: # ----------------------------------------------------- Un-Escape Special Chars
   81: 
   82: sub unescape {
   83:     my $str=shift;
   84:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
   85:     return $str;
   86: }
   87: 
   88: # -------------------------------------------------------- Escape Special Chars
   89: 
   90: sub escape {
   91:     my $str=shift;
   92:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
   93:     return $str;
   94: }
   95: 
   96: 
   97: # ------------------------------------------- Code to evaluate dynamic metadata
   98: 
   99: sub dynamicmeta {
  100: 
  101:     my $url=&declutter(shift);
  102:     $url=~s/\.meta$//;
  103:     my %returnhash=();
  104:     my ($adomain,$aauthor)=($url=~/^(\w+)\/(\w+)\//);
  105:     my $prodir=&propath($adomain,$aauthor);
  106:     if ((tie(%evaldata,'GDBM_File',
  107:              $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) &&
  108:         (tie(%newevaldata,'GDBM_File',
  109:              $prodir.'/nohist_new_resevaldata.db',&GDBM_WRCREAT(),0640))) {
  110:         my %sum=();
  111:         my %cnt=();
  112:         my %listitems=('count'        => 'add',
  113:                        'course'       => 'add',
  114:                        'avetries'     => 'avg',
  115:                        'stdno'        => 'add',
  116:                        'difficulty'   => 'avg',
  117:                        'clear'        => 'avg',
  118:                        'technical'    => 'avg',
  119:                        'helpful'      => 'avg',
  120:                        'correct'      => 'avg',
  121:                        'depth'        => 'avg',
  122:                        'comments'     => 'app',
  123:                        'usage'        => 'cnt'
  124:                        );
  125:         my $regexp=$url;
  126:         $regexp=~s/(\W)/\\$1/g;
  127:         $regexp='___'.$regexp.'___([a-z]+)$';
  128:         foreach (keys %evaldata) {
  129:             my $key=&unescape($_);
  130:             if ($key=~/$regexp/) {
  131:                 my $ctype=$1;
  132:                 if (defined($cnt{$ctype})) { 
  133:                     $cnt{$ctype}++; 
  134:                 } else { 
  135:                     $cnt{$ctype}=1; 
  136:                 }
  137:                 unless ($listitems{$ctype} eq 'app') {
  138:                     if (defined($sum{$ctype})) {
  139:                         $sum{$ctype}+=$evaldata{$_};
  140:                     } else {
  141:                         $sum{$ctype}=$evaldata{$_};
  142:                     }
  143:                 } else {
  144:                     if (defined($sum{$ctype})) {
  145:                         if ($evaldata{$_}) {
  146:                             $sum{$ctype}.='<hr>'.$evaldata{$_};
  147:                         }
  148:                     } else {
  149:                         $sum{$ctype}=''.$evaldata{$_};
  150:                     }
  151:                 }
  152:                 if ($ctype ne 'count') {
  153:                     $newevaldata{$_}=$evaldata{$_};
  154:                 }
  155:             }
  156:         }
  157:         foreach (keys %cnt) {
  158:             if ($listitems{$_} eq 'avg') {
  159:                 $returnhash{$_}=int(($sum{$_}/$cnt{$_})*100.0+0.5)/100.0;
  160:             } elsif ($listitems{$_} eq 'cnt') {
  161:                 $returnhash{$_}=$cnt{$_};
  162:             } else {
  163:                 $returnhash{$_}=$sum{$_};
  164:             }
  165:         }
  166:         if ($returnhash{'count'}) {
  167:             my $newkey=$$.'_'.time.'_searchcat___'.&escape($url).'___count';
  168:             $newevaldata{$newkey}=$returnhash{'count'};
  169:         }
  170:         untie(%evaldata);
  171:         untie(%newevaldata);
  172:     }
  173:     return %returnhash;
  174: }
  175: 
  176: # ----------------- Code to enable 'find' subroutine listing of the .meta files
  177: require "find.pl";
  178: sub wanted {
  179:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
  180:         -f _ &&
  181:         /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
  182:         push(@metalist,"$dir/$_");
  183: }
  184: 
  185: # ---------------  Read loncapa_apache.conf and loncapa.conf and get variables
  186: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
  187: my %perlvar=%{$perlvarref};
  188: undef $perlvarref; # remove since sensitive and not needed
  189: delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed
  190: 
  191: # ------------------------------------- Only run if machine is a library server
  192: exit unless $perlvar{'lonRole'} eq 'library';
  193: 
  194: # ----------------------------- Make sure this process is running from user=www
  195: 
  196: my $wwwid=getpwnam('www');
  197: if ($wwwid!=$<) {
  198:     $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
  199:     $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
  200:     system("echo 'User ID mismatch. searchcat.pl must be run as user www.' |\
  201:  mailto $emailto -s '$subj' > /dev/null");
  202:     exit 1;
  203: }
  204: 
  205: 
  206: # ---------------------------------------------------------- We are in business
  207: 
  208: open(LOG,'>'.$perlvar{'lonDaemons'}.'/logs/searchcat.log');
  209: print LOG '==== Searchcat Run '.localtime()."====\n\n";
  210: my $dbh;
  211: # ------------------------------------- Make sure that database can be accessed
  212: {
  213:     unless (
  214: 	    $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
  215: 	    ) { 
  216: 	print LOG "Cannot connect to database!\n";
  217: 	exit;
  218:     }
  219:     my $make_metadata_table = "CREATE TABLE IF NOT EXISTS metadata (".
  220:         "title TEXT, author TEXT, subject TEXT, url TEXT, keywords TEXT, ".
  221:         "version TEXT, notes TEXT, abstract TEXT, mime TEXT, language TEXT, ".
  222:         "creationdate DATETIME, lastrevisiondate DATETIME, owner TEXT, ".
  223:         "copyright TEXT, FULLTEXT idx_title (title), ".
  224:         "FULLTEXT idx_author (author), FULLTEXT idx_subject (subject), ".
  225:         "FULLTEXT idx_url (url), FULLTEXT idx_keywords (keywords), ".
  226:         "FULLTEXT idx_version (version), FULLTEXT idx_notes (notes), ".
  227:         "FULLTEXT idx_abstract (abstract), FULLTEXT idx_mime (mime), ".
  228:         "FULLTEXT idx_language (language), FULLTEXT idx_owner (owner), ".
  229:         "FULLTEXT idx_copyright (copyright)) TYPE=MYISAM";
  230:     # It would sure be nice to have some logging mechanism.
  231:     $dbh->do($make_metadata_table);
  232: }
  233: 
  234: # ------------------------------------------------------------- get .meta files
  235: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
  236: my @homeusers = grep {
  237:     &ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")
  238:     } grep {!/^\.\.?$/} readdir(RESOURCES);
  239: closedir RESOURCES;
  240: foreach my $user (@homeusers) {
  241:     print LOG "\n=== User: ".$user."\n\n";
  242:     # Remove left-over db-files from potentially crashed searchcat run
  243:     my $prodir=&propath($perlvar{'lonDefDomain'},$user);
  244:     unlink($prodir.'/nohist_new_resevaldata.db');
  245:     # Use find.pl
  246:     undef @metalist;
  247:     @metalist=();
  248:     &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
  249:     # -- process each file to get metadata and put into search catalog SQL
  250:     # database.  Also, check to see if already there.
  251:     # I could just delete (without searching first), but this works for now.
  252:     foreach my $m (@metalist) {
  253:         print LOG "- ".$m."\n";
  254:         my $ref=&metadata($m);
  255:         my $m2='/res/'.&declutter($m);
  256:         $m2=~s/\.meta$//;
  257:         &dynamicmeta($m2);
  258:         my $q2="select * from metadata where url like binary '$m2'";
  259:         my $sth = $dbh->prepare($q2);
  260:         $sth->execute();
  261:         my $r1=$sth->fetchall_arrayref;
  262:         if (@$r1) {
  263:             $sth=$dbh->prepare("delete from metadata where url like binary '$m2'");
  264:             $sth->execute();
  265:         }
  266:         $sth=$dbh->prepare('insert into metadata values ('.
  267:                            '"'.delete($ref->{'title'}).'"'.','.
  268:                            '"'.delete($ref->{'author'}).'"'.','.
  269:                            '"'.delete($ref->{'subject'}).'"'.','.
  270:                            '"'.$m2.'"'.','.
  271:                            '"'.delete($ref->{'keywords'}).'"'.','.
  272:                            '"'.'current'.'"'.','.
  273:                            '"'.delete($ref->{'notes'}).'"'.','.
  274:                            '"'.delete($ref->{'abstract'}).'"'.','.
  275:                            '"'.delete($ref->{'mime'}).'"'.','.
  276:                            '"'.delete($ref->{'language'}).'"'.','.
  277:                            '"'.sqltime(delete($ref->{'creationdate'})).'"'.','.
  278:                            '"'.sqltime(delete($ref->{'lastrevisiondate'})).'"'.','.
  279:                            '"'.delete($ref->{'owner'}).'"'.','.
  280:                            '"'.delete($ref->{'copyright'}).'"'.')');
  281:         $sth->execute();
  282:     }
  283:     
  284:     # --------------------------------------------------- Clean up database
  285:     # Need to, perhaps, remove stale SQL database records.
  286:     # ... not yet implemented
  287:         
  288:     # ------------------------------------------- Copy over the new db-files
  289:     system('mv '.$prodir.'/nohist_new_resevaldata.db '.
  290:            $prodir.'/nohist_resevaldata.db');
  291: }
  292: # --------------------------------------------------- Close database connection
  293: $dbh->disconnect;
  294: print LOG "\n==== Searchcat completed ".localtime()." ====\n";
  295: close(LOG);
  296: exit 0;
  297: 
  298: 
  299: 
  300: # =============================================================================
  301: 
  302: # ---------------------------------------------------------------- Get metadata
  303: # significantly altered from subroutine present in lonnet
  304: sub metadata {
  305:     my ($uri,$what)=@_;
  306:     my %metacache;
  307:     $uri=&declutter($uri);
  308:     my $filename=$uri;
  309:     $uri=~s/\.meta$//;
  310:     $uri='';
  311:     unless ($metacache{$uri.'keys'}) {
  312:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  313: 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
  314:         my $parser=HTML::TokeParser->new(\$metastring);
  315:         my $token;
  316:         while ($token=$parser->get_token) {
  317:             if ($token->[0] eq 'S') {
  318:                 my $entry=$token->[1];
  319:                 my $unikey=$entry;
  320:                 if (defined($token->[2]->{'part'})) { 
  321:                     $unikey.='_'.$token->[2]->{'part'}; 
  322:                 }
  323:                 if (defined($token->[2]->{'name'})) { 
  324:                     $unikey.='_'.$token->[2]->{'name'}; 
  325:                 }
  326:                 if ($metacache{$uri.'keys'}) {
  327:                     $metacache{$uri.'keys'}.=','.$unikey;
  328:                 } else {
  329:                     $metacache{$uri.'keys'}=$unikey;
  330:                 }
  331:                 map {
  332:                     $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
  333:                 } @{$token->[3]};
  334:                 unless (
  335:                         $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
  336:                         ) { $metacache{$uri.''.$unikey}=
  337:                                 $metacache{$uri.''.$unikey.'.default'};
  338:                         }
  339:             }
  340:         }
  341:     }
  342:     return \%metacache;
  343: }
  344: 
  345: # ------------------------------------------------------------ Serves up a file
  346: # returns either the contents of the file or a -1
  347: sub getfile {
  348:     my $file=shift;
  349:     if (! -e $file ) { return -1; };
  350:     my $fh=IO::File->new($file);
  351:     my $a='';
  352:     while (<$fh>) { $a .=$_; }
  353:     return $a;
  354: }
  355: 
  356: # ------------------------------------------------------------- Declutters URLs
  357: sub declutter {
  358:     my $thisfn=shift;
  359:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
  360:     $thisfn=~s/^\///;
  361:     $thisfn=~s/^res\///;
  362:     return $thisfn;
  363: }
  364: 
  365: # --------------------------------------- Is this the home server of an author?
  366: # (copied from lond, modification of the return value)
  367: sub ishome {
  368:     my $author=shift;
  369:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
  370:     my ($udom,$uname)=split(/\//,$author);
  371:     my $proname=propath($udom,$uname);
  372:     if (-e $proname) {
  373: 	return 1;
  374:     } else {
  375:         return 0;
  376:     }
  377: }
  378: 
  379: # -------------------------------------------- Return path to profile directory
  380: # (copied from lond)
  381: sub propath {
  382:     my ($udom,$uname)=@_;
  383:     $udom=~s/\W//g;
  384:     $uname=~s/\W//g;
  385:     my $subdir=$uname.'__';
  386:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
  387:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
  388:     return $proname;
  389: } 
  390: 
  391: # ---------------------------- convert 'time' format into a datetime sql format
  392: sub sqltime {
  393:     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  394: 	localtime(&unsqltime(@_[0]));
  395:     $mon++; $year+=1900;
  396:     return "$year-$mon-$mday $hour:$min:$sec";
  397: }
  398: 
  399: sub maketime {
  400:     my %th=@_;
  401:     return POSIX::mktime(($th{'seconds'},$th{'minutes'},$th{'hours'},
  402:                           $th{'day'},$th{'month'}-1,
  403:                           $th{'year'}-1900,0,0,$th{'dlsav'}));
  404: }
  405: 
  406: 
  407: #########################################
  408: #
  409: # Retro-fixing of un-backward-compatible time format
  410: 
  411: sub unsqltime {
  412:     my $timestamp=shift;
  413:     if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {
  414:         $timestamp=&maketime('year'=>$1,'month'=>$2,'day'=>$3,
  415:                              'hours'=>$4,'minutes'=>$5,'seconds'=>$6);
  416:     }
  417:     return $timestamp;
  418: }
  419: