Return to searchcat.pl CVS log

Up to [LON-CAPA] / loncom / metadata_database

removing stupid bug -Scott

    1: #!/usr/bin/perl
    2: # The LearningOnline Network
    3: # searchcat.pl "Search Catalog" batch script
    4: 
    5: # 04/14/2001 Scott Harrison
    6: 
    7: # This script goes through a LON-CAPA resource
    8: # directory and gathers metadata.
    9: # The metadata is entered into a SQL database.
   10: 
   11: use IO::File;
   12: use HTML::TokeParser;
   13: 
   14: my @metalist;
   15: # ----------------- Code to enable 'find' subroutine listing of the .meta files
   16: require "find.pl";
   17: sub wanted {
   18:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
   19:     -f _ &&
   20:     /^.*\.meta$/ &&
   21:     push(@metalist,"$dir/$_");
   22: }
   23: 
   24: # ------------------------------------ Read httpd access.conf and get variables
   25: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
   26: 
   27: while ($configline=<CONFIG>) {
   28:     if ($configline =~ /PerlSetVar/) {
   29: 	my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
   30:         chomp($varvalue);
   31:         $perlvar{$varname}=$varvalue;
   32:     }
   33: }
   34: close(CONFIG);
   35: 
   36: my $dbh;
   37: # ------------------------------------- Make sure that database can be accessed
   38: {
   39:     unless (
   40: 	    $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
   41: 	    ) { 
   42: 	print "Cannot connect to database!\n";
   43: 	exit;
   44:     }
   45: }
   46: 
   47: # ------------------------------------------------------------- get .meta files
   48: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
   49: my @homeusers=grep
   50:           {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
   51:           grep {!/^\.\.?$/} readdir(RESOURCES);
   52: closedir RESOURCES;
   53: foreach my $user (@homeusers) {
   54:     &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
   55: }
   56: 
   57: # -- process each file to get metadata and put into search catalog SQL database
   58: foreach my $m (@metalist) {
   59:     my $ref=&metadata($m);
   60:     my $sth=$dbh->prepare('insert into metadata values ('.
   61: 			  delete($ref->{'title'}),
   62: 			  delete($ref->{'author'}).','.
   63: 			  delete($ref->{'subject'}).','.
   64: 			  delete($ref->{'url'}).','.
   65: 			  delete($ref->{'keywords'}).','.
   66: 			  delete($ref->{'version'}).','.
   67: 			  delete($ref->{'notes'}).','.
   68: 			  delete($ref->{'abstract'}).','.
   69: 			  delete($ref->{'mime'}).','.
   70: 			  delete($ref->{'language'}).','.
   71: 			  delete($ref->{'creationdate'}).','.
   72: 			  delete($ref->{'lastrevisiondate'}).','.
   73: 			  delete($ref->{'owner'}).','.
   74: 			  delete($ref->{'copyright'}));
   75:     $sth->execute();
   76: }
   77: 
   78: # ----------------------------------------------------------- Clean up database
   79: # Need to, perhaps, remove stale SQL database records.
   80: # ... not yet implemented
   81: 
   82: # --------------------------------------------------- Close database connection
   83: $dbh->disconnect;
   84: 
   85: # ---------------------------------------------------------------- Get metadata
   86: # significantly altered from subroutine present in lonnet
   87: sub metadata {
   88:     my ($uri,$what)=@_;
   89:     my %metacache;
   90:     $uri=&declutter($uri);
   91:     my $filename=$uri;
   92:     $uri=~s/\.meta$//;
   93:     $uri='';
   94:     unless ($metacache{$uri.'keys'}) {
   95:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
   96: 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
   97:         my $parser=HTML::TokeParser->new(\$metastring);
   98:         my $token;
   99:         while ($token=$parser->get_token) {
  100:            if ($token->[0] eq 'S') {
  101: 	      my $entry=$token->[1];
  102:               my $unikey=$entry;
  103:               if (defined($token->[2]->{'part'})) { 
  104:                  $unikey.='_'.$token->[2]->{'part'}; 
  105: 	      }
  106:               if (defined($token->[2]->{'name'})) { 
  107:                  $unikey.='_'.$token->[2]->{'name'}; 
  108: 	      }
  109:               if ($metacache{$uri.'keys'}) {
  110:                  $metacache{$uri.'keys'}.=','.$unikey;
  111:               } else {
  112:                  $metacache{$uri.'keys'}=$unikey;
  113: 	      }
  114:               map {
  115: 		  $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
  116:               } @{$token->[3]};
  117:               unless (
  118:                  $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
  119: 		      ) { $metacache{$uri.''.$unikey}=
  120: 			      $metacache{$uri.''.$unikey.'.default'};
  121: 		      }
  122:           }
  123:        }
  124:     }
  125:     return \%metacache;
  126: }
  127: 
  128: # ------------------------------------------------------------ Serves up a file
  129: # returns either the contents of the file or a -1
  130: sub getfile {
  131:   my $file=shift;
  132:   if (! -e $file ) { return -1; };
  133:   my $fh=IO::File->new($file);
  134:   my $a='';
  135:   while (<$fh>) { $a .=$_; }
  136:   return $a
  137: }
  138: 
  139: # ------------------------------------------------------------- Declutters URLs
  140: sub declutter {
  141:     my $thisfn=shift;
  142:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
  143:     $thisfn=~s/^\///;
  144:     $thisfn=~s/^res\///;
  145:     return $thisfn;
  146: }
  147: 
  148: # --------------------------------------- Is this the home server of an author?
  149: # (copied from lond, modification of the return value)
  150: sub ishome {
  151:     my $author=shift;
  152:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
  153:     my ($udom,$uname)=split(/\//,$author);
  154:     my $proname=propath($udom,$uname);
  155:     if (-e $proname) {
  156: 	return 1;
  157:     } else {
  158:         return 0;
  159:     }
  160: }
  161: 
  162: # -------------------------------------------- Return path to profile directory
  163: # (copied from lond)
  164: sub propath {
  165:     my ($udom,$uname)=@_;
  166:     $udom=~s/\W//g;
  167:     $uname=~s/\W//g;
  168:     my $subdir=$uname.'__';
  169:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
  170:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
  171:     return $proname;
  172: }