Return to lonxml.pm CVS log

Up to [LON-CAPA] / loncom / xml

- changed to send a normal level message instead of Critical
- <br> -> <br /> cleanup

# 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

package Apache::lonxml; 
use vars 
qw(@pwd $outputstack $redirection $textredirection $on_offimport @extlinks);
use strict;
use HTML::TokeParser;
use Safe;
use Safe::Hole;
use Opcode;
use Apache::Constants qw(:common);

sub register {
  my $space;
  my @taglist;
  my $temptag;
  ($space,@taglist) = @_;
  foreach $temptag (@taglist) {
    $Apache::lonxml::alltags{$temptag}=$space;
  }
}

sub printalltags {
  my $temp;
  foreach $temp (sort keys %Apache::lonxml::alltags) {
    &Apache::lonxml::debug("$temp -- $Apache::lonxml::alltags{$temp}");
  }
}
use Apache::style;
use Apache::lontexconvert;
use Apache::run;
use Apache::londefdef;
use Apache::scripttag;
#==================================================   Main subroutine: xmlparse  
@pwd=();
$outputstack = '';
$redirection = 1;
$textredirection = 1;
$on_offimport = 0;
@extlinks=();

sub xmlparse {

 my ($target,$content_file_string,$safeinit,%style_for_target) = @_;
 if ($target eq 'meta') {
   $Apache::lonxml::textredirection = 0;
   $Apache::lonxml::on_offimport = 1;
 } elsif ($target eq 'grade') {
   $Apache::lonxml::textredirection = 0;
   $Apache::lonxml::on_offimport = 0;
 } else {
   $Apache::lonxml::textredirection = 1;
   $Apache::lonxml::on_offimport = 0;
 }
 #&printalltags();
 my @pars = ();
 @Apache::lonxml::pwd=();
 my $pwd=$ENV{'request.filename'};
 $pwd =~ s:/[^/]*$::;
 &newparser(\@pars,\$content_file_string,$pwd);
 my $currentstring = '';
 my $finaloutput = ''; 
 my $newarg = '';
 my $result;

 my $safeeval = new Safe;
 my $safehole = new Safe::Hole;
 $safeeval->permit("entereval");
 $safeeval->permit(":base_math");
 $safeeval->deny(":base_io");
 $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT');
#need to inspect this class of ops
# $safeeval->deny(":base_orig");
 $safeinit .= ';$external::target='.$target.';';
 $safeinit .= ';$external::randomseed='.&Apache::lonnet::rndseed().';';
 &Apache::run::run($safeinit,$safeeval);
#-------------------- Redefinition of the target in the case of compound target

 ($target, my @tenta) = split('&&',$target);

 my @stack = (); 
 my @parstack = ();
 &initdepth;
 my $token;
 while ( $#pars > -1 ) {
   while ($token = $pars[$#pars]->get_token) {
     if ($token->[0] eq 'T') {
       if ($Apache::lonxml::textredirection == 1) {$result=$token->[1];}
       # $finaloutput .= &Apache::run::evaluate($token->[1],$safeeval,'');
     } elsif ($token->[0] eq 'S') {
       # if ($target eq 'meta' and $token->[2]->{metaout} eq 'ON') {$Apache::lonxml::textredirection = 1;}
       # add tag to stack 	    
       push (@stack,$token->[1]);
       # add parameters list to another stack
       push (@parstack,&parstring($token));
       &increasedepth($token);       
       if (exists $style_for_target{$token->[1]}) {
	 
	 if ($Apache::lonxml::redirection == 1) {
	   $finaloutput .= &recurse($style_for_target{$token->[1]},
				    $target,$safeeval,\%style_for_target,
				    @parstack);
	 } else {
	   $Apache::lonxml::outputstack .=  &recurse($style_for_target{$token->[1]},
					$target,$safeeval,\%style_for_target,
					@parstack);
	 }
	 
       } else {
	 $result = &callsub("start_$token->[1]", $target, $token,\@parstack,
			    \@pars, $safeeval, \%style_for_target);
       }              
     } elsif ($token->[0] eq 'E')  {
       #if ($target eq 'meta') {$Apache::lonxml::textredirection = 0;}
       #clear out any tags that didn't end
       while ($token->[1] ne $stack[$#stack] 
	      && ($#stack > -1)) {
	 &Apache::lonxml::warning("Unbalanced tags in resource $stack['-1']");   
	 pop @stack;pop @parstack;&decreasedepth($token);
       }
       
       if (exists $style_for_target{'/'."$token->[1]"}) {

	if ($Apache::lonxml::redirection == 1) {
	 $finaloutput .= &recurse($style_for_target{'/'."$token->[1]"},
				  $target,$safeeval,\%style_for_target,
				  @parstack);
        } else {
         $Apache::lonxml::outputstack .=  &recurse($style_for_target{'/'."$token->[1]"},
				  $target,$safeeval,\%style_for_target,
				  @parstack);
        }

       } else {
	 $result = &callsub("end_$token->[1]", $target, $token, \@parstack,
			       \@pars,$safeeval, \%style_for_target);
       }
     }
     if ($result ne "") {
       if ( $#parstack > -1 ) {
 
	if ($Apache::lonxml::redirection == 1) {
	 $finaloutput .= &Apache::run::evaluate($result,$safeeval,
						$parstack[$#parstack]);
        } else {
         $Apache::lonxml::outputstack .= &Apache::run::evaluate($result,$safeeval,
						$parstack[$#parstack]);
        }

       } else {
	 $finaloutput .= &Apache::run::evaluate($result,$safeeval,'');
       }
       $result = '';
     } else {
         $finaloutput .= $result;
     }
     if ($token->[0] eq 'E') { pop @stack;pop @parstack;&decreasedepth($token);}
   }
   pop @pars;
   pop @Apache::lonxml::pwd;
 }

 return $finaloutput;
}

sub recurse {
  
  my @innerstack = (); 
  my @innerparstack = ();
  my ($newarg,$target,$safeeval,$style_for_target,@parstack) = @_;
  my @pat = ();
  &newparser(\@pat,\$newarg);
  my $tokenpat;
  my $partstring = '';
  my $output='';
  my $decls='';
  while ( $#pat > -1 ) {
    while  ($tokenpat = $pat[$#pat]->get_token) {
      if ($tokenpat->[0] eq 'T') {
	  if ($Apache::lonxml::textredirection == 1) {$partstring = $tokenpat->[1];}
      } elsif ($tokenpat->[0] eq 'S') {
	push (@innerstack,$tokenpat->[1]);
	push (@innerparstack,&parstring($tokenpat));
	&increasedepth($tokenpat);
	$partstring = &callsub("start_$tokenpat->[1]", 
			       $target, $tokenpat, \@innerparstack,
			       \@pat, $safeeval, $style_for_target);
      } elsif ($tokenpat->[0] eq 'E') {
	#clear out any tags that didn't end
	while ($tokenpat->[1] ne $innerstack[$#innerstack] 
	       && ($#innerstack > -1)) {
	  &Apache::lonxml::warning("Unbalanced tags in resource $innerstack['-1']");
	  pop @innerstack;pop @innerparstack;&decreasedepth($tokenpat);
	}
	$partstring = &callsub("end_$tokenpat->[1]",
			       $target, $tokenpat, \@innerparstack,
			       \@pat, $safeeval, $style_for_target);
      }
      #pass both the variable to the style tag, and the tag we 
      #are processing inside the <definedtag>
      if ( $partstring ne "" ) {
	if ( $#parstack > -1 ) { 
	  if ( $#innerparstack > -1 ) { 
	    $decls= $parstack[$#parstack].$innerparstack[$#innerparstack];
	  } else {
	    $decls= $parstack[$#parstack];
	  }
	} else {
	  if ( $#innerparstack > -1 ) { 
	    $decls=$innerparstack[$#innerparstack];
	  } else {
	    $decls='';
	  }
	}
	$output .= &Apache::run::evaluate($partstring,$safeeval,$decls);
	$partstring = '';
      }
      if ($tokenpat->[0] eq 'E') { pop @innerstack;pop @innerparstack;
				 &decreasedepth($tokenpat);}
    }
    pop @pat;
    pop @Apache::lonxml::pwd;
  }
  return $output;
}

sub callsub {
  my ($sub,$target,$token,$parstack,$parser,$safeeval,$style)=@_;
  my $currentstring='';
  {
      my $sub1;
    no strict 'refs';
    if (my $space=$Apache::lonxml::alltags{$token->[1]}) {
      #&Apache::lonxml::debug("Calling sub $sub in $space<br />\n");
      $sub1="$space\:\:$sub";
      $Apache::lonxml::curdepth=join('_',@Apache::lonxml::depthcounter);
      $currentstring = &$sub1($target,$token,$parstack,$parser,
			     $safeeval,$style);
    } else {
      #&Apache::lonxml::debug("NOT Calling sub $sub in $space<br />\n");
      if (defined($token->[4])) {
	$currentstring = $token->[4];
      } else {
	$currentstring = $token->[2];
      }
    }
    use strict 'refs';
  }
  return $currentstring;
}

sub initdepth {
  @Apache::lonxml::depthcounter=();
  $Apache::lonxml::depth=-1;
  $Apache::lonxml::olddepth=-1;
}

sub increasedepth {
  my ($token) = @_;
  $Apache::lonxml::depth++;
  $Apache::lonxml::depthcounter[$Apache::lonxml::depth]++;
  if ($Apache::lonxml::depthcounter[$Apache::lonxml::depth]==1) {
    $Apache::lonxml::olddepth=$Apache::lonxml::depth;
  }
  my $curdepth=join('_',@Apache::lonxml::depthcounter);
  &Apache::lonxml::debug("s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n");
#print "<br />s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n";
}

sub decreasedepth {
  my ($token) = @_;
  $Apache::lonxml::depth--;
  if ($Apache::lonxml::depth<$Apache::lonxml::olddepth-1) {
    $#Apache::lonxml::depthcounter--;
    $Apache::lonxml::olddepth=$Apache::lonxml::depth+1;
  }
  if (  $Apache::lonxml::depth < -1) {
    &Apache::lonxml::warning("Unbalanced tags in resource");   
    $Apache::lonxml::depth='-1';
  }
  my $curdepth=join('_',@Apache::lonxml::depthcounter);
  &Apache::lonxml::debug("e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n");
#print "<br />e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n";
}

sub get_all_text {

 my($tag,$pars)= @_;
 my $depth=0;
 my $token;
 my $result='';
 my $tag=substr($tag,1); #strip the / off the tag
 #&Apache::lonxml::debug("have:$tag:");
 while (($depth >=0) && ($token = $pars->get_token)) {
   #&Apache::lonxml::debug("token:$token->[0]:$depth:$token->[1]");
   if ($token->[0] eq 'T') {
     $result.=$token->[1];
   } elsif ($token->[0] eq 'S') {
     if ($token->[1] eq $tag) { $depth++; }
     $result.=$token->[4];
   } elsif ($token->[0] eq 'E')  {
     if ( $token->[1] eq $tag) { $depth--; }
     #skip sending back the last end tag
     if ($depth > -1) { $result.=$token->[2]; } else {
       $pars->unget_token($token);
     }
   }
 }
# &Apache::lonxml::debug("Exit:$result:");
 return $result
}

sub newparser {
  my ($parser,$contentref,$dir) = @_;
  push (@$parser,HTML::TokeParser->new($contentref));
  if ( $dir eq '' ) {
    push (@Apache::lonxml::pwd, $Apache::lonxml::pwd[$#Apache::lonxml::pwd]);
  } else {
    push (@Apache::lonxml::pwd, $dir);
  } 
#  &Apache::lonxml::debug("pwd:$#Apache::lonxml::pwd");
#  &Apache::lonxml::debug("pwd:$Apache::lonxml::pwd[$#Apache::lonxml::pwd]");
}

sub parstring {
  my ($token) = @_;
  my $temp='';
  map {
    unless ($_=~/\W/) {
      my $val=$token->[2]->{$_};
      $val =~ s/([\%\@\\])/\\$1/g;
      #if ($val =~ m/^[\%\@]/) { $val="\\".$val; }
      $temp .= "my \$$_=\"$val\";"
    }
  } @{$token->[3]};
  return $temp;
}

sub writeallows {
    my $thisurl='/res/'.&Apache::lonnet::declutter(shift);
    my $thisdir=$thisurl;
    $thisdir=~s/\/[^\/]+$//;
    my %httpref=();
    map {
       $httpref{'httpref.'.
 	        &Apache::lonnet::hreflocation($thisdir,$_)}=$thisurl;              } @extlinks;
    &Apache::lonnet::appenv(%httpref);
}

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->print(<<ENDHEADER);
#<html>
#<head>
#<title>Just test</title>
#</head>
#<body bgcolor="#FFFFFF">
#ENDHEADER
#  &Apache::lonhomework::send_header($request);
  $request->send_http_header;

  return OK if $request->header_only;

  $request->print(&Apache::lontexconvert::header());

  $request->print('<body bgcolor="#FFFFFF">'."\n");

  my $file=&Apache::lonnet::filelocation("",$request->uri);
  my %mystyle;
  my $result = ''; 
  my $filecontents=&Apache::lonnet::getfile($file);
  if ($filecontents == -1) {
    &Apache::lonxml::error("<b> Unable to find <i>$file</i></b>");
    $filecontents='';
  } else {
    $result = &Apache::lonxml::xmlparse($target,$filecontents,'',%mystyle);
  }
  $request->print($result);


  $request->print('</body>');
  $request->print(&Apache::lontexconvert::footer());
  writeallows($request->uri);
  return OK;
}
 
$Apache::lonxml::debug=0;
sub debug {
  if ($Apache::lonxml::debug eq 1) {
    print "DEBUG:".$_[0]."<br />\n";
  }
}

sub error {
  if ($Apache::lonxml::debug eq 1) {
    print "ERROR:".$_[0]."<br />\n";
  } else {
    print "<b>An Error occured while processing this resource. The instructor has been notified.</b> <br />";
    #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 ($Apache::lonxml::debug eq 1) {
    print "WARNING:".$_[0]."<br />\n";
  }
}

1;
__END__

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.