Annotation of loncom/metadata_database/searchcat.pl, revision 1.12
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 IO::File;
12: use HTML::TokeParser;
1.6 harris41 13: use DBI;
1.1 harris41 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 _ &&
1.10 harris41 21: /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
1.1 harris41 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:
1.3 harris41 37: my $dbh;
1.1 harris41 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
1.2 harris41 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: }
1.1 harris41 57:
58: # -- process each file to get metadata and put into search catalog SQL database
1.9 harris41 59: # Also, check to see if already there.
1.11 harris41 60: # I could just delete (without searching first), but this works for now.
1.1 harris41 61: foreach my $m (@metalist) {
62: my $ref=&metadata($m);
1.11 harris41 63: my $m2='/res/'.&declutter($m);
1.12 ! harris41 64: $m2=~s/\.meta$//;
! 65: my $q2="select * from metadata where url like binary '$m2'";
1.9 harris41 66: my $sth = $dbh->prepare($q2);
67: $sth->execute();
68: my $r1=$sth->fetchall_arrayref;
69: if (@$r1) {
1.12 ! harris41 70: $sth=$dbh->prepare("delete from metadata where url like binary '$m2'");
1.9 harris41 71: $sth->execute();
72: }
73: $sth=$dbh->prepare('insert into metadata values ('.
1.8 harris41 74: '"'.delete($ref->{'title'}).'"'.','.
75: '"'.delete($ref->{'author'}).'"'.','.
76: '"'.delete($ref->{'subject'}).'"'.','.
1.12 ! harris41 77: '"'.$m2.'"'.','.
1.8 harris41 78: '"'.delete($ref->{'keywords'}).'"'.','.
1.9 harris41 79: '"'.'current'.'"'.','.
1.8 harris41 80: '"'.delete($ref->{'notes'}).'"'.','.
81: '"'.delete($ref->{'abstract'}).'"'.','.
82: '"'.delete($ref->{'mime'}).'"'.','.
83: '"'.delete($ref->{'language'}).'"'.','.
84: '"'.delete($ref->{'creationdate'}).'"'.','.
85: '"'.delete($ref->{'lastrevisiondate'}).'"'.','.
86: '"'.delete($ref->{'owner'}).'"'.','.
87: '"'.delete($ref->{'copyright'}).'"'.')');
1.1 harris41 88: $sth->execute();
89: }
90:
91: # ----------------------------------------------------------- Clean up database
92: # Need to, perhaps, remove stale SQL database records.
93: # ... not yet implemented
94:
95: # --------------------------------------------------- Close database connection
96: $dbh->disconnect;
97:
98: # ---------------------------------------------------------------- Get metadata
99: # significantly altered from subroutine present in lonnet
100: sub metadata {
101: my ($uri,$what)=@_;
102: my %metacache;
103: $uri=&declutter($uri);
104: my $filename=$uri;
105: $uri=~s/\.meta$//;
106: $uri='';
107: unless ($metacache{$uri.'keys'}) {
108: unless ($filename=~/\.meta$/) { $filename.='.meta'; }
109: my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
110: my $parser=HTML::TokeParser->new(\$metastring);
111: my $token;
112: while ($token=$parser->get_token) {
113: if ($token->[0] eq 'S') {
114: my $entry=$token->[1];
115: my $unikey=$entry;
116: if (defined($token->[2]->{'part'})) {
117: $unikey.='_'.$token->[2]->{'part'};
118: }
119: if (defined($token->[2]->{'name'})) {
120: $unikey.='_'.$token->[2]->{'name'};
121: }
122: if ($metacache{$uri.'keys'}) {
123: $metacache{$uri.'keys'}.=','.$unikey;
124: } else {
125: $metacache{$uri.'keys'}=$unikey;
126: }
127: map {
128: $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
129: } @{$token->[3]};
130: unless (
131: $metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry)
132: ) { $metacache{$uri.''.$unikey}=
133: $metacache{$uri.''.$unikey.'.default'};
134: }
135: }
136: }
137: }
138: return \%metacache;
139: }
140:
141: # ------------------------------------------------------------ Serves up a file
142: # returns either the contents of the file or a -1
143: sub getfile {
144: my $file=shift;
145: if (! -e $file ) { return -1; };
146: my $fh=IO::File->new($file);
147: my $a='';
148: while (<$fh>) { $a .=$_; }
149: return $a
150: }
151:
152: # ------------------------------------------------------------- Declutters URLs
153: sub declutter {
154: my $thisfn=shift;
155: $thisfn=~s/^$perlvar{'lonDocRoot'}//;
156: $thisfn=~s/^\///;
157: $thisfn=~s/^res\///;
158: return $thisfn;
159: }
1.2 harris41 160:
161: # --------------------------------------- Is this the home server of an author?
162: # (copied from lond, modification of the return value)
163: sub ishome {
164: my $author=shift;
165: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
166: my ($udom,$uname)=split(/\//,$author);
167: my $proname=propath($udom,$uname);
168: if (-e $proname) {
169: return 1;
170: } else {
171: return 0;
172: }
173: }
174:
175: # -------------------------------------------- Return path to profile directory
176: # (copied from lond)
177: sub propath {
178: my ($udom,$uname)=@_;
179: $udom=~s/\W//g;
180: $uname=~s/\W//g;
181: my $subdir=$uname.'__';
182: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
183: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
184: return $proname;
185: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to searchcat.pl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / metadata_database