--- loncom/xml/lonxml.pm 2000/06/19 15:52:29 1.1 +++ loncom/xml/lonxml.pm 2001/08/15 14:22:07 1.113 @@ -1,1305 +1,1062 @@ -package Apache::lonxml; - +# The LearningOnline Network with CAPA +# XML Parser Module +# +# last modified 06/26/00 by Alexander Sakharuk +# 11/6 Gerd Kortemeyer +# 6/1/1 Gerd Kortemeyer +# 2/21,3/13 Guy +# 3/29,5/4 Gerd Kortemeyer +# 5/10 Scott Harrison +# 5/26 Gerd Kortemeyer +# 5/27 H. K. Ng +# 6/2,6/3,6/8,6/9 Gerd Kortemeyer +# 6/12,6/13 H. K. Ng +# 6/16 Gerd Kortemeyer +# 7/27 H. K. Ng +# 8/7,8/9,8/10,8/11,8/15 Gerd Kortemeyer + +package Apache::lonxml; +use vars +qw(@pwd @outputstack $redirection $import @extlinks $metamode $evaluate %insertlist @namespace); use strict; use HTML::TokeParser; +use HTML::TreeBuilder; use Safe; +use Safe::Hole; +use Math::Cephes qw(:trigs :hypers :bessels erf erfc); +use Math::Random qw(:all); +use Opcode; + +sub register { + my $space; + my @taglist; + my $temptag; + ($space,@taglist) = @_; + foreach $temptag (@taglist) { + $Apache::lonxml::alltags{$temptag}=$space; + } +} + use Apache::Constants qw(:common); use Apache::lontexconvert; +use Apache::style; +use Apache::run; +use Apache::londefdef; +use Apache::scripttag; +use Apache::edit; +use Apache::lonnet; +use Apache::File; + +#================================================== Main subroutine: xmlparse +#debugging control, to turn on debugging modify the correct handler +$Apache::lonxml::debug=0; + +#path to the directory containing the file currently being processed +@pwd=(); + +#these two are used for capturing a subset of the output for later processing, +#don't touch them directly use &startredirection and &endredirection +@outputstack = (); +$redirection = 0; + +#controls wheter the tag actually does +$import = 1; +@extlinks=(); + +# meta mode is a bit weird only some output is to be turned off +# tag turns metamode off (defined in londefdef.pm) +$metamode = 0; + +# turns on and of run::evaluate actually derefencing var refs +$evaluate = 1; + +# data structure for eidt mode, determines what tags can go into what other tags +%insertlist=(); + +# stores the list of active tag namespaces +@namespace=(); + +# has the dynamic menu been updated to know about this resource +$Apache::lonxml::registered=0; + +sub xmlbegin { + my $output=''; + if ($ENV{'browser.mathml'}) { + $output='' + .'' + .']>' + .''; + } else { + $output=''; + } + return $output; +} +sub xmlend { + my $discussion=''; + if ($ENV{'request.course.id'}) { + my $crs='/'.$ENV{'request.course.id'}; + if ($ENV{'request.course.sec'}) { + $crs.='_'.$ENV{'request.course.sec'}; + } + $crs=~s/\_/\//g; + my $seeid=&Apache::lonnet::allowed('rin',$crs); + my $symb=&Apache::lonnet::symbread(); + if ($symb) { + my %contrib=&Apache::lonnet::restore($symb,$ENV{'request.course.id'}, + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, + $ENV{'course.'.$ENV{'request.course.id'}.'.num'}); + if ($contrib{'version'}) { + $discussion.= + '

Course Discussion of Resource

