Return to lonxml.pm CVS log

Up to [LON-CAPA] / loncom / xml

- added debug,error, and warning functions
- they don't do much right now but eventually

- debug won't do anything
- error will provide error messages, if a student is using it it might just
  supress the actual message but send an email to the creator of the
  resource, if it is in an editing mode, it will give the user the error
  message and were it occured
- warning will be supressed when a student is using it, but will look like
  errors when an instructor is editing

# 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  

sub xmlparse {

 my ($target,$content_file_string,$safeinit,%style_for_target) = @_;
 my @pars = ();
 push (@pars,HTML::TokeParser->new(\$content_file_string));
 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.';';
 &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]}) {
	 $finaloutput .= &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]"}) {
	 $finaloutput .= &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 ) { 
	 $finaloutput .= &Apache::run::evaluate($result,$safeeval,
						$parstack[$#parstack]);
       } else {
	 $finaloutput .= &Apache::run::evaluate($result,$safeeval,'');
       }
       $result = '';
     }
     if ($token->[0] eq 'E') { pop @stack;pop @parstack;&decreasedepth($token);}
   }
   pop @pars;
 }
 return $finaloutput;
}

sub recurse {
  
  my @innerstack = (); 
  my @innerparstack = ();
  my ($newarg,$target,$safeeval,$style_for_target,@parstack) = @_;
  my @pat = ();
  push (@pat,HTML::TokeParser->new(\$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;
  }
  return $output;
}

sub callsub {
  my ($sub,$target,$token,$parstack,$parser,$safeeval,$style)=@_;
  my $currentstring='';
  {
    no strict 'refs';
    if (my $space=$Apache::lonxml::alltags{$token->[1]}) {
      &Apache::lonxml::debug("Calling sub $sub in $space<br>\n");
      $sub="$space\:\:$sub";
      $Apache::lonxml::curdepth=join('_',@Apache::lonxml::depthcounter);
      $currentstring = &$sub($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='';
 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 parstring {
  my ($token) = @_;
  my $temp='';
  map {
    if ($_=~/\w+/) {
      $temp .= "my \$$_=\"$token->[2]->{$_}\";"
    }
  } @{$token->[3]};
  return $temp;
}

$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";
  }
}
sub warning {
  if ($Apache::lonxml::debug eq 1) {
    print "WARNING:".$_[0]."<br>\n";
  }
}

1;
__END__