loncom/xml/lonxml.pm - view

File: [LON-CAPA] / loncom / xml / lonxml.pm
Revision 1.236: download - view: text, annotated - select for diffs
Wed Feb 19 14:55:27 2003 UTC (21 years, 5 months ago) by www
Branches: MAIN
CVS tags: HEAD

Filter out x-tended HTML tags as produced by Claris Homepage, for example
<x-claris-tagview>. Kept many documents from printing. Could not be dealt
with by normal callsub mechanism, because Perl subroutine names must be
alphanumeric.

1: # The LearningOnline Network with CAPA 2: # XML Parser Module 3: # 4: # $Id: lonxml.pm,v 1.236 2003/02/19 14:55:27 www Exp $ 5: # 6: # Copyright Michigan State University Board of Trustees 7: # 8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 9: # 10: # LON-CAPA is free software; you can redistribute it and/or modify 11: # it under the terms of the GNU General Public License as published by 12: # the Free Software Foundation; either version 2 of the License, or 13: # (at your option) any later version. 14: # 15: # LON-CAPA is distributed in the hope that it will be useful, 16: # but WITHOUT ANY WARRANTY; without even the implied warranty of 17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18: # GNU General Public License for more details. 19: # 20: # You should have received a copy of the GNU General Public License 21: # along with LON-CAPA; if not, write to the Free Software 22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 23: # 24: # /home/httpd/html/adm/gpl.txt 25: # 26: # http://www.lon-capa.org/ 27: # 28: # Copyright for TtHfunc and TtMfunc by Ian Hutchinson. 29: # TtHfunc and TtMfunc (the "Code") may be compiled and linked into 30: # binary executable programs or libraries distributed by the 31: # Michigan State University (the "Licensee"), but any binaries so 32: # distributed are hereby licensed only for use in the context 33: # of a program or computational system for which the Licensee is the 34: # primary author or distributor, and which performs substantial 35: # additional tasks beyond the translation of (La)TeX into HTML. 36: # The C source of the Code may not be distributed by the Licensee 37: # to any other parties under any circumstances. 38: # 39: # last modified 06/26/00 by Alexander Sakharuk 40: # 11/6 Gerd Kortemeyer 41: # 6/1/1 Gerd Kortemeyer 42: # 2/21,3/13 Guy 43: # 3/29,5/4 Gerd Kortemeyer 44: # 5/26 Gerd Kortemeyer 45: # 5/27 H. K. Ng 46: # 6/2,6/3,6/8,6/9 Gerd Kortemeyer 47: # 6/12,6/13 H. K. Ng 48: # 6/16 Gerd Kortemeyer 49: # 7/27 H. K. Ng 50: # 8/7,8/9,8/10,8/11,8/15,8/16,8/17,8/18,8/20,8/23,8/24 Gerd Kortemeyer 51: # Guy Albertelli 52: # 9/26 Gerd Kortemeyer 53: # Dec Guy Albertelli 54: # YEAR=2002 55: # 1/1 Gerd Kortemeyer 56: # 1/2 Matthew Hall 57: # 1/3 Gerd Kortemeyer 58: # 59: 60: package Apache::lonxml; 61: use vars 62: qw(@pwd @outputstack $redirection $import @extlinks $metamode $evaluate %insertlist @namespace $prevent_entity_encode $errorcount $warningcount); 63: use strict; 64: use HTML::LCParser(); 65: use HTML::TreeBuilder(); 66: use HTML::Entities(); 67: use Safe(); 68: use Safe::Hole(); 69: use Math::Cephes(); 70: use Math::Random(); 71: use Opcode(); 72: 73: sub register { 74: my ($space,@taglist) = @_; 75: foreach my $temptag (@taglist) { 76: push(@{ $Apache::lonxml::alltags{$temptag} },$space); 77: } 78: } 79: 80: sub deregister { 81: my ($space,@taglist) = @_; 82: foreach my $temptag (@taglist) { 83: my $tempspace = $Apache::lonxml::alltags{$temptag}[-1]; 84: if ($tempspace eq $space) { 85: pop(@{ $Apache::lonxml::alltags{$temptag} }); 86: } 87: } 88: #&printalltags(); 89: } 90: 91: use Apache::Constants qw(:common); 92: use Apache::lontexconvert(); 93: use Apache::style(); 94: use Apache::run(); 95: use Apache::londefdef(); 96: use Apache::scripttag(); 97: use Apache::edit(); 98: use Apache::lonnet(); 99: use Apache::File(); 100: use Apache::loncommon(); 101: use Apache::lonfeedback(); 102: use Apache::lonmsg(); 103: use Apache::loncacc(); 104: 105: #================================================== Main subroutine: xmlparse 106: #debugging control, to turn on debugging modify the correct handler 107: $Apache::lonxml::debug=0; 108: 109: # keeps count of the number of warnings and errors generated in a parse 110: $warningcount=0; 111: $errorcount=0; 112: 113: #path to the directory containing the file currently being processed 114: @pwd=(); 115: 116: #these two are used for capturing a subset of the output for later processing, 117: #don't touch them directly use &startredirection and &endredirection 118: @outputstack = (); 119: $redirection = 0; 120: 121: #controls wheter the <import> tag actually does 122: $import = 1; 123: @extlinks=(); 124: 125: # meta mode is a bit weird only some output is to be turned off 126: #<output> tag turns metamode off (defined in londefdef.pm) 127: $metamode = 0; 128: 129: # turns on and of run::evaluate actually derefencing var refs 130: $evaluate = 1; 131: 132: # data structure for eidt mode, determines what tags can go into what other tags 133: %insertlist=(); 134: 135: # stores the list of active tag namespaces 136: @namespace=(); 137: 138: # if 0 all high ASCII characters will be encoded into HTML Entities 139: $prevent_entity_encode=0; 140: 141: # has the dynamic menu been updated to know about this resource 142: $Apache::lonxml::registered=0; 143: 144: # a pointer the the Apache request object 145: $Apache::lonxml::request=''; 146: 147: # a problem number counter, and check on ether it is used 148: $Apache::lonxml::counter=4; 149: $Apache::lonxml::counter_changed=0; 150: 151: #internal check on whether to look at style defs 152: $Apache::lonxml::usestyle=1; 153: 154: sub xmlbegin { 155: my $output=''; 156: if ($ENV{'browser.mathml'}) { 157: $output='<?xml version="1.0"?>' 158: .'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>' 159: .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" ' 160: .'[<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">]>' 161: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" ' 162: .'xmlns="http://www.w3.org/TR/REC-html40">'; 163: } else { 164: $output='<html>'; 165: } 166: return $output; 167: } 168: 169: sub xmlend { 170: my ($discussiononly,$symb)=@_; 171: my $discussion=''; 172: if ($ENV{'request.course.id'}) { 173: my $crs='/'.$ENV{'request.course.id'}; 174: if ($ENV{'request.course.sec'}) { 175: $crs.='_'.$ENV{'request.course.sec'}; 176: } 177: $crs=~s/\_/\//g; 178: my $seeid=&Apache::lonnet::allowed('rin',$crs); 179: unless ($symb) { 180: $symb=&Apache::lonnet::symbread(); 181: } 182: if ($symb) { 183: my %contrib=&Apache::lonnet::restore($symb,$ENV{'request.course.id'}, 184: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, 185: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}); 186: if ($contrib{'version'}) { 187: unless ($discussiononly) { 188: $discussion.= 189: '<address><hr />'; 190: } 191: my $idx; 192: for ($idx=1;$idx<=$contrib{'version'};$idx++) { 193: my $hidden=($contrib{'hidden'}=~/\.$idx\./); 194: my $deleted=($contrib{'deleted'}=~/\.$idx\./); 195: unless ((($hidden) && (!$seeid)) || ($deleted)) { 196: my $message=$contrib{$idx.':message'}; 197: $message=~s/\n/\<br \/\>/g; 198: $message=&Apache::lontexconvert::msgtexconverted($message); 199: if ($message) { 200: if ($hidden) { 201: $message='<font color="#888888">'.$message.'</font>'; 202: } 203: my $screenname=&Apache::loncommon::screenname( 204: $contrib{$idx.':sendername'}, 205: $contrib{$idx.':senderdomain'}); 206: my $plainname=&Apache::loncommon::nickname( 207: $contrib{$idx.':sendername'}, 208: $contrib{$idx.':senderdomain'}); 209: 210: my $sender='Anonymous'; 211: if ((!$contrib{$idx.':anonymous'}) || ($seeid)) { 212: $sender=&Apache::loncommon::aboutmewrapper( 213: $plainname, 214: $contrib{$idx.':sendername'}, 215: $contrib{$idx.':senderdomain'}).' ('. 216: $contrib{$idx.':sendername'}.' at '. 217: $contrib{$idx.':senderdomain'}.')'; 218: if ($contrib{$idx.':anonymous'}) { 219: $sender.=' [anonymous] '. 220: $screenname; 221: } 222: if ($seeid) { 223: if ($hidden) { 224: $sender.=' <a href="/adm/feedback?unhide='. 225: $symb.':::'.$idx.'">Make Visible</a>'; 226: } else { 227: $sender.=' <a href="/adm/feedback?hide='. 228: $symb.':::'.$idx.'">Hide</a>'; 229: } 230: $sender.=' <a href="/adm/feedback?deldisc='. 231: $symb.':::'.$idx.'">Delete</a>'; 232: } 233: } else { 234: if ($screenname) { 235: $sender='<i>'.$screenname.'</i>'; 236: } 237: } 238: $discussion.='<p><b>'.$sender.'</b> ('. 239: localtime($contrib{$idx.':timestamp'}). 240: '):<blockquote>'.$message. 241: '</blockquote></p>'; 242: } 243: } 244: } 245: unless ($discussiononly) { 246: $discussion.='</address>'; 247: } 248: } 249: if ($discussiononly) { 250: $discussion.=(<<ENDDISCUSS); 251: <form action="/adm/feedback" method="post" name="mailform"> 252: <input type="submit" name="discuss" value="Post Discussion" /> 253: <input type="submit" name="anondiscuss" value="Post Anonymous Discussion" /> 254: <input type="hidden" name="symb" value="$symb" /> 255: <input type="hidden" name="sendit" value="true" /> 256: <br /> 257: <font size="1">Note: in anonymous discussion, your name is visible only to 258: course faculty</font><br /> 259: <textarea name=comment cols=60 rows=10 wrap=hard></textarea> 260: </form> 261: ENDDISCUSS 262: $discussion.=&Apache::lonfeedback::generate_preview_button(); 263: } 264: } 265: } 266: return $discussion.($discussiononly?'':'</html>'); 267: } 268: 269: sub tokeninputfield { 270: my $defhost=$Apache::lonnet::perlvar{'lonHostID'}; 271: $defhost=~tr/a-z/A-Z/; 272: return (<<ENDINPUTFIELD) 273: <script type="text/javascript"> 274: function updatetoken() { 275: var comp=new Array; 276: var barcode=unescape(document.tokeninput.barcode.value); 277: comp=barcode.split('*'); 278: if (typeof(comp[0])!="undefined") { 279: document.tokeninput.codeone.value=comp[0]; 280: } 281: if (typeof(comp[1])!="undefined") { 282: document.tokeninput.codetwo.value=comp[1]; 283: } 284: if (typeof(comp[2])!="undefined") { 285: comp[2]=comp[2].toUpperCase(); 286: document.tokeninput.codethree.value=comp[2]; 287: } 288: document.tokeninput.barcode.value=''; 289: } 290: </script> 291: <form method="post" name="tokeninput"> 292: <table border="2" bgcolor="#FFFFBB"> 293: <tr><th>DocID Checkin</th></tr> 294: <tr><td> 295: <table> 296: <tr> 297: <td>Scan in Barcode</td> 298: <td><input type="text" size="22" name="barcode" 299: onChange="updatetoken()"/></td> 300: </tr> 301: <tr><td><i>or</i> Type in DocID</td> 302: <td> 303: <input type="text" size="5" name="codeone" /> 304: <b><font size="+2">*</font></b> 305: <input type="text" size="5" name="codetwo" /> 306: <b><font size="+2">*</font></b> 307: <input type="text" size="10" name="codethree" value="$defhost" 308: onChange="this.value=this.value.toUpperCase()" /> 309: </td></tr> 310: </table> 311: </td></tr> 312: <tr><td><input type="submit" value="Check in DocID" /></td></tr> 313: </table> 314: </form> 315: ENDINPUTFIELD 316: } 317: 318: sub maketoken { 319: my ($symb,$tuname,$tudom,$tcrsid)=@_; 320: unless ($symb) { 321: $symb=&Apache::lonnet::symbread(); 322: } 323: unless ($tuname) { 324: $tuname=$ENV{'user.name'}; 325: $tudom=$ENV{'user.domain'}; 326: $tcrsid=$ENV{'request.course.id'}; 327: } 328: 329: return &Apache::lonnet::checkout($symb,$tuname,$tudom,$tcrsid); 330: } 331: 332: sub printtokenheader { 333: my ($target,$token,$tsymb,$tcrsid,$tudom,$tuname)=@_; 334: unless ($token) { return ''; } 335: 336: my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); 337: unless ($tsymb) { 338: $tsymb=$symb; 339: } 340: unless ($tuname) { 341: $tuname=$name; 342: $tudom=$domain; 343: $tcrsid=$courseid; 344: } 345: 346: my %reply=&Apache::lonnet::get('environment', 347: ['firstname','middlename','lastname','generation'], 348: $tudom,$tuname); 349: my $plainname=$reply{'firstname'}.' '. 350: $reply{'middlename'}.' '. 351: $reply{'lastname'}.' '. 352: $reply{'generation'}; 353: 354: if ($target eq 'web') { 355: my %idhash=&Apache::lonnet::idrget($tudom,($tuname)); 356: return 357: '<img align="right" src="/cgi-bin/barcode.png?encode='.$token.'" />'. 358: 'Checked out for '.$plainname. 359: '<br />User: '.$tuname.' at '.$tudom. 360: '<br />ID: '.$idhash{$tuname}. 361: '<br />CourseID: '.$tcrsid. 362: '<br />Course: '.$ENV{'course.'.$tcrsid.'.description'}. 363: '<br />DocID: '.$token. 364: '<br />Time: '.localtime().'<hr />'; 365: } else { 366: return $token; 367: } 368: } 369: 370: sub fontsettings() { 371: my $headerstring=''; 372: if (($ENV{'browser.os'} eq 'mac') && (!$ENV{'browser.mathml'})) { 373: $headerstring.= 374: '<meta Content-Type="text/html; charset=x-mac-roman">'; 375: } 376: return $headerstring; 377: } 378: 379: sub printalltags { 380: my $temp; 381: foreach $temp (sort keys %Apache::lonxml::alltags) { 382: &Apache::lonxml::debug("$temp -- ". 383: join(',',@{ $Apache::lonxml::alltags{$temp} })); 384: } 385: } 386: 387: sub xmlparse { 388: my ($request,$target,$content_file_string,$safeinit,%style_for_target) = @_; 389: 390: &setup_globals($request,$target); 391: &Apache::inputtags::initialize_inputtags(); 392: &Apache::outputtags::initialize_outputtags(); 393: &Apache::edit::initialize_edit(); 394: # 395: # do we have a course style file? 396: # 397: 398: if ($ENV{'request.course.id'} && $ENV{'request.state'} ne 'construct') { 399: my $bodytext= 400: $ENV{'course.'.$ENV{'request.course.id'}.'.default_xml_style'}; 401: if ($bodytext) { 402: my $location=&Apache::lonnet::filelocation('',$bodytext); 403: my $styletext=&Apache::lonnet::getfile($location); 404: if ($styletext ne '-1') { 405: %style_for_target = (%style_for_target, 406: &Apache::style::styleparser($target,$styletext)); 407: } 408: } 409: } 410: 411: #&printalltags(); 412: my @pars = (); 413: my $pwd=$ENV{'request.filename'}; 414: $pwd =~ s:/[^/]*$::; 415: &newparser(\@pars,\$content_file_string,$pwd); 416: 417: my $safeeval = new Safe; 418: my $safehole = new Safe::Hole; 419: &init_safespace($target,$safeeval,$safehole,$safeinit); 420: #-------------------- Redefinition of the target in the case of compound target 421: 422: ($target, my @tenta) = split('&&',$target); 423: 424: my @stack = (); 425: my @parstack = (); 426: &initdepth; 427: 428: my $finaloutput = &inner_xmlparse($target,\@stack,\@parstack,\@pars, 429: $safeeval,\%style_for_target); 430: if ($ENV{'request.uri'}) { 431: &writeallows($ENV{'request.uri'}); 432: } 433: if ($Apache::lonxml::counter_changed) { &store_counter() } 434: return $finaloutput; 435: } 436: 437: sub htmlclean { 438: my ($raw,$full)=@_; 439: 440: my $tree = HTML::TreeBuilder->new; 441: $tree->ignore_unknown(0); 442: 443: $tree->parse($raw); 444: 445: my $output= $tree->as_HTML(undef,' '); 446: 447: $output=~s/\<(br|hr|img|meta|allow)(.*?)\>/\<$1$2 \/\>/gis; 448: $output=~s/\<\/(br|hr|img|meta|allow)\>//gis; 449: unless ($full) { 450: $output=~s/\<[\/]*(body|head|html)\>//gis; 451: } 452: 453: $tree = $tree->delete; 454: 455: return $output; 456: } 457: 458: sub latex_special_symbols { 459: my ($current_token,$stack,$parstack,$where)=@_; 460: if ($where eq 'header') { 461: $current_token =~ s/\\/ /g; 462: $current_token =~ s/\{/\\\{/g; 463: $current_token =~ s/\}/\\\}/g; 464: $current_token =~ s/_/ /g; 465: $current_token =~ s/\^/ /g; 466: $current_token =~ s/&/\\&/g; 467: $current_token =~ s/\#/\\\#/g; 468: $current_token =~ s/%/\\%/g; 469: $current_token =~ s/\$/\\\$/g; 470: } else { 471: $current_token=~s/\\ /\\char92 /g; 472: $current_token=~s/\^/\\char94 /g; 473: $current_token=~s/\~/\\char126 /g; 474: $current_token=~s/(&[^a-z\#])/\\$1/g; 475: $current_token=~s/([^&])\#/$1\\#/g; 476: $current_token=~s/(\$|_|{|})/\\$1/g; 477: $current_token=~s/\\char92 /\\texttt{\\char92}/g; 478: $current_token=~s/>/\$>\$/g; #more 479: $current_token=~s/</\$<\$/g; #less 480: if ($current_token=~m/\d%/) {$current_token =~ s/(\d)%/$1\\%/g;} #percent after digit 481: if ($current_token=~m/\s%/) {$current_token =~ s/(\s)%/$1\\%/g;} #persent after space 482: } 483: return $current_token; 484: } 485: 486: sub inner_xmlparse { 487: my ($target,$stack,$parstack,$pars,$safeeval,$style_for_target)=@_; 488: my $finaloutput = ''; 489: my $result; 490: my $token; 491: while ( $#$pars > -1 ) { 492: while ($token = $$pars['-1']->get_token) { 493: if (($token->[0] eq 'T') || ($token->[0] eq 'C') || ($token->[0] eq 'D') ) { 494: if ($metamode<1) { 495: my $text=$token->[1]; 496: if ($token->[0] eq 'C' && $target eq 'tex') { 497: $text = '%'.$text."\n"; 498: } 499: $result.=$text; 500: } 501: } elsif ($token->[0] eq 'PI') { 502: if ($metamode<1) { 503: $result=$token->[2]; 504: } 505: } elsif ($token->[0] eq 'S') { 506: # add tag to stack 507: push (@$stack,$token->[1]); 508: # add parameters list to another stack 509: push (@$parstack,&parstring($token)); 510: &increasedepth($token); 511: if ($Apache::lonxml::usestyle && 512: exists($$style_for_target{$token->[1]})) { 513: $Apache::lonxml::usestyle=0; 514: my $string=$$style_for_target{$token->[1]}. 515: '<LONCAPA_INTERNAL_TURN_STYLE_ON />'; 516: &Apache::lonxml::newparser($pars,\$string); 517: } else { 518: $result = &callsub("start_$token->[1]", $target, $token, $stack, 519: $parstack, $pars, $safeeval, $style_for_target); 520: } 521: } elsif ($token->[0] eq 'E') { 522: #clear out any tags that didn't end 523: while ($token->[1] ne $$stack['-1'] && ($#$stack > -1)) { 524: my $lasttag=$$stack[-1]; 525: if ($token->[1] =~ /^$lasttag$/i) { 526: &Apache::lonxml::warning('Using tag </'.$token->[1].'> as end tag to <'.$$stack[-1].'>'); 527: last; 528: } else { 529: &Apache::lonxml::warning('Found tag </'.$token->[1].'> when looking for </'.$$stack[-1].'> in file'); 530: &end_tag($stack,$parstack,$token); 531: } 532: } 533: 534: if ($Apache::lonxml::usestyle && 535: exists($$style_for_target{'/'."$token->[1]"})) { 536: $Apache::lonxml::usestyle=0; 537: my $string=$$style_for_target{'/'.$token->[1]}. 538: '<LONCAPA_INTERNAL_TURN_STYLE_ON />'; 539: &Apache::lonxml::newparser($pars,\$string); 540: } else { 541: $result = &callsub("end_$token->[1]", $target, $token, $stack, 542: $parstack, $pars,$safeeval, $style_for_target); 543: } 544: } else { 545: &Apache::lonxml::error("Unknown token event :$token->[0]:$token->[1]:"); 546: } 547: #evaluate variable refs in result 548: if ($result ne "") { 549: if ( $#$parstack > -1 ) { 550: $result=&Apache::run::evaluate($result,$safeeval,$$parstack[-1]); 551: } else { 552: $result= &Apache::run::evaluate($result,$safeeval,''); 553: } 554: } 555: if (($token->[0] eq 'T') || ($token->[0] eq 'C') || ($token->[0] eq 'D') ) { 556: if ($target eq 'tex') { 557: $result=&latex_special_symbols($result,$stack,$parstack); 558: } 559: } 560: 561: # Encode any high ASCII characters 562: if (!$Apache::lonxml::prevent_entity_encode) { 563: $result=&HTML::Entities::encode($result,"\200-\377"); 564: } 565: if ($Apache::lonxml::redirection) { 566: $Apache::lonxml::outputstack['-1'] .= $result; 567: } else { 568: $finaloutput.=$result; 569: } 570: $result = ''; 571: 572: if ($token->[0] eq 'E') { 573: &end_tag($stack,$parstack,$token); 574: } 575: } 576: if ($#$pars > -1) { 577: pop @$pars; 578: pop @Apache::lonxml::pwd; 579: } 580: } 581: 582: # if ($target eq 'meta') { 583: # $finaloutput.=&endredirection; 584: # } 585: 586: 587: if (($ENV{'QUERY_STRING'}) && ($target eq 'web')) { 588: $finaloutput=&afterburn($finaloutput); 589: } 590: return $finaloutput; 591: } 592: 593: sub callsub { 594: my ($sub,$target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; 595: my $currentstring=''; 596: my $nodefault; 597: { 598: my $sub1; 599: no strict 'refs'; 600: my $tag=$token->[1]; 601: # get utterly rid of extended html tags 602: if ($tag=~/^x\-/i) { return ''; } 603: my $space=$Apache::lonxml::alltags{$tag}[-1]; 604: if (!$space) { 605: $tag=~tr/A-Z/a-z/; 606: $sub=~tr/A-Z/a-z/; 607: $space=$Apache::lonxml::alltags{$tag}[-1] 608: } 609: 610: my $deleted=0; 611: $Apache::lonxml::curdepth=join('_',@Apache::lonxml::depthcounter); 612: if (($token->[0] eq 'S') && ($target eq 'modified')) { 613: $deleted=&Apache::edit::handle_delete($space,$target,$token,$tagstack, 614: $parstack,$parser,$safeeval, 615: $style); 616: } 617: if (!$deleted) { 618: if ($space) { 619: #&Apache::lonxml::debug("Calling sub $sub in $space $metamode"); 620: $sub1="$space\:\:$sub"; 621: ($currentstring,$nodefault) = &$sub1($target,$token,$tagstack, 622: $parstack,$parser,$safeeval, 623: $style); 624: } else { 625: #&Apache::lonxml::debug("NOT Calling sub $sub in $space $metamode"); 626: if ($metamode <1) { 627: if (defined($token->[4]) && ($metamode < 1)) { 628: $currentstring = $token->[4]; 629: } else { 630: $currentstring = $token->[2]; 631: } 632: } 633: } 634: # &Apache::lonxml::debug("nodefalt:$nodefault:"); 635: if ($currentstring eq '' && $nodefault eq '') { 636: if ($target eq 'edit') { 637: #&Apache::lonxml::debug("doing default edit for $token->[1]"); 638: if ($token->[0] eq 'S') { 639: $currentstring = &Apache::edit::tag_start($target,$token); 640: } elsif ($token->[0] eq 'E') { 641: $currentstring = &Apache::edit::tag_end($target,$token); 642: } 643: } elsif ($target eq 'modified') { 644: if ($token->[0] eq 'S') { 645: $currentstring = $token->[4]; 646: $currentstring.=&Apache::edit::handle_insert(); 647: } elsif ($token->[0] eq 'E') { 648: $currentstring = $token->[2]; 649: $currentstring.=&Apache::edit::handle_insertafter($token->[1]); 650: } else { 651: $currentstring = $token->[2]; 652: } 653: } 654: } 655: } 656: use strict 'refs'; 657: } 658: return $currentstring; 659: } 660: 661: sub setup_globals { 662: my ($request,$target)=@_; 663: $Apache::lonxml::request=$request; 664: $Apache::lonxml::registered = 0; 665: $errorcount=0; 666: $warningcount=0; 667: $Apache::lonxml::default_homework_loaded=0; 668: $Apache::lonxml::usestyle=1; 669: &init_counter(); 670: @Apache::lonxml::pwd=(); 671: @Apache::lonxml::extlinks=(); 672: if ($target eq 'meta') { 673: $Apache::lonxml::redirection = 0; 674: $Apache::lonxml::metamode = 1; 675: $Apache::lonxml::evaluate = 1; 676: $Apache::lonxml::import = 0; 677: } elsif ($target eq 'answer') { 678: $Apache::lonxml::redirection = 0; 679: $Apache::lonxml::metamode = 1; 680: $Apache::lonxml::evaluate = 1; 681: $Apache::lonxml::import = 1; 682: } elsif ($target eq 'grade') { 683: &startredirection; 684: $Apache::lonxml::metamode = 0; 685: $Apache::lonxml::evaluate = 1; 686: $Apache::lonxml::import = 1; 687: } elsif ($target eq 'modified') { 688: $Apache::lonxml::redirection = 0; 689: $Apache::lonxml::metamode = 0; 690: $Apache::lonxml::evaluate = 0; 691: $Apache::lonxml::import = 0; 692: } elsif ($target eq 'edit') { 693: $Apache::lonxml::redirection = 0; 694: $Apache::lonxml::metamode = 0; 695: $Apache::lonxml::evaluate = 0; 696: $Apache::lonxml::import = 0; 697: } elsif ($target eq 'analyze') { 698: $Apache::lonxml::redirection = 0; 699: $Apache::lonxml::metamode = 0; 700: $Apache::lonxml::evaluate = 1; 701: $Apache::lonxml::import = 1; 702: } else { 703: $Apache::lonxml::redirection = 0; 704: $Apache::lonxml::metamode = 0; 705: $Apache::lonxml::evaluate = 1; 706: $Apache::lonxml::import = 1; 707: } 708: } 709: 710: sub init_safespace { 711: my ($target,$safeeval,$safehole,$safeinit) = @_; 712: $safeeval->permit("entereval"); 713: $safeeval->permit(":base_math"); 714: $safeeval->permit("sort"); 715: $safeeval->deny(":base_io"); 716: $safehole->wrap(\&Apache::scripttag::xmlparse,$safeeval,'&xmlparse'); 717: $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT'); 718: 719: $safehole->wrap(\&Math::Cephes::asin,$safeeval,'&asin'); 720: $safehole->wrap(\&Math::Cephes::acos,$safeeval,'&acos'); 721: $safehole->wrap(\&Math::Cephes::atan,$safeeval,'&atan'); 722: $safehole->wrap(\&Math::Cephes::sinh,$safeeval,'&sinh'); 723: $safehole->wrap(\&Math::Cephes::cosh,$safeeval,'&cosh'); 724: $safehole->wrap(\&Math::Cephes::tanh,$safeeval,'&tanh'); 725: $safehole->wrap(\&Math::Cephes::asinh,$safeeval,'&asinh'); 726: $safehole->wrap(\&Math::Cephes::acosh,$safeeval,'&acosh'); 727: $safehole->wrap(\&Math::Cephes::atanh,$safeeval,'&atanh'); 728: $safehole->wrap(\&Math::Cephes::erf,$safeeval,'&erf'); 729: $safehole->wrap(\&Math::Cephes::erfc,$safeeval,'&erfc'); 730: $safehole->wrap(\&Math::Cephes::j0,$safeeval,'&j0'); 731: $safehole->wrap(\&Math::Cephes::j1,$safeeval,'&j1'); 732: $safehole->wrap(\&Math::Cephes::jn,$safeeval,'&jn'); 733: $safehole->wrap(\&Math::Cephes::jv,$safeeval,'&jv'); 734: $safehole->wrap(\&Math::Cephes::y0,$safeeval,'&y0'); 735: $safehole->wrap(\&Math::Cephes::y1,$safeeval,'&y1'); 736: $safehole->wrap(\&Math::Cephes::yn,$safeeval,'&yn'); 737: $safehole->wrap(\&Math::Cephes::yv,$safeeval,'&yv'); 738: 739: $safehole->wrap(\&Math::Cephes::bdtr ,$safeeval,'&bdtr' ); 740: $safehole->wrap(\&Math::Cephes::bdtrc ,$safeeval,'&bdtrc' ); 741: $safehole->wrap(\&Math::Cephes::bdtri ,$safeeval,'&bdtri' ); 742: $safehole->wrap(\&Math::Cephes::btdtr ,$safeeval,'&btdtr' ); 743: $safehole->wrap(\&Math::Cephes::chdtr ,$safeeval,'&chdtr' ); 744: $safehole->wrap(\&Math::Cephes::chdtrc,$safeeval,'&chdtrc'); 745: $safehole->wrap(\&Math::Cephes::chdtri,$safeeval,'&chdtri'); 746: $safehole->wrap(\&Math::Cephes::fdtr ,$safeeval,'&fdtr' ); 747: $safehole->wrap(\&Math::Cephes::fdtrc ,$safeeval,'&fdtrc' ); 748: $safehole->wrap(\&Math::Cephes::fdtri ,$safeeval,'&fdtri' ); 749: $safehole->wrap(\&Math::Cephes::gdtr ,$safeeval,'&gdtr' ); 750: $safehole->wrap(\&Math::Cephes::gdtrc ,$safeeval,'&gdtrc' ); 751: $safehole->wrap(\&Math::Cephes::nbdtr ,$safeeval,'&nbdtr' ); 752: $safehole->wrap(\&Math::Cephes::nbdtrc,$safeeval,'&nbdtrc'); 753: $safehole->wrap(\&Math::Cephes::nbdtri,$safeeval,'&nbdtri'); 754: $safehole->wrap(\&Math::Cephes::ndtr ,$safeeval,'&ndtr' ); 755: $safehole->wrap(\&Math::Cephes::ndtri ,$safeeval,'&ndtri' ); 756: $safehole->wrap(\&Math::Cephes::pdtr ,$safeeval,'&pdtr' ); 757: $safehole->wrap(\&Math::Cephes::pdtrc ,$safeeval,'&pdtrc' ); 758: $safehole->wrap(\&Math::Cephes::pdtri ,$safeeval,'&pdtri' ); 759: $safehole->wrap(\&Math::Cephes::stdtr ,$safeeval,'&stdtr' ); 760: $safehole->wrap(\&Math::Cephes::stdtri,$safeeval,'&stdtri'); 761: 762: # $safehole->wrap(\&Math::Cephes::new_fract,$safeeval,'&new_fract'); 763: # $safehole->wrap(\&Math::Cephes::radd,$safeeval,'&radd'); 764: # $safehole->wrap(\&Math::Cephes::rsub,$safeeval,'&rsub'); 765: # $safehole->wrap(\&Math::Cephes::rmul,$safeeval,'&rmul'); 766: # $safehole->wrap(\&Math::Cephes::rdiv,$safeeval,'&rdiv'); 767: # $safehole->wrap(\&Math::Cephes::euclid,$safeeval,'&euclid'); 768: 769: $safehole->wrap(\&Math::Random::random_beta,$safeeval,'&math_random_beta'); 770: $safehole->wrap(\&Math::Random::random_chi_square,$safeeval,'&math_random_chi_square'); 771: $safehole->wrap(\&Math::Random::random_exponential,$safeeval,'&math_random_exponential'); 772: $safehole->wrap(\&Math::Random::random_f,$safeeval,'&math_random_f'); 773: $safehole->wrap(\&Math::Random::random_gamma,$safeeval,'&math_random_gamma'); 774: $safehole->wrap(\&Math::Random::random_multivariate_normal,$safeeval,'&math_random_multivariate_normal'); 775: $safehole->wrap(\&Math::Random::random_multinomial,$safeeval,'&math_random_multinomial'); 776: $safehole->wrap(\&Math::Random::random_noncentral_chi_square,$safeeval,'&math_random_noncentral_chi_square'); 777: $safehole->wrap(\&Math::Random::random_noncentral_f,$safeeval,'&math_random_noncentral_f'); 778: $safehole->wrap(\&Math::Random::random_normal,$safeeval,'&math_random_normal'); 779: $safehole->wrap(\&Math::Random::random_permutation,$safeeval,'&math_random_permutation'); 780: $safehole->wrap(\&Math::Random::random_permuted_index,$safeeval,'&math_random_permuted_index'); 781: $safehole->wrap(\&Math::Random::random_uniform,$safeeval,'&math_random_uniform'); 782: $safehole->wrap(\&Math::Random::random_poisson,$safeeval,'&math_random_poisson'); 783: $safehole->wrap(\&Math::Random::random_uniform_integer,$safeeval,'&math_random_uniform_integer'); 784: $safehole->wrap(\&Math::Random::random_negative_binomial,$safeeval,'&math_random_negative_binomial'); 785: $safehole->wrap(\&Math::Random::random_binomial,$safeeval,'&math_random_binomial'); 786: $safehole->wrap(\&Math::Random::random_seed_from_phrase,$safeeval,'&random_seed_from_phrase'); 787: $safehole->wrap(\&Math::Random::random_set_seed_from_phrase,$safeeval,'&random_set_seed_from_phrase'); 788: $safehole->wrap(\&Math::Random::random_get_seed,$safeeval,'&random_get_seed'); 789: $safehole->wrap(\&Math::Random::random_set_seed,$safeeval,'&random_set_seed'); 790: 791: #need to inspect this class of ops 792: # $safeeval->deny(":base_orig"); 793: $safeinit .= ';$external::target="'.$target.'";'; 794: my $rndseed; 795: my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); 796: $rndseed=&Apache::lonnet::rndseed($symb,$courseid,$domain,$name); 797: $safeinit .= ';$external::randomseed='.$rndseed.';'; 798: &Apache::run::run($safeinit,$safeeval); 799: } 800: 801: sub default_homework_load { 802: my ($safeeval)=@_; 803: &Apache::lonxml::debug('Loading default_homework'); 804: my $default=&Apache::lonnet::getfile('/home/httpd/html/res/adm/includes/default_homework.lcpm'); 805: if ($default == -1) { 806: &Apache::lonxml::error("<b>Unable to find <i>default_homework.lcpm</i></b>"); 807: } else { 808: &Apache::run::run($default,$safeeval); 809: $Apache::lonxml::default_homework_loaded=1; 810: } 811: } 812: 813: sub startredirection { 814: $Apache::lonxml::redirection++; 815: push (@Apache::lonxml::outputstack, ''); 816: } 817: 818: sub endredirection { 819: if (!$Apache::lonxml::redirection) { 820: &Apache::lonxml::error("Endredirection was called, before a startredirection, perhaps you have unbalanced tags. Some debuging information:".join ":",caller); 821: return ''; 822: } 823: $Apache::lonxml::redirection--; 824: pop @Apache::lonxml::outputstack; 825: } 826: 827: sub end_tag { 828: my ($tagstack,$parstack,$token)=@_; 829: pop(@$tagstack); 830: pop(@$parstack); 831: &decreasedepth($token); 832: } 833: 834: sub initdepth { 835: @Apache::lonxml::depthcounter=(); 836: $Apache::lonxml::depth=-1; 837: $Apache::lonxml::olddepth=-1; 838: } 839: 840: sub increasedepth { 841: my ($token) = @_; 842: $Apache::lonxml::depth++; 843: $Apache::lonxml::depthcounter[$Apache::lonxml::depth]++; 844: if ($Apache::lonxml::depthcounter[$Apache::lonxml::depth]==1) { 845: $Apache::lonxml::olddepth=$Apache::lonxml::depth; 846: } 847: my $curdepth=join('_',@Apache::lonxml::depthcounter); 848: &Apache::lonxml::debug("s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n"); 849: #print "<br />s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n"; 850: } 851: 852: sub decreasedepth { 853: my ($token) = @_; 854: $Apache::lonxml::depth--; 855: if ($Apache::lonxml::depth<$Apache::lonxml::olddepth-1) { 856: $#Apache::lonxml::depthcounter--; 857: $Apache::lonxml::olddepth=$Apache::lonxml::depth+1; 858: } 859: if ( $Apache::lonxml::depth < -1) { 860: &Apache::lonxml::warning("Missing tags, unable to properly run file."); 861: $Apache::lonxml::depth='-1'; 862: } 863: my $curdepth=join('_',@Apache::lonxml::depthcounter); 864: &Apache::lonxml::debug("e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n"); 865: #print "<br />e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n"; 866: } 867: 868: sub get_all_text_unbalanced { 869: #there is a copy of this in lonpublisher.pm 870: my($tag,$pars)= @_; 871: my $token; 872: my $result=''; 873: $tag='<'.$tag.'>'; 874: while ($token = $$pars[-1]->get_token) { 875: if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) { 876: $result.=$token->[1]; 877: } elsif ($token->[0] eq 'PI') { 878: $result.=$token->[2]; 879: } elsif ($token->[0] eq 'S') { 880: $result.=$token->[4]; 881: } elsif ($token->[0] eq 'E') { 882: $result.=$token->[2]; 883: } 884: if ($result =~ /(.*)\Q$tag\E(.*)/s) { 885: &Apache::lonxml::debug('Got a winner with leftovers ::'.$2); 886: &Apache::lonxml::debug('Result is :'.$1); 887: $result=$1; 888: my $redo=$tag.$2; 889: &Apache::lonxml::newparser($pars,\$redo); 890: last; 891: } 892: } 893: return $result 894: } 895: 896: sub increment_counter { 897: $Apache::lonxml::counter++; 898: $Apache::lonxml::counter_changed=1; 899: } 900: 901: sub init_counter { 902: if (defined($ENV{'form.counter'})) { 903: $Apache::lonxml::counter=$ENV{'form.counter'}; 904: } elsif (not defined($Apache::lonxml::counter)) { 905: $Apache::lonxml::counter=1; 906: &store_counter(); 907: } 908: $Apache::lonxml::counter_changed=0; 909: } 910: 911: sub store_counter { 912: &Apache::lonnet::appenv(('form.counter' => $Apache::lonxml::counter)); 913: return ''; 914: } 915: 916: sub get_all_text { 917: my($tag,$pars)= @_; 918: &Apache::lonxml::debug("Got a ".ref($pars)); 919: my $gotfullstack=1; 920: if (ref($pars) ne 'ARRAY') { 921: $gotfullstack=0; 922: $pars=[$pars]; 923: } 924: my $depth=0; 925: my $token; 926: my $result=''; 927: if ( $tag =~ m:^/: ) { 928: my $tag=substr($tag,1); 929: #&Apache::lonxml::debug("have:$tag:"); 930: my $top_empty=0; 931: while (($depth >=0) && ($#$pars > -1) && (!$top_empty)) { 932: while (($depth >=0) && ($token = $$pars[-1]->get_token)) { 933: #&Apache::lonxml::debug("e token:$token->[0]:$depth:$token->[1]:".$#$pars.":".$#Apache::lonxml::pwd); 934: if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) { 935: $result.=$token->[1]; 936: } elsif ($token->[0] eq 'PI') { 937: $result.=$token->[2]; 938: } elsif ($token->[0] eq 'S') { 939: if ($token->[1] =~ /^$tag$/i) { $depth++; } 940: $result.=$token->[4]; 941: } elsif ($token->[0] eq 'E') { 942: if ( $token->[1] =~ /^$tag$/i) { $depth--; } 943: #skip sending back the last end tag 944: if ($depth > -1) { $result.=$token->[2]; } else { 945: $$pars[-1]->unget_token($token); 946: } 947: } 948: } 949: if (($depth >=0) && ($#$pars == 0) ) { $top_empty=1; } 950: if (($depth >=0) && ($#$pars > 0) ) { 951: pop(@$pars); 952: pop(@Apache::lonxml::pwd); 953: } 954: } 955: if ($top_empty && $depth >= 0) { 956: #never found the end tag ran out of text, throw error send back blank 957: &error('Never found end tag for <'.$tag.'>'); 958: if ($gotfullstack) { 959: my $newstring='</'.$tag.'>'.$result; 960: &Apache::lonxml::newparser($pars,\$newstring); 961: } 962: $result=''; 963: } 964: } else { 965: while ($#$pars > -1) { 966: while ($token = $$pars[-1]->get_token) { 967: #&Apache::lonxml::debug("s token:$token->[0]:$depth:$token->[1]"); 968: if (($token->[0] eq 'T')||($token->[0] eq 'C')|| 969: ($token->[0] eq 'D')) { 970: $result.=$token->[1]; 971: } elsif ($token->[0] eq 'PI') { 972: $result.=$token->[2]; 973: } elsif ($token->[0] eq 'S') { 974: if ( $token->[1] =~ /^$tag$/i) { 975: $$pars[-1]->unget_token($token); last; 976: } else { 977: $result.=$token->[4]; 978: } 979: } elsif ($token->[0] eq 'E') { 980: $result.=$token->[2]; 981: } 982: } 983: if (($#$pars > 0) ) { 984: pop(@$pars); 985: pop(@Apache::lonxml::pwd); 986: } else { last; } 987: } 988: } 989: if ($result =~ m|<LONCAPA_INTERNAL_TURN_STYLE_ON />|) { 990: $Apache::lonxml::usestyle=1; 991: } 992: #&Apache::lonxml::debug("Exit:$result:"); 993: return $result 994: } 995: 996: sub newparser { 997: my ($parser,$contentref,$dir) = @_; 998: push (@$parser,HTML::LCParser->new($contentref)); 999: $$parser['-1']->xml_mode('1'); 1000: if ( $dir eq '' ) { 1001: push (@Apache::lonxml::pwd, $Apache::lonxml::pwd[$#Apache::lonxml::pwd]); 1002: } else { 1003: push (@Apache::lonxml::pwd, $dir); 1004: } 1005: # &Apache::lonxml::debug("pwd:$#Apache::lonxml::pwd"); 1006: # &Apache::lonxml::debug("pwd:$Apache::lonxml::pwd[$#Apache::lonxml::pwd]"); 1007: } 1008: 1009: sub parstring { 1010: my ($token) = @_; 1011: my $temp=''; 1012: foreach (@{$token->[3]}) { 1013: unless ($_=~/\W/) { 1014: my $val=$token->[2]->{$_}; 1015: $val =~ s/([\%\@\\\"\'])/\\$1/g; 1016: #if ($val =~ m/^[\%\@]/) { $val="\\".$val; } 1017: $temp .= "my \$$_=\"$val\";" 1018: } 1019: } 1020: return $temp; 1021: } 1022: 1023: sub writeallows { 1024: unless ($#extlinks>=0) { return; } 1025: my $thisurl='/res/'.&Apache::lonnet::declutter(shift); 1026: if ($ENV{'httpref.'.$thisurl}) { 1027: $thisurl=$ENV{'httpref.'.$thisurl}; 1028: } 1029: my $thisdir=$thisurl; 1030: $thisdir=~s/\/[^\/]+$//; 1031: my %httpref=(); 1032: foreach (@extlinks) { 1033: $httpref{'httpref.'. 1034: &Apache::lonnet::hreflocation($thisdir,$_)}=$thisurl; 1035: } 1036: @extlinks=(); 1037: &Apache::lonnet::appenv(%httpref); 1038: } 1039: 1040: # 1041: # Afterburner handles anchors, highlights and links 1042: # 1043: sub afterburn { 1044: my $result=shift; 1045: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, 1046: ['highlight','anchor','link']); 1047: if ($ENV{'form.highlight'}) { 1048: foreach (split(/\,/,$ENV{'form.highlight'})) { 1049: my $anchorname=$_; 1050: my $matchthis=$anchorname; 1051: $matchthis=~s/\_+/\\s\+/g; 1052: $result=~s/($matchthis)/\<font color=\"red\"\>$1\<\/font\>/gs; 1053: } 1054: } 1055: if ($ENV{'form.link'}) { 1056: foreach (split(/\,/,$ENV{'form.link'})) { 1057: my ($anchorname,$linkurl)=split(/\>/,$_); 1058: my $matchthis=$anchorname; 1059: $matchthis=~s/\_+/\\s\+/g; 1060: $result=~s/($matchthis)/\<a href=\"$linkurl\"\>$1\<\/a\>/gs; 1061: } 1062: } 1063: if ($ENV{'form.anchor'}) { 1064: my $anchorname=$ENV{'form.anchor'}; 1065: my $matchthis=$anchorname; 1066: $matchthis=~s/\_+/\\s\+/g; 1067: $result=~s/($matchthis)/\<a name=\"$anchorname\"\>$1\<\/a\>/s; 1068: $result.=(<<"ENDSCRIPT"); 1069: <script type="text/javascript"> 1070: document.location.hash='$anchorname'; 1071: </script> 1072: ENDSCRIPT 1073: } 1074: return $result; 1075: } 1076: 1077: sub storefile { 1078: my ($file,$contents)=@_; 1079: if (my $fh=Apache::File->new('>'.$file)) { 1080: print $fh $contents; 1081: $fh->close(); 1082: } else { 1083: &warning("Unable to save file $file"); 1084: } 1085: } 1086: 1087: sub createnewhtml { 1088: my $filecontents=(<<SIMPLECONTENT); 1089: <html> 1090: <head> 1091: <title> 1092: Title of Document Goes Here 1093: </title> 1094: </head> 1095: <body bgcolor="#FFFFFF"> 1096: 1097: Body of Document Goes Here 1098: 1099: </body> 1100: </html> 1101: SIMPLECONTENT 1102: return $filecontents; 1103: } 1104: 1105: 1106: sub inserteditinfo { 1107: my ($result,$filecontents)=@_; 1108: $filecontents = &HTML::Entities::encode($filecontents); 1109: # my $editheader='<a href="#editsection">Edit below</a><hr />'; 1110: my $buttons=(<<BUTTONS); 1111: <input type="submit" name="attemptclean" 1112: value="Save and then attempt to clean HTML" /> 1113: <input type="submit" name="savethisfile" value="Save this" /> 1114: <input type="submit" name="viewmode" value="View" /> 1115: BUTTONS 1116: my $editfooter=(<<ENDFOOTER); 1117: <hr /> 1118: <a name="editsection" /> 1119: <form method="post"> 1120: <input type="hidden" name="editmode" value="Edit" /> 1121: $buttons<br /> 1122: <textarea cols="80" rows="40" name="filecont">$filecontents</textarea> 1123: <br />$buttons 1124: <br /> 1125: </form> 1126: ENDFOOTER 1127: # $result=~s/(\<body[^\>]*\>)/$1$editheader/is; 1128: $result=~s/(\<\/body\>)/$editfooter/is; 1129: return $result; 1130: } 1131: 1132: sub get_target { 1133: my $viewgrades=&Apache::lonnet::allowed('vgr',$ENV{'request.course.id'}); 1134: if ( $ENV{'request.state'} eq 'published') { 1135: if ( defined($ENV{'form.grade_target'}) 1136: && ($viewgrades == 'F' )) { 1137: return ($ENV{'form.grade_target'}); 1138: } elsif (defined($ENV{'form.grade_target'})) { 1139: if (($ENV{'form.grade_target'} eq 'web') || 1140: ($ENV{'form.grade_target'} eq 'tex') ) { 1141: return $ENV{'form.grade_target'} 1142: } else { 1143: return 'web'; 1144: } 1145: } else { 1146: return 'web'; 1147: } 1148: } elsif ($ENV{'request.state'} eq 'construct') { 1149: if ( defined($ENV{'form.grade_target'})) { 1150: return ($ENV{'form.grade_target'}); 1151: } else { 1152: return 'web'; 1153: } 1154: } else { 1155: return 'web'; 1156: } 1157: } 1158: 1159: sub handler { 1160: my $request=shift; 1161: 1162: my $target=&get_target(); 1163: 1164: $Apache::lonxml::debug=0; 1165: 1166: if ($ENV{'browser.mathml'}) { 1167: $request->content_type('text/xml'); 1168: } else { 1169: $request->content_type('text/html'); 1170: } 1171: &Apache::loncommon::no_cache($request); 1172: $request->send_http_header; 1173: 1174: return OK if $request->header_only; 1175: 1176: 1177: my $file=&Apache::lonnet::filelocation("",$request->uri); 1178: # 1179: # Edit action? Save file. 1180: # 1181: unless ($ENV{'request.state'} eq 'published') { 1182: if (($ENV{'form.savethisfile'}) || ($ENV{'form.attemptclean'})) { 1183: &storefile($file,$ENV{'form.filecont'}); 1184: } 1185: } 1186: my %mystyle; 1187: my $result = ''; 1188: my $filecontents=&Apache::lonnet::getfile($file); 1189: if ($filecontents == -1) { 1190: $result=(<<ENDNOTFOUND); 1191: <html> 1192: <head> 1193: <title>File not found</title> 1194: </head> 1195: <body bgcolor="#FFFFFF"> 1196: <b>File not found: $file</b> 1197: </body> 1198: </html> 1199: ENDNOTFOUND 1200: $filecontents=''; 1201: if ($ENV{'request.state'} ne 'published') { 1202: $filecontents=&createnewhtml(); 1203: $ENV{'form.editmode'}='Edit'; #force edit mode 1204: } 1205: } else { 1206: unless ($ENV{'request.state'} eq 'published') { 1207: if ($ENV{'form.attemptclean'}) { 1208: $filecontents=&htmlclean($filecontents,1); 1209: } 1210: } 1211: if (!$ENV{'form.editmode'} || $ENV{'form.viewmode'}) { 1212: $result = &Apache::lonxml::xmlparse($request,$target,$filecontents, 1213: '',%mystyle); 1214: } 1215: } 1216: 1217: # 1218: # Edit action? Insert editing commands 1219: # 1220: unless ($ENV{'request.state'} eq 'published') { 1221: if ($ENV{'form.editmode'} && (!($ENV{'form.viewmode'}))) { 1222: my $displayfile=$request->uri; 1223: $displayfile=~s/^\/[^\/]*//; 1224: $result='<html><body bgcolor="#FFFFFF"><h3>'.$displayfile. 1225: '</h3></body></html>'; 1226: $result=&inserteditinfo($result,$filecontents); 1227: } 1228: } 1229: 1230: writeallows($request->uri); 1231: 1232: $request->print($result); 1233: 1234: return OK; 1235: } 1236: 1237: sub debug { 1238: if ($Apache::lonxml::debug eq 1) { 1239: $|=1; 1240: print('<font size="-2"<pre>DEBUG:'.&HTML::Entities::encode($_[0])."</pre></font>\n"); 1241: } 1242: } 1243: 1244: sub error { 1245: $errorcount++; 1246: if (($Apache::lonxml::debug eq 1) || ($ENV{'request.state'} eq 'construct') ) { 1247: # If printing in construction space, put the error inside <pre></pre> 1248: print "<b>ERROR:</b>".join("\n",@_)."\n"; 1249: } else { 1250: print "<b>An Error occured while processing this resource. The instructor has been notified.</b> <br />"; 1251: #notify author 1252: &Apache::lonmsg::author_res_msg($ENV{'request.filename'},join('<br />',@_)); 1253: #notify course 1254: if ( $ENV{'request.course.id'} ) { 1255: my (undef,%users)=&Apache::lonfeedback::decide_receiver(undef,0,1,1,1); 1256: my $declutter=&Apache::lonnet::declutter($ENV{'request.filename'}); 1257: foreach (keys %users) { 1258: my ($user,$domain) = split(/:/, $_); 1259: &Apache::lonmsg::user_normal_msg($user,$domain, 1260: "Error [$declutter]",join('<br />',@_)); 1261: } 1262: } 1263: 1264: #FIXME probably shouldn't have me get everything forever. 1265: &Apache::lonmsg::user_normal_msg('albertel','msu',"Error in $ENV{'request.filename'}",join('<br />',@_)); 1266: #&Apache::lonmsg::user_normal_msg('albertel','103',"Error in $ENV{'request.filename'}",$_[0]); 1267: } 1268: } 1269: 1270: sub warning { 1271: $warningcount++; 1272: if ($ENV{'request.state'} eq 'construct') { 1273: print "<b>W</b>ARNING<b>:</b>".join('<br />',@_)."<br />\n"; 1274: } 1275: } 1276: 1277: sub get_param { 1278: my ($param,$parstack,$safeeval,$context,$case_insensitive) = @_; 1279: if ( ! $context ) { $context = -1; } 1280: my $args =''; 1281: if ( $#$parstack > (-2-$context) ) { $args=$$parstack[$context]; } 1282: if ( ! $args ) { return undef; } 1283: if ( $case_insensitive ) { 1284: if ($args =~ s/(my \$)(\Q$param\E)(=\")/$1.lc($2).$3/ei) { 1285: return &Apache::run::run("{$args;".'return $'.$param.'}', 1286: $safeeval); #' 1287: } else { 1288: return undef; 1289: } 1290: } else { 1291: if ( $args =~ /my \$\Q$param\E=\"/ ) { 1292: return &Apache::run::run("{$args;".'return $'.$param.'}', 1293: $safeeval); #' 1294: } else { 1295: return undef; 1296: } 1297: } 1298: } 1299: 1300: sub get_param_var { 1301: my ($param,$parstack,$safeeval,$context,$case_insensitive) = @_; 1302: if ( ! $context ) { $context = -1; } 1303: my $args =''; 1304: if ( $#$parstack > (-2-$context) ) { $args=$$parstack[$context]; } 1305: &Apache::lonxml::debug("Args are $args param is $param"); 1306: if ($case_insensitive) { 1307: if (! ($args=~s/(my \$)(\Q$param\E)(=\")/$1.lc($2).$3/ei)) { 1308: return undef; 1309: } 1310: } elsif ( $args !~ /my \$\Q$param\E=\"/ ) { return undef; } 1311: my $value=&Apache::run::run("{$args;".'return $'.$param.'}',$safeeval); #' 1312: &Apache::lonxml::debug("first run is $value"); 1313: if ($value =~ /^[\$\@\%]\w+$/) { 1314: &Apache::lonxml::debug("doing second"); 1315: my @result=&Apache::run::run("return $value",$safeeval,1); 1316: if (!defined($result[0])) { 1317: return $value 1318: } else { 1319: if (wantarray) { return @result; } else { return $result[0]; } 1320: } 1321: } else { 1322: return $value; 1323: } 1324: } 1325: 1326: sub register_insert { 1327: my @data = split /\n/, &Apache::lonnet::getfile('/home/httpd/lonTabs/insertlist.tab'); 1328: my $i; 1329: my $tagnum=0; 1330: my @order; 1331: for ($i=0;$i < $#data; $i++) { 1332: my $line = $data[$i]; 1333: if ( $line =~ /^\#/ || $line =~ /^\s*\n/) { next; } 1334: if ( $line =~ /TABLE/ ) { last; } 1335: my ($tag,$descrip,$color,$function,$show) = split(/,/, $line); 1336: if ($tag) { 1337: $insertlist{"$tagnum.tag"} = $tag; 1338: $insertlist{"$tagnum.description"} = $descrip; 1339: $insertlist{"$tagnum.color"} = $color; 1340: $insertlist{"$tagnum.function"} = $function; 1341: if (!defined($show)) { $show='yes'; } 1342: $insertlist{"$tagnum.show"}= $show; 1343: $insertlist{"$tag.num"}=$tagnum; 1344: $tagnum++; 1345: } 1346: } 1347: $i++; #skipping TABLE line 1348: $tagnum = 0; 1349: for (;$i < $#data;$i++) { 1350: my $line = $data[$i]; 1351: my ($mnemonic,@which) = split(/ +/,$line); 1352: my $tag = $insertlist{"$tagnum.tag"}; 1353: for (my $j=0;$j <=$#which;$j++) { 1354: if ( $which[$j] eq 'Y' ) { 1355: if ($insertlist{"$j.show"} ne 'no') { 1356: push(@{ $insertlist{"$tag.which"} },$j); 1357: } 1358: } 1359: } 1360: $tagnum++; 1361: } 1362: } 1363: 1364: sub description { 1365: my ($token)=@_; 1366: my $tagnum; 1367: my $tag=$token->[1]; 1368: foreach my $namespace (reverse @Apache::lonxml::namespace) { 1369: my $testtag=$namespace.'::'.$tag; 1370: $tagnum=$insertlist{"$testtag.num"}; 1371: if (defined($tagnum)) { last; } 1372: } 1373: if (!defined ($tagnum)) { $tagnum=$Apache::lonxml::insertlist{"$tag.num"}; } 1374: return $insertlist{$tagnum.'.description'}; 1375: } 1376: 1377: # ----------------------------------------------------------------- whichuser 1378: # returns a list of $symb, $courseid, $domain, $name that is correct for 1379: # calls to lonnet functions for this setup. 1380: # - looks for form.grade_ parameters 1381: sub whichuser { 1382: my ($symb,$courseid,$domain,$name); 1383: if (defined($ENV{'form.grade_symb'})) { 1384: my $tmp_courseid=$ENV{'form.grade_courseid'}; 1385: my $allowed=&Apache::lonnet::allowed('mgr',$tmp_courseid); 1386: if ($allowed) { 1387: $symb=$ENV{'form.grade_symb'}; 1388: $courseid=$ENV{'form.grade_courseid'}; 1389: $domain=$ENV{'form.grade_domain'}; 1390: $name=$ENV{'form.grade_username'}; 1391: } 1392: } else { 1393: $symb=&Apache::lonnet::symbread(); 1394: $courseid=$ENV{'request.course.id'}; 1395: $domain=$ENV{'user.domain'}; 1396: $name=$ENV{'user.name'}; 1397: } 1398: return ($symb,$courseid,$domain,$name); 1399: } 1400: 1401: 1; 1402: __END__ 1403: 1404: