Return to searchcat.pl CVS log

Up to [LON-CAPA] / loncom / metadata_database

loncapa_apache.conf does not need to be directly specified

    1: #!/usr/bin/perl
    2: # The LearningOnline Network
    3: # searchcat.pl "Search Catalog" batch script
    4: #
    5: # $Id: searchcat.pl,v 1.20 2002/09/09 14:00:24 harris41 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: # YEAR=2001
   30: # 04/14/2001, 04/16/2001 Scott Harrison
   31: #
   32: # YEAR=2002
   33: # 05/11/2002 Scott Harrison
   34: #
   35: ###
   36: 
   37: # This script goes through a LON-CAPA resource
   38: # directory and gathers metadata.
   39: # The metadata is entered into a SQL database.
   40: 
   41: use lib '/home/httpd/lib/perl/';
   42: use LONCAPA::Configuration;
   43: 
   44: use IO::File;
   45: use HTML::TokeParser;
   46: use DBI;
   47: 
   48: my @metalist;
   49: # ----------------- Code to enable 'find' subroutine listing of the .meta files
   50: require "find.pl";
   51: sub wanted {
   52:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
   53:     -f _ &&
   54:     /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
   55:     push(@metalist,"$dir/$_");
   56: }
   57: 
   58: # ---------------  Read loncapa_apache.conf and loncapa.conf and get variables
   59: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
   60: my %perlvar=%{$perlvarref};
   61: undef $perlvarref; # remove since sensitive and not needed
   62: delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed
   63: 
   64: # ------------------------------------- Only run if machine is a library server
   65: exit unless $perlvar{'lonRole'} eq 'library';
   66: 
   67: my $dbh;
   68: # ------------------------------------- Make sure that database can be accessed
   69: {
   70:     unless (
   71: 	    $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
   72: 	    ) { 
   73: 	print "Cannot connect to database!\n";
   74: 	exit;
   75:     }
   76:     my $make_metadata_table = "CREATE TABLE IF NOT EXISTS metadata (".
   77:         "title TEXT, author TEXT, subject TEXT, url TEXT, keywords TEXT, ".
   78:         "version TEXT, notes TEXT, abstract TEXT, mime TEXT, language TEXT, ".
   79:         "creationdate DATETIME, lastrevisiondate DATETIME, owner TEXT, ".
   80:         "copyright TEXT, FULLTEXT idx_title (title), ".
   81:         "FULLTEXT idx_author (author), FULLTEXT idx_subject (subject), ".
   82:         "FULLTEXT idx_url (url), FULLTEXT idx_keywords (keywords), ".
   83:         "FULLTEXT idx_version (version), FULLTEXT idx_notes (notes), ".
   84:         "FULLTEXT idx_abstract (abstract), FULLTEXT idx_mime (mime), ".
   85:         "FULLTEXT idx_language (language), FULLTEXT idx_owner (owner), ".
   86:         "FULLTEXT idx_copyright (copyright)) TYPE=MYISAM";
   87:     # It would sure be nice to have some logging mechanism.
   88:     $dbh->do($make_metadata_table);
   89: }
   90: 
   91: # ------------------------------------------------------------- get .meta files
   92: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
   93: my @homeusers=grep
   94:           {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
   95:           grep {!/^\.\.?$/} readdir(RESOURCES);
   96: closedir RESOURCES;
   97: foreach my $user (@homeusers) {
   98:     &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
   99: }
  100: 
  101: # -- process each file to get metadata and put into search catalog SQL database
  102: # Also, check to see if already there.
  103: # I could just delete (without searching first), but this works for now.
  104: foreach my $m (@metalist) {
  105:     my $ref=&metadata($m);
  106:     my $m2='/res/'.&declutter($m);
  107:     $m2=~s/\.meta$//;
  108:     my $q2="select * from metadata where url like binary '$m2'";
  109:     my $sth = $dbh->prepare($q2);
  110:     $sth->execute();
  111:     my $r1=$sth->fetchall_arrayref;
  112:     if (@$r1) {
  113: 	$sth=$dbh->prepare("delete from metadata where url like binary '$m2'");
  114:         $sth->execute();
  115:     }
  116:     $sth=$dbh->prepare('insert into metadata values ('.
  117: 			  '"'.delete($ref->{'title'}).'"'.','.
  118: 			  '"'.delete($ref->{'author'}).'"'.','.
  119: 			  '"'.delete($ref->{'subject'}).'"'.','.
  120: 			  '"'.$m2.'"'.','.
  121: 			  '"'.delete($ref->{'keywords'}).'"'.','.
  122: 			  '"'.'current'.'"'.','.
  123: 			  '"'.delete($ref->{'notes'}).'"'.','.
  124: 			  '"'.delete($ref->{'abstract'}).'"'.','.
  125: 			  '"'.delete($ref->{'mime'}).'"'.','.
  126: 			  '"'.delete($ref->{'language'}).'"'.','.
  127: 			  '"'.sqltime(delete($ref->{'creationdate'})).'"'.','.
  128: 			  '"'.sqltime(delete($ref->{'lastrevisiondate'})).'"'.','.
  129: 			  '"'.delete($ref->{'owner'}).'"'.','.
  130: 			  '"'.delete($ref->{'copyright'}).'"'.')');
  131:     $sth->execute();
  132: }
  133: 
  134: # ----------------------------------------------------------- Clean up database
  135: # Need to, perhaps, remove stale SQL database records.
  136: # ... not yet implemented
  137: 
  138: # --------------------------------------------------- Close database connection
  139: $dbh->disconnect;
  140: 
  141: # ---------------------------------------------------------------- Get metadata
  142: # significantly altered from subroutine present in lonnet
  143: sub metadata {
  144:     my ($uri,$what)=@_;
  145:     my %metacache;
  146:     $uri=&declutter($uri);
  147:     my $filename=$uri;
  148:     $uri=~s/\.meta$//;
  149:     $uri='';
  150:     unless ($metacache{$uri.'keys'}) {
  151:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  152: 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
  153:         my $parser=HTML::TokeParser->new(\$metastring);
  154:         my $token;
  155:         while ($token=$parser->get_token) {
  156:            if ($token->[0] eq 'S') {
  157: 	      my $entry=$token->[1];
  158:               my $unikey=$entry;
  159:               if (defined($token->[2]->{'part'})) { 
  160:                  $unikey.='_'.$token->[2]->{'part'}; 
  161: 	      }
  162:               if (defined($token->[2]->{'name'})) { 
  163:                  $unikey.='_'.$token->[2]->{'name'}; 
  164: 	      }
  165:               if ($metacache{$uri.'keys'}) {
  166:                  $metacache{$uri.'keys'}.=','.$unikey;
  167:               } else {
  168:                  $metacache{$uri.'keys'}=$unikey;
  169: 	      }
  170:               map {
  171: 		  $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
  172:               } @{$token->[3]};
  173:               unless (
  174:                  $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
  175: 		      ) { $metacache{$uri.''.$unikey}=
  176: 			      $metacache{$uri.''.$unikey.'.default'};
  177: 		      }
  178:           }
  179:        }
  180:     }
  181:     return \%metacache;
  182: }
  183: 
  184: # ------------------------------------------------------------ Serves up a file
  185: # returns either the contents of the file or a -1
  186: sub getfile {
  187:   my $file=shift;
  188:   if (! -e $file ) { return -1; };
  189:   my $fh=IO::File->new($file);
  190:   my $a='';
  191:   while (<$fh>) { $a .=$_; }
  192:   return $a
  193: }
  194: 
  195: # ------------------------------------------------------------- Declutters URLs
  196: sub declutter {
  197:     my $thisfn=shift;
  198:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
  199:     $thisfn=~s/^\///;
  200:     $thisfn=~s/^res\///;
  201:     return $thisfn;
  202: }
  203: 
  204: # --------------------------------------- Is this the home server of an author?
  205: # (copied from lond, modification of the return value)
  206: sub ishome {
  207:     my $author=shift;
  208:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
  209:     my ($udom,$uname)=split(/\//,$author);
  210:     my $proname=propath($udom,$uname);
  211:     if (-e $proname) {
  212: 	return 1;
  213:     } else {
  214:         return 0;
  215:     }
  216: }
  217: 
  218: # -------------------------------------------- Return path to profile directory
  219: # (copied from lond)
  220: sub propath {
  221:     my ($udom,$uname)=@_;
  222:     $udom=~s/\W//g;
  223:     $uname=~s/\W//g;
  224:     my $subdir=$uname.'__';
  225:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
  226:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
  227:     return $proname;
  228: } 
  229: 
  230: # ---------------------------- convert 'time' format into a datetime sql format
  231: sub sqltime {
  232:     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  233: 	localtime(@_[0]);
  234:     $mon++; $year+=1900;
  235:     return "$year-$mon-$mday $hour:$min:$sec";
  236: }