Return to searchcat.pl CVS log

Up to [LON-CAPA] / loncom / metadata_database

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

1.1     ! harris41    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 strict;
        !            12: 
        !            13: use IO::File;
        !            14: use HTML::TokeParser;
        !            15: 
        !            16: my @metalist;
        !            17: # ----------------- Code to enable 'find' subroutine listing of the .meta files
        !            18: require "find.pl";
        !            19: sub wanted {
        !            20:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
        !            21:     -f _ &&
        !            22:     /^.*\.meta$/ &&
        !            23:     push(@metalist,"$dir/$_");
        !            24: }
        !            25: 
        !            26: # ------------------------------------ Read httpd access.conf and get variables
        !            27: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
        !            28: 
        !            29: while ($configline=<CONFIG>) {
        !            30:     if ($configline =~ /PerlSetVar/) {
        !            31: 	my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
        !            32:         chomp($varvalue);
        !            33:         $perlvar{$varname}=$varvalue;
        !            34:     }
        !            35: }
        !            36: close(CONFIG);
        !            37: 
        !            38: # ------------------------------------- Make sure that database can be accessed
        !            39: {
        !            40:     my $dbh;
        !            41:     unless (
        !            42: 	    $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
        !            43: 	    ) { 
        !            44: 	print "Cannot connect to database!\n";
        !            45: 	exit;
        !            46:     }
        !            47: }
        !            48: 
        !            49: # ------------------------------------------------------------- get .meta files
        !            50: # need to actually loop over existing users here.. will fix soon
        !            51: &find("$perlvar{'lonDocRoot'}/res");
        !            52: 
        !            53: # -- process each file to get metadata and put into search catalog SQL database
        !            54: foreach my $m (@metalist) {
        !            55:     my $ref=&metadata($m);
        !            56:     my $sth=$dbh->prepare('insert into metadata values ('.
        !            57: 			  delete($ref->{'title'}),
        !            58: 			  delete($ref->{'author'}).','.
        !            59: 			  delete($ref->{'subject'}).','.
        !            60: 			  delete($ref->{'url'}).','.
        !            61: 			  delete($ref->{'keywords'}).','.
        !            62: 			  delete($ref->{'version'}).','.
        !            63: 			  delete($ref->{'notes'}).','.
        !            64: 			  delete($ref->{'abstract'}).','.
        !            65: 			  delete($ref->{'mime'}).','.
        !            66: 			  delete($ref->{'language'}).','.
        !            67: 			  delete($ref->{'creationdate'}).','.
        !            68: 			  delete($ref->{'lastrevisiondate'}).','.
        !            69: 			  delete($ref->{'owner'}).','.
        !            70: 			  delete($ref->{'copyright'}).
        !            71: 			  ')';
        !            72:     $sth->execute();
        !            73: }
        !            74: 
        !            75: # ----------------------------------------------------------- Clean up database
        !            76: # Need to, perhaps, remove stale SQL database records.
        !            77: # ... not yet implemented
        !            78: 
        !            79: # --------------------------------------------------- Close database connection
        !            80: $dbh->disconnect;
        !            81: 
        !            82: # ---------------------------------------------------------------- Get metadata
        !            83: # significantly altered from subroutine present in lonnet
        !            84: sub metadata {
        !            85:     my ($uri,$what)=@_;
        !            86:     my %metacache;
        !            87:     $uri=&declutter($uri);
        !            88:     my $filename=$uri;
        !            89:     $uri=~s/\.meta$//;
        !            90:     $uri='';
        !            91:     unless ($metacache{$uri.'keys'}) {
        !            92:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
        !            93: 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
        !            94:         my $parser=HTML::TokeParser->new(\$metastring);
        !            95:         my $token;
        !            96:         while ($token=$parser->get_token) {
        !            97:            if ($token->[0] eq 'S') {
        !            98: 	      my $entry=$token->[1];
        !            99:               my $unikey=$entry;
        !           100:               if (defined($token->[2]->{'part'})) { 
        !           101:                  $unikey.='_'.$token->[2]->{'part'}; 
        !           102: 	      }
        !           103:               if (defined($token->[2]->{'name'})) { 
        !           104:                  $unikey.='_'.$token->[2]->{'name'}; 
        !           105: 	      }
        !           106:               if ($metacache{$uri.'keys'}) {
        !           107:                  $metacache{$uri.'keys'}.=','.$unikey;
        !           108:               } else {
        !           109:                  $metacache{$uri.'keys'}=$unikey;
        !           110: 	      }
        !           111:               map {
        !           112: 		  $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
        !           113:               } @{$token->[3]};
        !           114:               unless (
        !           115:                  $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
        !           116: 		      ) { $metacache{$uri.''.$unikey}=
        !           117: 			      $metacache{$uri.''.$unikey.'.default'};
        !           118: 		      }
        !           119:           }
        !           120:        }
        !           121:     }
        !           122:     return \%metacache;
        !           123: }
        !           124: 
        !           125: # ------------------------------------------------------------ Serves up a file
        !           126: # returns either the contents of the file or a -1
        !           127: sub getfile {
        !           128:   my $file=shift;
        !           129:   if (! -e $file ) { return -1; };
        !           130:   my $fh=IO::File->new($file);
        !           131:   my $a='';
        !           132:   while (<$fh>) { $a .=$_; }
        !           133:   return $a
        !           134: }
        !           135: 
        !           136: # ------------------------------------------------------------- Declutters URLs
        !           137: sub declutter {
        !           138:     my $thisfn=shift;
        !           139:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
        !           140:     $thisfn=~s/^\///;
        !           141:     $thisfn=~s/^res\///;
        !           142:     return $thisfn;
        !           143: }