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