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: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
51: my @homeusers=grep
52: {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
53: grep {!/^\.\.?$/} readdir(RESOURCES);
54: closedir RESOURCES;
55: foreach my $user (@homeusers) {
56: &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
57: }
58:
59: # -- process each file to get metadata and put into search catalog SQL database
60: foreach my $m (@metalist) {
61: my $ref=&metadata($m);
62: my $sth=$dbh->prepare('insert into metadata values ('.
63: delete($ref->{'title'}),
64: delete($ref->{'author'}).','.
65: delete($ref->{'subject'}).','.
66: delete($ref->{'url'}).','.
67: delete($ref->{'keywords'}).','.
68: delete($ref->{'version'}).','.
69: delete($ref->{'notes'}).','.
70: delete($ref->{'abstract'}).','.
71: delete($ref->{'mime'}).','.
72: delete($ref->{'language'}).','.
73: delete($ref->{'creationdate'}).','.
74: delete($ref->{'lastrevisiondate'}).','.
75: delete($ref->{'owner'}).','.
76: delete($ref->{'copyright'}).
77: ')';
78: $sth->execute();
79: }
80:
81: # ----------------------------------------------------------- Clean up database
82: # Need to, perhaps, remove stale SQL database records.
83: # ... not yet implemented
84:
85: # --------------------------------------------------- Close database connection
86: $dbh->disconnect;
87:
88: # ---------------------------------------------------------------- Get metadata
89: # significantly altered from subroutine present in lonnet
90: sub metadata {
91: my ($uri,$what)=@_;
92: my %metacache;
93: $uri=&declutter($uri);
94: my $filename=$uri;
95: $uri=~s/\.meta$//;
96: $uri='';
97: unless ($metacache{$uri.'keys'}) {
98: unless ($filename=~/\.meta$/) { $filename.='.meta'; }
99: my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
100: my $parser=HTML::TokeParser->new(\$metastring);
101: my $token;
102: while ($token=$parser->get_token) {
103: if ($token->[0] eq 'S') {
104: my $entry=$token->[1];
105: my $unikey=$entry;
106: if (defined($token->[2]->{'part'})) {
107: $unikey.='_'.$token->[2]->{'part'};
108: }
109: if (defined($token->[2]->{'name'})) {
110: $unikey.='_'.$token->[2]->{'name'};
111: }
112: if ($metacache{$uri.'keys'}) {
113: $metacache{$uri.'keys'}.=','.$unikey;
114: } else {
115: $metacache{$uri.'keys'}=$unikey;
116: }
117: map {
118: $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
119: } @{$token->[3]};
120: unless (
121: $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
122: ) { $metacache{$uri.''.$unikey}=
123: $metacache{$uri.''.$unikey.'.default'};
124: }
125: }
126: }
127: }
128: return \%metacache;
129: }
130:
131: # ------------------------------------------------------------ Serves up a file
132: # returns either the contents of the file or a -1
133: sub getfile {
134: my $file=shift;
135: if (! -e $file ) { return -1; };
136: my $fh=IO::File->new($file);
137: my $a='';
138: while (<$fh>) { $a .=$_; }
139: return $a
140: }
141:
142: # ------------------------------------------------------------- Declutters URLs
143: sub declutter {
144: my $thisfn=shift;
145: $thisfn=~s/^$perlvar{'lonDocRoot'}//;
146: $thisfn=~s/^\///;
147: $thisfn=~s/^res\///;
148: return $thisfn;
149: }
150:
151: # --------------------------------------- Is this the home server of an author?
152: # (copied from lond, modification of the return value)
153: sub ishome {
154: my $author=shift;
155: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
156: my ($udom,$uname)=split(/\//,$author);
157: my $proname=propath($udom,$uname);
158: if (-e $proname) {
159: return 1;
160: } else {
161: return 0;
162: }
163: }
164:
165: # -------------------------------------------- Return path to profile directory
166: # (copied from lond)
167: sub propath {
168: my ($udom,$uname)=@_;
169: $udom=~s/\W//g;
170: $uname=~s/\W//g;
171: my $subdir=$uname.'__';
172: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
173: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
174: return $proname;
175: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>