File:
[LON-CAPA] /
loncom /
xml /
lonxml.pm
Revision
1.132:
download - view:
text,
annotated -
select for diffs
Mon Oct 1 20:06:45 2001 UTC (22 years, 9 months ago) by
albertel
Branches:
MAIN
CVS tags:
HEAD
- added get_param_var (Will also evaluate paramater values that look like variable references inside the safe spacebefore returning them, should successfully handle both arrays, and hashes.) (Should the extra code be integrated back into get_param?)
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: # 5/10 Scott Harrison
10: # 5/26 Gerd Kortemeyer
11: # 5/27 H. K. Ng
12: # 6/2,6/3,6/8,6/9 Gerd Kortemeyer
13: # 6/12,6/13 H. K. Ng
14: # 6/16 Gerd Kortemeyer
15: # 7/27 H. K. Ng
16: # 8/7,8/9,8/10,8/11,8/15,8/16,8/17,8/18,8/20,8/23,8/24 Gerd Kortemeyer
17: # Guy Albertelli
18: # 9/26 Gerd Kortemeyer
19:
20:
21: package Apache::lonxml;
22: use vars
23: qw(@pwd @outputstack $redirection $import @extlinks $metamode $evaluate %insertlist @namespace);
24: use strict;
25: use HTML::TokeParser;
26: use HTML::TreeBuilder;
27: use Safe;
28: use Safe::Hole;
29: use Math::Cephes qw(:trigs :hypers :bessels erf erfc);
30: use Math::Random qw(:all);
31: use Opcode;
32:
33: sub register {
34: my $space;
35: my @taglist;
36: my $temptag;
37: ($space,@taglist) = @_;
38: foreach $temptag (@taglist) {
39: $Apache::lonxml::alltags{$temptag}=$space;
40: }
41: }
42:
43: use Apache::Constants qw(:common);
44: use Apache::lontexconvert;
45: use Apache::style;
46: use Apache::run;
47: use Apache::londefdef;
48: use Apache::scripttag;
49: use Apache::edit;
50: use Apache::lonnet;
51: use Apache::File;
52:
53: #================================================== Main subroutine: xmlparse
54: #debugging control, to turn on debugging modify the correct handler
55: $Apache::lonxml::debug=0;
56:
57: #path to the directory containing the file currently being processed
58: @pwd=();
59:
60: #these two are used for capturing a subset of the output for later processing,
61: #don't touch them directly use &startredirection and &endredirection
62: @outputstack = ();
63: $redirection = 0;
64:
65: #controls wheter the <import> tag actually does
66: $import = 1;
67: @extlinks=();
68:
69: # meta mode is a bit weird only some output is to be turned off
70: #<output> tag turns metamode off (defined in londefdef.pm)
71: $metamode = 0;
72:
73: # turns on and of run::evaluate actually derefencing var refs
74: $evaluate = 1;
75:
76: # data structure for eidt mode, determines what tags can go into what other tags
77: %insertlist=();
78:
79: # stores the list of active tag namespaces
80: @namespace=();
81:
82: # has the dynamic menu been updated to know about this resource
83: $Apache::lonxml::registered=0;
84:
85: sub xmlbegin {
86: my $output='';
87: if ($ENV{'browser.mathml'}) {
88: $output='<?xml version="1.0"?>'
89: .'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'
90: .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
91: .'[<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">]>'
92: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
93: .'xmlns="http://www.w3.org/TR/REC-html40">';
94: } else {
95: $output='<html>';
96: }
97: return $output;
98: }
99:
100: sub xmlend {
101: my $discussion='';
102: if ($ENV{'request.course.id'}) {
103: my $crs='/'.$ENV{'request.course.id'};
104: if ($ENV{'request.course.sec'}) {
105: $crs.='_'.$ENV{'request.course.sec'};
106: }
107: $crs=~s/\_/\//g;
108: my $seeid=&Apache::lonnet::allowed('rin',$crs);
109: my $symb=&Apache::lonnet::symbread();
110: if ($symb) {
111: my %contrib=&Apache::lonnet::restore($symb,$ENV{'request.course.id'},
112: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},
113: $ENV{'course.'.$ENV{'request.course.id'}.'.num'});
114: if ($contrib{'version'}) {
115: $discussion.=
116: '<address><hr /><h2>Course Discussion of Resource</h2>';
117: my $idx;
118: for ($idx=1;$idx<=$contrib{'version'};$idx++) {
119: my $hidden=($contrib{'hidden'}=~/\.$idx\./);
120: unless (($hidden) && (!$seeid)) {
121: my $message=$contrib{$idx.':message'};
122: $message=~s/\n/\<br \/\>/g;
123: if ($message) {
124: if ($hidden) {
125: $message='<font color="#888888">'.$message.'</font>';
126: }
127: my $sender='Anonymous';
128: if ((!$contrib{$idx.':anonymous'}) || ($seeid)) {
129: $sender=$contrib{$idx.':sendername'}.' at '.
130: $contrib{$idx.':senderdomain'};
131: if ($contrib{$idx.':anonymous'}) {
132: $sender.=' (anonymous)';
133: }
134: if ($seeid) {
135: if ($hidden) {
136: $sender.=' <a href="/adm/feedback?unhide='.
137: $symb.':::'.$idx.'">Make Visible</a>';
138: } else {
139: $sender.=' <a href="/adm/feedback?hide='.
140: $symb.':::'.$idx.'">Hide</a>';
141: }
142: }
143: }
144: $discussion.='<p><b>'.$sender.'</b> ('.
145: localtime($contrib{$idx.':timestamp'}).
146: '):<blockquote>'.$message.
147: '</blockquote></p>';
148: }
149: }
150: }
151: $discussion.='</address>';
152: }
153: }
154: }
155: return $discussion.'</html>';
156: }
157:
158: sub tokeninputfield {
159: my $defhost=$Apache::lonnet::perlvar{'lonHostID'};
160: $defhost=~tr/a-z/A-Z/;
161: return (<<ENDINPUTFIELD)
162: <script>
163: function updatetoken() {
164: var comp=new Array;
165: var barcode=unescape(document.tokeninput.barcode.value);
166: comp=barcode.split('*');
167: if (typeof(comp[0])!="undefined") {
168: document.tokeninput.codeone.value=comp[0];
169: }
170: if (typeof(comp[1])!="undefined") {
171: document.tokeninput.codetwo.value=comp[1];
172: }
173: if (typeof(comp[2])!="undefined") {
174: comp[2]=comp[2].toUpperCase();
175: document.tokeninput.codethree.value=comp[2];
176: }
177: document.tokeninput.barcode.value='';
178: }
179: </script>
180: <form method="post" name="tokeninput">
181: <table border="2" bgcolor="#FFFFBB">
182: <tr><th>DocID Checkin</th></tr>
183: <tr><td>
184: <table>
185: <tr>
186: <td>Scan in Barcode</td>
187: <td><input type="text" size="22" name="barcode"
188: onChange="updatetoken()"/></td>
189: </tr>
190: <tr><td><i>or</i> Type in DocID</td>
191: <td>
192: <input type="text" size="5" name="codeone" />
193: <b><font size="+2">*</font></b>
194: <input type="text" size="5" name="codetwo" />
195: <b><font size="+2">*</font></b>
196: <input type="text" size="10" name="codethree" value="$defhost"
197: onChange="this.value=this.value.toUpperCase()" />
198: </td></tr>
199: </table>
200: </td></tr>
201: <tr><td><input type="submit" value="Check in DocID" /></td></tr>
202: </table>
203: </form>
204: ENDINPUTFIELD
205: }
206:
207: sub maketoken {
208: my ($symb,$tuname,$tudom,$tcrsid)=@_;
209: unless ($symb) {
210: $symb=&Apache::lonnet::symbread();
211: }
212: unless ($tuname) {
213: $tuname=$ENV{'user.name'};
214: $tudom=$ENV{'user.domain'};
215: $tcrsid=$ENV{'request.course.id'};
216: }
217:
218: return &Apache::lonnet::checkout($symb,$tuname,$tudom,$tcrsid);
219: }
220:
221: sub printtokenheader {
222: my ($target,$token,$symb,$tuname,$tudom,$tcrsid)=@_;
223: unless ($token) { return ''; }
224:
225: unless ($symb) {
226: $symb=&Apache::lonnet::symbread();
227: }
228: unless ($tuname) {
229: $tuname=$ENV{'user.name'};
230: $tudom=$ENV{'user.domain'};
231: $tcrsid=$ENV{'request.course.id'};
232: }
233:
234: my %reply=&Apache::lonnet::get('environment',
235: ['firstname','middlename','lastname','generation'],
236: $tudom,$tuname);
237: my $plainname=$reply{'firstname'}.' '.
238: $reply{'middlename'}.' '.
239: $reply{'lastname'}.' '.
240: $reply{'generation'};
241:
242: if ($target eq 'web') {
243: return
244: '<img align="right" src="/cgi-bin/barcode.gif?encode='.$token.'" />'.
245: 'Checked out for '.$plainname.
246: '<br />User: '.$tuname.' at '.$tudom.
247: '<br />CourseID: '.$tcrsid.
248: '<br />DocID: '.$token.
249: '<br />Time: '.localtime().'<hr />';
250: } else {
251: return $token;
252: }
253: }
254:
255: sub fontsettings() {
256: my $headerstring='';
257: if (($ENV{'browser.os'} eq 'mac') && (!$ENV{'browser.mathml'})) {
258: $headerstring.=
259: '<meta Content-Type="text/html; charset=x-mac-roman">';
260: }
261: return $headerstring;
262: }
263:
264: sub registerurl {
265: my $forcereg=shift;
266: if ($ENV{'request.publicaccess'}) {
267: return
268: '<script>function LONCAPAreg(){} function LONCAPAstale(){}</script>';
269: }
270: if ($Apache::lonxml::registered && !$forcereg) { return ''; }
271: $Apache::lonxml::registered=1;
272: if (($ENV{'REQUEST_URI'}!~/^\/(res\/)*adm\//) || ($forcereg)) {
273: my $hwkadd='';
274: if ($ENV{'REQUEST_URI'}=~/\.(problem|exam|quiz|assess|survey|form)$/) {
275: if (&Apache::lonnet::allowed('vgr',$ENV{'request.course.id'})) {
276: $hwkadd.=(<<ENDSUBM);
277: menu.switchbutton
278: (7,1,'subm.gif','view sub','missions',
279: 'gocmd("/adm/grades","submission")');
280: ENDSUBM
281: }
282: if (&Apache::lonnet::allowed('mgr',$ENV{'request.course.id'})) {
283: $hwkadd.=(<<ENDGRDS);
284: menu.switchbutton
285: (7,2,'pgrd.gif','problem','grades',
286: 'gocmd("/adm/grades","viewgrades")');
287: ENDGRDS
288: }
289: if (&Apache::lonnet::allowed('opa',$ENV{'request.course.id'})) {
290: $hwkadd.=(<<ENDPARM);
291: menu.switchbutton
292: (7,3,'pparm.gif','problem','parms',
293: 'gocmd("/adm/parmset","set")');
294: ENDPARM
295: }
296: }
297: return (<<ENDREGTHIS);
298:
299: <script language="JavaScript">
300: // BEGIN LON-CAPA Internal
301:
302: function LONCAPAreg() {
303: menu=window.open("","LONCAPAmenu");
304: menu.clearTimeout(menu.menucltim);
305: menu.currentURL=window.location.pathname;
306: menu.currentStale=0;
307: menu.clearbut(3,1);
308: menu.switchbutton
309: (6,3,'catalog.gif','catalog','info','catalog_info()');
310: menu.switchbutton
311: (8,1,'eval.gif','evaluate','this','gopost("/adm/evaluate",currentURL)');
312: menu.switchbutton
313: (8,2,'fdbk.gif','feedback','on this','gopost("/adm/feedback",currentURL)');
314: menu.switchbutton
315: (8,3,'prt.gif','prepare','printout','gopost("/adm/printout",currentURL)');
316: menu.switchbutton
317: (2,1,'back.gif','backward','','gopost("/adm/flip","back:"+currentURL)');
318: menu.switchbutton
319: (2,3,'forw.gif','forward','','gopost("/adm/flip","forward:"+currentURL)');
320: menu.switchbutton
321: (9,1,'sbkm.gif','set','bookmark','set_bookmark()');
322: menu.switchbutton
323: (9,2,'vbkm.gif','view','bookmark','edit_bookmarks()');
324: menu.switchbutton
325: (9,3,'anot.gif','anno-','tations','annotate()');
326: $hwkadd
327: }
328:
329: function LONCAPAstale() {
330: menu=window.open("","LONCAPAmenu");
331: menu.currentStale=1;
332: menu.switchbutton
333: (3,1,'reload.gif','return','location','go(currentURL)');
334: menu.clearbut(7,1);
335: menu.clearbut(7,2);
336: menu.clearbut(7,3);
337: menu.menucltim=menu.setTimeout(
338: 'clearbut(2,1);clearbut(2,3);clearbut(8,1);clearbut(8,2);clearbut(8,3);'+
339: 'clearbut(9,1);clearbut(9,2);clearbut(9,3);clearbut(6,3)',
340: 2000);
341:
342: }
343:
344: // END LON-CAPA Internal
345: </script>
346: ENDREGTHIS
347:
348: } else {
349: return (<<ENDDONOTREGTHIS);
350:
351: <script language="JavaScript">
352: // BEGIN LON-CAPA Internal
353:
354: function LONCAPAreg() {
355: menu=window.open("","LONCAPAmenu");
356: menu.currentStale=1;
357: menu.clearbut(2,1);
358: menu.clearbut(2,3);
359: menu.clearbut(8,1);
360: menu.clearbut(8,2);
361: menu.clearbut(8,3);
362: if (menu.currentURL) {
363: menu.switchbutton
364: (3,1,'reload.gif','return','location','go(currentURL)');
365: } else {
366: menu.clearbut(3,1);
367: }
368: }
369:
370: function LONCAPAstale() {
371: }
372:
373: // END LON-CAPA Internal
374: </script>
375: ENDDONOTREGTHIS
376:
377: }
378: }
379:
380: sub loadevents() {
381: return 'LONCAPAreg();';
382: }
383:
384: sub unloadevents() {
385: return 'LONCAPAstale();';
386: }
387:
388: sub printalltags {
389: my $temp;
390: foreach $temp (sort keys %Apache::lonxml::alltags) {
391: &Apache::lonxml::debug("$temp -- $Apache::lonxml::alltags{$temp}");
392: }
393: }
394:
395: sub xmlparse {
396: my ($target,$content_file_string,$safeinit,%style_for_target) = @_;
397:
398: &setup_globals($target);
399: #&printalltags();
400: my @pars = ();
401: my $pwd=$ENV{'request.filename'};
402: $pwd =~ s:/[^/]*$::;
403: &newparser(\@pars,\$content_file_string,$pwd);
404:
405: my $safeeval = new Safe;
406: my $safehole = new Safe::Hole;
407: &init_safespace($target,$safeeval,$safehole,$safeinit);
408: #-------------------- Redefinition of the target in the case of compound target
409:
410: ($target, my @tenta) = split('&&',$target);
411:
412: my @stack = ();
413: my @parstack = ();
414: &initdepth;
415:
416: my $finaloutput = &inner_xmlparse($target,\@stack,\@parstack,\@pars,
417: $safeeval,\%style_for_target);
418: if ($ENV{'request.uri'}) {
419: &writeallows($ENV{'request.uri'});
420: }
421: return $finaloutput;
422: }
423:
424: sub htmlclean {
425: my ($raw,$full)=@_;
426:
427: my $tree = HTML::TreeBuilder->new;
428: $tree->ignore_unknown(0);
429:
430: $tree->parse($raw);
431:
432: my $output= $tree->as_HTML(undef,' ');
433:
434: $output=~s/\<(br|hr|img|meta|allow)([^\>\/]*)\>/\<$1$2 \/\>/gis;
435: $output=~s/\<\/(br|hr|img|meta|allow)\>//gis;
436: unless ($full) {
437: $output=~s/\<[\/]*(body|head|html)\>//gis;
438: }
439:
440: $tree = $tree->delete;
441:
442: return $output;
443: }
444:
445: sub inner_xmlparse {
446: my ($target,$stack,$parstack,$pars,$safeeval,$style_for_target)=@_;
447: my $finaloutput = '';
448: my $result;
449: my $token;
450: while ( $#$pars > -1 ) {
451: while ($token = $$pars['-1']->get_token) {
452: if (($token->[0] eq 'T') || ($token->[0] eq 'C') || ($token->[0] eq 'D') ) {
453: if ($metamode<1) {
454: $result=$token->[1];
455: }
456: } elsif ($token->[0] eq 'PI') {
457: if ($metamode<1) {
458: $result=$token->[2];
459: }
460: } elsif ($token->[0] eq 'S') {
461: # add tag to stack
462: push (@$stack,$token->[1]);
463: # add parameters list to another stack
464: push (@$parstack,&parstring($token));
465: &increasedepth($token);
466: if (exists $$style_for_target{$token->[1]}) {
467: if ($Apache::lonxml::redirection) {
468: $Apache::lonxml::outputstack['-1'] .=
469: &recurse($$style_for_target{$token->[1]},$target,$safeeval,
470: $style_for_target,@$parstack);
471: } else {
472: $finaloutput .= &recurse($$style_for_target{$token->[1]},$target,
473: $safeeval,$style_for_target,@$parstack);
474: }
475: } else {
476: $result = &callsub("start_$token->[1]", $target, $token, $stack,
477: $parstack, $pars, $safeeval, $style_for_target);
478: }
479: } elsif ($token->[0] eq 'E') {
480: #clear out any tags that didn't end
481: while ($token->[1] ne $$stack['-1'] && ($#$stack > -1)) {
482: &Apache::lonxml::warning("Unbalanced tags in resource $$stack['-1']");
483: &end_tag($stack,$parstack,$token);
484: }
485:
486: if (exists $$style_for_target{'/'."$token->[1]"}) {
487: if ($Apache::lonxml::redirection) {
488: $Apache::lonxml::outputstack['-1'] .=
489: &recurse($$style_for_target{'/'."$token->[1]"},
490: $target,$safeeval,$style_for_target,@$parstack);
491: } else {
492: $finaloutput .= &recurse($$style_for_target{'/'."$token->[1]"},
493: $target,$safeeval,$style_for_target,
494: @$parstack);
495: }
496:
497: } else {
498: $result = &callsub("end_$token->[1]", $target, $token, $stack,
499: $parstack, $pars,$safeeval, $style_for_target);
500: }
501: } else {
502: &Apache::lonxml::error("Unknown token event :$token->[0]:$token->[1]:");
503: }
504: #evaluate variable refs in result
505: if ($result ne "") {
506: if ( $#$parstack > -1 ) {
507: if ($Apache::lonxml::redirection) {
508: $Apache::lonxml::outputstack['-1'] .=
509: &Apache::run::evaluate($result,$safeeval,$$parstack['-1']);
510: } else {
511: $finaloutput .= &Apache::run::evaluate($result,$safeeval,
512: $$parstack['-1']);
513: }
514: } else {
515: $finaloutput .= &Apache::run::evaluate($result,$safeeval,'');
516: }
517: $result = '';
518: }
519: if ($token->[0] eq 'E') {
520: &end_tag($stack,$parstack,$token);
521: }
522: }
523: pop @$pars;
524: pop @Apache::lonxml::pwd;
525: }
526:
527: # if ($target eq 'meta') {
528: # $finaloutput.=&endredirection;
529: # }
530:
531: if (($ENV{'QUERY_STRING'}) && ($target eq 'web')) {
532: $finaloutput=&afterburn($finaloutput);
533: }
534: return $finaloutput;
535: }
536:
537: sub recurse {
538: my @innerstack = ();
539: my @innerparstack = ();
540: my ($newarg,$target,$safeeval,$style_for_target,@parstack) = @_;
541: my @pat = ();
542: &newparser(\@pat,\$newarg);
543: my $tokenpat;
544: my $partstring = '';
545: my $output='';
546: my $decls='';
547: while ( $#pat > -1 ) {
548: while ($tokenpat = $pat[$#pat]->get_token) {
549: if (($tokenpat->[0] eq 'T') || ($tokenpat->[0] eq 'C') || ($tokenpat->[0] eq 'D') ) {
550: if ($metamode<1) { $partstring=$tokenpat->[1]; }
551: } elsif ($tokenpat->[0] eq 'PI') {
552: if ($metamode<1) { $partstring=$tokenpat->[2]; }
553: } elsif ($tokenpat->[0] eq 'S') {
554: push (@innerstack,$tokenpat->[1]);
555: push (@innerparstack,&parstring($tokenpat));
556: &increasedepth($tokenpat);
557: $partstring = &callsub("start_$tokenpat->[1]", $target, $tokenpat,
558: \@innerstack, \@innerparstack, \@pat,
559: $safeeval, $style_for_target);
560: } elsif ($tokenpat->[0] eq 'E') {
561: #clear out any tags that didn't end
562: while ($tokenpat->[1] ne $innerstack[$#innerstack]
563: && ($#innerstack > -1)) {
564: &Apache::lonxml::warning("Unbalanced tags in resource $innerstack['-1']");
565: &end_tag(\@innerstack,\@innerparstack,$tokenpat);
566: }
567: $partstring = &callsub("end_$tokenpat->[1]", $target, $tokenpat,
568: \@innerstack, \@innerparstack, \@pat,
569: $safeeval, $style_for_target);
570: } else {
571: &Apache::lonxml::error("Unknown token event :$tokenpat->[0]:$tokenpat->[1]:");
572: }
573: #pass both the variable to the style tag, and the tag we
574: #are processing inside the <definedtag>
575: if ( $partstring ne "" ) {
576: if ( $#parstack > -1 ) {
577: if ( $#innerparstack > -1 ) {
578: $decls= $parstack[$#parstack].$innerparstack[$#innerparstack];
579: } else {
580: $decls= $parstack[$#parstack];
581: }
582: } else {
583: if ( $#innerparstack > -1 ) {
584: $decls=$innerparstack[$#innerparstack];
585: } else {
586: $decls='';
587: }
588: }
589: $output .= &Apache::run::evaluate($partstring,$safeeval,$decls);
590: $partstring = '';
591: }
592: if ($tokenpat->[0] eq 'E') { pop @innerstack;pop @innerparstack;
593: &decreasedepth($tokenpat);}
594: }
595: pop @pat;
596: pop @Apache::lonxml::pwd;
597: }
598: return $output;
599: }
600:
601: sub callsub {
602: my ($sub,$target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
603: my $currentstring='';
604: my $nodefault;
605: {
606: my $sub1;
607: no strict 'refs';
608: my $tag=$token->[1];
609: my $space=$Apache::lonxml::alltags{$tag};
610: if (!$space) {
611: $tag=~tr/A-Z/a-z/;
612: $sub=~tr/A-Z/a-z/;
613: $space=$Apache::lonxml::alltags{$tag}
614: }
615:
616: my $deleted=0;
617: $Apache::lonxml::curdepth=join('_',@Apache::lonxml::depthcounter);
618: if (($token->[0] eq 'S') && ($target eq 'modified')) {
619: $deleted=&Apache::edit::handle_delete($space,$target,$token,$tagstack,
620: $parstack,$parser,$safeeval,
621: $style);
622: }
623: if (!$deleted) {
624: if ($space) {
625: #&Apache::lonxml::debug("Calling sub $sub in $space $metamode<br />\n");
626: $sub1="$space\:\:$sub";
627: ($currentstring,$nodefault) = &$sub1($target,$token,$tagstack,
628: $parstack,$parser,$safeeval,
629: $style);
630: } else {
631: #&Apache::lonxml::debug("NOT Calling sub $sub in $space $metamode<br />\n");
632: if ($metamode <1) {
633: if (defined($token->[4]) && ($metamode < 1)) {
634: $currentstring = $token->[4];
635: } else {
636: $currentstring = $token->[2];
637: }
638: }
639: }
640: # &Apache::lonxml::debug("nodefalt:$nodefault:");
641: if ($currentstring eq '' && $nodefault eq '') {
642: if ($target eq 'edit') {
643: &Apache::lonxml::debug("doing default edit for $token->[1]");
644: if ($token->[0] eq 'S') {
645: $currentstring = &Apache::edit::tag_start($target,$token);
646: } elsif ($token->[0] eq 'E') {
647: $currentstring = &Apache::edit::tag_end($target,$token);
648: }
649: } elsif ($target eq 'modified') {
650: if ($token->[0] eq 'S') {
651: $currentstring = $token->[4];
652: $currentstring.=&Apache::edit::handle_insert();
653: } else {
654: $currentstring = $token->[2];
655: }
656: }
657: }
658: }
659: use strict 'refs';
660: }
661: return $currentstring;
662: }
663:
664: sub setup_globals {
665: my ($target)=@_;
666: $Apache::lonxml::registered = 0;
667: @Apache::lonxml::pwd=();
668: @Apache::lonxml::extlinks=();
669: if ($target eq 'meta') {
670: $Apache::lonxml::redirection = 0;
671: $Apache::lonxml::metamode = 1;
672: $Apache::lonxml::evaluate = 1;
673: $Apache::lonxml::import = 0;
674: } elsif ($target eq 'answer') {
675: $Apache::lonxml::redirection = 0;
676: $Apache::lonxml::metamode = 1;
677: $Apache::lonxml::evaluate = 1;
678: $Apache::lonxml::import = 1;
679: } elsif ($target eq 'grade') {
680: &startredirection;
681: $Apache::lonxml::metamode = 0;
682: $Apache::lonxml::evaluate = 1;
683: $Apache::lonxml::import = 1;
684: } elsif ($target eq 'modified') {
685: $Apache::lonxml::redirection = 0;
686: $Apache::lonxml::metamode = 0;
687: $Apache::lonxml::evaluate = 0;
688: $Apache::lonxml::import = 0;
689: } elsif ($target eq 'edit') {
690: $Apache::lonxml::redirection = 0;
691: $Apache::lonxml::metamode = 0;
692: $Apache::lonxml::evaluate = 0;
693: $Apache::lonxml::import = 0;
694: } else {
695: $Apache::lonxml::redirection = 0;
696: $Apache::lonxml::metamode = 0;
697: $Apache::lonxml::evaluate = 1;
698: $Apache::lonxml::import = 1;
699: }
700: }
701:
702: sub init_safespace {
703: my ($target,$safeeval,$safehole,$safeinit) = @_;
704: $safeeval->permit("entereval");
705: $safeeval->permit(":base_math");
706: $safeeval->permit("sort");
707: $safeeval->deny(":base_io");
708: $safehole->wrap(\&Apache::scripttag::xmlparse,$safeeval,'&xmlparse');
709: $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT');
710:
711: $safehole->wrap(\&Math::Cephes::asin,$safeeval,'&asin');
712: $safehole->wrap(\&Math::Cephes::acos,$safeeval,'&acos');
713: $safehole->wrap(\&Math::Cephes::atan,$safeeval,'&atan');
714: $safehole->wrap(\&Math::Cephes::sinh,$safeeval,'&sinh');
715: $safehole->wrap(\&Math::Cephes::cosh,$safeeval,'&cosh');
716: $safehole->wrap(\&Math::Cephes::tanh,$safeeval,'&tanh');
717: $safehole->wrap(\&Math::Cephes::asinh,$safeeval,'&asinh');
718: $safehole->wrap(\&Math::Cephes::acosh,$safeeval,'&acosh');
719: $safehole->wrap(\&Math::Cephes::atanh,$safeeval,'&atanh');
720: $safehole->wrap(\&Math::Cephes::erf,$safeeval,'&erf');
721: $safehole->wrap(\&Math::Cephes::erfc,$safeeval,'&erfc');
722: $safehole->wrap(\&Math::Cephes::j0,$safeeval,'&j0');
723: $safehole->wrap(\&Math::Cephes::j1,$safeeval,'&j1');
724: $safehole->wrap(\&Math::Cephes::jn,$safeeval,'&jn');
725: $safehole->wrap(\&Math::Cephes::jv,$safeeval,'&jv');
726: $safehole->wrap(\&Math::Cephes::y0,$safeeval,'&y0');
727: $safehole->wrap(\&Math::Cephes::y1,$safeeval,'&y1');
728: $safehole->wrap(\&Math::Cephes::yn,$safeeval,'&yn');
729: $safehole->wrap(\&Math::Cephes::yv,$safeeval,'&yv');
730: $safehole->wrap(\&Math::Random::random_beta,$safeeval,'&math_random_beta');
731: $safehole->wrap(\&Math::Random::random_chi_square,$safeeval,'&math_random_chi_square');
732: $safehole->wrap(\&Math::Random::random_exponential,$safeeval,'&math_random_exponential');
733: $safehole->wrap(\&Math::Random::random_f,$safeeval,'&math_random_f');
734: $safehole->wrap(\&Math::Random::random_gamma,$safeeval,'&math_random_gamma');
735: $safehole->wrap(\&Math::Random::random_multivariate_normal,$safeeval,'&math_random_multivariate_normal');
736: $safehole->wrap(\&Math::Random::random_multinomial,$safeeval,'&math_random_multinomial');
737: $safehole->wrap(\&Math::Random::random_noncentral_chi_square,$safeeval,'&math_random_noncentral_chi_square');
738: $safehole->wrap(\&Math::Random::random_noncentral_f,$safeeval,'&math_random_noncentral_f');
739: $safehole->wrap(\&Math::Random::random_normal,$safeeval,'&math_random_normal');
740: $safehole->wrap(\&Math::Random::random_permutation,$safeeval,'&math_random_permutation');
741: $safehole->wrap(\&Math::Random::random_permuted_index,$safeeval,'&math_random_permuted_index');
742: $safehole->wrap(\&Math::Random::random_uniform,$safeeval,'&math_random_uniform');
743: $safehole->wrap(\&Math::Random::random_poisson,$safeeval,'&math_random_poisson');
744: $safehole->wrap(\&Math::Random::random_uniform_integer,$safeeval,'&math_random_uniform_integer');
745: $safehole->wrap(\&Math::Random::random_negative_binomial,$safeeval,'&math_random_negative_binomial');
746: $safehole->wrap(\&Math::Random::random_binomial,$safeeval,'&math_random_binomial');
747: $safehole->wrap(\&Math::Random::random_seed_from_phrase,$safeeval,'&random_seed_from_phrase');
748: $safehole->wrap(\&Math::Random::random_set_seed_from_phrase,$safeeval,'&random_set_seed_from_phrase');
749: $safehole->wrap(\&Math::Random::random_get_seed,$safeeval,'&random_get_seed');
750: $safehole->wrap(\&Math::Random::random_set_seed,$safeeval,'&random_set_seed');
751:
752: #need to inspect this class of ops
753: # $safeeval->deny(":base_orig");
754: $safeinit .= ';$external::target="'.$target.'";';
755: my $rndseed;
756: my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
757: $rndseed=&Apache::lonnet::rndseed($symb,$courseid,$domain,$name);
758: $safeinit .= ';$external::randomseed='.$rndseed.';';
759: &Apache::run::run($safeinit,$safeeval);
760: }
761:
762: sub startredirection {
763: $Apache::lonxml::redirection++;
764: push (@Apache::lonxml::outputstack, '');
765: }
766:
767: sub endredirection {
768: if (!$Apache::lonxml::redirection) {
769: &Apache::lonxml::error("Endredirection was called, before a startredirection, perhaps you have unbalanced tags. Some debuging information:".join ":",caller);
770: return '';
771: }
772: $Apache::lonxml::redirection--;
773: pop @Apache::lonxml::outputstack;
774: }
775:
776: sub end_tag {
777: my ($tagstack,$parstack,$token)=@_;
778: pop(@$tagstack);
779: pop(@$parstack);
780: &decreasedepth($token);
781: }
782:
783: sub initdepth {
784: @Apache::lonxml::depthcounter=();
785: $Apache::lonxml::depth=-1;
786: $Apache::lonxml::olddepth=-1;
787: }
788:
789: sub increasedepth {
790: my ($token) = @_;
791: $Apache::lonxml::depth++;
792: $Apache::lonxml::depthcounter[$Apache::lonxml::depth]++;
793: if ($Apache::lonxml::depthcounter[$Apache::lonxml::depth]==1) {
794: $Apache::lonxml::olddepth=$Apache::lonxml::depth;
795: }
796: my $curdepth=join('_',@Apache::lonxml::depthcounter);
797: &Apache::lonxml::debug("s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n");
798: #print "<br />s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n";
799: }
800:
801: sub decreasedepth {
802: my ($token) = @_;
803: $Apache::lonxml::depth--;
804: if ($Apache::lonxml::depth<$Apache::lonxml::olddepth-1) {
805: $#Apache::lonxml::depthcounter--;
806: $Apache::lonxml::olddepth=$Apache::lonxml::depth+1;
807: }
808: if ( $Apache::lonxml::depth < -1) {
809: &Apache::lonxml::warning("Unbalanced tags in resource");
810: $Apache::lonxml::depth='-1';
811: }
812: my $curdepth=join('_',@Apache::lonxml::depthcounter);
813: &Apache::lonxml::debug("e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n");
814: #print "<br />e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n";
815: }
816:
817: sub get_all_text {
818:
819: my($tag,$pars)= @_;
820: my $depth=0;
821: my $token;
822: my $result='';
823: if ( $tag =~ m:^/: ) {
824: my $tag=substr($tag,1);
825: # &Apache::lonxml::debug("have:$tag:");
826: while (($depth >=0) && ($token = $pars->get_token)) {
827: # &Apache::lonxml::debug("e token:$token->[0]:$depth:$token->[1]");
828: if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) {
829: $result.=$token->[1];
830: } elsif ($token->[0] eq 'PI') {
831: $result.=$token->[2];
832: } elsif ($token->[0] eq 'S') {
833: if ($token->[1] eq $tag) { $depth++; }
834: $result.=$token->[4];
835: } elsif ($token->[0] eq 'E') {
836: if ( $token->[1] eq $tag) { $depth--; }
837: #skip sending back the last end tag
838: if ($depth > -1) { $result.=$token->[2]; } else {
839: $pars->unget_token($token);
840: }
841: }
842: }
843: } else {
844: while ($token = $pars->get_token) {
845: # &Apache::lonxml::debug("s token:$token->[0]:$depth:$token->[1]");
846: if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) {
847: $result.=$token->[1];
848: } elsif ($token->[0] eq 'PI') {
849: $result.=$token->[2];
850: } elsif ($token->[0] eq 'S') {
851: if ( $token->[1] eq $tag) {
852: $pars->unget_token($token); last;
853: } else {
854: $result.=$token->[4];
855: }
856: } elsif ($token->[0] eq 'E') {
857: $result.=$token->[2];
858: }
859: }
860: }
861: # &Apache::lonxml::debug("Exit:$result:");
862: return $result
863: }
864:
865: sub newparser {
866: my ($parser,$contentref,$dir) = @_;
867: push (@$parser,HTML::TokeParser->new($contentref));
868: $$parser['-1']->xml_mode('1');
869: if ( $dir eq '' ) {
870: push (@Apache::lonxml::pwd, $Apache::lonxml::pwd[$#Apache::lonxml::pwd]);
871: } else {
872: push (@Apache::lonxml::pwd, $dir);
873: }
874: # &Apache::lonxml::debug("pwd:$#Apache::lonxml::pwd");
875: # &Apache::lonxml::debug("pwd:$Apache::lonxml::pwd[$#Apache::lonxml::pwd]");
876: }
877:
878: sub parstring {
879: my ($token) = @_;
880: my $temp='';
881: map {
882: unless ($_=~/\W/) {
883: my $val=$token->[2]->{$_};
884: $val =~ s/([\%\@\\])/\\$1/g;
885: #if ($val =~ m/^[\%\@]/) { $val="\\".$val; }
886: $temp .= "my \$$_=\"$val\";"
887: }
888: } @{$token->[3]};
889: return $temp;
890: }
891:
892: sub writeallows {
893: unless ($#extlinks>=0) { return; }
894: my $thisurl='/res/'.&Apache::lonnet::declutter(shift);
895: if ($ENV{'httpref.'.$thisurl}) {
896: $thisurl=$ENV{'httpref.'.$thisurl};
897: }
898: my $thisdir=$thisurl;
899: $thisdir=~s/\/[^\/]+$//;
900: my %httpref=();
901: map {
902: $httpref{'httpref.'.
903: &Apache::lonnet::hreflocation($thisdir,$_)}=$thisurl;
904: } @extlinks;
905: @extlinks=();
906: &Apache::lonnet::appenv(%httpref);
907: }
908:
909: #
910: # Afterburner handles anchors, highlights and links
911: #
912: sub afterburn {
913: my $result=shift;
914: map {
915: my ($name, $value) = split(/=/,$_);
916: $value =~ tr/+/ /;
917: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
918: if (($name eq 'highlight')||($name eq 'anchor')||($name eq 'link')) {
919: unless ($ENV{'form.'.$name}) {
920: $ENV{'form.'.$name}=$value;
921: }
922: }
923: } (split(/&/,$ENV{'QUERY_STRING'}));
924: if ($ENV{'form.highlight'}) {
925: map {
926: my $anchorname=$_;
927: my $matchthis=$anchorname;
928: $matchthis=~s/\_+/\\s\+/g;
929: $result=~s/($matchthis)/\<font color=\"red\"\>$1\<\/font\>/gs;
930: } split(/\,/,$ENV{'form.highlight'});
931: }
932: if ($ENV{'form.link'}) {
933: map {
934: my ($anchorname,$linkurl)=split(/\>/,$_);
935: my $matchthis=$anchorname;
936: $matchthis=~s/\_+/\\s\+/g;
937: $result=~s/($matchthis)/\<a href=\"$linkurl\"\>$1\<\/a\>/gs;
938: } split(/\,/,$ENV{'form.link'});
939: }
940: if ($ENV{'form.anchor'}) {
941: my $anchorname=$ENV{'form.anchor'};
942: my $matchthis=$anchorname;
943: $matchthis=~s/\_+/\\s\+/g;
944: $result=~s/($matchthis)/\<a name=\"$anchorname\"\>$1\<\/a\>/s;
945: $result.=(<<"ENDSCRIPT");
946: <script>
947: document.location.hash='$anchorname';
948: </script>
949: ENDSCRIPT
950: }
951: return $result;
952: }
953:
954: sub storefile {
955: my ($file,$contents)=@_;
956: if (my $fh=Apache::File->new('>'.$file)) {
957: print $fh $contents;
958: $fh->close();
959: }
960: }
961:
962: sub inserteditinfo {
963: my ($result,$filecontents)=@_;
964: unless ($filecontents) {
965: $filecontents=(<<SIMPLECONTENT);
966: <html>
967: <head>
968: <title>
969: Title of Document Goes Here
970: </title>
971: </head>
972: <body bgcolor="#FFFFFF">
973:
974: Body of Document Goes Here
975:
976: </body>
977: </html>
978: SIMPLECONTENT
979: }
980: my $editheader='<a href="#editsection">Edit below</a><hr />';
981: my $editfooter=(<<ENDFOOTER);
982: <hr />
983: <a name="editsection" />
984: <form method="post">
985: <textarea cols="80" rows="40" name="filecont">$filecontents</textarea>
986: <br />
987: <input type="submit" name="attemptclean"
988: value="Save and then attempt to clean HTML" />
989: <input type="submit" name="savethisfile" value="Save this" />
990: </form>
991: ENDFOOTER
992: $result=~s/(\<body[^\>]*\>)/$1$editheader/is;
993: $result=~s/(\<\/body\>)/$editfooter/is;
994: return $result;
995: }
996:
997: sub handler {
998: my $request=shift;
999:
1000: my $target='web';
1001:
1002: $Apache::lonxml::debug=0;
1003:
1004: if ($ENV{'browser.mathml'}) {
1005: $request->content_type('text/xml');
1006: } else {
1007: $request->content_type('text/html');
1008: }
1009:
1010: $request->send_http_header;
1011:
1012: return OK if $request->header_only;
1013:
1014:
1015: my $file=&Apache::lonnet::filelocation("",$request->uri);
1016: #
1017: # Edit action? Save file.
1018: #
1019: unless ($ENV{'request.state'} eq 'published') {
1020: if (($ENV{'form.savethisfile'}) || ($ENV{'form.attemptclean'})) {
1021: &storefile($file,$ENV{'form.filecont'});
1022: }
1023: }
1024: my %mystyle;
1025: my $result = '';
1026: my $filecontents=&Apache::lonnet::getfile($file);
1027: if ($filecontents == -1) {
1028: $result=(<<ENDNOTFOUND);
1029: <html>
1030: <head>
1031: <title>File not found</title>
1032: </head>
1033: <body bgcolor="#FFFFFF">
1034: <b>File not found: $file</b>
1035: </body>
1036: </html>
1037: ENDNOTFOUND
1038: $filecontents='';
1039: } else {
1040: unless ($ENV{'request.state'} eq 'published') {
1041: if ($ENV{'form.attemptclean'}) {
1042: $filecontents=&htmlclean($filecontents,1);
1043: }
1044: }
1045: $result = &Apache::lonxml::xmlparse($target,$filecontents,'',%mystyle);
1046: }
1047:
1048: #
1049: # Edit action? Insert editing commands
1050: #
1051: unless ($ENV{'request.state'} eq 'published') {
1052: $result=&inserteditinfo($result,$filecontents);
1053: }
1054:
1055: writeallows($request->uri);
1056:
1057: $request->print($result);
1058:
1059: return OK;
1060: }
1061:
1062: sub debug {
1063: if ($Apache::lonxml::debug eq 1) {
1064: print("DEBUG:".$_[0]."<br />\n");
1065: }
1066: }
1067:
1068: sub error {
1069: if (($Apache::lonxml::debug eq 1) || ($ENV{'request.state'} eq 'construct') ) {
1070: print "<b>ERROR:</b>".$_[0]."<br />\n";
1071: } else {
1072: print "<b>An Error occured while processing this resource. The instructor has been notified.</b> <br />";
1073: #notify author
1074: &Apache::lonmsg::author_res_msg($ENV{'request.filename'},$_[0]);
1075: #notify course
1076: if ( $ENV{'request.course.id'} ) {
1077: my $users=$ENV{'course.'.$ENV{'request.course.id'}.'.comment.email'};
1078: foreach my $user (split /\,/, $users) {
1079: ($user,my $domain) = split /:/, $user;
1080: &Apache::lonmsg::user_normal_msg($user,$domain,"Error in $ENV{'request.filename'}",$_[0]);
1081: }
1082: }
1083:
1084: #FIXME probably shouldn't have me get everything forever.
1085: &Apache::lonmsg::user_normal_msg('albertel','msu',"Error in $ENV{'request.filename'}",$_[0]);
1086: #&Apache::lonmsg::user_normal_msg('albertel','103',"Error in $ENV{'request.filename'}",$_[0]);
1087: }
1088: }
1089:
1090: sub warning {
1091: if ($ENV{'request.state'} eq 'construct') {
1092: print "<b>W</b>ARNING<b>:</b>".$_[0]."<br />\n";
1093: }
1094: }
1095:
1096: sub get_param {
1097: my ($param,$parstack,$safeeval,$context) = @_;
1098: if ( ! $context ) { $context = -1; }
1099: my $args ='';
1100: if ( $#$parstack > (-2-$context) ) { $args=$$parstack[$context]; }
1101: if ( $args =~ /my \$$param=\"/ ) {
1102: return &Apache::run::run("{$args;".'return $'.$param.'}',$safeeval); #'
1103: } else {
1104: return undef;
1105: }
1106: }
1107:
1108: sub get_param_var {
1109: my ($param,$parstack,$safeeval,$context) = @_;
1110: if ( ! $context ) { $context = -1; }
1111: my $args ='';
1112: if ( $#$parstack > (-2-$context) ) { $args=$$parstack[$context]; }
1113: if ( $args !~ /my \$$param=\"/ ) { return undef; }
1114: my $value=&Apache::run::run("{$args;".'return $'.$param.'}',$safeeval); #'
1115: if ($value =~ /^[\$\@\%]/) {
1116: return &Apache::run::run("return $value",$safeeval,1);
1117: } else {
1118: return $value;
1119: }
1120: }
1121:
1122: sub register_insert {
1123: my @data = split /\n/, &Apache::lonnet::getfile('/home/httpd/lonTabs/insertlist.tab');
1124: my $i;
1125: my $tagnum=0;
1126: my @order;
1127: for ($i=0;$i < $#data; $i++) {
1128: my $line = $data[$i];
1129: if ( $line =~ /^\#/ || $line =~ /^\s*\n/) { next; }
1130: if ( $line =~ /TABLE/ ) { last; }
1131: my ($tag,$descrip,$color,$function,$show) = split(/,/, $line);
1132: $insertlist{"$tagnum.tag"} = $tag;
1133: $insertlist{"$tagnum.description"} = $descrip;
1134: $insertlist{"$tagnum.color"} = $color;
1135: $insertlist{"$tagnum.function"} = $function;
1136: $insertlist{"$tagnum.show"}= $show;
1137: $insertlist{"$tag.num"}=$tagnum;
1138: $tagnum++;
1139: }
1140: $i++; #skipping TABLE line
1141: $tagnum = 0;
1142: for (;$i < $#data;$i++) {
1143: my $line = $data[$i];
1144: my ($mnemonic,@which) = split(/ +/,$line);
1145: my $tag = $insertlist{"$tagnum.tag"};
1146: for (my $j=0;$j <$#which;$j++) {
1147: if ( $which[$j] eq 'Y' ) {
1148: if ($insertlist{"$j.show"} ne 'no') {
1149: push(@{ $insertlist{"$tag.which"} },$j);
1150: }
1151: }
1152: }
1153: $tagnum++;
1154: }
1155: }
1156:
1157: sub description {
1158: my ($token)=@_;
1159: return $insertlist{$insertlist{"$token->[1].num"}.'.description'};
1160: }
1161:
1162: # ----------------------------------------------------------------- whichuser
1163: # returns a list of $symb, $courseid, $domain, $name that is correct for
1164: # calls to lonnet functions for this setup.
1165: # - looks for form.grade_ parameters
1166: sub whichuser {
1167: my $symb=&Apache::lonnet::symbread();
1168: my $courseid=$ENV{'request.course.id'};
1169: my $domain=$ENV{'user.domain'};
1170: my $name=$ENV{'user.name'};
1171: if (defined($ENV{'form.grade_symb'})) {
1172: my $tmp_courseid=$ENV{'form.grade_courseid'};
1173: my $allowed=&Apache::lonnet::allowed('mgr',$tmp_courseid);
1174: if ($allowed) {
1175: $symb=$ENV{'form.grade_symb'};
1176: $courseid=$ENV{'form.grade_courseid'};
1177: $domain=$ENV{'form.grade_domain'};
1178: $name=$ENV{'form.grade_username'};
1179: }
1180: }
1181: return ($symb,$courseid,$domain,$name);
1182: }
1183:
1184: 1;
1185: __END__
1186:
1187:
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