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