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