Return to lonproblem.pm CVS log

Up to [LON-CAPA] / loncom / homework

Integrating loncom file into CVS archive.

# The LearningOnline Network with CAPA
# Problem Handler
#
# 12/15-01/21,01/24 Gerd Kortemeyer

package Apache::lonproblem;

use strict;
use HTML::TokeParser;
use Safe;
use Apache::File;

# ================================================================ Main Handler

sub handler {
my $r=shift;
my @parsecontents;
my $parsestring;
my $outstring;

{
  my $fh=Apache::File->new($r->filename);
  @parsecontents=<$fh>;
}

$parsestring=join('',@parsecontents);

print "<form>";

&xmlparse($r,$parsestring,'web');

print "\n---------------\n";
print "<form>";
&xmlparse($r,$parsestring,'edit');
$outstring=xmlparse($parsestring,'modified');
print "\n---------------\n$outstring\n";
return 1; #change to ok
}

# =============================================================================
# ============================================================= Parsing Routine
# Takes $parsestring and $target
# =============================================================================

sub xmlparse {

my ($r,$parsestring,$target) = @_;

my $safeeval   = new Safe 'Script';

my $parsereval = new Safe 'Parser';

my $parser=HTML::TokeParser->new(\$parsestring);

my $outtext='';

# ---------------------------------------------------------------- Handled tags

my %toptoplevel  = ( 'problem'    => 'Problem',
                     'entryform'  => 'Entry Form',
                     'survey'     => 'Survey',
                     'graded'     => 'Manually Graded' );


# --------------------------------------------------------------- Toplevel Tags

my %topleveltags = ( 'block'   => 'Condition Block',
                     'part'    => 'Problem Part';
                     'include' => 'Include Section',
                     'answer'  => 'Answerfield';
                     'script'  => 'Script', 
                     'outtext' => 'Text Block' );
 
# ---------------------------------------------------------- Preregistered Tags

my %includetags  = ( 'scriptlib' => 'Script Library',
                     'parserlib' => 'Parser Library' );

# -------------------------------------------------------------------- All Tags

my %xmltags      = ( %includetags, %topleveltags, %toptoplevel );

my $toplevel     = '';
my $above        = '';

# --------------------------------------------------- Depth counter for editing

my @depthcounter=();
my $depth=-1;
my $olddepth=-1;

# ----------------------------------------------------------------------- Stack

my @stack=('');

# -------------------------------------------------------------- Init $saveeval

&init_safeeval($safeeval);

# ---------------------------------------------------------- Parse $parsestring

my $token;

while ($token=$parser->get_token) {
# =============================================================================
   if ($token->[0] eq 'S') {
# =================================================================== Start Tag
# --------------------------------------------------------------- Depth Counter
      if (defined($xmltags{$token->[1]})) {
         if ($depth<$olddepth-1) {
            $#depthcounter--;
            $olddepth=$depth;
         }
         $depth++;
         $depthcounter[$depth]++;
         if ($depthcounter[$depth]==1) {
            $olddepth=$depth;
         }
      }  
# -----------------------------------------------------------------------------


      if ($target eq 'web') {
         my $sub="start_$token->[1]";
         {
           no strict 'refs';
           if (defined (&$sub)) { 
              &$sub($r,$token,$parser,$safeeval,\@stack); 
           } else {
              $stack[$#stack].=$token->[4];
           }
         }
      }

      if ($target eq 'edit') {
         my $depthlabel=join('_',@depthcounter);
         if (defined($xmltags{$token->[1]})) {
            if (defined($topleveltags{$token->[1]})) {
               &insertmenu($r,$xmltags{$token->[1]},
                           $depthlabel,\%topleveltags);
              $toplevel=$token->[1];
            } else {
                if ($toplevel eq 'answer') {
                   &insertmenu($r,$xmltags{$token->[1]},
                               $depthlabel,\%answertags);
                }
            }
            my $sub="start_edit_$token->[1]";
            {
              no strict 'refs';
              if (defined (&$sub)) { 
                 &$sub($r,$token,$parser,$xmltags{$token->[1]},
                       $depthlabel,$above,\%answertypes,\@stack); 
              }
            } 
         } else {
            $stack[$#stack].=$token->[4];
         }
      }

      if ($target eq 'modified') {
      }

# =============================================================================
   } elsif ($token->[0] eq 'E') {
# ===================================================================== End Tag

      if ($target eq 'web') {
         my $sub="end_$token->[1]";
         {
           no strict 'refs';
           if (defined (&$sub)) { 
              &$sub($r,$token,$parser,$safeeval,\@stack);
           } else {
              $stack[$#stack].=$token->[2];
           }
         }
      }

      if ($target eq 'edit') {
         if (defined($xmltags{$token->[1]})) {
            my $sub="end_edit_$token->[1]";
            {
              no strict 'refs';
              if (defined (&$sub)) { 
                 &$sub($r,$token,$above,\@stack); 
              }
            } 
         } 
      }

      if ($target eq 'modified') {
      }
# --------------------------------------------------------------- Depth Counter
      if (defined($xmltags{$token->[1]})) { $depth--; }
# -----------------------------------------------------------------------------
# =============================================================================
   } elsif ($token->[0] eq 'T') {
# ================================================================= Parsed Text
      $stack[$#stack].=$token->[1];
   }
}

return $outtext;
}
# =============================================================================

# --------------------------------------------------------------- Execute Token



# ------------------------------------------------- Helper Routines for Editing

sub rawprint {
   my ($r,$data)=@_;
   $r->print($data);
}

sub insertmenu {
   my ($r,$description,$depthlabel,$xmltagsref)=@_;
   &rawprint($r,'<br><table bgcolor="#DDDD33" width="100%"><tr><td>');
   &rawprint($r,"\n".'<select name="mod_menu_'.$depthlabel.'">'."\n");
   &rawprint($r,'<option value="no_changes" selected>(no changes)</option>');
   &rawprint($r,"\n".
                '<option value="delete">Delete '.$description.
                                               ' Below</option>');
   my $key;
   foreach $key (keys %$xmltagsref) {
      &rawprint($r,"\n".
                   '<option value="insert_'.$key.'">Insert '.
                   $$xmltagsref{$key}.'</option>');
   }
   &rawprint($r,"\n".'</select></td></tr></table><br>'."\n");
}

# =============================================================================
# ================================================ Routines for Safe Evaluation
# =============================================================================

# -------------------------------------------- Initialize routines in $safeeval

sub init_safeeval {
   my $safeeval=shift;
   my $initprg=<<'ENDINIT'; 

# -------------------------------------------- Initializations inside $safeeval

$e=25;
$c=20;

ENDINIT
# ---------------------------------------------------------------- Execute that
   $safeeval->reval($initprg);
}

# ----------------------------------------------- Routines that use Safe Spaces

sub printout {
   my ($r,$data,$safespace)=@_;
   $r->print($safespace->reval('return qq('.$data.');'));
}

sub runfile {
   my ($r,$filename,$safespace)=@_;
   my $includefile;
   if ($filename=~/^\//) {
       $includefile=$filename;
   } else {
       $includefile=$r->dir_config('lonIncludes');
       $includefile.='/'.$filename;
   }
   if (-e $includefile) {
      $safespace->rdo($includefile);
   }   
}

sub run {
   my ($expression,$safespace)=@_;
   $safespace->reval($expression);   
}

sub booleanexpr {
   my ($expression,$safespace)=@_;
   return $safespace->reval('return '.$expression.';');
}


# =============================================================================
# ================================================== Tag Handlers for Rendering
# =============================================================================

sub start_block {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   if (!booleanexpr($token->[2]{'condition'},$safeeval)) {
      my $blockdepth=0;
      my $nexttoken;
      while ($nexttoken=$parser->get_tag()) { 
         if ($nexttoken->[0] eq 'block') { $blockdepth++ };
         if ($nexttoken->[0] eq '/block') {
            if ($blockdepth==0) { 
               return; 
            } else {
               $blockdepth--;
            }
         }
      }
   }
   return;
}

sub start_script {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   $stackref->[$#$stackref+1]='';
}

sub end_script {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   &run($stackref->[$#$stackref],$safeeval);
   $#$stackref--;
}

sub start_outtext {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   $stackref->[$#$stackref+1]='';
}

sub end_outtext {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   &printout($r,$stackref->[$#$stackref],$safeeval);
   $#$stackref--;
}

sub start_inlinetext {
   &start_outtext(@_);
}

sub end_inlinetext {
   &end_outtext(@_);
}

sub start_scriptlib {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   &runfile($r,$parser->get_text('/scriptlib'),$safeeval);
}

sub start_parserlib {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   &runfile($r,$parser->get_text('/parserlib'),$parsereval);
}


sub start_answer {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   $stackref->[$#$stackref+1]='<answer>::'.
     join(':',map{$_.':'.$token->[2]->{$_}} @{$token->[3]});   
   $stackref->[$#$stackref+1]='';
}

sub end_answer {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   my @itemtexts;
   my @itemargs;
   my $stackpointer=$#$stackref;
   while (($stackref->[$stackpointer]!~'<answer>::') && ($stackpointer>0)) { 
      $stackpointer--; 
   }
   my %answerargs=split(/:/,$stackref->[$stackpointer]);
}

sub start_item {
   my ($r,$token,$parser,$safeeval,$stackref)=@_;
   $stackref->[$#$stackref+1]='<item>::'.
     join(':',map{$_.':'.$token->[2]->{$_}} @{$token->[3]});   
   $stackref->[$#$stackref+1]='';
}

sub end_item {}

# =============================================================================
# ==================================================== Tag Handlers for Editing
# =============================================================================

sub start_edit_outtext {
   my ($r,$token,$parser,$description,$depthlabel,$above,$answertyperef,
       $stackref)=@_;
   &rawprint($r,"\n<h3>$description</h3>".
     '<textarea rows="10" cols="80" name="data_'.$depthlabel.'">');
   $stackref->[$#$stackref+1]='';
}

sub end_edit_outtext {
   my ($r,$token,$above,$stackref)=@_;
   &rawprint($r,$stackref->[$#$stackref]."</textarea>\n");   
   $#$stackref--;
}

sub start_edit_script {
   &start_edit_outtext(@_);
}

sub end_edit_script {
   &end_edit_outtext(@_);
}

sub start_edit_inlinetext {
   &start_edit_outtext(@_);
}

sub end_edit_inlinetext {
   &end_edit_inlinetext(@_);
}

sub start_edit_block {
   my ($r,$token,$parser,$description,$depthlabel,$above,$answertyperef,
       $stackref)=@_;
   my $bgcolor=$depthlabel;
   $bgcolor=~s/\_//g;
   $bgcolor=substr(length($bgcolor),-1,1);
   $bgcolor=~tr/1-5/A-E/;
   $bgcolor=$bgcolor.'FFF'.$bgcolor.'A';
   &rawprint($r,"\n".'<br><table border="2" cellpadding="10" bgcolor="#'.
                $bgcolor.
                '" width="100%"><tr><td><h3>'.$description.'</h3>');
}

sub end_edit_block {
   my ($r,$token,$above,$stackref)=@_;
   &rawprint($r,"\n".'</td></tr></table><br>');
}

sub start_edit_answer {
   my ($r,$token,$parser,$description,$depthlabel,$above,$answertyperef,
       $stackref)=@_;
   start_edit_block(@_);
   $above=$token->[2]{'type'};
   &rawprint($r,"\n".'<select name="mod_type_'.$depthlabel.'">');
   my $key;
   foreach $key (keys %$answertyperef) {
      &rawprint($r,"\n".'<option value="'.$key.'"');
      if ($above eq $key) { &rawprint($r,' selected'); }
      &rawprint($r,'>'.$$answertyperef{$key}.'</option>');
   }
   &rawprint($r,"\n".'</select>'."\n");
}

sub end_edit_answer {
   my ($r,$token,$above,$stackref)=@_;
   end_edit_block(@_);
}

sub start_edit_include {
    start_edit_block(@_);
}

sub end_edit_include {
    end_edit_block(@_);
}

sub start_edit_problem {
    start_edit_block(@_);
}

sub end_edit_problem {
    end_edit_block(@_);
}

1;
__END__