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