Annotation of loncom/publisher/lonpublisher.pm, revision 1.11
1.1 www 1: # The LearningOnline Network with CAPA
2: # Publication Handler
3: #
4: # (TeX Content Handler
5: #
6: # 05/29/00,05/30,10/11 Gerd Kortemeyer)
7: #
1.10 www 8: # 11/28,11/29,11/30,12/01,12/02 Gerd Kortemeyer
1.1 www 9:
10: package Apache::lonpublisher;
11:
12: use strict;
13: use Apache::File;
1.2 www 14: use Apache::Constants qw(:common :http :methods);
15: use HTML::TokeParser;
1.4 www 16: use Apache::lonxml;
1.10 www 17: use Apache::structuretags;
18: use Apache::response;
1.2 www 19:
1.3 www 20: my %addid;
1.5 www 21: my %nokey;
1.9 www 22: my %language;
1.10 www 23: my %cprtag;
24:
1.7 www 25: my %metadatafields;
26: my %metadatakeys;
27:
28: sub metaeval {
29: my $metastring=shift;
30:
31: my $parser=HTML::TokeParser->new(\$metastring);
32: my $token;
33: while ($token=$parser->get_token) {
34: if ($token->[0] eq 'S') {
35: my $entry=$token->[1];
36: my $unikey=$entry;
37: if (defined($token->[2]->{'part'})) {
38: $unikey.='_'.$token->[2]->{'part'};
39: }
40: if (defined($token->[2]->{'name'})) {
41: $unikey.='_'.$token->[2]->{'name'};
42: }
43: map {
44: $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_};
45: if ($metadatakeys{$unikey}) {
46: $metadatakeys{$unikey}.=','.$_;
47: } else {
48: $metadatakeys{$unikey}=$_;
49: }
50: } @{$token->[3]};
51: if ($metadatafields{$unikey}) {
1.8 www 52: my $newentry=$parser->get_text('/'.$entry);
53: unless ($metadatafields{$unikey}=~/$newentry/) {
54: $metadatafields{$unikey}.=', '.$newentry;
55: }
1.7 www 56: } else {
57: $metadatafields{$unikey}=$parser->get_text('/'.$entry);
58: }
59: }
60: }
61: }
62:
63: sub metaread {
64: my ($logfile,$fn)=@_;
65: unless (-e $fn) {
66: print $logfile 'No file '.$fn."\n";
67: return '<br><b>No file:</b> <tt>'.$fn.'</tt>';
68: }
69: print $logfile 'Processing '.$fn."\n";
70: my $metastring;
71: {
72: my $metafh=Apache::File->new($fn);
73: $metastring=join('',<$metafh>);
74: }
75: &metaeval($metastring);
76: return '<br><b>Processed file:</b> <tt>'.$fn.'</tt>';
77: }
78:
1.8 www 79: sub textfield {
1.10 www 80: my ($title,$name,$value)=@_;
1.8 www 81: return "\n<p><b>$title:</b><br>".
1.11 ! www 82: '<input type=text name="'.$name.'" size=80 value="'.$value.'">';
! 83: }
! 84:
! 85: sub hiddenfield {
! 86: my ($name,$value)=@_;
! 87: return "\n".'<input type=hidden name="'.$name.'" value="'.$value.'">';
1.8 www 88: }
89:
1.9 www 90: sub selectbox {
1.10 www 91: my ($title,$name,$value,%options)=@_;
92: my $selout="\n<p><b>$title:</b><br>".'<select name="'.$name.'">';
93: map {
94: $selout.='<option value="'.$_.'"';
95: if ($_ eq $value) { $selout.=' selected'; }
96: $selout.='>'.$options{$_}.'</option>';
97: } sort keys %options;
98: return $selout.'</select>';
1.9 www 99: }
100:
1.2 www 101: sub publish {
1.4 www 102:
1.2 www 103: my ($source,$target,$style)=@_;
104: my $logfile;
1.4 www 105: my $scrout='';
106:
1.2 www 107: unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
1.7 www 108: return
109: '<font color=red>No write permission to user directory, FAIL</font>';
1.2 www 110: }
111: print $logfile
1.11 ! www 112: "\n\n================= Publish ".localtime()." Phase One ================\n";
1.2 www 113:
1.3 www 114: if (($style eq 'ssi') || ($style eq 'rat')) {
115: # ------------------------------------------------------- This needs processing
1.4 www 116:
117: # ----------------------------------------------------------------- Backup Copy
1.3 www 118: my $copyfile=$source.'.save';
119: {
120: my $org=Apache::File->new($source);
121: my $cop=Apache::File->new('>'.$copyfile);
122: while (my $line=<$org>) { print $cop $line; }
123: }
124: if (-e $copyfile) {
125: print $logfile "Copied original file to ".$copyfile."\n";
126: } else {
1.4 www 127: print $logfile "Unable to write backup ".$copyfile."\n";
1.7 www 128: return "<font color=red>Failed to write backup copy, FAIL</font>";
1.3 www 129: }
1.4 www 130: # ------------------------------------------------------------- IDs and indices
131:
132: my $maxindex=10;
133: my $maxid=10;
134: my $content='';
135: my $needsfixup=0;
136:
137: {
138: my $org=Apache::File->new($source);
139: $content=join('',<$org>);
140: }
141: {
142: my $parser=HTML::TokeParser->new(\$content);
143: my $token;
144: while ($token=$parser->get_token) {
145: if ($token->[0] eq 'S') {
146: my $counter;
147: if ($counter=$addid{$token->[1]}) {
148: if ($counter eq 'id') {
149: if (defined($token->[2]->{'id'})) {
150: $maxid=
151: ($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
152: } else {
153: $needsfixup=1;
154: }
155: } else {
156: if (defined($token->[2]->{'index'})) {
157: $maxindex=
158: ($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
159: } else {
160: $needsfixup=1;
161: }
162: }
163: }
164: }
165: }
166: }
167: if ($needsfixup) {
168: print $logfile "Needs ID and/or index fixup\n".
169: "Max ID : $maxid (min 10)\n".
170: "Max Index: $maxindex (min 10)\n";
171:
172: my $outstring='';
173: my $parser=HTML::TokeParser->new(\$content);
174: my $token;
175: while ($token=$parser->get_token) {
176: if ($token->[0] eq 'S') {
177: my $counter;
178: if ($counter=$addid{$token->[1]}) {
179: if ($counter eq 'id') {
180: if (defined($token->[2]->{'id'})) {
181: $outstring.=$token->[4];
182: } else {
183: $maxid++;
184: my $thisid=' id="'.$maxid.'"';
185: my $fixup=$token->[4];
186: $fixup=~s/(\<\w+)/$1$thisid/;
187: $outstring.=$fixup;
188: print $logfile 'ID: '.$fixup."\n";
189: }
190: } else {
191: if (defined($token->[2]->{'index'})) {
192: $outstring.=$token->[4];
193: } else {
194: $maxindex++;
195: my $thisindex=' index="'.$maxindex.'"';
196: my $fixup=$token->[4];
197: $fixup=~s/(\<\w+)/$1$thisindex/;
198: $outstring.=$fixup;
199: print $logfile 'Index: '.$fixup."\n";
200: }
201: }
202: } else {
203: $outstring.=$token->[4];
204: }
205: } elsif ($token->[0] eq 'E') {
206: $outstring.=$token->[2];
207: } else {
208: $outstring.=$token->[1];
209: }
210: }
211: {
212: my $org;
213: unless ($org=Apache::File->new('>'.$source)) {
214: print $logfile "No write permit to $source\n";
1.7 www 215: return
216: "<font color=red>No write permission to $source, FAIL</font>";
1.4 www 217: }
218: print $org $outstring;
219: }
220: $content=$outstring;
221: print $logfile "End of ID and/or index fixup\n".
222: "Max ID : $maxid (min 10)\n".
223: "Max Index: $maxindex (min 10)\n";
224: } else {
225: print $logfile "Does not need ID and/or index fixup\n";
226: }
1.7 www 227:
228: # --------------------------------------------- Initial step done, now metadata
229:
230: # ---------------------------------------- Storage for metadata keys and fields
231:
1.8 www 232: %metadatafields=();
233: %metadatakeys=();
234:
235: my %oldparmstores=();
1.7 www 236:
237: # ------------------------------------------------ First, check out environment
1.8 www 238: unless (-e $source.'.meta') {
1.7 www 239: $metadatafields{'author'}=$ENV{'environment.firstname'}.' '.
240: $ENV{'environment.middlename'}.' '.
241: $ENV{'environment.lastname'}.' '.
242: $ENV{'environment.generation'};
1.8 www 243: $metadatafields{'author'}=~s/\s+/ /g;
244: $metadatafields{'author'}=~s/\s+$//;
1.10 www 245: $metadatafields{'owner'}=$ENV{'user.name'}.'@'.$ENV{'user.domain'};
1.7 www 246:
247: # ------------------------------------------------ Check out directory hierachy
248:
249: my $thisdisfn=$source;
250: $thisdisfn=~s/^\/home\/$ENV{'user.name'}\///;
251:
252: my @urlparts=split(/\//,$thisdisfn);
253: $#urlparts--;
254:
255: my $currentpath='/home/'.$ENV{'user.name'}.'/';
256:
257: map {
258: $currentpath.=$_.'/';
259: $scrout.=&metaread($logfile,$currentpath.'default.meta');
260: } @urlparts;
261:
262: # ------------------- Clear out parameters and stores (there should not be any)
263:
264: map {
265: if (($_=~/^parameter/) || ($_=~/^stores/)) {
266: delete $metadatafields{$_};
267: }
268: } keys %metadatafields;
269:
1.8 www 270: } else {
1.7 www 271: # ---------------------- Read previous metafile, remember parameters and stores
272:
273: $scrout.=&metaread($logfile,$source.'.meta');
274:
275: map {
276: if (($_=~/^parameter/) || ($_=~/^stores/)) {
277: $oldparmstores{$_}=1;
278: delete $metadatafields{$_};
279: }
280: } keys %metadatafields;
281:
1.8 www 282: }
1.7 www 283:
1.4 www 284: # -------------------------------------------------- Parse content for metadata
285:
1.10 www 286: my $allmeta=Apache::lonxml::xmlparse('meta',$content);
1.7 www 287: &metaeval($allmeta);
288:
289: # ---------------- Find and document discrepancies in the parameters and stores
290:
291: my $chparms='';
292: map {
293: if (($_=~/^parameter/) || ($_=~/^stores/)) {
294: unless ($_=~/\.\w+$/) {
295: unless ($oldparmstores{$_}) {
296: print $logfile 'New: '.$_."\n";
297: $chparms.=$_.' ';
298: }
299: }
300: }
301: } sort keys %metadatafields;
302: if ($chparms) {
303: $scrout.='<p><b>New parameters or stored values:</b> '.
304: $chparms;
305: }
306:
307: my $chparms='';
308: map {
309: if (($_=~/^parameter/) || ($_=~/^stores/)) {
310: unless (($metadatafields{$_}) || ($_=~/\.\w+$/)) {
311: print $logfile 'Obsolete: '.$_."\n";
312: $chparms.=$_.' ';
313: }
314: }
315: } sort keys %oldparmstores;
316: if ($chparms) {
317: $scrout.='<p><b>Obsolete parameters or stored values:</b> '.
318: $chparms;
319: }
1.5 www 320:
1.8 www 321: # ------------------------------------------------------- Now have all metadata
1.5 www 322:
1.8 www 323: $scrout.=
324: '<form action="/adm/publish" method="post">'.
1.11 ! www 325: &hiddenfield('phase','two').
! 326: &hiddenfield('filename',$ENV{'form.filename'}).
! 327: &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)).
1.10 www 328: &textfield('Title','title',$metadatafields{'title'}).
329: &textfield('Author(s)','author',$metadatafields{'author'}).
330: &textfield('Subject','subject',$metadatafields{'subject'});
1.5 www 331:
332: # --------------------------------------------------- Scan content for keywords
1.7 www 333:
1.8 www 334: my $keywordout='<p><b>Keywords:</b><br><table border=2><tr>';
1.7 www 335: my $colcount=0;
336:
1.5 www 337: {
338: my $textonly=$content;
339: $textonly=~s/\<script[^\<]+\<\/script\>//g;
340: $textonly=~s/\<m\>[^\<]+\<\/m\>//g;
341: $textonly=~s/\<[^\>]*\>//g;
342: $textonly=~tr/A-Z/a-z/;
343: $textonly=~s/[\$\&][a-z]\w*//g;
344: $textonly=~s/[^a-z\s]//g;
345:
346: my %keywords=();
347: map {
348: unless ($nokey{$_}) {
349: $keywords{$_}=1;
350: }
351: } ($textonly=~m/(\w+)/g);
352:
353:
1.7 www 354: map {
1.8 www 355: $keywordout.='<td><input type=checkbox name="'.$_.'"';
356: if ($metadatafields{'keywords'}=~/$_/) {
357: $keywordout.=' checked';
358: }
359: $keywordout.='>'.$_.'</td>';
1.7 www 360: if ($colcount>10) {
361: $keywordout.="</tr><tr>\n";
362: $colcount=0;
363: }
364: $colcount++;
365: } sort keys %keywords;
366: $keywordout.='</tr></table>';
1.5 www 367:
368: }
1.4 www 369:
1.7 www 370: $scrout.=$keywordout;
1.9 www 371:
1.10 www 372: $scrout.=&textfield('Notes','notes',$metadatafields{'notes'});
1.9 www 373:
374: $scrout.=
375: '<p><b>Abstract:</b><br><textarea cols=80 rows=5 name=abstract>'.
376: $metadatafields{'abstract'}.'</textarea>';
377:
1.11 ! www 378: $source=~/\.(\w+)$/;
! 379:
! 380: $scrout.=&hiddenfield('mime',$1);
! 381:
1.10 www 382: $scrout.=&selectbox('Language','language',
383: $metadatafields{'language'},%language);
1.11 ! www 384:
! 385: unless ($metadatafields{'creationdate'}) {
! 386: $metadatafields{'creationdate'}=time;
! 387: }
! 388: $scrout.=&hiddenfield('creationdate',$metadatafields{'creationdate'});
! 389:
! 390: $scrout.=&hiddenfield('lastrevisiondate',time);
! 391:
1.9 www 392:
1.10 www 393: $scrout.=&textfield('Publisher/Owner','owner',
394: $metadatafields{'owner'});
395:
396: $scrout.=&selectbox('Copyright/Distribution','copyright',
397: $metadatafields{'copyright'},%cprtag);
1.9 www 398:
1.3 www 399: }
1.8 www 400: return $scrout.
401: '<p><input type="submit" value="Finalize Publication"></form>';
1.2 www 402: }
1.1 www 403:
1.11 ! www 404: sub phasetwo {
! 405:
! 406: my ($source,$target,$style)=@_;
! 407: my $logfile;
! 408: my $scrout='';
! 409:
! 410: unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
! 411: return
! 412: '<font color=red>No write permission to user directory, FAIL</font>';
! 413: }
! 414: print $logfile
! 415: "\n================= Publish ".localtime()." Phase Two ================\n";
! 416:
! 417: %metadatafields=();
! 418: %metadatakeys=();
! 419:
! 420: &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'}));
! 421:
! 422: $metadatafields{'title'}=$ENV{'form.title'};
! 423: $metadatafields{'author'}=$ENV{'form.author'};
! 424: $metadatafields{'subject'}=$ENV{'form.subject'};
! 425: $metadatafields{'keywords'}=$ENV{'form.keywords'};
! 426: $metadatafields{'notes'}=$ENV{'form.notes'};
! 427: $metadatafields{'abstract'}=$ENV{'form.abstract'};
! 428: $metadatafields{'mime'}=$ENV{'form.mime'};
! 429: $metadatafields{'language'}=$ENV{'form.language'};
! 430: $metadatafields{'creationdate'}=$ENV{'form.creationdate'};
! 431: $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'};
! 432: $metadatafields{'owner'}=$ENV{'form.owner'};
! 433: $metadatafields{'copyright'}=$ENV{'form.copyright'};
! 434:
! 435: map {
! 436: print $logfile "\n".$_.': '.$metadatafields{$_}.
! 437: "\n".$_.'.keys: '.$metadatakeys{$_};
! 438: } sort keys %metadatafields;
! 439:
! 440:
! 441: }
! 442:
1.1 www 443: # ================================================================ Main Handler
444:
445: sub handler {
446: my $r=shift;
1.2 www 447:
448: if ($r->header_only) {
449: $r->content_type('text/html');
450: $r->send_http_header;
451: return OK;
452: }
453:
454: # -------------------------------------------------------------- Check filename
455:
456: my $fn=$ENV{'form.filename'};
457:
458: unless ($fn) {
459: $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
460: ' trying to publish empty filename', $r->filename);
461: return HTTP_NOT_FOUND;
462: }
1.4 www 463:
464: unless ($ENV{'user.home'} eq $r->dir_config('lonHostID')) {
465: $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
466: ' trying to publish file '.$ENV{'form.filename'}.
467: ' ('.$fn.') - not homeserver ('.$ENV{'user.home'}.')',
468: $r->filename);
469: return HTTP_NOT_ACCEPTABLE;
470: }
1.2 www 471:
472: $fn=~s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/;
473:
474: my $targetdir='';
475: my $docroot=$r->dir_config('lonDocRoot');
476: if ($1 ne $ENV{'user.name'}) {
477: $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
478: ' trying to publish unowned file '.$ENV{'form.filename'}.
479: ' ('.$fn.')',
480: $r->filename);
481: return HTTP_NOT_ACCEPTABLE;
482: } else {
483: $targetdir=$docroot.'/res/'.$ENV{'user.domain'};
484: }
485:
486:
487: unless (-e $fn) {
488: $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
489: ' trying to publish non-existing file '.$ENV{'form.filename'}.
490: ' ('.$fn.')',
491: $r->filename);
492: return HTTP_NOT_FOUND;
493: }
494:
1.11 ! www 495: unless ($ENV{'form.phase'} eq 'two') {
! 496:
1.2 www 497: # --------------------------------- File is there and owned, init lookup tables
498:
1.3 www 499: %addid=();
500:
501: {
502: my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab');
503: while (<$fh>=~/(\w+)\s+(\w+)/) {
504: $addid{$1}=$2;
505: }
1.5 www 506: }
507:
508: %nokey=();
509:
510: {
511: my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab');
512: map {
513: my $word=$_;
514: chomp($word);
515: $nokey{$word}=1;
1.9 www 516: } <$fh>;
517: }
518:
519: %language=();
520:
521: {
522: my $fh=Apache::File->new($r->dir_config('lonTabDir').'/language.tab');
523: map {
1.10 www 524: $_=~/(\w+)\s+([\w\s\-]+)/;
1.9 www 525: $language{$1}=$2;
1.10 www 526: } <$fh>;
527: }
528:
529: %cprtag=();
530:
531: {
532: my $fh=Apache::File->new($r->dir_config('lonIncludes').'/copyright.tab');
533: map {
534: $_=~/(\w+)\s+([\w\s\-]+)/;
535: $cprtag{$1}=$2;
1.5 www 536: } <$fh>;
1.3 www 537: }
1.11 ! www 538:
! 539: }
! 540:
1.2 www 541: # ----------------------------------------------------------- Start page output
542:
1.1 www 543: $r->content_type('text/html');
544: $r->send_http_header;
545:
546: $r->print('<html><head><title>LON-CAPA Publishing</title></head>');
547: $r->print('<body bgcolor="#FFFFFF">');
1.2 www 548: my $thisfn=$fn;
549:
550: # ------------------------------------------------------------- Individual file
551: {
552: $thisfn=~/\.(\w+)$/;
553: my $thistype=$1;
554: my $thisembstyle=&Apache::lonnet::fileembstyle($thistype);
555:
556: my $thistarget=$thisfn;
557:
558: $thistarget=~s/^\/home/$targetdir/;
559: $thistarget=~s/\/public\_html//;
560:
561: my $thisdistarget=$thistarget;
562: $thisdistarget=~s/^$docroot//;
563:
564: my $thisdisfn=$thisfn;
565: $thisdisfn=~s/^\/home\/$ENV{'user.name'}\/public_html\///;
566:
567: $r->print('<h2>Publishing '.
568: &Apache::lonnet::filedescription($thistype).' <tt>'.
569: $thisdisfn.'</tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><p>');
1.11 ! www 570:
1.2 www 571: # ------------ We are publishing from $thisfn to $thistarget with $thisembstyle
572:
1.11 ! www 573: unless ($ENV{'form.phase'} eq 'two') {
! 574: $r->print('<hr>'.&publish($thisfn,$thistarget,$thisembstyle));
! 575: } else {
! 576: $r->print('<hr>'.&phasetwo($thisfn,$thistarget,$thisembstyle));
! 577: }
1.2 www 578:
1.11 ! www 579: }
1.1 www 580: $r->print('</body></html>');
581:
582: return OK;
583: }
584:
585: 1;
586: __END__
587:
588:
589:
590:
591:
592:
593:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonpublisher.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / publisher