1: # The LearningOnline Network with CAPA
2: # XML Parser Module
3: #
4: # last modified 06/26/00 by Alexander Sakharuk
5: # 11/6 Gerd Kortemeyer
6: # 6/1/1 Gerd Kortemeyer
7: # 2/21,3/13 Guy
8: # 3/29,5/4 Gerd Kortemeyer
9:
10: package Apache::lonxml;
11: use vars
12: qw(@pwd @outputstack $redirection $import @extlinks $metamode);
13: use strict;
14: use HTML::TokeParser;
15: use Safe;
16: use Safe::Hole;
17: use Opcode;
18: use Apache::Constants qw(:common);
19: use Apache::lontexconvert;
20:
21:
22: sub xmlbegin {
23: my $output='';
24: if ($ENV{'browser.mathml'}) {
25: $output='<?xml version="1.0"?>'
26: .'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'
27: .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
28: .'[<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">]>'
29: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
30: .'xmlns="http://www.w3.org/TR/REC-html40">';
31: } else {
32: $output='<html>';
33: }
34: return $output;
35: }
36:
37: sub xmlend {
38: return '</html>';
39: }
40:
41: sub fontsettings() {
42: my $headerstring='';
43: if (($ENV{'browser.os'} eq 'mac') && (!$ENV{'browser.mathml'})) {
44: $headerstring.=
45: '<meta Content-Type="text/html; charset=x-mac-roman">';
46: }
47: return $headerstring;
48: }
49:
50: sub registerurl {
51: return (<<ENDSCRIPT);
52: <script language="JavaScript">
53: // BEGIN LON-CAPA Internal
54: function LONCAPAreg() {
55: if (window.location.pathname!="/res/adm/pages/menu.html") {
56: menu=window.open("","LONCAPAmenu");
57: menu.currentURL=window.location.pathname;
58: menu.currentStale=0;
59: }
60: }
61:
62: function LONCAPAstale() {
63: if (window.location.pathname!="/res/adm/pages/menu.html") {
64: menu=window.open("","LONCAPAmenu");
65: menu.currentStale=1;
66: }
67: }
68: // END LON-CAPA Internal
69: </script>
70: ENDSCRIPT
71: }
72:
73: sub loadevents() {
74: return 'LONCAPAreg();';
75: }
76:
77: sub unloadevents() {
78: return 'LONCAPAstale();';
79: }
80:
81: sub register {
82: my $space;
83: my @taglist;
84: my $temptag;
85: ($space,@taglist) = @_;
86: foreach $temptag (@taglist) {
87: $Apache::lonxml::alltags{$temptag}=$space;
88: }
89: }
90:
91: sub printalltags {
92: my $temp;
93: foreach $temp (sort keys %Apache::lonxml::alltags) {
94: &Apache::lonxml::debug("$temp -- $Apache::lonxml::alltags{$temp}");
95: }
96: }
97: use Apache::style;
98: use Apache::run;
99: use Apache::londefdef;
100: use Apache::scripttag;
101: use Apache::edit;
102: #================================================== Main subroutine: xmlparse
103: @pwd=();
104: @outputstack = ();
105: $redirection = 0;
106: $import = 1;
107: @extlinks=();
108: $metamode = 0;
109:
110: sub xmlparse {
111:
112: my ($target,$content_file_string,$safeinit,%style_for_target) = @_;
113: if ($target eq 'meta') {
114: # meta mode is a bit weird only some output is to be turned off
115: #<output> tag turns metamode off (defined in londefdef.pm)
116: $Apache::lonxml::redirection = 0;
117: $Apache::lonxml::metamode = 1;
118: $Apache::lonxml::import = 0;
119: } elsif ($target eq 'grade') {
120: &startredirection;
121: $Apache::lonxml::metamode = 0;
122: $Apache::lonxml::import = 1;
123: } else {
124: $Apache::lonxml::metamode = 0;
125: $Apache::lonxml::redirection = 0;
126: $Apache::lonxml::import = 1;
127: }
128: #&printalltags();
129: my @pars = ();
130: @Apache::lonxml::pwd=();
131: my $pwd=$ENV{'request.filename'};
132: $pwd =~ s:/[^/]*$::;
133: &newparser(\@pars,\$content_file_string,$pwd);
134: my $currentstring = '';
135: my $finaloutput = '';
136: my $newarg = '';
137: my $result;
138:
139: my $safeeval = new Safe;
140: my $safehole = new Safe::Hole;
141: $safeeval->permit("entereval");
142: $safeeval->permit(":base_math");
143: $safeeval->deny(":base_io");
144: $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT');
145: #need to inspect this class of ops
146: # $safeeval->deny(":base_orig");
147: $safeinit .= ';$external::target='.$target.';';
148: $safeinit .= ';$external::randomseed='.&Apache::lonnet::rndseed().';';
149: &Apache::run::run($safeinit,$safeeval);
150: #-------------------- Redefinition of the target in the case of compound target
151:
152: ($target, my @tenta) = split('&&',$target);
153:
154: my @stack = ();
155: my @parstack = ();
156: &initdepth;
157: my $token;
158: while ( $#pars > -1 ) {
159: while ($token = $pars[$#pars]->get_token) {
160: if (($token->[0] eq 'T') || ($token->[0] eq 'C') || ($token->[0] eq 'D') ) {
161: if ($metamode<1) { $result=$token->[1]; }
162: } elsif ($token->[0] eq 'PI') {
163: if ($metamode<1) { $result=$token->[2]; }
164: } elsif ($token->[0] eq 'S') {
165: # add tag to stack
166: push (@stack,$token->[1]);
167: # add parameters list to another stack
168: push (@parstack,&parstring($token));
169: &increasedepth($token);
170: if (exists $style_for_target{$token->[1]}) {
171: if ($Apache::lonxml::redirection) {
172: $Apache::lonxml::outputstack['-1'] .=
173: &recurse($style_for_target{$token->[1]},$target,$safeeval,
174: \%style_for_target,@parstack);
175: } else {
176: $finaloutput .= &recurse($style_for_target{$token->[1]},$target,
177: $safeeval,\%style_for_target,@parstack);
178: }
179: } else {
180: $result = &callsub("start_$token->[1]", $target, $token,\@parstack,
181: \@pars, $safeeval, \%style_for_target);
182: }
183: } elsif ($token->[0] eq 'E') {
184: #clear out any tags that didn't end
185: while ($token->[1] ne $stack[$#stack] && ($#stack > -1)) {
186: &Apache::lonxml::warning("Unbalanced tags in resource $stack['-1']");
187: pop @stack;pop @parstack;&decreasedepth($token);
188: }
189:
190: if (exists $style_for_target{'/'."$token->[1]"}) {
191: if ($Apache::lonxml::redirection) {
192: $Apache::lonxml::outputstack['-1'] .=
193: &recurse($style_for_target{'/'."$token->[1]"},
194: $target,$safeeval,\%style_for_target,@parstack);
195: } else {
196: $finaloutput .= &recurse($style_for_target{'/'."$token->[1]"},
197: $target,$safeeval,\%style_for_target,
198: @parstack);
199: }
200:
201: } else {
202: $result = &callsub("end_$token->[1]", $target, $token, \@parstack,
203: \@pars,$safeeval, \%style_for_target);
204: }
205: } else {
206: &Apache::lonxml::error("Unknown token event :$token->[0]:$token->[1]:");
207: }
208: #evaluate variable refs in result
209: if ($result ne "") {
210: if ( $#parstack > -1 ) {
211: if ($Apache::lonxml::redirection) {
212: $Apache::lonxml::outputstack['-1'] .=
213: &Apache::run::evaluate($result,$safeeval,$parstack[$#parstack]);
214: } else {
215: $finaloutput .= &Apache::run::evaluate($result,$safeeval,
216: $parstack[$#parstack]);
217: }
218: } else {
219: $finaloutput .= &Apache::run::evaluate($result,$safeeval,'');
220: }
221: $result = '';
222: }
223: if ($token->[0] eq 'E') {
224: pop @stack;pop @parstack;&decreasedepth($token);
225: }
226: }
227: pop @pars;
228: pop @Apache::lonxml::pwd;
229: }
230:
231: # if ($target eq 'meta') {
232: # $finaloutput.=&endredirection;
233: # }
234:
235: if (($ENV{'QUERY_STRING'}) && ($target eq 'web')) {
236: $finaloutput=&afterburn($finaloutput);
237: }
238:
239: return $finaloutput;
240: }
241:
242:
243: sub recurse {
244:
245: my @innerstack = ();
246: my @innerparstack = ();
247: my ($newarg,$target,$safeeval,$style_for_target,@parstack) = @_;
248: my @pat = ();
249: &newparser(\@pat,\$newarg);
250: my $tokenpat;
251: my $partstring = '';
252: my $output='';
253: my $decls='';
254: while ( $#pat > -1 ) {
255: while ($tokenpat = $pat[$#pat]->get_token) {
256: if (($tokenpat->[0] eq 'T') || ($tokenpat->[0] eq 'C') || ($tokenpat->[0] eq 'D') ) {
257: if ($metamode<1) { $partstring=$tokenpat->[1]; }
258: } elsif ($tokenpat->[0] eq 'PI') {
259: if ($metamode<1) { $partstring=$tokenpat->[2]; }
260: } elsif ($tokenpat->[0] eq 'S') {
261: push (@innerstack,$tokenpat->[1]);
262: push (@innerparstack,&parstring($tokenpat));
263: &increasedepth($tokenpat);
264: $partstring = &callsub("start_$tokenpat->[1]",
265: $target, $tokenpat, \@innerparstack,
266: \@pat, $safeeval, $style_for_target);
267: } elsif ($tokenpat->[0] eq 'E') {
268: #clear out any tags that didn't end
269: while ($tokenpat->[1] ne $innerstack[$#innerstack]
270: && ($#innerstack > -1)) {
271: &Apache::lonxml::warning("Unbalanced tags in resource $innerstack['-1']");
272: pop @innerstack;pop @innerparstack;&decreasedepth($tokenpat);
273: }
274: $partstring = &callsub("end_$tokenpat->[1]",
275: $target, $tokenpat, \@innerparstack,
276: \@pat, $safeeval, $style_for_target);
277: } else {
278: &Apache::lonxml::error("Unknown token event :$tokenpat->[0]:$tokenpat->[1]:");
279: }
280: #pass both the variable to the style tag, and the tag we
281: #are processing inside the <definedtag>
282: if ( $partstring ne "" ) {
283: if ( $#parstack > -1 ) {
284: if ( $#innerparstack > -1 ) {
285: $decls= $parstack[$#parstack].$innerparstack[$#innerparstack];
286: } else {
287: $decls= $parstack[$#parstack];
288: }
289: } else {
290: if ( $#innerparstack > -1 ) {
291: $decls=$innerparstack[$#innerparstack];
292: } else {
293: $decls='';
294: }
295: }
296: $output .= &Apache::run::evaluate($partstring,$safeeval,$decls);
297: $partstring = '';
298: }
299: if ($tokenpat->[0] eq 'E') { pop @innerstack;pop @innerparstack;
300: &decreasedepth($tokenpat);}
301: }
302: pop @pat;
303: pop @Apache::lonxml::pwd;
304: }
305: return $output;
306: }
307:
308: sub callsub {
309: my ($sub,$target,$token,$parstack,$parser,$safeeval,$style)=@_;
310: my $currentstring='';
311: {
312: my $sub1;
313: no strict 'refs';
314: if ($target eq 'edit' && $token->[0] eq 'S') {
315: $currentstring = &Apache::edit::tag_start($target,$token,$parstack,$parser,
316: $safeeval,$style);
317: }
318: my $tag=$token->[1];
319: my $space=$Apache::lonxml::alltags{$tag};
320: if (!$space) {
321: $tag=~tr/A-Z/a-z/;
322: $sub=~tr/A-Z/a-z/;
323: $space=$Apache::lonxml::alltags{$tag}
324: }
325: if ($space) {
326: &Apache::lonxml::debug("Calling sub $sub in $space $metamode<br />\n");
327: $sub1="$space\:\:$sub";
328: $Apache::lonxml::curdepth=join('_',@Apache::lonxml::depthcounter);
329: $currentstring .= &$sub1($target,$token,$parstack,$parser,
330: $safeeval,$style);
331: } else {
332: &Apache::lonxml::debug("NOT Calling sub $sub in $space $metamode<br />\n");
333: if ($metamode <1) {
334: if (defined($token->[4]) && ($metamode < 1)) {
335: $currentstring .= $token->[4];
336: } else {
337: $currentstring .= $token->[2];
338: }
339: }
340: }
341: if ($target eq 'edit' && $token->[0] eq 'E') {
342: $currentstring .= &Apache::edit::tag_end($target,$token,$parstack,$parser,
343: $safeeval,$style);
344: }
345: use strict 'refs';
346: }
347: return $currentstring;
348: }
349:
350: sub startredirection {
351: $Apache::lonxml::redirection++;
352: push (@Apache::lonxml::outputstack, '');
353: }
354:
355: sub endredirection {
356: if (!$Apache::lonxml::redirection) {
357: &Apache::lonxml::error("Endredirection was called, before a startredirection, perhaps you have unbalanced tags. Some debuggin information:".join ":",caller);
358: return '';
359: }
360: $Apache::lonxml::redirection--;
361: pop @Apache::lonxml::outputstack;
362: }
363:
364: sub initdepth {
365: @Apache::lonxml::depthcounter=();
366: $Apache::lonxml::depth=-1;
367: $Apache::lonxml::olddepth=-1;
368: }
369:
370: sub increasedepth {
371: my ($token) = @_;
372: $Apache::lonxml::depth++;
373: $Apache::lonxml::depthcounter[$Apache::lonxml::depth]++;
374: if ($Apache::lonxml::depthcounter[$Apache::lonxml::depth]==1) {
375: $Apache::lonxml::olddepth=$Apache::lonxml::depth;
376: }
377: my $curdepth=join('_',@Apache::lonxml::depthcounter);
378: &Apache::lonxml::debug("s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n");
379: #print "<br />s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n";
380: }
381:
382: sub decreasedepth {
383: my ($token) = @_;
384: $Apache::lonxml::depth--;
385: if ($Apache::lonxml::depth<$Apache::lonxml::olddepth-1) {
386: $#Apache::lonxml::depthcounter--;
387: $Apache::lonxml::olddepth=$Apache::lonxml::depth+1;
388: }
389: if ( $Apache::lonxml::depth < -1) {
390: &Apache::lonxml::warning("Unbalanced tags in resource");
391: $Apache::lonxml::depth='-1';
392: }
393: my $curdepth=join('_',@Apache::lonxml::depthcounter);
394: &Apache::lonxml::debug("e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n");
395: #print "<br />e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n";
396: }
397:
398: sub get_all_text {
399:
400: my($tag,$pars)= @_;
401: my $depth=0;
402: my $token;
403: my $result='';
404: if ( $tag =~ m:^/: ) {
405: my $tag=substr($tag,1);
406: # &Apache::lonxml::debug("have:$tag:");
407: while (($depth >=0) && ($token = $pars->get_token)) {
408: # &Apache::lonxml::debug("e token:$token->[0]:$depth:$token->[1]");
409: if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) {
410: $result.=$token->[1];
411: } elsif ($token->[0] eq 'PI') {
412: $result.=$token->[2];
413: } elsif ($token->[0] eq 'S') {
414: if ($token->[1] eq $tag) { $depth++; }
415: $result.=$token->[4];
416: } elsif ($token->[0] eq 'E') {
417: if ( $token->[1] eq $tag) { $depth--; }
418: #skip sending back the last end tag
419: if ($depth > -1) { $result.=$token->[2]; } else {
420: $pars->unget_token($token);
421: }
422: }
423: }
424: } else {
425: while ($token = $pars->get_token) {
426: # &Apache::lonxml::debug("s token:$token->[0]:$depth:$token->[1]");
427: if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) {
428: $result.=$token->[1];
429: } elsif ($token->[0] eq 'PI') {
430: $result.=$token->[2];
431: } elsif ($token->[0] eq 'S') {
432: if ( $token->[1] eq $tag) {
433: $pars->unget_token($token); last;
434: } else {
435: $result.=$token->[4];
436: }
437: } elsif ($token->[0] eq 'E') {
438: $result.=$token->[2];
439: }
440: }
441: }
442: # &Apache::lonxml::debug("Exit:$result:");
443: return $result
444: }
445:
446: sub newparser {
447: my ($parser,$contentref,$dir) = @_;
448: push (@$parser,HTML::TokeParser->new($contentref));
449: $$parser['-1']->xml_mode('1');
450: if ( $dir eq '' ) {
451: push (@Apache::lonxml::pwd, $Apache::lonxml::pwd[$#Apache::lonxml::pwd]);
452: } else {
453: push (@Apache::lonxml::pwd, $dir);
454: }
455: # &Apache::lonxml::debug("pwd:$#Apache::lonxml::pwd");
456: # &Apache::lonxml::debug("pwd:$Apache::lonxml::pwd[$#Apache::lonxml::pwd]");
457: }
458:
459: sub parstring {
460: my ($token) = @_;
461: my $temp='';
462: map {
463: unless ($_=~/\W/) {
464: my $val=$token->[2]->{$_};
465: $val =~ s/([\%\@\\])/\\$1/g;
466: #if ($val =~ m/^[\%\@]/) { $val="\\".$val; }
467: $temp .= "my \$$_=\"$val\";"
468: }
469: } @{$token->[3]};
470: return $temp;
471: }
472:
473: sub writeallows {
474: my $thisurl='/res/'.&Apache::lonnet::declutter(shift);
475: my $thisdir=$thisurl;
476: $thisdir=~s/\/[^\/]+$//;
477: my %httpref=();
478: map {
479: $httpref{'httpref.'.
480: &Apache::lonnet::hreflocation($thisdir,$_)}=$thisurl; } @extlinks;
481: &Apache::lonnet::appenv(%httpref);
482: }
483:
484: #
485: # Afterburner handles anchors, highlights and links
486: #
487:
488: sub afterburn {
489: my $result=shift;
490: map {
491: my ($name, $value) = split(/=/,$_);
492: $value =~ tr/+/ /;
493: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
494: if (($name eq 'highlight')||($name eq 'anchor')||($name eq 'link')) {
495: unless ($ENV{'form.'.$name}) {
496: $ENV{'form.'.$name}=$value;
497: }
498: }
499: } (split(/&/,$ENV{'QUERY_STRING'}));
500: if ($ENV{'form.highlight'}) {
501: map {
502: my $anchorname=$_;
503: my $matchthis=$anchorname;
504: $matchthis=~s/\_+/\\s\+/g;
505: $result=~s/($matchthis)/\<font color=\"red\"\>$1\<\/font\>/gs;
506: } split(/\,/,$ENV{'form.highlight'});
507: }
508: if ($ENV{'form.link'}) {
509: map {
510: my ($anchorname,$linkurl)=split(/\>/,$_);
511: my $matchthis=$anchorname;
512: $matchthis=~s/\_+/\\s\+/g;
513: $result=~s/($matchthis)/\<a href=\"$linkurl\"\>$1\<\/a\>/gs;
514: } split(/\,/,$ENV{'form.link'});
515: }
516: if ($ENV{'form.anchor'}) {
517: my $anchorname=$ENV{'form.anchor'};
518: my $matchthis=$anchorname;
519: $matchthis=~s/\_+/\\s\+/g;
520: $result=~s/($matchthis)/\<a name=\"$anchorname\"\>$1\<\/a\>/s;
521: $result.=(<<"ENDSCRIPT");
522: <script>
523: document.location.hash='$anchorname';
524: </script>
525: ENDSCRIPT
526: }
527: return $result;
528: }
529:
530: sub handler {
531: my $request=shift;
532:
533: my $target='web';
534:
535: $Apache::lonxml::debug=0;
536:
537: if ($ENV{'browser.mathml'}) {
538: $request->content_type('text/xml');
539: } else {
540: $request->content_type('text/html');
541: }
542:
543: # $request->print(<<ENDHEADER);
544: #<html>
545: #<head>
546: #<title>Just test</title>
547: #</head>
548: #<body bgcolor="#FFFFFF">
549: #ENDHEADER
550: # &Apache::lonhomework::send_header($request);
551: $request->send_http_header;
552:
553: return OK if $request->header_only;
554:
555:
556: my $file=&Apache::lonnet::filelocation("",$request->uri);
557: my %mystyle;
558: my $result = '';
559: my $filecontents=&Apache::lonnet::getfile($file);
560: if ($filecontents == -1) {
561: &Apache::lonxml::error("<b> Unable to find <i>$file</i></b>");
562: $filecontents='';
563: } else {
564: $result = &Apache::lonxml::xmlparse($target,$filecontents,'',%mystyle);
565: }
566:
567: $request->print($result);
568:
569: writeallows($request->uri);
570: return OK;
571: }
572:
573: sub debug {
574: if ($Apache::lonxml::debug eq 1) {
575: print "DEBUG:".$_[0]."<br />\n";
576: }
577: }
578:
579: sub error {
580: if ($Apache::lonxml::debug eq 1) {
581: print "<b>ERROR:</b>".$_[0]."<br />\n";
582: } else {
583: print "<b>An Error occured while processing this resource. The instructor has been notified.</b> <br />";
584: #notify author
585: &Apache::lonmsg::author_res_msg($ENV{'request.filename'},$_[0]);
586: #notify course
587: if ( $ENV{'request.course.id'} ) {
588: my $users=$ENV{'course.'.$ENV{'request.course.id'}.'.comment.email'};
589: foreach my $user (split /\,/, $users) {
590: ($user,my $domain) = split /:/, $user;
591: &Apache::lonmsg::user_normal_msg($user,$domain,"Error in $ENV{'request.filename'}",$_[0]);
592: }
593: }
594:
595: #FIXME probably shouldn't have me get everything forever.
596: &Apache::lonmsg::user_normal_msg('albertel','msu',"Error in $ENV{'request.filename'}",$_[0]);
597: #&Apache::lonmsg::user_normal_msg('albertel','103',"Error in $ENV{'request.filename'}",$_[0]);
598: }
599: }
600:
601: sub warning {
602: if ($Apache::lonxml::debug eq 1) {
603: print "<b>W</b>ARNING<b>:</b>".$_[0]."<br />\n";
604: }
605: }
606:
607: 1;
608: __END__
609:
610:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonxml.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / xml