Return to lonxml.pm CVS log

Up to [LON-CAPA] / loncom / xml

- start _should_ be correct
- end tag is a horrible broken mess that doesn't work

# 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;

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,%style_for_target) = @_;
 my $pars = HTML::TokeParser->new(\$content_file_string);
 my $currentstring = '';
 my $finaloutput = ''; 
 my $newarg = '';
 my $safeeval = new Safe;
 $safeeval->permit("entereval");
#-------------------- Redefinition of the target in the case of compound target

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

#------------------------- Stack definition (in stack we have all current tags)

 my @stack = (); 
 my @parstack = ();

#------------------------------------- Parse input string (content_file_string)
 
 my $token;
 
 while ($token = $pars->get_token) {
   if ($token->[0] eq 'T') {
     $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));
     
     if (exists $style_for_target{$token->[1]}) {
       #basically recurse, but we never got more than one level down so just 
       #create the new context here
       my @innerstack = (); 
       my @innerparstack = ();
       # use style file definition
       $newarg = $style_for_target{$token->[1]};       
       my $pat = HTML::TokeParser->new(\$newarg);
       my $tokenpat = '';
       my $partstring = '';

       while  ($tokenpat = $pat->get_token) {
	 if ($tokenpat->[0] eq 'T') {
	   $partstring = $tokenpat->[1];
	 } elsif ($tokenpat->[0] eq 'S') {
	   push (@innerstack,$tokenpat->[1]);
	   push (@innerparstack,&parstring($tokenpat));
	   $partstring = &callsub("start_$tokenpat->[1]", 
				  $target, $tokenpat, \@innerparstack)
	 } elsif ($tokenpat->[0] eq 'E') {
	   #clear out any tags that didn't end
	   while ($tokenpat->[1] ne $innerstack[$#innerstack] 
		  && ($#innerstack > 0)) {pop @innerstack;pop @innerparstack;}
	   $partstring = &callsub("end_$tokenpat->[1]",
				  $target, $tokenpat, \@innerparstack)
	 }
	 #pass both the variable to the style tag, and the tag we 
	 #are processing inside the <definedtag>
	 $finaloutput .= &Apache::run::evaluate($partstring,$safeeval,
		$parstack[$#parstack].$innerparstack[$#innerparstack]);
	 if ($tokenpat->[0] eq 'E') { pop @innerstack;pop @innerparstack; }
       }
     } else {
       my $result = &callsub("start_$token->[1]", $target, $token, \@parstack);
       $finaloutput .= &Apache::run::evaluate($result,$safeeval,
					      $parstack[$#parstack]);
     }              
   } elsif ($token->[0] eq 'E')  {
     # Put here check for correct final tag (to avoid existence of 
     # starting tag only)
     
     pop @stack; 
     unless (exists $style_for_target{$token->[1]}) {
       my $sub="end_$token->[1]";
       $finaloutput .= callsub($sub, $target, $token, \@parstack);
     }
     #---- end tag from the style file
     if (exists $style_for_target{'/'."$token->[1]"}) {
       $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];
		 }
	       }
	       
               my @tempor_list = split(',',$parstack[$#parstack]);
               my @te_kl = ();
               my %tempor_hash = ();
               map {(my $onete,my $twote) = split('=',$_); push (@te_kl,$onete); 
                    $tempor_hash{$onete} = $twote} @tempor_list;
               map {$partstring =~ s/\$$_/$tempor_hash{$_}/g; } @te_kl; 
	       print "want to use run\n";
               &Apache::run::run($partstring,$safeeval);
	       
               $partstring = '';
	     } elsif ($tokenpat->[1] eq 'evaluate') {		
	       $outputstring = &Apache::run::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 {
         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 callsub {
  my ($sub,$target,$token,@parstack)=@_;
  my $currentstring='';
  {
    no strict 'refs';
    if (my $space=$Apache::lonxml::alltags{$token->[1]}) {
      #print "Calling sub $sub in $space \n";
      $sub="$space\:\:$sub";
      $currentstring = &$sub($target,$token,\@parstack);
    } else {
      #print "NOT Calling sub $sub\n";
      if (defined($token->[4])) {
	$currentstring = $token->[4];
      } else {
	$currentstring = $token->[2];
      }
    }
    use strict 'refs';
  }
  return $currentstring;
}

sub parstring {
  my ($token) = @_;
  my $temp='';
  map {$temp .= "my \$$_=\"$token->[2]->{$_}\";"} @{$token->[3]};
  return $temp;
}
1;
__END__