Return to lonxml.pm CVS log

Up to [LON-CAPA] / loncom / xml

new but not full and last version of cbi.sty

# The LearningOnline Network with CAPA
# XML Parser Module 
#
# last modified 06/26/00 by Alexander Sakharuk

package Apache::lonxml; 

use strict;
use HTML::TokeParser;
use Safe;
use Opcode;

sub register {
  my $space;
  my @taglist;
  my $temptag;
  ($space,@taglist) = @_;
  foreach $temptag (@taglist) {
    $Apache::lonxml::alltags{$temptag}=$space;
  }
}
                                     
use Apache::style;
use Apache::lontexconvert;
use Apache::run;
use Apache::londefdef;
use Apache::scripttag;
#==================================================   Main subroutine: xmlparse  
@Apache::lonxml::pwd=();
$Apache::lonxml::outputstack = '';
$Apache::lonxml::redirection = 1;

sub xmlparse {

 my ($target,$content_file_string,$safeinit,%style_for_target) = @_;
 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;
 $safeeval->permit("entereval");
 $safeeval->permit(":base_math");
 $safeeval->deny(":base_io");
#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') {
       $result=$token->[1];
#       $finaloutput .= &Apache::run::evaluate($token->[1],$safeeval,'');
     } elsif ($token->[0] eq 'S') {
       # 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')  {
       #clear out any tags that didn't end
       while ($token->[1] ne $stack[$#stack] 
	      && ($#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') {
	$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)) {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) = @_;
  if ($Apache::lonxml::depth<$Apache::lonxml::olddepth-1) {
    $#Apache::lonxml::depthcounter--;
    $Apache::lonxml::olddepth=$Apache::lonxml::depth;
  }
  $Apache::lonxml::depth++;
#  print "<br>s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1]<br>\n";
  $Apache::lonxml::depthcounter[$Apache::lonxml::depth]++;
  if ($Apache::lonxml::depthcounter[$Apache::lonxml::depth]==1) {
    $Apache::lonxml::olddepth=$Apache::lonxml::depth;
  }
}

sub decreasedepth {
  my ($token) = @_;
  $Apache::lonxml::depth--;
#  print "<br>e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1]<br>\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)) {
   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]; }
   }
 }
 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 {
    if ($_=~/\w+/) {
      $temp .= "my \$$_=\"$token->[2]->{$_}\";"
    }
  } @{$token->[3]};
  return $temp;
}

sub handler {
  my $request=shift;

  my $target='web';
  $Apache::lonxml::debug=1;
  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 = "/home/httpd/html".$request->uri;
  my %mystyle;
  my $result = '';
  $result = Apache::lonxml::xmlparse($target, &Apache::lonnet::getfile($file),'',%mystyle);
  $request->print($result);

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