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