1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # searchcat.pl "Search Catalog" batch script
4: #
5: # $Id: searchcat.pl,v 1.70.2.1 2007/01/03 03:58:34 albertel Exp $
6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
13: # the Free Software Foundation; either version 2 of the License, or
14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
27: # http://www.lon-capa.org/
28: #
29: ###
30:
31: =pod
32:
33: =head1 NAME
34:
35: B<searchcat.pl> - put authoritative filesystem data into sql database.
36:
37: =head1 SYNOPSIS
38:
39: Ordinarily this script is to be called from a loncapa cron job
40: (CVS source location: F<loncapa/loncom/cron/loncapa>; typical
41: filesystem installation location: F</etc/cron.d/loncapa>).
42:
43: Here is the cron job entry.
44:
45: C<# Repopulate and refresh the metadata database used for the search catalog.>
46: C<10 1 * * 7 www /home/httpd/perl/searchcat.pl>
47:
48: This script only allows itself to be run as the user C<www>.
49:
50: =head1 DESCRIPTION
51:
52: This script goes through a loncapa resource directory and gathers metadata.
53: The metadata is entered into a SQL database.
54:
55: This script also does general database maintenance such as reformatting
56: the C<loncapa:metadata> table if it is deprecated.
57:
58: This script evaluates dynamic metadata from the authors'
59: F<nohist_resevaldata.db> database file in order to store it in MySQL.
60:
61: This script is playing an increasingly important role for a loncapa
62: library server. The proper operation of this script is critical for a smooth
63: and correct user experience.
64:
65: =cut
66:
67: use strict;
68: use DBI;
69: use lib '/home/httpd/lib/perl/';
70: use LONCAPA::lonmetadata;
71:
72: use Getopt::Long;
73: use IO::File;
74: use HTML::TokeParser;
75: use GDBM_File;
76: use POSIX qw(strftime mktime);
77:
78: use Apache::lonnet();
79:
80: use File::Find;
81:
82: #
83: # Set up configuration options
84: my ($simulate,$oneuser,$help,$verbose,$logfile,$debug);
85: GetOptions (
86: 'help' => \$help,
87: 'simulate' => \$simulate,
88: 'only=s' => \$oneuser,
89: 'verbose=s' => \$verbose,
90: 'debug' => \$debug,
91: );
92:
93: if ($help) {
94: print <<"ENDHELP";
95: $0
96: Rebuild and update the LON-CAPA metadata database.
97: Options:
98: -help Print this help
99: -simulate Do not modify the database.
100: -only=user Only compute for the given user. Implies -simulate
101: -verbose=val Sets logging level, val must be a number
102: -debug Turns on debugging output
103: ENDHELP
104: exit 0;
105: }
106:
107: if (! defined($debug)) {
108: $debug = 0;
109: }
110:
111: if (! defined($verbose)) {
112: $verbose = 0;
113: }
114:
115: if (defined($oneuser)) {
116: $simulate=1;
117: }
118:
119: ##
120: ## Use variables for table names so we can test this routine a little easier
121: my %oldnames = (
122: 'metadata' => 'metadata',
123: 'portfolio' => 'portfolio_metadata',
124: 'access' => 'portfolio_access',
125: 'addedfields' => 'portfolio_addedfields',
126: );
127:
128: my %newnames;
129: # new table names - append pid to have unique temporary tables
130: foreach my $key (keys(%oldnames)) {
131: $newnames{$key} = 'new'.$oldnames{$key}.$$;
132: }
133:
134: #
135: # Only run if machine is a library server
136: exit if ($Apache::lonnet::perlvar{'lonRole'} ne 'library');
137: #
138: # Make sure this process is running from user=www
139: my $wwwid=getpwnam('www');
140: if ($wwwid!=$<) {
141: my $emailto="$Apache::lonnet::perlvar{'lonAdmEMail'},$Apache::lonnet::perlvar{'lonSysEMail'}";
142: my $subj="LON: $Apache::lonnet::perlvar{'lonHostID'} User ID mismatch";
143: system("echo 'User ID mismatch. searchcat.pl must be run as user www.' |\
144: mail -s '$subj' $emailto > /dev/null");
145: exit 1;
146: }
147: #
148: # Let people know we are running
149: open(LOG,'>>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/logs/searchcat.log');
150: &log(0,'==== Searchcat Run '.localtime()."====");
151:
152:
153: if ($debug) {
154: &log(0,'simulating') if ($simulate);
155: &log(0,'only processing user '.$oneuser) if ($oneuser);
156: &log(0,'verbosity level = '.$verbose);
157: }
158: #
159: # Connect to database
160: my $dbh;
161: if (! ($dbh = DBI->connect("DBI:mysql:loncapa","www",$Apache::lonnet::perlvar{'lonSqlAccess'},
162: { RaiseError =>0,PrintError=>0}))) {
163: &log(0,"Cannot connect to database!");
164: die "MySQL Error: Cannot connect to database!\n";
165: }
166: # This can return an error and still be okay, so we do not bother checking.
167: # (perhaps it should be more robust and check for specific errors)
168: foreach my $key (keys(%newnames)) {
169: if ($newnames{$key} ne '') {
170: $dbh->do('DROP TABLE IF EXISTS '.$newnames{$key});
171: }
172: }
173:
174: #
175: # Create the new metadata and portfolio tables
176: foreach my $key (keys(%newnames)) {
177: if ($newnames{$key} ne '') {
178: my $request =
179: &LONCAPA::lonmetadata::create_metadata_storage($newnames{$key},$oldnames{$key});
180: $dbh->do($request);
181: if ($dbh->err) {
182: $dbh->disconnect();
183: &log(0,"MySQL Error Create: ".$dbh->errstr);
184: die $dbh->errstr;
185: }
186: }
187: }
188:
189: #
190: # find out which users we need to examine
191: my @domains = sort(&Apache::lonnet::current_machine_domains());
192: &log(9,'domains ="'.join('","',@domains).'"');
193:
194: foreach my $dom (@domains) {
195: &log(9,'domain = '.$dom);
196: opendir(RESOURCES,"$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom");
197: my @homeusers =
198: grep {
199: &ishome("$Apache::lonnet::perlvar{'lonDocRoot'}/res/$dom/$_");
200: } grep {
201: !/^\.\.?$/;
202: } readdir(RESOURCES);
203: closedir RESOURCES;
204: &log(5,'users = '.$dom.':'.join(',',@homeusers));
205: #
206: if ($oneuser) {
207: @homeusers=($oneuser);
208: }
209: #
210: # Loop through the users
211: foreach my $user (@homeusers) {
212: &log(0,"=== User: ".$user);
213: &process_dynamic_metadata($user,$dom);
214: #
215: # Use File::Find to get the files we need to read/modify
216: find(
217: {preprocess => \&only_meta_files,
218: #wanted => \&print_filename,
219: #wanted => \&log_metadata,
220: wanted => \&process_meta_file,
221: no_chdir => 1,
222: }, join('/',($Apache::lonnet::perlvar{'lonDocRoot'},'res',$dom,$user)) );
223: }
224: # Search for public portfolio files
225: my %portusers;
226: if ($oneuser) {
227: %portusers = (
228: $oneuser => '',
229: );
230: } else {
231: my $dir = $Apache::lonnet::perlvar{lonUsersDir}.'/'.$dom;
232: &descend_tree($dir,0,\%portusers);
233: }
234: foreach my $uname (keys(%portusers)) {
235: my $urlstart = '/uploaded/'.$dom.'/'.$uname;
236: my $pathstart = &propath($dom,$uname).'/userfiles';
237: my $is_course = &Apache::lonnet::is_course($dom,$uname);
238: my $curr_perm = &Apache::lonnet::get_portfile_permissions($dom,$uname);
239: my %access = &Apache::lonnet::get_access_controls($curr_perm);
240: foreach my $file (keys(%access)) {
241: my ($group,$url,$fullpath);
242: if ($is_course) {
243: ($group, my ($path)) = ($file =~ /^(\w+)(\/.+)$/);
244: $fullpath = $pathstart.'/groups/'.$group.'/portfolio'.$path;
245: $url = $urlstart.'/groups/'.$group.'/portfolio'.$path;
246: } else {
247: $fullpath = $pathstart.'/portfolio'.$file;
248: $url = $urlstart.'/portfolio'.$file;
249: }
250: if (ref($access{$file}) eq 'HASH') {
251: &process_portfolio_access_data($url,$access{$file});
252: }
253: &process_portfolio_metadata($url,$fullpath,$is_course,$dom,
254: $uname,$group);
255: }
256: }
257: }
258:
259: #
260: # Rename the tables
261: if (! $simulate) {
262: foreach my $key (keys(%oldnames)) {
263: if (($oldnames{$key} ne '') && ($newnames{$key} ne '')) {
264: $dbh->do('DROP TABLE IF EXISTS '.$oldnames{$key});
265: if (! $dbh->do('RENAME TABLE '.$newnames{$key}.' TO '.$oldnames{$key})) {
266: &log(0,"MySQL Error Rename: ".$dbh->errstr);
267: die $dbh->errstr;
268: } else {
269: &log(1,"MySQL table rename successful for $key.");
270: }
271: }
272: }
273: }
274: if (! $dbh->disconnect) {
275: &log(0,"MySQL Error Disconnect: ".$dbh->errstr);
276: die $dbh->errstr;
277: }
278: ##
279: ## Finished!
280: &log(0,"==== Searchcat completed ".localtime()." ====");
281: close(LOG);
282:
283: &write_type_count();
284: &write_copyright_count();
285:
286: exit 0;
287:
288: ##
289: ## Status logging routine. Inputs: $level, $message
290: ##
291: ## $level 0 should be used for normal output and error messages
292: ##
293: ## $message does not need to end with \n. In the case of errors
294: ## the message should contain as much information as possible to
295: ## help in diagnosing the problem.
296: ##
297: sub log {
298: my ($level,$message)=@_;
299: $level = 0 if (! defined($level));
300: if ($verbose >= $level) {
301: print LOG $message.$/;
302: }
303: }
304:
305: sub descend_tree {
306: my ($dir,$depth,$alldomusers) = @_;
307: if (-d $dir) {
308: opendir(DIR,$dir);
309: my @contents = grep(!/^\./,readdir(DIR));
310: closedir(DIR);
311: $depth ++;
312: foreach my $item (@contents) {
313: if ($depth < 4) {
314: &descend_tree($dir.'/'.$item,$depth,$alldomusers);
315: } else {
316: if (-e $dir.'/'.$item.'/file_permissions.db') {
317:
318: $$alldomusers{$item} = '';
319: }
320: }
321: }
322: }
323: }
324:
325: sub process_portfolio_access_data {
326: my ($url,$access_hash) = @_;
327: foreach my $key (keys(%{$access_hash})) {
328: my $acc_data;
329: $acc_data->{url} = $url;
330: $acc_data->{keynum} = $key;
331: my ($num,$scope,$end,$start) =
332: ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
333: $acc_data->{scope} = $scope;
334: if ($end != 0) {
335: $acc_data->{end} = &sqltime($end);
336: }
337: $acc_data->{start} = &sqltime($start);
338: if (! $simulate) {
339: my ($count,$err) =
340: &LONCAPA::lonmetadata::store_metadata($dbh,
341: $newnames{'access'},
342: 'portfolio_access',$acc_data);
343: if ($err) {
344: &log(0,"MySQL Error Insert: ".$err);
345: }
346: if ($count < 1) {
347: &log(0,"Unable to insert record into MySQL database for $url");
348: }
349: }
350: }
351: }
352:
353: sub process_portfolio_metadata {
354: my ($url,$fullpath,$is_course,$dom,$uname,$group) = @_;
355: my ($ref,$crs,$addedfields) = &portfolio_metadata($fullpath,$dom,$uname,
356: $group);
357: &getfiledates($ref,$fullpath);
358: if ($is_course) {
359: $ref->{'groupname'} = $group;
360: }
361: my %Data;
362: if (ref($ref) eq 'HASH') {
363: %Data = %{$ref};
364: }
365: %Data = (
366: %Data,
367: 'url'=>$url,
368: 'version'=>'current',
369: );
370: if (! $simulate) {
371: my ($count,$err) =
372: &LONCAPA::lonmetadata::store_metadata($dbh,
373: $newnames{'portfolio'},
374: 'portfolio_metadata',\%Data);
375: if ($err) {
376: &log(0,"MySQL Error Insert: ".$err);
377: }
378: if ($count < 1) {
379: &log(0,"Unable to insert record into MySQL portfolio_metadata database table for $url");
380: }
381: if (ref($addedfields) eq 'HASH') {
382: if (keys(%{$addedfields}) > 0) {
383: foreach my $key (keys(%{$addedfields})) {
384: my $added_data = {
385: 'url' => $url,
386: 'field' => $key,
387: 'value' => $addedfields->{$key},
388: 'courserestricted' => $crs,
389: };
390: ($count,$err) = &LONCAPA::lonmetadata::store_metadata($dbh,
391: $newnames{'addedfields'},
392: 'portfolio_addedfields',
393: $added_data);
394: if ($err) {
395: &log(0,"MySQL Error Insert: ".$err);
396: }
397: if ($count < 1) {
398: &log(0,"Unable to insert record into MySQL portfolio_addedfields database table for url = $url and field = $key");
399: }
400: }
401: }
402: }
403: }
404: return;
405: }
406:
407: ########################################################
408: ########################################################
409: ### ###
410: ### File::Find support routines ###
411: ### ###
412: ########################################################
413: ########################################################
414: ##
415: ## &only_meta_files
416: ##
417: ## Called by File::Find.
418: ## Takes a list of files/directories in and returns a list of files/directories
419: ## to search.
420: sub only_meta_files {
421: my @PossibleFiles = @_;
422: my @ChosenFiles;
423: foreach my $file (@PossibleFiles) {
424: if ( ($file =~ /\.meta$/ && # Ends in meta
425: $file !~ /\.\d+\.[^\.]+\.meta$/ # is not for a prior version
426: ) || (-d $File::Find::dir."/".$file )) { # directories are okay
427: # but we do not want /. or /..
428: push(@ChosenFiles,$file);
429: }
430: }
431: return @ChosenFiles;
432: }
433:
434: ##
435: ##
436: ## Debugging routines, use these for 'wanted' in the File::Find call
437: ##
438: sub print_filename {
439: my ($file) = $_;
440: my $fullfilename = $File::Find::name;
441: if ($debug) {
442: if (-d $file) {
443: &log(5," Got directory ".$fullfilename);
444: } else {
445: &log(5," Got file ".$fullfilename);
446: }
447: }
448: $_=$file;
449: }
450:
451: sub log_metadata {
452: my ($file) = $_;
453: my $fullfilename = $File::Find::name;
454: return if (-d $fullfilename); # No need to do anything here for directories
455: if ($debug) {
456: &log(6,$fullfilename);
457: my $ref = &metadata($fullfilename);
458: if (! defined($ref)) {
459: &log(6," No data");
460: return;
461: }
462: while (my($key,$value) = each(%$ref)) {
463: &log(6," ".$key." => ".$value);
464: }
465: &count_copyright($ref->{'copyright'});
466: }
467: $_=$file;
468: }
469:
470: ##
471: ## process_meta_file
472: ## Called by File::Find.
473: ## Only input is the filename in $_.
474: sub process_meta_file {
475: my ($file) = $_;
476: my $filename = $File::Find::name; # full filename
477: return if (-d $filename); # No need to do anything here for directories
478: #
479: &log(3,$filename) if ($debug);
480: #
481: my $ref = &metadata($filename);
482: #
483: # $url is the original file url, not the metadata file
484: my $target = $filename;
485: $target =~ s/\.meta$//;
486: my $url='/res/'.&declutter($target);
487: &log(3," ".$url) if ($debug);
488: #
489: # Ignore some files based on their metadata
490: if ($ref->{'obsolete'}) {
491: &log(3,"obsolete") if ($debug);
492: return;
493: }
494: &count_copyright($ref->{'copyright'});
495: if ($ref->{'copyright'} eq 'private') {
496: &log(3,"private") if ($debug);
497: return;
498: }
499: #
500: # Find the dynamic metadata
501: my %dyn;
502: if ($url=~ m:/default$:) {
503: $url=~ s:/default$:/:;
504: &log(3,"Skipping dynamic data") if ($debug);
505: } else {
506: &log(3,"Retrieving dynamic data") if ($debug);
507: %dyn=&get_dynamic_metadata($url);
508: &count_type($url);
509: }
510: &getfiledates($ref,$target);
511: #
512: my %Data = (
513: %$ref,
514: %dyn,
515: 'url'=>$url,
516: 'version'=>'current');
517: if (! $simulate) {
518: my ($count,$err) =
519: &LONCAPA::lonmetadata::store_metadata($dbh,$newnames{'metadata'},
520: 'metadata',\%Data);
521: if ($err) {
522: &log(0,"MySQL Error Insert: ".$err);
523: }
524: if ($count < 1) {
525: &log(0,"Unable to insert record into MySQL database for $url");
526: }
527: }
528: #
529: # Reset $_ before leaving
530: $_ = $file;
531: }
532:
533: ########################################################
534: ########################################################
535: ### ###
536: ### &metadata($uri) ###
537: ### Retrieve metadata for the given file ###
538: ### ###
539: ########################################################
540: ########################################################
541: sub metadata {
542: my ($uri) = @_;
543: my %metacache=();
544: $uri=&declutter($uri);
545: my $filename=$uri;
546: $uri=~s/\.meta$//;
547: $uri='';
548: if ($filename !~ /\.meta$/) {
549: $filename.='.meta';
550: }
551: my $metastring=&getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$filename);
552: return undef if (! defined($metastring));
553: my $parser=HTML::TokeParser->new(\$metastring);
554: my $token;
555: while ($token=$parser->get_token) {
556: if ($token->[0] eq 'S') {
557: my $entry=$token->[1];
558: my $unikey=$entry;
559: if (defined($token->[2]->{'part'})) {
560: $unikey.='_'.$token->[2]->{'part'};
561: }
562: if (defined($token->[2]->{'name'})) {
563: $unikey.='_'.$token->[2]->{'name'};
564: }
565: if ($metacache{$uri.'keys'}) {
566: $metacache{$uri.'keys'}.=','.$unikey;
567: } else {
568: $metacache{$uri.'keys'}=$unikey;
569: }
570: foreach ( @{$token->[3]}) {
571: $metacache{$uri.''.$unikey.'.'.$_}=$token->[2]->{$_};
572: }
573: if (! ($metacache{$uri.''.$unikey}=$parser->get_text('/'.$entry))){
574: $metacache{$uri.''.$unikey} =
575: $metacache{$uri.''.$unikey.'.default'};
576: }
577: } # End of ($token->[0] eq 'S')
578: }
579: return \%metacache;
580: }
581:
582: ###############################################################
583: ###############################################################
584: ### ###
585: ### &portfolio_metadata($filepath,$dom,$uname,$group) ###
586: ### Retrieve metadata for the given file ###
587: ### Returns array - ###
588: ### contains reference to metadatahash and ###
589: ### optional reference to addedfields hash ###
590: ### ###
591: ###############################################################
592: ###############################################################
593: sub portfolio_metadata {
594: my ($fullpath,$dom,$uname,$group)=@_;
595: my ($mime) = ( $fullpath=~/\.(\w+)$/ );
596: my %metacache=();
597: if ($fullpath !~ /\.meta$/) {
598: $fullpath .= '.meta';
599: }
600: my (@standard_fields,%addedfields);
601: my $colsref =
602: $LONCAPA::lonmetadata::Portfolio_metadata_table_description;
603: if (ref($colsref) eq 'ARRAY') {
604: my @columns = @{$colsref};
605: foreach my $coldata (@columns) {
606: push(@standard_fields,$coldata->{'name'});
607: }
608: }
609: my $metastring=&getfile($fullpath);
610: if (! defined($metastring)) {
611: $metacache{'keys'}= 'owner,domain,mime';
612: $metacache{'owner'} = $uname.':'.$dom;
613: $metacache{'domain'} = $dom;
614: $metacache{'mime'} = $mime;
615: if (defined($group)) {
616: $metacache{'keys'} .= ',courserestricted';
617: $metacache{'courserestricted'} = 'course.'.$dom.'_'.$uname;
618: }
619: } else {
620: my $parser=HTML::TokeParser->new(\$metastring);
621: my $token;
622: while ($token=$parser->get_token) {
623: if ($token->[0] eq 'S') {
624: my $entry=$token->[1];
625: if ($metacache{'keys'}) {
626: $metacache{'keys'}.=','.$entry;
627: } else {
628: $metacache{'keys'}=$entry;
629: }
630: my $value = $parser->get_text('/'.$entry);
631: if (!grep(/^\Q$entry\E$/,@standard_fields)) {
632: my $clean_value = lc($value);
633: $clean_value =~ s/\s/_/g;
634: if ($clean_value ne $entry) {
635: if (defined($addedfields{$entry})) {
636: $addedfields{$entry} .=','.$value;
637: } else {
638: $addedfields{$entry} = $value;
639: }
640: }
641: } else {
642: $metacache{$entry} = $value;
643: }
644: }
645: } # End of ($token->[0] eq 'S')
646: }
647: if (keys(%addedfields) > 0) {
648: foreach my $key (sort keys(%addedfields)) {
649: $metacache{'addedfieldnames'} .= $key.',';
650: $metacache{'addedfieldvalues'} .= $addedfields{$key}.'&&&';
651: }
652: $metacache{'addedfieldnames'} =~ s/,$//;
653: $metacache{'addedfieldvalues'} =~ s/\&\&\&$//;
654: if ($metacache{'keys'}) {
655: $metacache{'keys'}.=',addedfieldnames';
656: } else {
657: $metacache{'keys'}='addedfieldnames';
658: }
659: $metacache{'keys'}.=',addedfieldvalues';
660: }
661: return (\%metacache,$metacache{'courserestricted'},\%addedfields);
662: }
663:
664: ##
665: ## &getfile($filename)
666: ## Slurps up an entire file into a scalar.
667: ## Returns undef if the file does not exist
668: sub getfile {
669: my $file = shift();
670: if (! -e $file ) {
671: return undef;
672: }
673: my $fh=IO::File->new($file);
674: my $contents = '';
675: while (<$fh>) {
676: $contents .= $_;
677: }
678: return $contents;
679: }
680:
681: ##
682: ## &getfiledates()
683: ## Converts creationdate and modifieddates to SQL format
684: ## Applies stat() to file to retrieve dates if missing
685: sub getfiledates {
686: my ($ref,$target) = @_;
687: if (! defined($ref->{'creationdate'}) ||
688: $ref->{'creationdate'} =~ /^\s*$/) {
689: $ref->{'creationdate'} = (stat($target))[9];
690: }
691: if (! defined($ref->{'lastrevisiondate'}) ||
692: $ref->{'lastrevisiondate'} =~ /^\s*$/) {
693: $ref->{'lastrevisiondate'} = (stat($target))[9];
694: }
695: $ref->{'creationdate'} = &sqltime($ref->{'creationdate'});
696: $ref->{'lastrevisiondate'} = &sqltime($ref->{'lastrevisiondate'});
697: }
698:
699: ########################################################
700: ########################################################
701: ### ###
702: ### Dynamic Metadata ###
703: ### ###
704: ########################################################
705: ########################################################
706: ##
707: ## Dynamic metadata description (incomplete)
708: ##
709: ## For a full description of all fields,
710: ## see LONCAPA::lonmetadata
711: ##
712: ## Field Type
713: ##-----------------------------------------------------------
714: ## count integer
715: ## course integer
716: ## course_list comma separated list of course ids
717: ## avetries real
718: ## avetries_list comma separated list of real numbers
719: ## stdno real
720: ## stdno_list comma separated list of real numbers
721: ## usage integer
722: ## usage_list comma separated list of resources
723: ## goto scalar
724: ## goto_list comma separated list of resources
725: ## comefrom scalar
726: ## comefrom_list comma separated list of resources
727: ## difficulty real
728: ## difficulty_list comma separated list of real numbers
729: ## sequsage scalar
730: ## sequsage_list comma separated list of resources
731: ## clear real
732: ## technical real
733: ## correct real
734: ## helpful real
735: ## depth real
736: ## comments html of all the comments made
737: ##
738: {
739:
740: my %DynamicData;
741: my %Counts;
742:
743: sub process_dynamic_metadata {
744: my ($user,$dom) = @_;
745: undef(%DynamicData);
746: undef(%Counts);
747: #
748: my $prodir = &propath($dom,$user);
749: #
750: # Read in the dynamic metadata
751: my %evaldata;
752: if (! tie(%evaldata,'GDBM_File',
753: $prodir.'/nohist_resevaldata.db',&GDBM_READER(),0640)) {
754: return 0;
755: }
756: #
757: %DynamicData = &LONCAPA::lonmetadata::process_reseval_data(\%evaldata);
758: untie(%evaldata);
759: $DynamicData{'domain'} = $dom;
760: #print('user = '.$user.' domain = '.$dom.$/);
761: #
762: # Read in the access count data
763: &log(7,'Reading access count data') if ($debug);
764: my %countdata;
765: if (! tie(%countdata,'GDBM_File',
766: $prodir.'/nohist_accesscount.db',&GDBM_READER(),0640)) {
767: return 0;
768: }
769: while (my ($key,$count) = each(%countdata)) {
770: next if ($key !~ /^$dom/);
771: $key = &unescape($key);
772: &log(8,' Count '.$key.' = '.$count) if ($debug);
773: $Counts{$key}=$count;
774: }
775: untie(%countdata);
776: if ($debug) {
777: &log(7,scalar(keys(%Counts)).
778: " Counts read for ".$user."@".$dom);
779: &log(7,scalar(keys(%DynamicData)).
780: " Dynamic metadata read for ".$user."@".$dom);
781: }
782: #
783: return 1;
784: }
785:
786: sub get_dynamic_metadata {
787: my ($url) = @_;
788: $url =~ s:^/res/::;
789: my %data = &LONCAPA::lonmetadata::process_dynamic_metadata($url,
790: \%DynamicData);
791: # find the count
792: $data{'count'} = $Counts{$url};
793: #
794: # Log the dynamic metadata
795: if ($debug) {
796: while (my($k,$v)=each(%data)) {
797: &log(8," ".$k." => ".$v);
798: }
799: }
800: return %data;
801: }
802:
803: } # End of %DynamicData and %Counts scope
804:
805: ########################################################
806: ########################################################
807: ### ###
808: ### Counts ###
809: ### ###
810: ########################################################
811: ########################################################
812: {
813:
814: my %countext;
815:
816: sub count_type {
817: my $file=shift;
818: $file=~/\.(\w+)$/;
819: my $ext=lc($1);
820: $countext{$ext}++;
821: }
822:
823: sub write_type_count {
824: open(RESCOUNT,'>/home/httpd/html/lon-status/rescount.txt');
825: while (my ($extension,$count) = each(%countext)) {
826: print RESCOUNT $extension.'='.$count.'&';
827: }
828: print RESCOUNT 'time='.time."\n";
829: close(RESCOUNT);
830: }
831:
832: } # end of scope for %countext
833:
834: {
835:
836: my %copyrights;
837:
838: sub count_copyright {
839: $copyrights{@_[0]}++;
840: }
841:
842: sub write_copyright_count {
843: open(COPYCOUNT,'>/home/httpd/html/lon-status/copyrightcount.txt');
844: while (my ($copyright,$count) = each(%copyrights)) {
845: print COPYCOUNT $copyright.'='.$count.'&';
846: }
847: print COPYCOUNT 'time='.time."\n";
848: close(COPYCOUNT);
849: }
850:
851: } # end of scope for %copyrights
852:
853: ########################################################
854: ########################################################
855: ### ###
856: ### Miscellanous Utility Routines ###
857: ### ###
858: ########################################################
859: ########################################################
860: ##
861: ## &ishome($username)
862: ## Returns 1 if $username is a LON-CAPA author, 0 otherwise
863: ## (copied from lond, modification of the return value)
864: sub ishome {
865: my $author=shift;
866: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
867: my ($udom,$uname)=split(/\//,$author);
868: my $proname=propath($udom,$uname);
869: if (-e $proname) {
870: return 1;
871: } else {
872: return 0;
873: }
874: }
875:
876: ##
877: ## &propath($udom,$uname)
878: ## Returns the path to the users LON-CAPA directory
879: ## (copied from lond)
880: sub propath {
881: my ($udom,$uname)=@_;
882: $udom=~s/\W//g;
883: $uname=~s/\W//g;
884: my $subdir=$uname.'__';
885: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
886: my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
887: return $proname;
888: }
889:
890: ##
891: ## &sqltime($timestamp)
892: ##
893: ## Convert perl $timestamp to MySQL time. MySQL expects YYYY-MM-DD HH:MM:SS
894: ##
895: sub sqltime {
896: my ($time) = @_;
897: my $mysqltime;
898: if ($time =~
899: /(\d+)-(\d+)-(\d+) # YYYY-MM-DD
900: \s # a space
901: (\d+):(\d+):(\d+) # HH:MM::SS
902: /x ) {
903: # Some of the .meta files have the time in mysql
904: # format already, so just make sure they are 0 padded and
905: # pass them back.
906: $mysqltime = sprintf('%04d-%02d-%02d %02d:%02d:%02d',
907: $1,$2,$3,$4,$5,$6);
908: } elsif ($time =~ /^\d+$/) {
909: my @TimeData = gmtime($time);
910: # Alter the month to be 1-12 instead of 0-11
911: $TimeData[4]++;
912: # Alter the year to be from 0 instead of from 1900
913: $TimeData[5]+=1900;
914: $mysqltime = sprintf('%04d-%02d-%02d %02d:%02d:%02d',
915: @TimeData[5,4,3,2,1,0]);
916: } elsif (! defined($time) || $time == 0) {
917: $mysqltime = 0;
918: } else {
919: &log(0," sqltime:Unable to decode time ".$time);
920: $mysqltime = 0;
921: }
922: return $mysqltime;
923: }
924:
925: ##
926: ## &declutter($filename)
927: ## Given a filename, returns a url for the filename.
928: sub declutter {
929: my $thisfn=shift;
930: $thisfn=~s/^$Apache::lonnet::perlvar{'lonDocRoot'}//;
931: $thisfn=~s/^\///;
932: $thisfn=~s/^res\///;
933: return $thisfn;
934: }
935:
936: ##
937: ## Escape / Unescape special characters
938: sub unescape {
939: my $str=shift;
940: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
941: return $str;
942: }
943:
944: sub escape {
945: my $str=shift;
946: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
947: return $str;
948: }
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