Return to lonxml.pm CVS log

Up to [LON-CAPA] / loncom / xml

- changed redirection, and output stack to work more intelligently, checkount radiobuttonresponse for a good example, should have to muck with @Apache::lonxml::outputstack and $Apache::lonxml::redirection directly use startredirection and enredirection

    1: # The LearningOnline Network with CAPA
    2: # XML Parser Module 
    3: #
    4: # last modified 06/26/00 by Alexander Sakharuk
    5: # 11/6 Gerd Kortemeyer
    6: # 6/1/1 Gerd Kortemeyer
    7: # 2/21 Guy
    8: 
    9: package Apache::lonxml; 
   10: use vars 
   11: qw(@pwd @outputstack $redirection $textredirection $import @extlinks);
   12: use strict;
   13: use HTML::TokeParser;
   14: use Safe;
   15: use Safe::Hole;
   16: use Opcode;
   17: use Apache::Constants qw(:common);
   18: 
   19: sub register {
   20:   my $space;
   21:   my @taglist;
   22:   my $temptag;
   23:   ($space,@taglist) = @_;
   24:   foreach $temptag (@taglist) {
   25:     $Apache::lonxml::alltags{$temptag}=$space;
   26:   }
   27: }
   28: 
   29: sub printalltags {
   30:   my $temp;
   31:   foreach $temp (sort keys %Apache::lonxml::alltags) {
   32:     &Apache::lonxml::debug("$temp -- $Apache::lonxml::alltags{$temp}");
   33:   }
   34: }
   35: use Apache::style;
   36: use Apache::lontexconvert;
   37: use Apache::run;
   38: use Apache::londefdef;
   39: use Apache::scripttag;
   40: #==================================================   Main subroutine: xmlparse  
   41: @pwd=();
   42: @outputstack = ();
   43: $redirection = 0;
   44: $import = 1;
   45: @extlinks=();
   46: 
   47: sub xmlparse {
   48: 
   49:  my ($target,$content_file_string,$safeinit,%style_for_target) = @_;
   50:  if ($target eq 'meta') {
   51:    &startredirection;
   52:    $Apache::lonxml::import = 0;
   53:  } elsif ($target eq 'grade') {
   54:    &startredirection;
   55:    $Apache::lonxml::import = 1;
   56:  } else {
   57:    $Apache::lonxml::redirection = 0;
   58:    $Apache::lonxml::import = 1;
   59:  }
   60:  #&printalltags();
   61:  my @pars = ();
   62:  @Apache::lonxml::pwd=();
   63:  my $pwd=$ENV{'request.filename'};
   64:  $pwd =~ s:/[^/]*$::;
   65:  &newparser(\@pars,\$content_file_string,$pwd);
   66:  my $currentstring = '';
   67:  my $finaloutput = ''; 
   68:  my $newarg = '';
   69:  my $result;
   70: 
   71:  my $safeeval = new Safe;
   72:  my $safehole = new Safe::Hole;
   73:  $safeeval->permit("entereval");
   74:  $safeeval->permit(":base_math");
   75:  $safeeval->deny(":base_io");
   76:  $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT');
   77: #need to inspect this class of ops
   78: # $safeeval->deny(":base_orig");
   79:  $safeinit .= ';$external::target='.$target.';';
   80:  $safeinit .= ';$external::randomseed='.&Apache::lonnet::rndseed().';';
   81:  &Apache::run::run($safeinit,$safeeval);
   82: #-------------------- Redefinition of the target in the case of compound target
   83: 
   84:  ($target, my @tenta) = split('&&',$target);
   85: 
   86:  my @stack = (); 
   87:  my @parstack = ();
   88:  &initdepth;
   89:  my $token;
   90:  while ( $#pars > -1 ) {
   91:    while ($token = $pars[$#pars]->get_token) {
   92:      if ($token->[0] eq 'T') {
   93:        $result=$token->[1];
   94:      } elsif ($token->[0] eq 'S') {
   95:        # add tag to stack 	    
   96:        push (@stack,$token->[1]);
   97:        # add parameters list to another stack
   98:        push (@parstack,&parstring($token));
   99:        &increasedepth($token);       
  100:        if (exists $style_for_target{$token->[1]}) {
  101: 	 if ($Apache::lonxml::redirection) {
  102: 	   $Apache::lonxml::outputstack['-1'] .=  
  103: 	     &recurse($style_for_target{$token->[1]},$target,$safeeval,
  104: 		      \%style_for_target,@parstack);
  105: 	 } else {
  106: 	   $finaloutput .= &recurse($style_for_target{$token->[1]},$target,
  107: 				    $safeeval,\%style_for_target,@parstack);
  108: 	 }
  109:        } else {
  110: 	 $result = &callsub("start_$token->[1]", $target, $token,\@parstack,
  111: 			    \@pars, $safeeval, \%style_for_target);
  112:        }              
  113:      } elsif ($token->[0] eq 'E')  {
  114:        #clear out any tags that didn't end
  115:        while ($token->[1] ne $stack[$#stack] && ($#stack > -1)) {
  116: 	 &Apache::lonxml::warning("Unbalanced tags in resource $stack['-1']");
  117: 	 pop @stack;pop @parstack;&decreasedepth($token);
  118:        }
  119:        
  120:        if (exists $style_for_target{'/'."$token->[1]"}) {
  121: 	 if ($Apache::lonxml::redirection) {
  122: 	   $Apache::lonxml::outputstack['-1'] .=  
  123: 	     &recurse($style_for_target{'/'."$token->[1]"},
  124: 		      $target,$safeeval,\%style_for_target,@parstack);
  125: 	 } else {
  126: 	   $finaloutput .= &recurse($style_for_target{'/'."$token->[1]"},
  127: 				    $target,$safeeval,\%style_for_target,
  128: 				    @parstack);
  129: 	 }
  130: 	 
  131:        } else {
  132: 	 $result = &callsub("end_$token->[1]", $target, $token, \@parstack,
  133: 			    \@pars,$safeeval, \%style_for_target);
  134:        }
  135:      }
  136:      #evaluate variable refs in result
  137:      if ($result ne "") {
  138:        if ( $#parstack > -1 ) {
  139: 	 if ($Apache::lonxml::redirection) {
  140: 	   $Apache::lonxml::outputstack['-1'] .= 
  141: 	     &Apache::run::evaluate($result,$safeeval,$parstack[$#parstack]);
  142: 	 } else {
  143: 	   $finaloutput .= &Apache::run::evaluate($result,$safeeval,
  144: 						  $parstack[$#parstack]);
  145: 	 }
  146:        } else {
  147: 	 $finaloutput .= &Apache::run::evaluate($result,$safeeval,'');
  148:        }
  149:        $result = '';
  150:      } 
  151:      if ($token->[0] eq 'E') { 
  152:        pop @stack;pop @parstack;&decreasedepth($token);
  153:      }
  154:    }
  155:    pop @pars;
  156:    pop @Apache::lonxml::pwd;
  157:  }
  158: 
  159:  return $finaloutput;
  160: }
  161: 
  162: sub recurse {
  163:   
  164:   my @innerstack = (); 
  165:   my @innerparstack = ();
  166:   my ($newarg,$target,$safeeval,$style_for_target,@parstack) = @_;
  167:   my @pat = ();
  168:   &newparser(\@pat,\$newarg);
  169:   my $tokenpat;
  170:   my $partstring = '';
  171:   my $output='';
  172:   my $decls='';
  173:   while ( $#pat > -1 ) {
  174:     while  ($tokenpat = $pat[$#pat]->get_token) {
  175:       if ($tokenpat->[0] eq 'T') {
  176: 	$partstring = $tokenpat->[1];
  177:       } elsif ($tokenpat->[0] eq 'S') {
  178: 	push (@innerstack,$tokenpat->[1]);
  179: 	push (@innerparstack,&parstring($tokenpat));
  180: 	&increasedepth($tokenpat);
  181: 	$partstring = &callsub("start_$tokenpat->[1]", 
  182: 			       $target, $tokenpat, \@innerparstack,
  183: 			       \@pat, $safeeval, $style_for_target);
  184:       } elsif ($tokenpat->[0] eq 'E') {
  185: 	#clear out any tags that didn't end
  186: 	while ($tokenpat->[1] ne $innerstack[$#innerstack] 
  187: 	       && ($#innerstack > -1)) {
  188: 	  &Apache::lonxml::warning("Unbalanced tags in resource $innerstack['-1']");
  189: 	  pop @innerstack;pop @innerparstack;&decreasedepth($tokenpat);
  190: 	}
  191: 	$partstring = &callsub("end_$tokenpat->[1]",
  192: 			       $target, $tokenpat, \@innerparstack,
  193: 			       \@pat, $safeeval, $style_for_target);
  194:       }
  195:       #pass both the variable to the style tag, and the tag we 
  196:       #are processing inside the <definedtag>
  197:       if ( $partstring ne "" ) {
  198: 	if ( $#parstack > -1 ) { 
  199: 	  if ( $#innerparstack > -1 ) { 
  200: 	    $decls= $parstack[$#parstack].$innerparstack[$#innerparstack];
  201: 	  } else {
  202: 	    $decls= $parstack[$#parstack];
  203: 	  }
  204: 	} else {
  205: 	  if ( $#innerparstack > -1 ) { 
  206: 	    $decls=$innerparstack[$#innerparstack];
  207: 	  } else {
  208: 	    $decls='';
  209: 	  }
  210: 	}
  211: 	$output .= &Apache::run::evaluate($partstring,$safeeval,$decls);
  212: 	$partstring = '';
  213:       }
  214:       if ($tokenpat->[0] eq 'E') { pop @innerstack;pop @innerparstack;
  215: 				 &decreasedepth($tokenpat);}
  216:     }
  217:     pop @pat;
  218:     pop @Apache::lonxml::pwd;
  219:   }
  220:   return $output;
  221: }
  222: 
  223: sub callsub {
  224:   my ($sub,$target,$token,$parstack,$parser,$safeeval,$style)=@_;
  225:   my $currentstring='';
  226:   {
  227:       my $sub1;
  228:     no strict 'refs';
  229:     if (my $space=$Apache::lonxml::alltags{$token->[1]}) {
  230:       #&Apache::lonxml::debug("Calling sub $sub in $space<br />\n");
  231:       $sub1="$space\:\:$sub";
  232:       $Apache::lonxml::curdepth=join('_',@Apache::lonxml::depthcounter);
  233:       $currentstring = &$sub1($target,$token,$parstack,$parser,
  234: 			     $safeeval,$style);
  235:     } else {
  236:       #&Apache::lonxml::debug("NOT Calling sub $sub in $space<br />\n");
  237:       if (defined($token->[4])) {
  238: 	$currentstring = $token->[4];
  239:       } else {
  240: 	$currentstring = $token->[2];
  241:       }
  242:     }
  243:     use strict 'refs';
  244:   }
  245:   return $currentstring;
  246: }
  247: 
  248: sub startredirection {
  249:   $Apache::lonxml::redirection++;
  250:   push (@Apache::lonxml::outputstack, '');
  251: }
  252: 
  253: sub endredirection {
  254:   if (!$Apache::lonxml::redirection) {
  255:     &Apache::lonxml::error("Endredirection was called, before a startredirection, perhaps you have unbalanced tags. Some debuggin information:".join ":",caller);
  256:     return '';
  257:   }
  258:   $Apache::lonxml::redirection--;
  259:   pop @Apache::lonxml::outputstack;
  260: }
  261: 
  262: sub initdepth {
  263:   @Apache::lonxml::depthcounter=();
  264:   $Apache::lonxml::depth=-1;
  265:   $Apache::lonxml::olddepth=-1;
  266: }
  267: 
  268: sub increasedepth {
  269:   my ($token) = @_;
  270:   $Apache::lonxml::depth++;
  271:   $Apache::lonxml::depthcounter[$Apache::lonxml::depth]++;
  272:   if ($Apache::lonxml::depthcounter[$Apache::lonxml::depth]==1) {
  273:     $Apache::lonxml::olddepth=$Apache::lonxml::depth;
  274:   }
  275:   my $curdepth=join('_',@Apache::lonxml::depthcounter);
  276:   &Apache::lonxml::debug("s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n");
  277: #print "<br />s $Apache::lonxml::depth : $Apache::lonxml::olddepth : $curdepth : $token->[1]\n";
  278: }
  279: 
  280: sub decreasedepth {
  281:   my ($token) = @_;
  282:   $Apache::lonxml::depth--;
  283:   if ($Apache::lonxml::depth<$Apache::lonxml::olddepth-1) {
  284:     $#Apache::lonxml::depthcounter--;
  285:     $Apache::lonxml::olddepth=$Apache::lonxml::depth+1;
  286:   }
  287:   if (  $Apache::lonxml::depth < -1) {
  288:     &Apache::lonxml::warning("Unbalanced tags in resource");   
  289:     $Apache::lonxml::depth='-1';
  290:   }
  291:   my $curdepth=join('_',@Apache::lonxml::depthcounter);
  292:   &Apache::lonxml::debug("e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n");
  293: #print "<br />e $Apache::lonxml::depth : $Apache::lonxml::olddepth : $token->[1] : $curdepth\n";
  294: }
  295: 
  296: sub get_all_text {
  297: 
  298:  my($tag,$pars)= @_;
  299:  my $depth=0;
  300:  my $token;
  301:  my $result='';
  302:  my $tag=substr($tag,1); #strip the / off the tag
  303:  #&Apache::lonxml::debug("have:$tag:");
  304:  while (($depth >=0) && ($token = $pars->get_token)) {
  305:    #&Apache::lonxml::debug("token:$token->[0]:$depth:$token->[1]");
  306:    if ($token->[0] eq 'T') {
  307:      $result.=$token->[1];
  308:    } elsif ($token->[0] eq 'S') {
  309:      if ($token->[1] eq $tag) { $depth++; }
  310:      $result.=$token->[4];
  311:    } elsif ($token->[0] eq 'E')  {
  312:      if ( $token->[1] eq $tag) { $depth--; }
  313:      #skip sending back the last end tag
  314:      if ($depth > -1) { $result.=$token->[2]; } else {
  315:        $pars->unget_token($token);
  316:      }
  317:    }
  318:  }
  319: # &Apache::lonxml::debug("Exit:$result:");
  320:  return $result
  321: }
  322: 
  323: sub newparser {
  324:   my ($parser,$contentref,$dir) = @_;
  325:   push (@$parser,HTML::TokeParser->new($contentref));
  326:   if ( $dir eq '' ) {
  327:     push (@Apache::lonxml::pwd, $Apache::lonxml::pwd[$#Apache::lonxml::pwd]);
  328:   } else {
  329:     push (@Apache::lonxml::pwd, $dir);
  330:   } 
  331: #  &Apache::lonxml::debug("pwd:$#Apache::lonxml::pwd");
  332: #  &Apache::lonxml::debug("pwd:$Apache::lonxml::pwd[$#Apache::lonxml::pwd]");
  333: }
  334: 
  335: sub parstring {
  336:   my ($token) = @_;
  337:   my $temp='';
  338:   map {
  339:     unless ($_=~/\W/) {
  340:       my $val=$token->[2]->{$_};
  341:       $val =~ s/([\%\@\\])/\\$1/g;
  342:       #if ($val =~ m/^[\%\@]/) { $val="\\".$val; }
  343:       $temp .= "my \$$_=\"$val\";"
  344:     }
  345:   } @{$token->[3]};
  346:   return $temp;
  347: }
  348: 
  349: sub writeallows {
  350:     my $thisurl='/res/'.&Apache::lonnet::declutter(shift);
  351:     my $thisdir=$thisurl;
  352:     $thisdir=~s/\/[^\/]+$//;
  353:     my %httpref=();
  354:     map {
  355:        $httpref{'httpref.'.
  356:  	        &Apache::lonnet::hreflocation($thisdir,$_)}=$thisurl;              } @extlinks;
  357:     &Apache::lonnet::appenv(%httpref);
  358: }
  359: 
  360: sub handler {
  361:   my $request=shift;
  362:   
  363:   my $target='web';
  364:   $Apache::lonxml::debug=0;
  365:   if ($ENV{'browser.mathml'}) {
  366:     $request->content_type('text/xml');
  367:   } else {
  368:     $request->content_type('text/html');
  369:   }
  370: 
  371: #  $request->print(<<ENDHEADER);
  372: #<html>
  373: #<head>
  374: #<title>Just test</title>
  375: #</head>
  376: #<body bgcolor="#FFFFFF">
  377: #ENDHEADER
  378: #  &Apache::lonhomework::send_header($request);
  379:   $request->send_http_header;
  380: 
  381:   return OK if $request->header_only;
  382: 
  383:   $request->print(&Apache::lontexconvert::header());
  384: 
  385:   $request->print('<body bgcolor="#FFFFFF">'."\n");
  386: 
  387:   my $file=&Apache::lonnet::filelocation("",$request->uri);
  388:   my %mystyle;
  389:   my $result = ''; 
  390:   my $filecontents=&Apache::lonnet::getfile($file);
  391:   if ($filecontents == -1) {
  392:     &Apache::lonxml::error("<b> Unable to find <i>$file</i></b>");
  393:     $filecontents='';
  394:   } else {
  395:     $result = &Apache::lonxml::xmlparse($target,$filecontents,'',%mystyle);
  396:   }
  397:   $request->print($result);
  398: 
  399: 
  400:   $request->print('</body>');
  401:   $request->print(&Apache::lontexconvert::footer());
  402:   writeallows($request->uri);
  403:   return OK;
  404: }
  405:  
  406: $Apache::lonxml::debug=0;
  407: sub debug {
  408:   if ($Apache::lonxml::debug eq 1) {
  409:     print "DEBUG:".$_[0]."<br />\n";
  410:   }
  411: }
  412: 
  413: sub error {
  414:   if ($Apache::lonxml::debug eq 1) {
  415:     print "<b>ERROR:</b>".$_[0]."<br />\n";
  416:   } else {
  417:     print "<b>An Error occured while processing this resource. The instructor has been notified.</b> <br />";
  418:     #notify author
  419:     &Apache::lonmsg::author_res_msg($ENV{'request.filename'},$_[0]);
  420:     #notify course
  421:     if ( $ENV{'request.course.id'} ) {
  422:       my $users=$ENV{'course.'.$ENV{'request.course.id'}.'.comment.email'};
  423:       foreach my $user (split /\,/, $users) {
  424: 	($user,my $domain) = split /:/, $user;
  425: 	&Apache::lonmsg::user_normal_msg($user,$domain,"Error in $ENV{'request.filename'}",$_[0]);
  426:       }
  427:     }
  428:     
  429:     #FIXME probably shouldn't have me get everything forever.
  430:     &Apache::lonmsg::user_normal_msg('albertel','msu',"Error in $ENV{'request.filename'}",$_[0]);
  431:     #&Apache::lonmsg::user_normal_msg('albertel','103',"Error in $ENV{'request.filename'}",$_[0]);   
  432:   }
  433: }
  434: 
  435: sub warning {
  436:   if ($Apache::lonxml::debug eq 1) {
  437:     print "<b>W</b>ARNING<b>:</b>".$_[0]."<br />\n";
  438:   }
  439: }
  440: 
  441: 1;
  442: __END__