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