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

    1: # The LearningOnline Network with CAPA
    2: # XML Parser Module 
    3: #
    4: # last modified 06/26/00 by Alexander Sakharuk
    5: 
    6: package Apache::lonxml; 
    7: 
    8: use strict;
    9: use HTML::TokeParser;
   10: use Safe;
   11: use Opcode;
   12: 
   13: sub register {
   14:   my $space;
   15:   my @taglist;
   16:   my $temptag;
   17:   ($space,@taglist) = @_;
   18:   foreach $temptag (@taglist) {
   19:     $Apache::lonxml::alltags{$temptag}=$space;
   20:   }
   21: }
   22:                                      
   23: use Apache::style;
   24: use Apache::lontexconvert;
   25: use Apache::run;
   26: use Apache::londefdef;
   27: use Apache::scripttag;
   28: #==================================================   Main subroutine: xmlparse  
   29: 
   30: sub xmlparse {
   31: 
   32:  my ($target,$content_file_string,$safeinit,%style_for_target) = @_;
   33:  my @pars = ();
   34:  push (@pars,HTML::TokeParser->new(\$content_file_string));
   35:  my $currentstring = '';
   36:  my $finaloutput = ''; 
   37:  my $newarg = '';
   38:  my $result;
   39:  my $safeeval = new Safe;
   40:  $safeeval->permit("entereval");
   41:  $safeeval->permit(":base_math");
   42:  $safeeval->deny(":base_io");
   43: #need to inspect this class of ops
   44: # $safeeval->deny(":base_orig");
   45:  $safeinit .= ';$external::target='.$target.';';
   46:  &Apache::run::run($safeinit,$safeeval);
   47: #-------------------- Redefinition of the target in the case of compound target
   48: 
   49:  ($target, my @tenta) = split('&&',$target);
   50: 
   51:  my @stack = (); 
   52:  my @parstack = ();
   53:  &initdepth;
   54:  my $token;
   55:  while ( $#pars > -1 ) {
   56:    while ($token = $pars[$#pars]->get_token) {
   57:      if ($token->[0] eq 'T') {
   58:        $result=$token->[1];
   59: #       $finaloutput .= &Apache::run::evaluate($token->[1],$safeeval,'');
   60:      } elsif ($token->[0] eq 'S') {
   61:        # add tag to stack 	    
   62:        push (@stack,$token->[1]);
   63:        # add parameters list to another stack
   64:        push (@parstack,&parstring($token));
   65:        &increasedepth($token);       
   66:        if (exists $style_for_target{$token->[1]}) {
   67: 	 $finaloutput .= &recurse($style_for_target{$token->[1]},
   68: 				  $target,$safeeval,\%style_for_target,
   69: 				  @parstack);
   70:        } else {
   71: 	 $result = &callsub("start_$token->[1]", $target, $token,\@parstack,
   72: 			       \@pars, $safeeval, \%style_for_target);
   73:        }              
   74:      } elsif ($token->[0] eq 'E')  {
   75:        #clear out any tags that didn't end
   76:        while ($token->[1] ne $stack[$#stack] 
   77: 	      && ($#stack > -1)) {pop @stack;pop @parstack;&decreasedepth($token);}
   78:        
   79:        if (exists $style_for_target{'/'."$token->[1]"}) {
   80: 	 $finaloutput .= &recurse($style_for_target{'/'."$token->[1]"},
   81: 				  $target,$safeeval,\%style_for_target,
   82: 				  @parstack);
   83:        } else {
   84: 	 $result = &callsub("end_$token->[1]", $target, $token, \@parstack,
   85: 			       \@pars,$safeeval, \%style_for_target);
   86:        }
   87:      }
   88:      if ($result ne "" ) {
   89:        if ( $#parstack > -1 ) { 
   90: 	 $finaloutput .= &Apache::run::evaluate($result,$safeeval,
   91: 						$parstack[$#parstack]);
   92:        } else {
   93: 	 $finaloutput .= &Apache::run::evaluate($result,$safeeval,'');
   94:        }
   95:        $result = '';
   96:      }
   97:      if ($token->[0] eq 'E') { pop @stack;pop @parstack;&decreasedepth($token);}
   98:    }
   99:    pop @pars;
  100:  }
  101:  return $finaloutput;
  102: }
  103: 
  104: sub recurse {
  105:   
  106:   my @innerstack = (); 
  107:   my @innerparstack = ();
  108:   my ($newarg,$target,$safeeval,$style_for_target,@parstack) = @_;
  109:   my @pat = ();
  110:   push (@pat,HTML::TokeParser->new(\$newarg));
  111:   my $tokenpat;
  112:   my $partstring = '';
  113:   my $output='';
  114:   my $decls='';
  115:   while ( $#pat > -1 ) {
  116:     while  ($tokenpat = $pat[$#pat]->get_token) {
  117:       if ($tokenpat->[0] eq 'T') {
  118: 	$partstring = $tokenpat->[1];
  119:       } elsif ($tokenpat->[0] eq 'S') {
  120: 	push (@innerstack,$tokenpat->[1]);
  121: 	push (@innerparstack,&parstring($tokenpat));
  122: 	&increasedepth($tokenpat);
  123: 	$partstring = &callsub("start_$tokenpat->[1]", 
  124: 			       $target, $tokenpat, \@innerparstack,
  125: 			       \@pat, $safeeval, $style_for_target);
  126:       } elsif ($tokenpat->[0] eq 'E') {
  127: 	#clear out any tags that didn't end
  128: 	while ($tokenpat->[1] ne $innerstack[$#innerstack] 
  129: 	       && ($#innerstack > -1)) {pop @innerstack;pop @innerparstack;
  130: 					&decreasedepth($tokenpat);}
  131: 	$partstring = &callsub("end_$tokenpat->[1]",
  132: 			       $target, $tokenpat, \@innerparstack,
  133: 			       \@pat, $safeeval, $style_for_target);
  134:       }
  135:       #pass both the variable to the style tag, and the tag we 
  136:       #are processing inside the <definedtag>
  137:       if ( $partstring ne "" ) {
  138: 	if ( $#parstack > -1 ) { 
  139: 	  if ( $#innerparstack > -1 ) { 
  140: 	    $decls= $parstack[$#parstack].$innerparstack[$#innerparstack];
  141: 	  } else {
  142: 	    $decls= $parstack[$#parstack];
  143: 	  }
  144: 	} else {
  145: 	  if ( $#innerparstack > -1 ) { 
  146: 	    $decls=$innerparstack[$#innerparstack];
  147: 	  } else {
  148: 	    $decls='';
  149: 	  }
  150: 	}
  151: 	$output .= &Apache::run::evaluate($partstring,$safeeval,$decls);
  152: 	$partstring = '';
  153:       }
  154:       if ($tokenpat->[0] eq 'E') { pop @innerstack;pop @innerparstack;
  155: 				 &decreasedepth($tokenpat);}
  156:     }
  157:     pop @pat;
  158:   }
  159:   return $output;
  160: }
  161: 
  162: sub callsub {
  163:   my ($sub,$target,$token,$parstack,$parser,$safeeval,$style)=@_;
  164:   my $currentstring='';
  165:   {
  166:     no strict 'refs';
  167:     if (my $space=$Apache::lonxml::alltags{$token->[1]}) {
  168:       &Apache::lonxml::debug("Calling sub $sub in $space<br>\n");
  169:       $sub="$space\:\:$sub";
  170:       $Apache::lonxml::curdepth=join('_',@Apache::lonxml::depthcounter);
  171:       $currentstring = &$sub($target,$token,$parstack,$parser,
  172: 			     $safeeval,$style);
  173:     } else {
  174:       &Apache::lonxml::debug("NOT Calling sub $sub in $space<br>\n");
  175:       if (defined($token->[4])) {
  176: 	$currentstring = $token->[4];
  177:       } else {
  178: 	$currentstring = $token->[2];
  179:       }
  180:     }
  181:     use strict 'refs';
  182:   }
  183:   return $currentstring;
  184: }
  185: 
  186: sub initdepth {
  187:   @Apache::lonxml::depthcounter=();
  188:   $Apache::lonxml::depth=-1;
  189:   $Apache::lonxml::olddepth=-1;
  190: }
  191: 
  192: sub increasedepth {
  193:   my ($token) = @_;
  194:   if ($Apache::lonxml::depth<$Apache::lonxml::olddepth-1) {
  195:     $#Apache::lonxml::depthcounter--;
  196:     $Apache::lonxml::olddepth=$Apache::lonxml::depth;
  197:   }
  198:   $Apache::lonxml::depth++;
  199: #  print "<br>s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1]<br>\n";
  200:   $Apache::lonxml::depthcounter[$Apache::lonxml::depth]++;
  201:   if ($Apache::lonxml::depthcounter[$Apache::lonxml::depth]==1) {
  202:     $Apache::lonxml::olddepth=$Apache::lonxml::depth;
  203:   }
  204: }
  205: 
  206: sub decreasedepth {
  207:   my ($token) = @_;
  208:   $Apache::lonxml::depth--;
  209: #  print "<br>e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1]<br>\n";
  210: }
  211: 
  212: sub get_all_text {
  213: 
  214:  my($tag,$pars)= @_;
  215:  my $depth=0;
  216:  my $token;
  217:  my $result='';
  218:  while (($depth >=0) && ($token = $pars->get_token)) {
  219:    if ($token->[0] eq 'T') {
  220:      $result.=$token->[1];
  221:    } elsif ($token->[0] eq 'S') {
  222:      if ($token->[1] eq $tag) { $depth++; }
  223:      $result.=$token->[4];
  224:    } elsif ($token->[0] eq 'E')  {
  225:      if ($token->[1] eq $tag) { $depth--; }
  226:      #skip sending back the last end tag
  227:      if ($depth > -1) { $result.=$token->[2]; }
  228:    }
  229:  }
  230:  return $result
  231: }
  232: 
  233: 
  234: sub parstring {
  235:   my ($token) = @_;
  236:   my $temp='';
  237:   map {
  238:     if ($_=~/\w+/) {
  239:       $temp .= "my \$$_=\"$token->[2]->{$_}\";"
  240:     }
  241:   } @{$token->[3]};
  242:   return $temp;
  243: }
  244: 
  245: $Apache::lonxml::debug=0;
  246: sub debug {
  247:   if ($Apache::lonxml::debug eq 1) {
  248:     print "DEBUG:".$_[0]."<br>\n";
  249:   }
  250: }
  251: sub error {
  252:   if ($Apache::lonxml::debug eq 1) {
  253:     print "ERROR:".$_[0]."<br>\n";
  254:   }
  255: }
  256: sub warning {
  257:   if ($Apache::lonxml::debug eq 1) {
  258:     print "WARNING:".$_[0]."<br>\n";
  259:   }
  260: }
  261: 
  262: 1;
  263: __END__
  264: 
  265: 
  266: 
  267: 
  268: