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