'; + my $idx; + for ($idx=1;$idx<=$contrib{'version'};$idx++) { + my $hidden=($contrib{'hidden'}=~/\.$idx\./); + unless (($hidden) && (!$seeid)) { + my $message=$contrib{$idx.':message'}; + $message=~s/\n/\
/g; + if ($message) { + if ($hidden) { + $message=''.$message.''; + } + my $sender='Anonymous'; + if ((!$contrib{$idx.':anonymous'}) || ($seeid)) { + $sender=$contrib{$idx.':sendername'}.' at '. + $contrib{$idx.':senderdomain'}; + if ($contrib{$idx.':anonymous'}) { + $sender.=' (anonymous)'; + } + if ($seeid) { + if ($hidden) { + $sender.=' Make Visible'; + } else { + $sender.=' Hide'; + } + } + } + $discussion.='

'.$sender.' ('. + localtime($contrib{$idx.':timestamp'}). + '):

'.$message. + '

'; + } + } + } + $discussion.='
'; + } + } + } + return $discussion.''; +} -#======================================================= Main subroutine: xmlparse +sub checkout { + my ($target,$symb,$tuname,$tudom,$tcrsid)=@_; + unless ($symb) { + $symb=&Apache::lonnet::symbread(); + } + unless ($tuname) { + $tuname=$ENV{'user.name'}; + $tudom=$ENV{'user.domain'}; + $tcrsid=$ENV{'request.course.id'}; + } + my $lonhost = $Apache::lonnet::perlvar{'lonHostID'}; + my $infostr=&Apache::lonnet::escape( + $tuname.'&'. + $tudom.'&'. + $tcrsid.'&'. + $symb.'&'. + time.'&'.$ENV{'REMOTE_ADDR'}); + my $token=Apache::lonnet::reply('tmpput:'.$infostr,$lonhost); + if ($token=~/^error\:/) { return ''; } + $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; + $token=~tr/a-z/A-Z/; + if (&Apache::lonnet::log($tudom,$tuname, + &Apache::lonnet::homeserver($tuname,$tudom), + &Apache::lonnet::escape('Checkout '.$infostr.' - '. + $token)) ne 'ok') { + return ''; + } + if ($target eq 'web') { + return ''; + } else { + return $token; + } +} -sub xmlparse { +sub fontsettings() { + my $headerstring=''; + if (($ENV{'browser.os'} eq 'mac') && (!$ENV{'browser.mathml'})) { + $headerstring.= + ''; + } + return $headerstring; +} - my ($target,$content_file_string,%style_for_target) = @_; - my $pars = HTML::TokeParser->new(\$content_file_string); - my $currentstring = ''; - my $finaloutput = ''; - my $newarg = ''; - my $tempostring = ''; - my $tempocont = ''; - my $safeeval = new Safe; - -#------------------------- Redefinition of the target in the case of compound target - ($target, my @tenta) = split('&&',$target); -#------------------------------ Stack definition (in stack we have all current tags) +sub registerurl { + my $forcereg=shift; + if ($Apache::lonxml::registered) { return ''; } + $Apache::lonxml::registered=1; + if (($ENV{'REQUEST_URI'}!~/^\/(res\/)*adm\//) || ($forcereg)) { + my $hwkadd=''; + if ($ENV{'REQUEST_URI'}=~/\.(problem|exam|quiz|assess|survey|form)$/) { + if (&Apache::lonnet::allowed('vgr',$ENV{'request.course.id'})) { + $hwkadd.=(< +// BEGIN LON-CAPA Internal + + function LONCAPAreg() { + menu=window.open("","LONCAPAmenu"); + menu.clearTimeout(menu.menucltim); + menu.currentURL=window.location.pathname; + menu.currentStale=0; + menu.clearbut(3,1); + menu.switchbutton + (6,3,'catalog.gif','catalog','info','catalog_info()'); + menu.switchbutton + (8,1,'eval.gif','evaluate','this','gopost("/adm/evaluate",currentURL)'); + menu.switchbutton + (8,2,'fdbk.gif','feedback','on this','gopost("/adm/feedback",currentURL)'); + menu.switchbutton + (8,3,'prt.gif','prepare','printout','gopost("/adm/printout",currentURL)'); + menu.switchbutton + (2,1,'back.gif','backward','','gopost("/adm/flip","back:"+currentURL)'); + menu.switchbutton + (2,3,'forw.gif','forward','','gopost("/adm/flip","forward:"+currentURL)'); + menu.switchbutton + (9,1,'sbkm.gif','set','bookmark','set_bookmark()'); + menu.switchbutton + (9,2,'vbkm.gif','view','bookmark','edit_bookmarks()'); + menu.switchbutton + (9,3,'anot.gif','anno-','tations','annotate()'); + $hwkadd + } - my @stack = (); - my @parstack = (); + function LONCAPAstale() { + menu=window.open("","LONCAPAmenu"); + menu.currentStale=1; + menu.switchbutton + (3,1,'reload.gif','return','location','go(currentURL)'); + menu.clearbut(7,1); + menu.clearbut(7,2); + menu.clearbut(7,3); + menu.menucltim=menu.setTimeout( + 'clearbut(2,1);clearbut(2,3);clearbut(8,1);clearbut(8,2);clearbut(8,3);'+ + 'clearbut(9,1);clearbut(9,2);clearbut(9,3);clearbut(6,3)', + 2000); -#------------------------------------------ Parse input string (content_file_string) - - my $token; + } + +// END LON-CAPA Internal + +ENDREGTHIS + + } else { + return (< +// BEGIN LON-CAPA Internal + + function LONCAPAreg() { + menu=window.open("","LONCAPAmenu"); + menu.currentStale=1; + menu.clearbut(2,1); + menu.clearbut(2,3); + menu.clearbut(8,1); + menu.clearbut(8,2); + menu.clearbut(8,3); + if (menu.currentURL) { + menu.switchbutton + (3,1,'reload.gif','return','location','go(currentURL)'); + } else { + menu.clearbut(3,1); + } + } + + function LONCAPAstale() { + } + +// END LON-CAPA Internal + +ENDDONOTREGTHIS - while ($token = $pars->get_token) { - if ($token->[0] eq 'T') { - $finaloutput .= $token->[1]; - $tempocont .= $token->[1]; - } elsif ($token->[0] eq 'S') { -#------------------------------------------------------------------ add tag to stack - push (@stack,$token->[1]); -#---------------------------------------------- add parameters list to another stack - map {$tempostring .= "$_=$token->[2]->{$_},"} @{$token->[3]}; - push (@parstack,$tempostring); - $tempostring = ''; - $tempocont = ''; - - if (exists $style_for_target{$token->[1]}) { - -#--------------------------------------------------------- use style file definition - - $newarg = $style_for_target{$token->[1]}; - - if (index($newarg,'script') != -1 ) { - my $pat = HTML::TokeParser->new(\$newarg); - my $tokenpat; - my $partstring = ''; - my $oustring = ''; - my $outputstring; - - while ($tokenpat = $pat->get_token) { - if ($tokenpat->[0] eq 'T') { - $oustring .= $tokenpat->[1]; - } elsif ($tokenpat->[0] eq 'S') { - if ($tokenpat->[1] eq 'script') { - while ($tokenpat = $pat->get_token and $tokenpat->[1] ne 'script') { - if ($tokenpat->[0] eq 'S') { - $partstring .= $tokenpat->[4]; - } elsif ($tokenpat->[0] eq 'T') { - $partstring .= $tokenpat->[1]; - } elsif ($tokenpat->[0] eq 'E') { - $partstring .= $tokenpat->[2]; - } - } - - map {$partstring =~ s/\$$_/$token->[2]->{$_}/g; } @{$token->[3]}; - - &run($partstring,$safeeval); - $partstring = ''; - } elsif ($tokenpat->[1] eq 'evaluate') { - $outputstring = &evaluate($tokenpat->[2]{expression},$safeeval); - $oustring .= $outputstring; - } else { - $oustring .= $tokenpat->[4]; - } - } elsif ($tokenpat->[0] eq 'E' and $tokenpat->[1] ne 'evaluate') { - $oustring .= $tokenpat->[1]; - } - } - $newarg = $oustring; - } else { - map {$newarg =~ s/\$$_/$token->[2]->{$_}/g; } @{$token->[3]}; - } - $finaloutput .= $newarg; - } else { -#----------------------------------------------------- use default definition of tag - my $sub="start_$token->[1]"; - - { - no strict 'refs'; - if (defined (&$sub)) { - $currentstring = &$sub($target,$token,\@parstack); - $finaloutput .= $currentstring; - $currentstring = ''; - } else { - $finaloutput .= $token->[4]; - } - use strict 'refs'; - } - } - } elsif ($token->[0] eq 'E') { - pop @stack; - unless (exists $style_for_target{$token->[1]}) { - my $sub="end_$token->[1]"; - { - no strict 'refs'; - if (defined (&$sub)) { - $currentstring = &$sub($target,$token,\@parstack); - $finaloutput .= $currentstring; - $currentstring = ''; - } else { - $finaloutput .= $token->[4]; - } - use strict 'refs'; - } - } -#------------------------------------------------------- end tag from the style file - if (exists $style_for_target{'/'."$token->[1]"}) { - $newarg = $style_for_target{'/'."$token->[1]"}; - my @very_temp = split(',',@parstack[$#parstack]); - map {my @ret= split('=',$_); $newarg =~ s/\$$ret[0]/$ret[1]/g; } @very_temp; - $finaloutput .= $newarg; - } - pop @parstack; - } } - return $finaloutput; } +sub loadevents() { + return 'LONCAPAreg();'; +} -#================================================================== style subroutine +sub unloadevents() { + return 'LONCAPAstale();'; +} -sub styleparser { +sub printalltags { + my $temp; + foreach $temp (sort keys %Apache::lonxml::alltags) { + &Apache::lonxml::debug("$temp -- $Apache::lonxml::alltags{$temp}"); + } +} - my ($target,$content_style_string) = @_; +sub xmlparse { + my ($target,$content_file_string,$safeinit,%style_for_target) = @_; -#------------------------------------------------ target redefinition (if necessary) - - my @target_string = ''; - my $element; - - ($element,@target_string) = split ('&&',$target); - - map {$content_style_string =~ s/\<(.*)$_\>/\<$1$element\>/g; } @target_string; - - $target = $element; - -#------------------------------------------------- create a table for defined target -#---------------------------------------------- from the information from Style File - - my @value_style = (); - my $current_key = ''; - my $current_value = ''; - - my $pstyle = HTML::TokeParser->new(\$content_style_string); - - my $stoken; - - while ($stoken = $pstyle->get_token) { -#---------------------------------------------------------- start for tag definition - if ($stoken->[0] eq 'S' and $stoken->[1] eq 'definetag') { -#------------------------------------------------------------------- new key in hash - $current_key = $stoken->[2]{name}; - if ($target eq 'meta') { -#-------------------------------------------------- reserved for the metadate output - - - } else { -#-------------------------------------------------------------------- outtext output - while ($stoken = $pstyle->get_token and $stoken->[1] ne 'outtext') { - } - while ($stoken = $pstyle->get_token and $stoken->[0] ne 'S') { - $current_value .= $stoken->[1]; - } - while ($stoken->[1] ne 'definetag') { - if ($stoken->[0] eq 'S' and $stoken->[1] eq $target) { - while ($stoken = $pstyle->get_token) { - if ($stoken->[1] ne $target) { - if ($stoken->[0] eq 'S') { - $current_value .= $stoken->[4]; - } - if ($stoken->[0] eq 'E') { - $current_value .= $stoken->[2]; - } - if ($stoken->[0] eq 'T') { - $current_value .= $stoken->[1]; - } - } else { - last; - } - } - } elsif ($stoken->[0] eq 'S' and $stoken->[1] ne $target) { - while ($stoken = $pstyle->get_token and $stoken->[0] ne 'E') { - } - } - - while ($stoken = $pstyle->get_token) { - if ($stoken->[0] eq 'T') { - $current_value .= $stoken->[1]; - } - if ($stoken->[0] eq 'E') { - last; - } - if ($stoken->[0] eq 'S') { - last; - } - } - - } - } - - } - push (@value_style,lc $current_key,$current_value); - $current_key = ''; - $current_value = ''; + &setup_globals($target); + #&printalltags(); + my @pars = (); + my $pwd=$ENV{'request.filename'}; + $pwd =~ s:/[^/]*$::; + &newparser(\@pars,\$content_file_string,$pwd); + + my $safeeval = new Safe; + my $safehole = new Safe::Hole; + &init_safespace($target,$safeeval,$safehole,$safeinit); +#-------------------- Redefinition of the target in the case of compound target + + ($target, my @tenta) = split('&&',$target); + + my @stack = (); + my @parstack = (); + &initdepth; - } - - my %style_for_target = @value_style; - -#-------------------------------------------------------------------- check printing -# while (($current_key,$current_value) = each %style_for_target) { -# print "$current_key => $current_value\n"; -# } + my $finaloutput = &inner_xmlparse($target,\@stack,\@parstack,\@pars, + $safeeval,\%style_for_target); - return %style_for_target; - + return $finaloutput; } +sub htmlclean { + my ($raw,$full)=@_; + my $tree = HTML::TreeBuilder->new; + $tree->ignore_unknown(0); + + $tree->parse($raw); -#=============================================================== Subroutine definition -#--------------------------------------------------------------------------------- Run - sub evaluate { - my ($expression,$safeeval) = @_; - return $safeeval->reval($expression); - } - - sub run { - my ($code,$safeeval) = @_; - $safeeval->reval($code); - } - -#===================================================================== TAG SUBROUTINES -#----------------------------------------------------------------------------- tag - sub start_m { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = "\$out = lontexconvert::converted(\$in = '\$'.\""; - } elsif ($target eq 'tex') { - $currentstring = "\$"; - } - return $currentstring; - } - sub end_m { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = "\".'\$') "; - } elsif ($target eq 'tex') { - $currentstring = "\$"; - } - return $currentstring; - } -#-------------------------------------------------------------------------- tag - sub start_html { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[4]; - } - return $currentstring; - } - sub end_html { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[2]; - } - return $currentstring; - } -#-------------------------------------------------------------------------- tag - sub start_head { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[4]; - } - return $currentstring; - } - sub end_head { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[2]; - } - return $currentstring; - } -#--------------------------------------------------------------------------- tag - sub start_map { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[4]; - } - return $currentstring; - } - sub end_map { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[2]; - } - return $currentstring; - } -#------------------------------------------------------------------------ tag - sub start_applet { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[4]; - } - return $currentstring; - } - sub end_applet { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[2]; - } - return $currentstring; - } -#------------------------------------------------------------------------ tag - sub start_input { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[4]; - } - return $currentstring; - } - sub end_input { - my ($target,$token) = @_; - my $currentstring = ''; - if ($target eq 'web') { - $currentstring = $token->[2]; - } - return $currentstring; - } -#---------------------------------------------------------------------- +
+ + + +ENDFOOTER + $result=~s/(\]*\>)/$1$editheader/is; + $result=~s/(\<\/body\>)/$editfooter/is; + return $result; +} + +sub handler { + my $request=shift; + + my $target='web'; + + $Apache::lonxml::debug=0; + + if ($ENV{'browser.mathml'}) { + $request->content_type('text/xml'); + } else { + $request->content_type('text/html'); + } + + $request->send_http_header; + + return OK if $request->header_only; + + + my $file=&Apache::lonnet::filelocation("",$request->uri); +# +# Edit action? Save file. +# + unless ($ENV{'request.state'} eq 'published') { + if (($ENV{'form.savethisfile'}) || ($ENV{'form.attemptclean'})) { + &storefile($file,$ENV{'form.filecont'}); + } + } + my %mystyle; + my $result = ''; + my $filecontents=&Apache::lonnet::getfile($file); + if ($filecontents == -1) { + $result=(< + +File not found + + +File not found: $file + + +ENDNOTFOUND + $filecontents=''; + } else { + unless ($ENV{'request.state'} eq 'published') { + if ($ENV{'form.attemptclean'}) { + $filecontents=&htmlclean($filecontents,1); + } + } + $result = &Apache::lonxml::xmlparse($target,$filecontents,'',%mystyle); + } + +# +# Edit action? Insert editing commands +# + unless ($ENV{'request.state'} eq 'published') { + $result=&inserteditinfo($result,$filecontents); + } + + $request->print($result); + + writeallows($request->uri); + return OK; +} + +sub debug { + if ($Apache::lonxml::debug eq 1) { + print("DEBUG:".$_[0]."
\n"); + } +} + +sub error { + if (($Apache::lonxml::debug eq 1) || ($ENV{'request.state'} eq 'construct') ) { + print "ERROR:".$_[0]."
\n"; + } else { + print "An Error occured while processing this resource. The instructor has been notified.
"; + #notify author + &Apache::lonmsg::author_res_msg($ENV{'request.filename'},$_[0]); + #notify course + if ( $ENV{'request.course.id'} ) { + my $users=$ENV{'course.'.$ENV{'request.course.id'}.'.comment.email'}; + foreach my $user (split /\,/, $users) { + ($user,my $domain) = split /:/, $user; + &Apache::lonmsg::user_normal_msg($user,$domain,"Error in $ENV{'request.filename'}",$_[0]); + } + } + + #FIXME probably shouldn't have me get everything forever. + &Apache::lonmsg::user_normal_msg('albertel','msu',"Error in $ENV{'request.filename'}",$_[0]); + #&Apache::lonmsg::user_normal_msg('albertel','103',"Error in $ENV{'request.filename'}",$_[0]); + } +} + +sub warning { + if ($ENV{'request.state'} eq 'construct') { + print "WARNING:".$_[0]."
\n"; + } +} + +sub get_param { + my ($param,$parstack,$safeeval,$context) = @_; + if ( ! $context ) { $context = -1; } + my $args =''; + if ( $#$parstack > (-2-$context) ) { $args=$$parstack[$context]; } + return &Apache::run::run("{$args;".'return $'.$param.'}',$safeeval); #' +} + +sub register_insert { + my @data = split /\n/, &Apache::lonnet::getfile('/home/httpd/lonTabs/insertlist.tab'); + my $i; + my $tagnum=0; + my @order; + for ($i=0;$i < $#data; $i++) { + my $line = $data[$i]; + if ( $line =~ /^\#/ || $line =~ /^\s*\n/) { next; } + if ( $line =~ /TABLE/ ) { last; } + my ($tag,$descrip,$color,$function,$show) = split(/,/, $line); + $insertlist{"$tagnum.tag"} = $tag; + $insertlist{"$tagnum.description"} = $descrip; + $insertlist{"$tagnum.color"} = $color; + $insertlist{"$tagnum.function"} = $function; + $insertlist{"$tagnum.show"}= $show; + $insertlist{"$tag.num"}=$tagnum; + $tagnum++; + } + $i++; #skipping TABLE line + $tagnum = 0; + for (;$i < $#data;$i++) { + my $line = $data[$i]; + my ($mnemonic,@which) = split(/ +/,$line); + my $tag = $insertlist{"$tagnum.tag"}; + for (my $j=0;$j <$#which;$j++) { + if ( $which[$j] eq 'Y' ) { + if ($insertlist{"$j.show"} ne 'no') { + push(@{ $insertlist{"$tag.which"} },$j); } + } + } + $tagnum++; + } +} +sub description { + my ($token)=@_; + return $insertlist{$insertlist{"$token->[1].num"}.'.description'}; +} 1; __END__ + +