[system] / trunk / pg / lib / WeBWorK / PG / Translator.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/WeBWorK/PG/Translator.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6584 - (download) (as text) (annotate)
Tue Nov 30 20:17:58 2010 UTC (9 years ago) by gage
File size: 61137 byte(s)
switch to use WWSafe.pm


    1 ################################################################################
    2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project
    3 # $Id$
    4 ################################################################################
    5 
    6 package WeBWorK::PG::Translator;
    7 
    8 use strict;
    9 use warnings;
   10 use Opcode;
   11 use WWSafe;
   12 use Net::SMTP;
   13 use WeBWorK::PG::IO;
   14 
   15 #use PadWalker;     # used for processing error messages
   16 #use Data::Dumper;
   17 
   18 
   19 # loading GD within the Safe compartment has occasionally caused infinite recursion
   20 # Putting these use statements here seems to avoid this problem
   21 # It is not clear that this is essential once things are working properly.
   22 #use Exporter;
   23 #use DynaLoader;
   24 
   25 
   26 =head1 NAME
   27 
   28 WeBWorK::PG::Translator - Evaluate PG code and evaluate answers safely
   29 
   30 =head1 SYNPOSIS
   31 
   32     my $pt = new WeBWorK::PG::Translator;      # create a translator;
   33     $pt->environment(\%envir);      # provide the environment variable for the problem
   34     $pt->initialize();              # initialize the translator
   35     $pt-> set_mask();               # set the operation mask for the translator safe compartment
   36     $pt->source_string($source);    # provide the source string for the problem
   37 
   38     $pt -> unrestricted_load("${courseScriptsDirectory}PG.pl");
   39     $pt -> unrestricted_load("${courseScriptsDirectory}dangerousMacros.pl");
   40                                     # load the unprotected macro files
   41                                     # these files are evaluated with the Safe compartment wide open
   42                                     # other macros are loaded from within the problem using loadMacros
   43 
   44     $pt ->translate();              # translate the problem (the out following 4 pieces of information are created)
   45 
   46     $PG_PROBLEM_TEXT_ARRAY_REF = $pt->ra_text();              # output text for the body of the HTML file (in array form)
   47     $PG_PROBLEM_TEXT_REF = $pt->r_text();                     # output text for the body of the HTML file
   48     $PG_HEADER_TEXT_REF = $pt->r_header;#\$PG_HEADER_TEXT;    # text for the header of the HTML file
   49     $PG_ANSWER_HASH_REF = $pt->rh_correct_answers;            # a hash of answer evaluators
   50     $PG_FLAGS_REF = $pt ->rh_flags;                           # misc. status flags.
   51 
   52     $pt -> process_answers(\%inputs);    # evaluates all of the answers using submitted answers from %input
   53 
   54     my $rh_answer_results = $pt->rh_evaluated_answers;  # provides a hash of the results of evaluating the answers.
   55     my $rh_problem_result = $pt->grade_problem;         # grades the problem using the default problem grading method.
   56 
   57 =head1 DESCRIPTION
   58 
   59 This module defines an object which will translate a problem written in the Problem Generating (PG) language
   60 
   61 =cut
   62 
   63 =head2 be_strict
   64 
   65 This creates a substitute for C<use strict;> which cannot be used in PG problem
   66 sets or PG macro files.  Use this way to imitate the behavior of C<use strict;>
   67 
   68   BEGIN {
   69     be_strict(); # an alias for use strict.
   70                  # This means that all global variable
   71                  # must contain main:: as a prefix.
   72   }
   73 
   74 =cut
   75 
   76 BEGIN {
   77   # allows the use of strict within macro packages.
   78   sub be_strict {
   79     require 'ww_strict.pm';
   80     strict::import();
   81   }
   82 
   83   # also define in Main::, for PG modules.
   84   sub Main::be_strict { &be_strict }
   85 }
   86 
   87 =head2 evaluate_modules
   88 
   89   Usage:  $obj -> evaluate_modules('WWPlot', 'Fun', 'Circle');
   90           $obj -> evaluate_modules('reset');
   91 
   92 Adds the modules WWPlot.pm, Fun.pm and Circle.pm in the courseScripts directory to the list of modules
   93 which can be used by the PG problems.  The keyword 'reset' or 'erase' erases the list of modules already loaded
   94 
   95 =cut
   96 
   97 
   98 sub evaluate_modules {
   99   my $self = shift;
  100   my @modules = @_;
  101   local $SIG{__DIE__} = "DEFAULT"; # we're going to be eval()ing code
  102   foreach (@modules) {
  103     #warn "attempting to load $_\n";
  104     # ensure that the name is in fact a base name
  105     s/\.pm$// and warn "fixing your broken package name: $_.pm => $_";
  106     # call runtime_use on the package name
  107     # don't worry -- runtime_use won't load a package twice!
  108     #eval { runtime_use $_ };                   #
  109     eval "package Main; require $_; import $_"; # change for WW1
  110     warn "Failed to evaluate module $_: $@" if $@;
  111     # record this in the appropriate place
  112     push @{$self->{ra_included_modules}}, "\%${_}::";
  113   }
  114 }
  115 #      old code for runtime_use
  116 #     if ( -r  "${courseScriptsDirectory}${module_name}.pm"   ) {
  117 #       eval(qq! require "${courseScriptsDirectory}${module_name}.pm";  import ${module_name};! );
  118 #       warn "Errors in including the module ${courseScriptsDirectory}$module_name.pm $@" if $@;
  119 #     } else {
  120 #       eval(qq! require "${module_name}.pm";  import ${module_name};! );
  121 #       warn "Errors in including either the module $module_name.pm or ${courseScriptsDirectory}${module_name}.pm $@" if $@;
  122 #     }
  123 =head2 load_extra_packages
  124 
  125   Usage:  $obj -> load_extra_packages('AlgParserWithImplicitExpand',
  126                                       'Expr','ExprWithImplicitExpand');
  127 
  128 Loads extra packages for modules that contain more than one package.  Works in conjunction with
  129 evaluate_modules.  It is assumed that the file containing the extra packages (along with the base
  130 pachage name which is the same as the name of the file minus the .pm extension) has already been
  131 loaded using evaluate_modules
  132 =cut
  133 
  134 sub load_extra_packages{
  135   my $self = shift;
  136   my @package_list = @_;
  137   my $package_name;
  138 
  139   foreach (@package_list) {
  140     # ensure that the name is in fact a base name
  141     s/\.pm$// and warn "fixing your broken package name: $_.pm => $_";
  142     # import symbols from the extra package
  143     import $_;
  144     warn "Failed to evaluate module $_: $@" if $@;
  145     # record this in the appropriate place
  146     push @{$self->{ra_included_modules}}, "\%${_}::";
  147   }
  148 }
  149 
  150 =head2  new
  151   Creates the translator object.
  152 
  153 =cut
  154 
  155 
  156 sub new {
  157   my $class = shift;
  158   my $safe_cmpt = new Safe; #('PG_priv');
  159   my $self = {
  160       preprocess_code           =>  \&default_preprocess_code,
  161       postprocess_code           => \&default_postprocess_code,
  162     envir                     => undef,
  163     PG_PROBLEM_TEXT_ARRAY_REF => [],
  164     PG_PROBLEM_TEXT_REF       => 0,
  165     PG_HEADER_TEXT_REF        => 0,
  166     PG_ANSWER_HASH_REF        => {},
  167     PG_FLAGS_REF              => {},
  168     rh_pgcore                 => undef,    # ref to PGcore object
  169     safe                      => $safe_cmpt,
  170     safe_compartment_name     => $safe_cmpt->root,
  171     errors                    => "",
  172     source                    => "",
  173     rh_correct_answers        => {},
  174     rh_student_answers        => {},
  175     rh_evaluated_answers      => {},
  176     rh_problem_result         => {},
  177     rh_problem_state          => {
  178       recorded_score       => 0, # the score recorded in the data base
  179       num_of_correct_ans   => 0, # the number of correct attempts at doing the problem
  180       num_of_incorrect_ans => 0, # the number of incorrect attempts
  181     },
  182     rf_problem_grader         => \&std_problem_grader,
  183     rf_safety_filter          => \&safetyFilter,
  184     # ra_included_modules is now populated independantly of @class_modules:
  185     ra_included_modules       => [], # [ @class_modules ],
  186     rh_directories            => {},
  187   };
  188   bless $self, $class;
  189 }
  190 
  191 =pod
  192 
  193 (b) The following routines defined within the PG module are shared:
  194 
  195   &be_strict
  196   &read_whole_problem_file
  197   &convertPath
  198   &surePathToTmpFile
  199   &fileFromPath
  200   &directoryFromPath
  201   &createFile
  202 
  203   &includePGtext
  204 
  205   &PG_answer_eval
  206   &PG_restricted_eval
  207 
  208   &send_mail_to
  209   &PGsort
  210 
  211 In addition the environment hash C<%envir> is shared.  This variable is unpacked
  212 when PG.pl is run and provides most of the environment variables for each problem
  213 template.
  214 
  215 =for html
  216 
  217   <A href =
  218   "${Global::webworkDocsURL}techdescription/pglanguage/PGenvironment.html"> environment variables</A>
  219 
  220 =cut
  221 
  222 
  223 =pod
  224 
  225 (c) Sharing macros:
  226 
  227 The macros shared with the safe compartment are
  228 
  229   '&read_whole_problem_file'
  230   '&convertPath'
  231   '&surePathToTmpFile'
  232   '&fileFromPath'
  233   '&directoryFromPath'
  234   '&createFile'
  235   '&PG_answer_eval'
  236   '&PG_restricted_eval'
  237   '&be_strict'
  238   '&send_mail_to'
  239   '&PGsort'
  240   '&dumpvar'
  241   '&includePGtext'
  242 
  243 =cut
  244 
  245 # SHARE variables and routines with safe compartment
  246 #
  247 # Some symbols are defined here (or in the IO module), and used inside the safe
  248 # compartment. Under WeBWorK 1.x, functions defined here had access to the
  249 # Global:: namespace, which contained course-specific data such things as
  250 # directory locations, the address of the SMTP server, and so on. Under WeBWorK
  251 # 2, there is no longer a global namespace. To get around this, IO functions
  252 # which need access to course-specific data are now defined in the IO.pl macro
  253 # file, which has access to the problem environment. Several entries have been
  254 # added to the problem environment to support this move.
  255 #
  256 
  257 
  258 # Useful for timing portions of the translating process
  259 # The timer $WeBWorK::timer is defined in the module WeBWorK.pm
  260 # You must make sure that the code in that script for initialzing the
  261 # timer is active.
  262 
  263 sub time_it {
  264   my $msg = shift;
  265   $WeBWorK::timer->continue("PG macro:". $msg) if defined($WeBWorK::timer);
  266 }
  267 
  268 my %shared_subroutine_hash = (
  269   'time_it'                  => __PACKAGE__,
  270   '&PG_answer_eval'          => __PACKAGE__,
  271   '&PG_restricted_eval'      => __PACKAGE__,
  272   '&PG_macro_file_eval'       => __PACKAGE__,
  273   '&be_strict'               => __PACKAGE__,
  274   '&PGsort'                  => __PACKAGE__,
  275   '&dumpvar'                 => __PACKAGE__,
  276   %WeBWorK::PG::IO::SHARE, # add names from WeBWorK::PG::IO and WeBWorK::PG::IO::*
  277 );
  278 
  279 sub initialize {
  280     my $self = shift;
  281     my $safe_cmpt = $self->{safe};
  282     #print "initializing safeCompartment",$safe_cmpt -> root(), "\n";
  283 
  284     $safe_cmpt -> share(keys %shared_subroutine_hash);
  285     no strict;
  286     local(%envir) = %{ $self ->{envir} };
  287   $safe_cmpt -> share('%envir');
  288   #local($rf_answer_eval) = sub { $self->PG_answer_eval(@_); };
  289   #local($rf_restricted_eval) = sub { $self->PG_restricted_eval(@_); };
  290   #$safe_cmpt -> share('$rf_answer_eval');
  291   #$safe_cmpt -> share('$rf_restricted_eval');
  292   use strict;
  293 
  294   $safe_cmpt -> share_from('main', $self->{ra_included_modules} );
  295     # the above line will get changed when we fix the PG modules thing. heh heh.
  296 }
  297 
  298 
  299 ################################################################
  300 #  Preloading the macro files
  301 ################################################################
  302 
  303 #  Preloading the macro files can significantly speed up the translation process.
  304 #  Files are read into a separate safe compartment (typically Safe::Root1::)
  305 #  This means that all non-explicit subroutine references and those explicitly prefixed by main::
  306 #  are prefixed by Safe::Root1::
  307 #  These subroutines (but not the constants) are then explicitly exported to the current
  308 #  safe compartment Safe::Rootx::
  309 
  310 #  Although they are not large, it is important to import PG.pl and dangerousMacros.pl into the
  311 #  cached safe compartment as well.  This is because a call in PGbasicmacros.pl to NEW_ANSWER_NAME
  312 #  which is defined in PG.pl would actually be a call to Safe::Root1::NEW_ANSWER_NAME since
  313 #  PGbasicmacros is compiled into the SAfe::Root1:: compartment.  If PG.pl has only been compiled into
  314 #  the current Safe compartment, this call will fail.  There are many calls between PG.pl, dangerousMacros,
  315 #  PGbasicmacros and PGanswermacros so it is easiest to have all of them defined in Safe::Root1::
  316 #  There subroutines are still available in the current safe compartment.
  317 #  Sharing the hash %Safe::Root1:: in the current compartment means that any references to Safe::Root1::NEW_ANSWER_NAME
  318 #  will be found as long as NEW_ANSWER_NAME has been defined in Safe::Root1::
  319 #
  320 #  Constants and references to subroutines in other macro files have to be handled carefully in preloaded files.
  321 #  For example a call to main::display_matrix (defined in PGmatrixmacros.pl) will become Safe::Root1::display_matrix and
  322 #  will fail since PGmatrixmacros.pl is loaded only into the current safe compartment Safe::Rootx::.
  323 #  The value of main:: has to be evaluated at runtime in order to make this work.  Hence  something like
  324 #  my $temp_code  = eval('\&main::display_matrix');
  325 #  &$temp_code($matrix_object_to_be_displayed);
  326 # in PGanswermacros.pl
  327 #  would reference the run time value of main::, namely Safe::Rootx::
  328 #  There may be a clearer or more efficient way to obtain the runtime value of main::
  329 
  330 
  331 sub pre_load_macro_files {
  332     time_it("Begin pre_load_macro_files");
  333   my $self                = shift;
  334   my $cached_safe_cmpt    = shift;
  335   my $dirName             = shift;
  336   my @fileNameList        = @_;
  337   my $debugON         = 0;    # This helps with debugging the loading of macro files
  338 
  339 ################################################################
  340 #    prepare safe_cache
  341 ################################################################
  342   $cached_safe_cmpt -> share(keys %shared_subroutine_hash);
  343     no strict;
  344     local(%envir) = %{ $self ->{envir} };
  345   $cached_safe_cmpt -> share('%envir');
  346   use strict;
  347     $cached_safe_cmpt -> share_from('main', $self->{ra_included_modules} );
  348     $cached_safe_cmpt->mask(Opcode::full_opset());  # allow no operations
  349     $cached_safe_cmpt->permit(qw(   :default ));
  350     $cached_safe_cmpt->permit(qw(time));  # used to determine whether solutions are visible.
  351   $cached_safe_cmpt->permit(qw( atan2 sin cos exp log sqrt ));
  352 
  353   # just to make sure we'll deny some things specifically
  354   $cached_safe_cmpt->deny(qw(entereval));
  355   $cached_safe_cmpt->deny(qw (  unlink symlink system exec ));
  356   $cached_safe_cmpt->deny(qw(print require));
  357 
  358 ################################################################
  359 #    read in macro files
  360 ################################################################
  361 
  362   foreach my $fileName (@fileNameList)   {
  363       # determine whether the file has already been loaded by checking for
  364       # subroutine named _${macro_file_name}_init
  365     my $macro_file_name = $fileName;
  366     $macro_file_name =~s/\.pl//;  # trim off the extension
  367     $macro_file_name =~s/\.pg//;  # sometimes the extension is .pg (e.g. CAPA files)
  368     my $init_subroutine_name      = "_${macro_file_name}_init";
  369         my $macro_file_loaded = defined(&{$cached_safe_cmpt->root."::$init_subroutine_name"}) ? 1 : 0;
  370 
  371 
  372     if ( $macro_file_loaded  )     {
  373       warn "$macro_file_name is already loaded" if $debugON;
  374      }else {
  375       warn "reading and evaluating $macro_file_name from $dirName/$fileName" if $debugON;
  376       ### read in file
  377       my $filePath = "$dirName/$fileName";
  378       local(*MACROFILE);
  379       local($/);
  380       $/ = undef;   # allows us to treat the file as a single line
  381       open(MACROFILE, "<$filePath") || die "Cannot open file: $filePath";
  382       my $string = <MACROFILE>;
  383       close(MACROFILE);
  384 
  385 
  386 ################################################################
  387 #    Evaluate macro files
  388 ################################################################
  389 #    FIXME  The following hardwired behavior should be modifiable
  390 #    either in the procedure call or in global.conf:
  391 #
  392 #    PG.pl, IO.pl and dangerousMacros.pl are loaded without restriction
  393 #    All other files are loaded with restriction
  394 #
  395       # construct a regex that matches only these three files safely
  396       my @unrestricted_files = (); #  no longer needed? FIXME w/PG.pl dangerousMacros.pl IO.pl/;
  397       my $unrestricted_files = join("|", map { quotemeta } @unrestricted_files);
  398 
  399       my $store_mask;
  400       if ($fileName =~ /^($unrestricted_files)$/) {
  401             $store_mask = $cached_safe_cmpt->mask();
  402         $cached_safe_cmpt ->mask(Opcode::empty_opset());
  403           }
  404       $cached_safe_cmpt -> reval('BEGIN{push @main::__eval__,__FILE__}; package main; ' .$string);
  405       warn "preload Macros: errors in compiling $macro_file_name:<br> $@" if $@;
  406       $self->{envir}{__files__}{$cached_safe_cmpt->reval('pop @main::__eval__')} = $filePath;
  407       if ($fileName =~ /^($unrestricted_files)$/) {
  408             $cached_safe_cmpt ->mask($store_mask);
  409             warn "mask restored after $fileName" if $debugON;
  410           }
  411 
  412 
  413     }
  414   }
  415 
  416 ################################################################################
  417 # load symbol table
  418 ################################################################################
  419   warn "begin loading symbol table "  if $debugON;
  420   no strict 'refs';
  421   my %symbolHash  = %{$cached_safe_cmpt->root.'::'};
  422   use strict 'refs';
  423   my @subroutine_names;
  424 
  425   foreach my $name (keys %symbolHash) {
  426     # weed out internal symbols
  427     next if $name =~ /^(INC|_|__ANON__|main::)$/;
  428     if ( defined(&{*{$symbolHash{$name}}})  )  {
  429 #         warn "subroutine $name" if $debugON;;
  430       push(@subroutine_names, "&$name");
  431     }
  432   }
  433 
  434   warn "Loading symbols into active safe compartment:<br> ", join(" ",sort @subroutine_names) if $debugON;
  435   $self->{safe} -> share_from($cached_safe_cmpt->root,[@subroutine_names]);
  436 
  437   # Also need to share the cached safe compartment symbol hash in the current safe compartment.
  438   # This is necessary because the macro files have been read into the cached safe compartment
  439   # So all subroutines have the implied names  Safe::Root1::subroutine
  440   # When they call each other we need to make sure that they can reach each other
  441   # through the Safe::Root1 symbol table.
  442 
  443   $self->{safe} -> share('%'.$cached_safe_cmpt->root.'::');
  444   warn 'Sharing '.'%'. $cached_safe_cmpt->root. '::'  if $debugON;
  445   time_it("End pre_load_macro_files");
  446   # return empty string.
  447   '';
  448 }
  449 
  450 sub environment{
  451   my $self = shift;
  452   my $envirref = shift;
  453   if ( defined($envirref) )  {
  454     if (ref($envirref) eq 'HASH') {
  455       %{ $self -> {envir} } = %$envirref;
  456     } else {
  457       $self ->{errors} .= "ERROR: The environment method for PG_translate objects requires a reference to a hash";
  458     }
  459   }
  460   $self->{envir} ; #reference to current environment
  461 }
  462 
  463 =head2   Safe compartment pass through macros
  464 
  465 
  466 
  467 =cut
  468 
  469 sub mask {
  470   my $self = shift;
  471   my $mask = shift;
  472   my $safe_compartment = $self->{safe};
  473   $safe_compartment->mask($mask);
  474 }
  475 sub permit {
  476   my $self = shift;
  477   my @array = shift;
  478   my $safe_compartment = $self->{safe};
  479   $safe_compartment->permit(@array);
  480 }
  481 sub deny {
  482 
  483   my $self = shift;
  484   my @array = shift;
  485   my $safe_compartment = $self->{safe};
  486   $safe_compartment->deny(@array);
  487 }
  488 sub share_from {
  489   my $self = shift;
  490   my $pckg_name = shift;
  491   my $array_ref =shift;
  492   my $safe_compartment = $self->{safe};
  493   $safe_compartment->share_from($pckg_name,$array_ref);
  494 }
  495 
  496 sub source_string {
  497   my $self = shift;
  498   my $temp = shift;
  499   my $out;
  500   if ( ref($temp) eq 'SCALAR') {
  501     $self->{source} = $$temp;
  502     $out = $self->{source};
  503   } elsif ($temp) {
  504     $self->{source} = $temp;
  505     $out = $self->{source};
  506   }
  507   $self -> {source};
  508 }
  509 
  510 sub source_file {
  511   my $self = shift;
  512   my $filePath = shift;
  513   local(*SOURCEFILE);
  514   local($/);
  515   $/ = undef;   # allows us to treat the file as a single line
  516   my $err = "";
  517   if ( open(SOURCEFILE, "<$filePath") ) {
  518     $self -> {source} = <SOURCEFILE>;
  519     close(SOURCEFILE);
  520   } else {
  521     $self->{errors} .= "Can't open file: $filePath";
  522     croak( "Can't open file: $filePath\n" );
  523   }
  524 
  525 
  526 
  527   $err;
  528 }
  529 
  530 
  531 
  532 sub unrestricted_load {
  533   my $self = shift;
  534   my $filePath = shift;
  535   my $safe_cmpt = $self ->{safe};
  536   my $store_mask = $safe_cmpt->mask();
  537   $safe_cmpt->mask(Opcode::empty_opset());
  538   my $safe_cmpt_package_name = $safe_cmpt->root();
  539 
  540   my $macro_file_name = fileFromPath($filePath);
  541   $macro_file_name =~s/\.pl//;  # trim off the extenstion
  542   my $export_subroutine_name = "_${macro_file_name}_export";
  543   my $init_subroutine_name = "${safe_cmpt_package_name}::_${macro_file_name}_init";
  544 
  545   my $local_errors = "";
  546   no strict;
  547   #  warn "dangerousMacros main:: contains <br>\n  ".join("<br>\n ", %main::) if $debugON;
  548   my $init_subroutine  = eval { \&{$init_subroutine_name} };
  549   warn "No init routine for $init_subroutine_name: $@" if  $debugON and $@;
  550   use strict;
  551     my $macro_file_loaded = ref($init_subroutine) =~ /CODE/;
  552 
  553   #print STDERR "$macro_file_name   has not yet been loaded\n" unless $macro_file_loaded;
  554   unless ($macro_file_loaded) {
  555     ## load the $filePath file
  556     ## Using rdo insures that the $filePath file is loaded for every problem, allowing initializations to occur.
  557     ## Ordinary mortals should not be fooling with the fundamental macros in these files.
  558     my $local_errors = "";
  559     if (-r $filePath ) {
  560       my $rdoResult = $safe_cmpt->rdo($filePath);
  561             #warn "unrestricted load:  $filePath\n";
  562       $local_errors ="\nThere were problems compiling the file:\n $filePath\n $@\n" if $@;
  563       $self ->{errors} .= $local_errors if $local_errors;
  564       use strict;
  565     } else {
  566       $local_errors = "Can't open file $filePath for reading\n";
  567       $self ->{errors} .= $local_errors if $local_errors;
  568     }
  569     $safe_cmpt -> mask($store_mask);
  570 
  571   }
  572   # try again to define the initization subroutine
  573   $init_subroutine  = eval { \&{"$init_subroutine_name"} };
  574   $macro_file_loaded  = ref($init_subroutine) =~ /CODE/;
  575   if ( $macro_file_loaded ) {
  576 
  577         #warn "unrestricted load:  initializing $macro_file_name  $init_subroutine" ;
  578         &$init_subroutine();
  579   }
  580   $local_errors .= "\nUnknown error.  Unable to load $filePath\n" if ($local_errors eq '' and not $macro_file_loaded);
  581   #print STDERR "$filePath is properly loaded\n\n" if $macro_file_loaded;
  582   $local_errors;
  583 }
  584 
  585 sub nameSpace {
  586   my $self = shift;
  587   $self->{safe}->root;
  588 }
  589 
  590 sub a_text {
  591   my $self  = shift;
  592   @{$self->{PG_PROBLEM_TEXT_ARRAY_REF}};
  593 }
  594 
  595 sub header {
  596   my $self = shift;
  597   ${$self->{PG_HEADER_TEXT_REF}};
  598 }
  599 
  600 sub h_flags {
  601   my $self = shift;
  602   %{$self->{PG_FLAGS_REF}};
  603 }
  604 
  605 sub rh_flags {
  606   my $self = shift;
  607   $self->{PG_FLAGS_REF};
  608 }
  609 sub h_answers{
  610   my $self = shift;
  611   %{$self->{PG_ANSWER_HASH_REF}};
  612 }
  613 
  614 sub ra_text {
  615   my $self  = shift;
  616     $self->{PG_PROBLEM_TEXT_ARRAY_REF};
  617 
  618 }
  619 
  620 sub r_text {
  621   my $self  = shift;
  622     $self->{PG_PROBLEM_TEXT_REF};
  623 }
  624 
  625 sub r_header {
  626   my $self = shift;
  627   $self->{PG_HEADER_TEXT_REF};
  628 }
  629 
  630 sub rh_directories {
  631   my $self = shift;
  632   my $rh_directories = shift;
  633   $self->{rh_directories}=$rh_directories if ref($rh_directories) eq 'HASH';
  634   $self->{rh_directories};
  635 }
  636 
  637 sub rh_correct_answers {
  638   my $self = shift;
  639   my @in = @_;
  640   return $self->{rh_correct_answers} if @in == 0;
  641 
  642   if ( ref($in[0]) eq 'HASH' ) {
  643     $self->{rh_correct_answers} = { %{ $in[0] } }; # store a copy of the hash
  644   } else {
  645     $self->{rh_correct_answers} = { @in }; # store a copy of the hash
  646   }
  647   $self->{rh_correct_answers}
  648 }
  649 
  650 sub rf_problem_grader {
  651   my $self = shift;
  652   my $in = shift;
  653   return $self->{rf_problem_grader} unless defined($in);
  654   if (ref($in) =~/CODE/ ) {
  655     $self->{rf_problem_grader} = $in;
  656   } else {
  657     die "ERROR: Attempted to install a problem grader which was not a reference to a subroutine.";
  658   }
  659   $self->{rf_problem_grader}
  660 }
  661 
  662 
  663 sub errors{
  664   my $self = shift;
  665   $self->{errors};
  666 }
  667 
  668 
  669 
  670 =head2  set_mask
  671 
  672 
  673 
  674 
  675 
  676 
  677 (e) Now we close the safe compartment.  Only the certain operations can be used
  678 within PG problems and the PG macro files.  These include the subroutines
  679 shared with the safe compartment as defined above and most Perl commands which
  680 do not involve file access, access to the system or evaluation.
  681 
  682 Specifically the following are allowed
  683 
  684   time()
  685     # gives the current Unix time
  686     # used to determine whether solutions are visible.
  687   atan, sin cos exp log sqrt
  688     # arithemetic commands -- more are defined in PGauxiliaryFunctions.pl
  689 
  690 The following are specifically not allowed:
  691 
  692   eval()
  693   unlink, symlink, system, exec
  694   print require
  695 
  696 
  697 
  698 =cut
  699 
  700 ##############################################################################
  701 
  702           ## restrict the operations allowed within the safe compartment
  703 
  704 sub set_mask {
  705   my $self = shift;
  706   my $safe_cmpt = $self ->{safe};
  707     $safe_cmpt->mask(Opcode::full_opset());  # allow no operations
  708     $safe_cmpt->permit(qw(   :default ));
  709     $safe_cmpt->permit(qw(time));  # used to determine whether solutions are visible.
  710   $safe_cmpt->permit(qw( atan2 sin cos exp log sqrt ));
  711 
  712   # just to make sure we'll deny some things specifically
  713   $safe_cmpt->deny(qw(entereval));
  714   $safe_cmpt->deny(qw (  unlink symlink system exec ));
  715   $safe_cmpt->deny(qw(print require));
  716 }
  717 
  718 ############################################################################
  719 
  720 =head2  PG_errorMessage
  721 
  722 This routine processes error messages by fixing file names and adding
  723 traceback information.  It loops through the function calls via
  724 caller() in order to give more information about where the error
  725 occurred.  Since the loadMacros() files and the .pg file itself are
  726 handled via various kinds of eval calls, the caller() information does
  727 not contain the file names.  So we have saved them in the
  728 $main::__files__ hash, which we look up here and use to replace the
  729 (eval nnn) file names that are in the caller stack.  We shorten the
  730 filenames by removing the templates or root directories when possible,
  731 so they are easier to read.
  732 
  733 We skip any nested calls to Parser:: or Value:: so that these act more like
  734 perl built-in functions.
  735 
  736 We stop when we find a routine in the WeBWorK:: package, or an __ANON__
  737 routine, in order to avoid reporting the PG translator calls that
  738 surround the pg file.  Finally, there is usually one more eval before
  739 that, so we remove it as well.
  740 
  741 File names are shortened, when possible, by replacing the templates
  742 directory with [TMPL], the WeBWorK root directory by [WW] and
  743 the PG root directory by [PG].
  744 
  745 =cut
  746 
  747 sub PG_errorMessage {
  748   my $return = shift; my $frame = 2; # return can be 'message' or 'traceback'
  749   my $message = join("\n",@_); $message =~ s/\.?\s+$//;
  750   my $files = eval ('$main::__files__'); $files = {} unless $files;
  751   my $tmpl = $files->{tmpl} || '$';
  752   my $root = $files->{root} || '$';
  753   my $pg   = $files->{pg}   || '$';
  754   #
  755   #  Fix initial message file names
  756   #
  757   $message =~ s! $tmpl! [TMPL]!g; $message =~ s! $root! [WW]!g; $message =~ s! $pg! [PG]!g;
  758   $message =~ s/(\(eval \d+\)) (line (\d+))/$2 of $1/;
  759   while ($message =~ m/of (?:file )?(\(eval \d+\))/ && defined($files->{$1})) {
  760     my $name = $files->{$1};
  761     $name =~ s!^$tmpl![TMPL]!; $name =~ s!^$root![WW]!; $name =~ s!^$pg![PG]!;
  762     $message =~ s/\(eval \d+\)/$name/g;
  763   }
  764   #
  765   #  Return just the message if that's all we want, or
  766   #   if the message already includes a stack trace
  767   #
  768   return $message."\n" if $return eq 'message' || $message =~ m/\n   Died within/;
  769   #
  770   #  Look through caller stack for traceback information
  771   #
  772   my @trace = ($message);
  773   my $skipParser = (caller(3))[3] =~ m/^(Parser|Value)::/;
  774   while (my ($pkg,$file,$line,$subname) = caller($frame++)) {
  775     last if ($subname =~ m/^(Safe::reval|main::__ANON__)/);
  776     next if $skipParser && $subname =~ m/^(Parser|Value)::/;  # skip Parser and Value calls
  777     next if $subname =~ m/__ANON__/;
  778     $file = $files->{$file} || $file;
  779     $file =~ s!^$tmpl![TMPL]!; $file =~ s!^$root![WW]!; $file =~ s!^$pg![PG]!;
  780     $message =  "   from within $subname called at line $line of $file";
  781     push @trace, $message; $skipParser = 0;
  782   }
  783   splice(@trace,1,1) while $trace[1] && $trace[1] =~ m/within \(eval\)/;
  784   pop @trace while $trace[-1] && $trace[-1] =~ m/within \(eval\)/;
  785   $trace[1] =~ s/   from/   Died/ if $trace[1];
  786   #
  787   #  report the full traceback
  788   #
  789   return join("\n",@trace,'');
  790 }
  791 
  792 =head2 PG_undef_var_check
  793 
  794 =pod
  795 
  796  Produces warnings of this type in order to help you guess which local variable is undefined
  797  Warning: Use of uninitialized value in concatenation (.) or string at mpu.cgi line 25.
  798  Possible variables are:
  799            '$GLOBAL_VARIABLE' => \'global',
  800            '$t' => \undef,
  801            '$s' => \'regular output'
  802 
  803 
  804 
  805 
  806 =cut
  807 
  808 sub PG_undef_var_check {
  809   if($_[0] !~ /^Use of uninitialized value/) {
  810     return @_;
  811   } else {
  812     # If there are objects, the output can be VERY large when you increase this
  813     local $Data::Dumper::Maxdepth = 2;
  814     # takes all lexical variables from caller-nemaspace
  815     my $possibles = Data::Dumper::Dumper({ %{PadWalker::peek_my(1)}, %{PadWalker::peek_our(1)} });
  816 
  817     $possibles ne "\$VAR1 = {};\n" ? ($possibles =~ s/^.*?\n(.*)\n.*?\n$/$1/ms) : ($possibles = '');
  818     return "Warning: " . join(', ', @_) . "Possible variables are:\n$possibles\n";
  819   }
  820 
  821 }
  822 ############################################################################
  823 
  824 =head2  Translate
  825 
  826 
  827 =cut
  828 
  829 sub translate {
  830   my $self = shift;
  831   my @PROBLEM_TEXT_OUTPUT = ();
  832   my $safe_cmpt = $self ->{safe};
  833   my $evalString = $self -> {source};
  834   $self ->{errors} .= qq{ERROR:  This problem file was empty!\n} unless ($evalString) ;
  835   $self ->{errors} .= qq{ERROR:  You must define the environment before translating.}
  836        unless defined( $self->{envir} );
  837 
  838   # install handlers for warn and die that call PG_errorMessage.
  839   # if the existing signal handler is not a coderef, the built-in warn or
  840   # die function is called. this does not account for the case where the
  841   # handler is set to "IGNORE" or to the name of a function. in these cases
  842   # the built-in function will be called.
  843 
  844   my $outer_sig_warn = $SIG{__WARN__};
  845   local $SIG{__WARN__} = sub {
  846     ref $outer_sig_warn eq "CODE"
  847       ? &$outer_sig_warn(PG_errorMessage('message', $_[0]))
  848       : warn PG_errorMessage('message', $_[0]);
  849   };
  850 
  851   my $outer_sig_die = $SIG{__DIE__};
  852   local $SIG{__DIE__} = sub {
  853     ref $outer_sig_die eq "CODE"
  854       ? &$outer_sig_die(PG_errorMessage('traceback', $_[0]))
  855       : die PG_errorMessage('traceback', $_[0]);
  856   };
  857 
  858 =pod
  859 
  860 (3) B<Preprocess the problem text>
  861 
  862 The input text is subjected to two global replacements.
  863 First every incidence of
  864 
  865   BEGIN_TEXT
  866   problem text
  867   END_TEXT
  868 
  869 is replaced by
  870 
  871     TEXT( EV3( <<'END_TEXT' ) );
  872   problem text
  873   END_TEXT
  874 
  875 The first construction is syntactic sugar for the second. This is explained
  876 in C<PGbasicmacros.pl>.
  877 
  878 Second every incidence
  879 of \ (backslash) is replaced by \\ (double backslash).  Third each incidence of
  880 ~~ is replaced by a single backslash.
  881 
  882 This is done to alleviate a basic
  883 incompatibility between TeX and Perl. TeX uses backslashes constantly to denote
  884 a command word (as opposed to text which is to be entered literally).  Perl
  885 uses backslash to escape the following symbol.  This escape
  886 mechanism takes place immediately when a Perl script is compiled and takes
  887 place throughout the code and within every quoted string (both double and single
  888 quoted strings) with the single exception of single quoted "here" documents.
  889 That is backlashes which appear in
  890 
  891     TEXT(<<'EOF');
  892     ... text including \{   \} for example
  893     EOF
  894 
  895 are the only ones not immediately evaluated.  This behavior makes it very difficult
  896 to use TeX notation for defining mathematics within text.
  897 
  898 The initial global
  899 replacement, before compiling a PG problem, allows one to use backslashes within
  900 text without doubling them. (The anomolous behavior inside single quoted "here"
  901 documents is compensated for by the behavior of the evaluation macro EV3.) This
  902 makes typing TeX easy, but introduces one difficulty in entering normal Perl code.
  903 
  904 The second global replacement provides a work around for this -- use ~~ when you
  905 would ordinarily use a backslash in Perl code.
  906 In order to define a carriage return use ~~n rather than \n; in order to define
  907 a reference to a variable you must use ~~@array rather than \@array. This is
  908 annoying and a source of simple compiler errors, but must be lived with.
  909 
  910 The problems are not evaluated in strict mode, so global variables can be used
  911 without warnings.
  912 
  913 
  914 
  915 =cut
  916 
  917 ############################################################################
  918 
  919 
  920         ##########################################
  921         ###### PG preprocessing code #############
  922         ##########################################
  923 
  924             $evalString = &{$self->{preprocess_code}}($evalString);
  925 
  926 
  927 #               # default_preprocess_code
  928 #           # BEGIN_TEXT and END_TEXT must occur on a line by themselves.
  929 #           $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g;
  930 #         $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3\(<<'END_TEXT'\)\);\n/g;
  931 #         $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT
  932 #
  933 #       $evalString =~ s/\\/\\\\/g;    # \ can't be used for escapes because of TeX conflict
  934 #           $evalString =~ s/~~/\\/g;      # use ~~ as escape instead, use # for comments
  935 
  936 
  937 =pod
  938 
  939 (4) B<Evaluate the problem text>
  940 
  941 Evaluate the text within the safe compartment.  Save the errors. The safe
  942 compartment is a new one unless the $safeCompartment was set to zero in which
  943 case the previously defined safe compartment is used. (See item 1.)
  944 
  945 =cut
  946 
  947         my ($PG_PROBLEM_TEXT_REF, $PG_HEADER_TEXT_REF, $PG_ANSWER_HASH_REF, $PG_FLAGS_REF, $PGcore)
  948               =$safe_cmpt->reval("   $evalString");
  949                #warn "using safe compartment ", $safe_cmpt->root;
  950 # This section could use some more error messages.  In particular if a problem doesn't produce the right output, the user needs
  951 # information about which problem was at fault.
  952 #
  953 #
  954 
  955 #################
  956 # FIXME The various warning message tracks are still being sorted out
  957 # WARNING and DEBUG tracks are being handled elsewhere (in Problem.pm?)
  958 #################
  959         $self->{errors} .= $@;
  960 
  961 
  962 #         $self->{errors}.=join(CGI::br(), @{$PGcore->{flags}->{WARNING_messages}} );
  963 #         $self->{errors}.=join(CGI::br(), @{$PGcore->{flags}->{DEBUG_messages  }} );
  964 #######################################################################
  965 
  966 #         push(@PROBLEM_TEXT_OUTPUT   ,   split(/(\n)/,$$PG_PROBLEM_TEXT_REF)  ) if  defined($$PG_PROBLEM_TEXT_REF  );
  967           push(@PROBLEM_TEXT_OUTPUT   ,   split(/^/,$$PG_PROBLEM_TEXT_REF)  ) if  ref($PG_PROBLEM_TEXT_REF  ) eq 'SCALAR';
  968                                                                            ## This is better than using defined($$PG_PROBLEM_TEXT_REF)
  969                                                                            ## Because more pleasant feedback is given
  970                                                                            ## when the problem doesn't render.
  971            # try to get the \n to appear at the end of the line
  972 
  973         use strict;
  974         #############################################################################
  975         ##########  end  EVALUATION code                                  ###########
  976         #############################################################################
  977 
  978         ##########################################
  979         ###### PG postprocessing code #############
  980         ##########################################
  981       $PG_PROBLEM_TEXT_REF = &{$self->{postprocess_code}}($PG_PROBLEM_TEXT_REF);
  982 
  983 
  984 =pod
  985 
  986 (5) B<Process errors>
  987 
  988 The error provided by Perl
  989 is truncated slightly and returned. In the text
  990 string which would normally contain the rendered problem.
  991 
  992 The original text string is given line numbers and concatenated to
  993 the errors.
  994 
  995 =cut
  996 
  997 
  998 
  999         ##########################################
 1000     ###### PG error processing code ##########
 1001     ##########################################
 1002         my (@input,$lineNumber,$line);
 1003         if ($self -> {errors}) {
 1004                 #($self -> {errors}) =~ s/</&lt/g;
 1005                 #($self -> {errors}) =~ s/>/&gt/g;
 1006            #try to clean up errors so they will look ok
 1007                 $self ->{errors} =~ s/\[[^\]]+?\] [^ ]+?\.pl://gm;   #erase [Fri Dec 31 12:58:30 1999] processProblem7.pl:
 1008                 #$self -> {errors} =~ s/eval\s+'(.|[\n|r])*$//;
 1009             #end trying to clean up errors so they will look ok
 1010 
 1011 
 1012                 push(@PROBLEM_TEXT_OUTPUT   ,  qq!\n<A NAME="problem! .
 1013                     $self->{envir} ->{'probNum'} .
 1014                     qq!"><PRE>        Problem!.
 1015                     $self->{envir} ->{'probNum'}.
 1016                     qq!\nERROR caught by Translator while processing problem file:! .
 1017                   $self->{envir}->{'probFileName'}.
 1018                   "\n****************\r\n" .
 1019                   $self -> {errors}."\r\n" .
 1020                   "****************<BR>\n");
 1021 
 1022                push(@PROBLEM_TEXT_OUTPUT   , "------Input Read\r\n");
 1023                $self->{source} =~ s/</&lt;/g;
 1024                @input=split("\n", $self->{source});
 1025                $lineNumber = 1;
 1026                 foreach $line (@input) {
 1027                     chomp($line);
 1028                     push(@PROBLEM_TEXT_OUTPUT, "$lineNumber\t\t$line\r\n");
 1029                     $lineNumber ++;
 1030                 }
 1031                 push(@PROBLEM_TEXT_OUTPUT  ,"\n-----<BR></PRE>\r\n");
 1032 
 1033 
 1034 
 1035         }
 1036 
 1037 =pod
 1038 
 1039 (6) B<Prepare return values>
 1040 
 1041   Returns:
 1042       $PG_PROBLEM_TEXT_ARRAY_REF -- Reference to a string containing the rendered text.
 1043       $PG_HEADER_TEXT_REF -- Reference to a string containing material to placed in the header (for use by JavaScript)
 1044       $PG_ANSWER_HASH_REF -- Reference to an array containing the answer evaluators.
 1045       $PG_FLAGS_REF -- Reference to a hash containing flags and other references:
 1046         'error_flag' is set to 1 if there were errors in rendering
 1047       $PGcore -- the PGcore object
 1048 
 1049 =cut
 1050 
 1051         ## we need to make sure that the other output variables are defined
 1052 
 1053                 ## If the eval failed with errors, one or more of these variables won't be defined.
 1054                 $PG_ANSWER_HASH_REF = {}      unless defined($PG_ANSWER_HASH_REF);
 1055                 $PG_HEADER_TEXT_REF = \( "" ) unless defined($PG_HEADER_TEXT_REF);
 1056                 $PG_FLAGS_REF = {}            unless defined($PG_FLAGS_REF);
 1057 
 1058             $PG_FLAGS_REF->{'error_flag'} = 1     if $self -> {errors};
 1059         my $PG_PROBLEM_TEXT                     = join("",@PROBLEM_TEXT_OUTPUT);
 1060 
 1061         $self ->{ PG_PROBLEM_TEXT_REF }     = \$PG_PROBLEM_TEXT;
 1062         $self ->{ PG_PROBLEM_TEXT_ARRAY_REF }   = \@PROBLEM_TEXT_OUTPUT;
 1063       $self ->{ PG_HEADER_TEXT_REF  }   = $PG_HEADER_TEXT_REF;
 1064       $self ->{ rh_correct_answers  }   = $PG_ANSWER_HASH_REF;
 1065       $self ->{ PG_FLAGS_REF      }   = $PG_FLAGS_REF;
 1066       $self ->{ rh_pgcore             }       = $PGcore;
 1067 
 1068       #warn "PGcore is ", ref($PGcore), " in Translator";
 1069       #$self ->{errors};
 1070 }  # end translate
 1071 
 1072 
 1073 =head2   Answer evaluation methods
 1074 
 1075 =cut
 1076 
 1077 =head3  access methods
 1078 
 1079   $obj->rh_student_answers
 1080 
 1081 =cut
 1082 
 1083 
 1084 
 1085 sub rh_evaluated_answers {
 1086   my $self = shift;
 1087   my @in = @_;
 1088   return $self->{rh_evaluated_answers} if @in == 0;
 1089 
 1090   if ( ref($in[0]) eq 'HASH' ) {
 1091     $self->{rh_evaluated_answers} = { %{ $in[0] } }; # store a copy of the hash
 1092   } else {
 1093     $self->{rh_evaluated_answers} = { @in }; # store a copy of the hash
 1094   }
 1095   $self->{rh_evaluated_answers};
 1096 }
 1097 sub rh_problem_result {
 1098   my $self = shift;
 1099   my @in = @_;
 1100   return $self->{rh_problem_result} if @in == 0;
 1101 
 1102   if ( ref($in[0]) eq 'HASH' ) {
 1103     $self->{rh_problem_result} = { %{ $in[0] } }; # store a copy of the hash
 1104   } else {
 1105     $self->{rh_problem_result} = { @in }; # store a copy of the hash
 1106   }
 1107   $self->{rh_problem_result};
 1108 }
 1109 sub rh_problem_state {
 1110   my $self = shift;
 1111   my @in = @_;
 1112   return $self->{rh_problem_state} if @in == 0;
 1113 
 1114   if ( ref($in[0]) eq 'HASH' ) {
 1115     $self->{rh_problem_state} = { %{ $in[0] } }; # store a copy of the hash
 1116   } else {
 1117     $self->{rh_problem_state} = { @in }; # store a copy of the hash
 1118   }
 1119   $self->{rh_problem_state};
 1120 }
 1121 
 1122 
 1123 =head3 process_answers
 1124 
 1125 
 1126   $obj->process_answers()
 1127 
 1128 
 1129 =cut
 1130 
 1131 
 1132 sub process_answers{
 1133   my $self = shift;
 1134   my @in = @_;
 1135   my %h_student_answers;
 1136   if (ref($in[0]) eq 'HASH' ) {
 1137     %h_student_answers = %{ $in[0] };  #receiving a reference to a hash of answers
 1138   } else {
 1139     %h_student_answers = @in;          # receiving a hash of answers
 1140   }
 1141   my $rh_correct_answers = $self->rh_correct_answers();
 1142   my @answer_entry_order = ( defined($self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER}) ) ?
 1143                         @{$self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER}} : keys %{$rh_correct_answers};
 1144 
 1145   # define custom warn/die handlers for answer evaluation. these used to be inside
 1146   # the foreach loop around the conditional involving $rf_fun, but for efficiency
 1147   # we've moved it out here. This means that the handlers will be active during the
 1148   # code before and after the actual answer evaluation.
 1149 
 1150   my $outer_sig_warn = $SIG{__WARN__};
 1151   local $SIG{__WARN__} = sub {
 1152     ref $outer_sig_warn eq "CODE"
 1153       ? &$outer_sig_warn(PG_errorMessage('message', $_[0]))
 1154       : warn PG_errorMessage('message', $_[0]);
 1155   };
 1156 
 1157   # the die handler is a closure over %errorTable and $outer_sig_die.
 1158   #
 1159   # %errorTable accumulates a "full" error message for each error that occurs during
 1160   # answer evaluation. then, right after the evaluation (which is done within a call
 1161   # to Safe::reval), $@ is checked and it's value is looked up in %errorTable to get
 1162   # the full error to report.
 1163   #
 1164   # my question: why is this a hash? this is die, so once one occurs, we exit the reval.
 1165   # wouldn't it be sufficient to have a scalar like $backtrace_for_last_error?
 1166   #
 1167   # Note that %errorTable is cleared for each answer.
 1168   my %errorTable;
 1169   my $outer_sig_die = $SIG{__DIE__};
 1170   local $SIG{__DIE__} = sub {
 1171 
 1172     # this chunk taken from dpvc's original handler
 1173     my $fullerror = PG_errorMessage('traceback', @_);
 1174     my ($error,$traceback) = split /\n/, $fullerror, 2;
 1175     $fullerror =~ s/\n   /<BR>&nbsp;&nbsp;&nbsp;/g; $fullerror =~ s/\n/<BR>/g;
 1176     $error .= "\n";
 1177     $errorTable{$error} = $fullerror;
 1178     # end of dpvc's original code
 1179 
 1180     ref $outer_sig_die eq "CODE"
 1181       ? &$outer_sig_die($error)
 1182       : die $error;
 1183   };
 1184 
 1185   # apply each instructors answer to the corresponding student answer
 1186 
 1187   foreach my $ans_name ( @answer_entry_order ) {
 1188     my ($ans, $errors) = $self->filter_answer( $h_student_answers{$ans_name} );
 1189     no strict;
 1190     # evaluate the answers inside the safe compartment.
 1191     local($rf_fun,$temp_ans) = (undef,undef);
 1192     if ( defined($rh_correct_answers ->{$ans_name} ) ) {
 1193       $rf_fun  = $rh_correct_answers->{$ans_name};
 1194     } else {
 1195       warn "There is no answer evaluator for the question labeled $ans_name";
 1196     }
 1197     $temp_ans  = $ans;
 1198     $temp_ans = '' unless defined($temp_ans); #make sure that answer is always defined
 1199                                               # in case the answer evaluator forgets to check
 1200     $self->{safe}->share('$rf_fun','$temp_ans');
 1201 
 1202       # clear %errorTable for each problem
 1203       %errorTable = (); # is the error table being used? perhaps by math objects?
 1204 
 1205     my $rh_ans_evaluation_result;
 1206     if (ref($rf_fun) eq 'CODE' ) {
 1207       $rh_ans_evaluation_result = $self->{safe} ->reval( '&{ $rf_fun }($temp_ans, ans_label => \''.$ans_name.'\')' ) ;
 1208       warn "Error in Translator.pm::process_answers: Answer $ans_name: |$temp_ans|\n $@\n" if $@;
 1209     } elsif (ref($rf_fun) =~ /AnswerEvaluator/)   {
 1210       $rh_ans_evaluation_result = $self->{safe} ->reval('$rf_fun->evaluate($temp_ans, ans_label => \''.$ans_name.'\')');
 1211       $@ = $errorTable{$@} if $@ && defined($errorTable{$@});  #Are we redefining error messages here?
 1212       warn "Error in Translator.pm::process_answers: Answer $ans_name: |$temp_ans|\n $@\n" if $@;
 1213       warn "Evaluation error: Answer $ans_name:<BR>\n",
 1214         $rh_ans_evaluation_result->error_flag(), " :: ",
 1215         $rh_ans_evaluation_result->error_message(),"<BR>\n"
 1216           if defined($rh_ans_evaluation_result)
 1217             and defined($rh_ans_evaluation_result->error_flag());
 1218     } else {
 1219       warn "Error in Translator.pm::process_answers: Answer $ans_name:<BR>\n Unrecognized evaluator type |", ref($rf_fun), "|";
 1220     }
 1221 
 1222     use strict;
 1223     unless ( ( ref($rh_ans_evaluation_result) eq 'HASH') or ( ref($rh_ans_evaluation_result) eq 'AnswerHash') ) {
 1224       warn "Error in Translator.pm::process_answers: Answer $ans_name:<BR>\n
 1225         Answer evaluators must return a hash or an AnswerHash type, not type |",
 1226         ref($rh_ans_evaluation_result), "|";
 1227     }
 1228     $rh_ans_evaluation_result ->{ans_message} .= "$errors \n" if $errors;
 1229     $rh_ans_evaluation_result ->{ans_name} = $ans_name;
 1230     $self->{rh_evaluated_answers}->{$ans_name} = $rh_ans_evaluation_result;
 1231   }
 1232   $self->rh_evaluated_answers;
 1233 }
 1234 
 1235 
 1236 
 1237 =head3 grade_problem
 1238 
 1239   $obj->rh_problem_state(%problem_state);  # sets the current problem state
 1240   $obj->grade_problem(%form_options);
 1241 
 1242 
 1243 =cut
 1244 
 1245 
 1246 sub grade_problem {
 1247   my $self = shift;
 1248   no strict;
 1249   local %rf_options = @_;
 1250   local $rf_grader = $self->{rf_problem_grader};
 1251   local $rh_answers = $self->{rh_evaluated_answers};
 1252   local $rh_state = $self->{rh_problem_state};
 1253   $self->{safe}->share('$rf_grader','$rh_answers','$rh_state','%rf_options');
 1254 ############################################
 1255 #
 1256 # FIXME
 1257 # warning messages are not being transmitted from this evaluation
 1258 # ??????
 1259 ############################################
 1260 
 1261   ($self->{rh_problem_result},$self->{rh_problem_state}) =
 1262     $self->{safe}->reval('&{$rf_grader}($rh_answers,$rh_state,%rf_options)');
 1263   use strict;
 1264   die $@ if $@;
 1265   ($self->{rh_problem_result}, $self->{rh_problem_state});
 1266 }
 1267 
 1268 sub rf_std_problem_grader {
 1269     my $self = shift;
 1270   return \&std_problem_grader;
 1271 }
 1272 sub old_std_problem_grader{
 1273   my $rh_evaluated_answers = shift;
 1274   my %flags = @_;  # not doing anything with these yet
 1275   my %evaluated_answers = %{$rh_evaluated_answers};
 1276   my  $allAnswersCorrectQ=1;
 1277   foreach my $ans_name (keys %evaluated_answers) {
 1278   # I'm not sure if this check is really useful.
 1279       if (ref($evaluated_answers{$ans_name} ) eq 'HASH' ) {
 1280         $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} );
 1281       } else {
 1282         warn "Error: Answer $ans_name is not a hash";
 1283         warn "$evaluated_answers{$ans_name}";
 1284       }
 1285   }
 1286   # Notice that "all answers are correct" if there are no questions.
 1287   { score       => $allAnswersCorrectQ,
 1288     prev_tries    => 0,
 1289     partial_credit  => $allAnswersCorrectQ,
 1290     errors      =>  "",
 1291     type              => 'old_std_problem_grader',
 1292     flags       => {}, # not doing anything with these yet
 1293   };  # hash output
 1294 
 1295 }
 1296 
 1297 #####################################
 1298 # This is a model for plug-in problem graders
 1299 #####################################
 1300 
 1301 sub std_problem_grader{
 1302   my $rh_evaluated_answers = shift;
 1303   my $rh_problem_state = shift;
 1304   my %form_options = @_;
 1305   my %evaluated_answers = %{$rh_evaluated_answers};
 1306   #  The hash $rh_evaluated_answers typically contains:
 1307   #      'answer1' => 34, 'answer2'=> 'Mozart', etc.
 1308 
 1309   # By default the  old problem state is simply passed back out again.
 1310   my %problem_state = %$rh_problem_state;
 1311 
 1312 
 1313   # %form_options might include
 1314   # The user login name
 1315   # The permission level of the user
 1316   # The studentLogin name for this psvn.
 1317   # Whether the form is asking for a refresh or is submitting a new answer.
 1318 
 1319   # initial setup of the answer
 1320   my %problem_result = ( score        => 0,
 1321                errors         => '',
 1322                type           => 'std_problem_grader',
 1323                msg          => '',
 1324              );
 1325   # Checks
 1326 
 1327   my $ansCount = keys %evaluated_answers;  # get the number of answers
 1328   unless ($ansCount > 0 ) {
 1329     $problem_result{msg} = "This problem did not ask any questions.";
 1330     return(\%problem_result,\%problem_state);
 1331   }
 1332 
 1333   if ($ansCount > 1 ) {
 1334     $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' ;
 1335   }
 1336 
 1337   unless (defined( $form_options{answers_submitted}) and $form_options{answers_submitted} == 1) {
 1338     return(\%problem_result,\%problem_state);
 1339   }
 1340 
 1341   my  $allAnswersCorrectQ=1;
 1342   foreach my $ans_name (keys %evaluated_answers) {
 1343   # I'm not sure if this check is really useful.
 1344       if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) {
 1345         $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} );
 1346       } else {
 1347         warn "Error: Answer $ans_name is not a hash";
 1348         warn "$evaluated_answers{$ans_name}";
 1349         warn "This probably means that the answer evaluator is for this answer is not working correctly.";
 1350         $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}";
 1351       }
 1352   }
 1353   # report the results
 1354   $problem_result{score} = $allAnswersCorrectQ;
 1355 
 1356   # I don't like to put in this bit of code.
 1357   # It makes it hard to construct error free problem graders
 1358   # I would prefer to know that the problem score was numeric.
 1359     unless ($problem_state{recorded_score} =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ) {
 1360       $problem_state{recorded_score} = 0;  # This gets rid of non-numeric scores
 1361     }
 1362     #
 1363   if ($allAnswersCorrectQ == 1 or $problem_state{recorded_score} == 1) {
 1364     $problem_state{recorded_score} = 1;
 1365   } else {
 1366     $problem_state{recorded_score} = 0;
 1367   }
 1368 
 1369   $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1;
 1370   $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0;
 1371   (\%problem_result, \%problem_state);
 1372 }
 1373 sub rf_avg_problem_grader {
 1374     my $self = shift;
 1375   return \&avg_problem_grader;
 1376 }
 1377 sub avg_problem_grader{
 1378   my $rh_evaluated_answers = shift;
 1379   my $rh_problem_state = shift;
 1380   my %form_options = @_;
 1381   my %evaluated_answers = %{$rh_evaluated_answers};
 1382   #  The hash $rh_evaluated_answers typically contains:
 1383   #      'answer1' => 34, 'answer2'=> 'Mozart', etc.
 1384 
 1385   # By default the  old problem state is simply passed back out again.
 1386   my %problem_state = %$rh_problem_state;
 1387 
 1388 
 1389   # %form_options might include
 1390   # The user login name
 1391   # The permission level of the user
 1392   # The studentLogin name for this psvn.
 1393   # Whether the form is asking for a refresh or is submitting a new answer.
 1394 
 1395   # initial setup of the answer
 1396   my  $total=0;
 1397   my %problem_result = (
 1398     score => 0,
 1399     errors => '',
 1400     type => 'avg_problem_grader',
 1401     msg => '',
 1402   );
 1403   my $count = keys %evaluated_answers;
 1404   $problem_result{msg} = 'You can earn partial credit on this problem.' if $count >1;
 1405   # Return unless answers have been submitted
 1406   unless ($form_options{answers_submitted} == 1) {
 1407     return(\%problem_result,\%problem_state);
 1408   }
 1409   # Answers have been submitted -- process them.
 1410   foreach my $ans_name (keys %evaluated_answers) {
 1411     $total += $evaluated_answers{$ans_name}->{score};
 1412   }
 1413   # Calculate score rounded to three places to avoid roundoff problems
 1414   $problem_result{score} = ($count) ? $total/$count : 0 ; # give zero if no answers have been evaluated.
 1415   # increase recorded score if the current score is greater.
 1416   $problem_state{recorded_score}=0 unless defined $problem_state{recorded_score};
 1417   $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score};
 1418 
 1419 
 1420   $problem_state{num_of_correct_ans}++ if $total == $count;
 1421   $problem_state{num_of_incorrect_ans}++ if $total < $count ;
 1422   warn "Error in grading this problem the total $total is larger than $count" if $total > $count;
 1423   (\%problem_result, \%problem_state);
 1424 
 1425 }
 1426 =head3 safetyFilter
 1427 
 1428   ($filtered_ans, $errors) = $obj ->filter_ans($ans)
 1429                                $obj ->rf_safety_filter()
 1430 
 1431 =cut
 1432 
 1433 sub filter_answer {
 1434   my $self = shift;
 1435   my $ans = shift;
 1436   my @filtered_answers;
 1437   my $errors='';
 1438   if (ref($ans) eq 'ARRAY') {   #handle the case where the answer comes from several inputs with the same name
 1439                   # In many cases this will be passed as a reference to an array
 1440                   # if it is passed as a single string (separated by \0 characters) as
 1441                   # some early versions of CGI behave, then
 1442                   # it is unclear what will happen when the answer is filtered.
 1443     foreach my $item (@{$ans}) {
 1444       my ($filtered_ans, $error) = &{ $self->{rf_safety_filter} } ($item);
 1445       push(@filtered_answers, $filtered_ans);
 1446       $errors .= " ". $error if $error;  # add error message if error is non-zero.
 1447     }
 1448     (\@filtered_answers,$errors);
 1449 
 1450   } else {
 1451     &{ $self->{rf_safety_filter} } ($ans);
 1452   }
 1453 
 1454 }
 1455 sub rf_safety_filter {
 1456   my $self = shift;
 1457   my $rf_filter = shift;
 1458   $self->{rf_safety_filter} = $rf_filter if $rf_filter and ref($rf_filter) eq 'CODE';
 1459   warn "The safety_filter must be a reference to a subroutine" unless ref($rf_filter) eq 'CODE' ;
 1460   $self->{rf_safety_filter}
 1461 }
 1462 sub safetyFilter {
 1463       my $answer = shift;  # accepts one answer and checks it
 1464       my $submittedAnswer = $answer;
 1465     $answer = '' unless defined $answer;
 1466     my ($errorno);
 1467     $answer =~ tr/\000-\037/ /;
 1468    #### Return if answer field is empty ########
 1469     unless ($answer =~ /\S/) {
 1470 #     $errorno = "<BR>No answer was submitted.";
 1471             $errorno = 0;  ## don't report blank answer as error
 1472 
 1473       return ($answer,$errorno);
 1474       }
 1475    ######### replace ^ with **    (for exponentiation)
 1476    #  $answer =~ s/\^/**/g;
 1477    ######### Return if  forbidden characters are found
 1478     unless ($answer =~ /^[a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)]+$/ )  {
 1479       $answer =~ tr/a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)/#/c;
 1480       $errorno = "<BR>There are forbidden characters in your answer: $submittedAnswer<BR>";
 1481 
 1482       return ($answer,$errorno);
 1483       }
 1484 
 1485     $errorno = 0;
 1486     return($answer, $errorno);
 1487 }
 1488 
 1489 ##   Check submittedAnswer for forbidden characters, etc.
 1490 #     ($submittedAnswer,$errorno) = safetyFilter($submittedAnswer);
 1491 #       $errors .= "No answer was submitted.<BR>" if $errorno == 1;
 1492 #       $errors .= "There are forbidden characters in your answer: $submittedAnswer<BR>" if $errorno ==2;
 1493 #
 1494 ##   Check correctAnswer for forbidden characters, etc.
 1495 #     unless (ref($correctAnswer) ) {  #skip check if $correctAnswer is a function
 1496 #       ($correctAnswer,$errorno) = safetyFilter($correctAnswer);
 1497 #       $errors .= "No correct answer is given in the statement of the problem.
 1498 #                   Please report this to your instructor.<BR>" if $errorno == 1;
 1499 #       $errors .= "There are forbidden characters in the problems answer.
 1500 #                   Please report this to your instructor.<BR>" if $errorno == 2;
 1501 #     }
 1502 
 1503 
 1504 
 1505 =head2 PGsort
 1506 
 1507 Because of the way sort is optimized in Perl, the symbols $a and $b
 1508 have special significance.
 1509 
 1510 C<sort {$a<=>$b} @list>
 1511 C<sort {$a cmp $b} @list>
 1512 
 1513 sorts the list numerically and lexically respectively.
 1514 
 1515 If C<my $a;> is used in a problem, before the sort routine is defined in a macro, then
 1516 things get badly confused.  To correct this the macro PGsort is defined below.  It is
 1517 evaluated before the problem template is read.  In PGbasicmacros.pl, the two subroutines
 1518 
 1519   PGsort sub { $_[0] < $_[1] }, @list;
 1520   PGsort sub { $_[0] lt $_[1] }, @list;
 1521 
 1522 (called num_sort and lex_sort) provide slightly slower, but safer, routines for the PG language.
 1523 (The subroutines for ordering are B<required>. Note the commas!)
 1524 
 1525 =cut
 1526 
 1527 # This sort can cause troubles because of its special use of $a and $b
 1528 # Putting it in dangerousMacros.pl worked frequently, but not always.
 1529 # In particular ANS( ans_eva1 ans_eval2) caused trouble.
 1530 # One answer at a time did not --- very strange.
 1531 # This was replaced by a quick sort routine because the original subroutine
 1532 # did not work with Safe when Perl was built with ithreads
 1533 
 1534 #sub PGsort {
 1535 # my $sort_order = shift;
 1536 # die "Must supply an ordering function with PGsort: PGsort sub {\$a cmp \$b }, \@list\n" unless ref($sort_order) eq 'CODE';
 1537 # sort {&$sort_order($a,$b)} @_;
 1538 #}
 1539 
 1540       # quicksort
 1541 sub PGsort {
 1542          my $cmp = shift;
 1543    die "Must supply an ordering function with PGsort: PGsort  sub {\$_[0]  < \$_[1] }, \@list\n" unless ref($cmp) eq 'CODE';
 1544          if (@_ == 0) { return () }
 1545          else {
 1546            my $b_item = shift;
 1547            my ($small, $large);
 1548            my $a_item;
 1549            for $a_item (@_) {
 1550              push @{&$cmp($a_item, $b_item) ? $small : $large}, $a_item;
 1551            }
 1552            return (PGsort($cmp, @$small), $b_item, PGsort($cmp, @$large));
 1553          }
 1554        }
 1555 
 1556 
 1557 =head2 includePGtext
 1558 
 1559   includePGtext($string_ref, $envir_ref)
 1560 
 1561 Calls C<createPGtext> recursively with the $safeCompartment variable set to 0
 1562 so that the rendering continues in the current safe compartment.  The output
 1563 is the same as the output from createPGtext. This is used in processing
 1564 some of the sample CAPA files.
 1565 
 1566 =cut
 1567 
 1568 #this is a method for importing additional PG files from within one PG file.
 1569 # sub includePGtext {
 1570 #     my $self = shift;
 1571 #     my $string_ref =shift;
 1572 #     my $envir_ref = shift;
 1573 #     $self->environment($envir_ref);
 1574 #   $self->createPGtext($string_ref);
 1575 # }
 1576 # evaluation macros
 1577 
 1578 
 1579 
 1580 no strict;   # this is important -- I guess because eval operates on code which is not written with strict in mind.
 1581 
 1582 
 1583 
 1584 =head2 PG_restricted_eval
 1585 
 1586   PG_restricted_eval($string)
 1587 
 1588 Evaluated in package 'main'. Result of last statement is returned.
 1589 When called from within a safe compartment the safe compartment package
 1590 is 'main'.
 1591 
 1592 
 1593 =cut
 1594 
 1595 # Remember, eval STRING evaluates code in the current lexical context, so any
 1596 # lexicals available here will also be available in the evaluated code. So we
 1597 # move the actual eval into a helper function called PG_restricted_eval_helper,
 1598 # which doesn't need to have any lexicals.
 1599 sub PG_restricted_eval {
 1600   my $string = shift;
 1601   my $out = PG_restricted_eval_helper($string);
 1602   my $err = $@;
 1603   my $err_report = $err if $err =~ /\S/;
 1604   return wantarray ? ($out, $err, $err_report) : $out;
 1605 }
 1606 
 1607 # This is a helper that doesn't use any lexicals. See above.
 1608 sub PG_restricted_eval_helper {
 1609   no strict;
 1610   local $SIG{__WARN__} = "DEFAULT";
 1611   local $SIG{__DIE__} = "DEFAULT";
 1612   return eval("package main;\n" . $_[0]);
 1613 }
 1614 
 1615 sub PG_macro_file_eval {      # would like to modify this so that it requires use strict on the files that it evaluates.
 1616     my $string = shift;
 1617     my ($pck,$file,$line) = caller;
 1618 
 1619   local $SIG{__WARN__} = "DEFAULT";
 1620   local $SIG{__DIE__} = "DEFAULT";
 1621 
 1622     no strict;
 1623     my $out = eval  ("package main; be_strict();\n" . $string );
 1624     my $errors =$@;
 1625     my $full_error_report = "PG_macro_file_eval detected error at line $line of file $file \n"
 1626                 . $errors .
 1627                 "The calling package is $pck\n" if defined($errors) && $errors =~/\S/;
 1628     use strict;
 1629 
 1630     return (wantarray) ?  ($out, $errors,$full_error_report) : $out;
 1631 }
 1632 =head2 PG_answer_eval
 1633 
 1634 
 1635   PG_answer_eval($string)
 1636 
 1637 Evaluated in package defined by the current safe compartment.
 1638 Result of last statement is returned.
 1639 When called from within a safe compartment the safe compartment package
 1640 is 'main'.
 1641 
 1642 There is still some confusion about how these two evaluation subroutines work
 1643 and how best to define them.  It is useful to have two evaluation procedures
 1644 since at some point one might like to make the answer evaluations more stringent.
 1645 
 1646 =cut
 1647 
 1648 
 1649 sub PG_answer_eval {
 1650    local($string) = shift;   # I made this local just in case -- see PG_restricted_eval
 1651    my $errors = '';
 1652    my $full_error_report = '';
 1653    my ($pck,$file,$line) = caller;
 1654     # Because of the global variable $PG::compartment_name and $PG::safe_cmpt
 1655     # only one problem safe compartment can be active at a time.
 1656     # This might cause problems at some point.  In that case a cleverer way
 1657     # of insuring that the package stays in scope until the answer is evaluated
 1658     # will be required.
 1659 
 1660     # This is pretty tricky and doesn't always work right.
 1661     # We seem to need PG_priv instead of main when PG_answer_eval is called within a completion
 1662     # 'package PG_priv; '
 1663 
 1664         local $SIG{__WARN__} = sub {die(@_)};  # make warn die, so all errors are reported.
 1665   local $SIG{__DIE__} = "DEFAULT";
 1666 
 1667     no strict;
 1668     my $out = eval('package main;'.$string);
 1669     $out = '' unless defined($out);
 1670     $errors .= $@;
 1671     $full_error_report = "ERROR: at line $line of file $file
 1672                 $errors
 1673                 The calling package is $pck\n" if defined($errors) && $errors =~/\S/;
 1674     use strict;
 1675 
 1676     return (wantarray) ?  ($out, $errors,$full_error_report) : $out;
 1677 
 1678 
 1679 }
 1680 
 1681 # sub original_preprocess_code {
 1682 #   my $evalString = shift;
 1683 #   # BEGIN_TEXT and END_TEXT must occur on a line by themselves.
 1684 #   $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g;
 1685 #   $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3\(<<'END_TEXT'\)\);\n/g;
 1686 #   $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT
 1687 #
 1688 #   $evalString =~ s/\\/\\\\/g;    # \ can't be used for escapes because of TeX conflict
 1689 #   $evalString =~ s/~~/\\/g;      # use ~~ as escape instead, use # for comments
 1690 #   $evalString;
 1691 # }
 1692 sub default_preprocess_code {
 1693   my $evalString = shift;
 1694   # BEGIN_TEXT and END_TEXT must occur on a line by themselves.
 1695   $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g;
 1696   $evalString =~ s/\n\s*END_PGML[\s;]*\n/\nEND_PGML\n/g;
 1697   $evalString =~ s/\n\s*END_SOLUTION[\s;]*\n/\nEND_SOLUTION\n/g;
 1698   $evalString =~ s/\n\s*END_HINT[\s;]*\n/\nEND_HINT\n/g;
 1699   $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3P\(<<'END_TEXT'\)\);\n/g;
 1700   $evalString =~ s/\n\s*BEGIN_PGML[\s;]*\n/\nTEXT\(PGML::Format2\(<<'END_PGML'\)\);\n/g;
 1701   $evalString =~ s/\n\s*BEGIN_SOLUTION[\s;]*\n/\nSOLUTION\(EV3P\(<<'END_SOLUTION'\)\);\n/g;
 1702   $evalString =~ s/\n\s*BEGIN_HINT[\s;]*\n/\nHINT\(EV3P\(<<'END_HINT'\)\);\n/g;
 1703   $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT
 1704 
 1705   $evalString =~ s/\\/\\\\/g;    # \ can't be used for escapes because of TeX conflict
 1706   $evalString =~ s/~~/\\/g;      # use ~~ as escape instead, use # for comments
 1707   $evalString;
 1708 }
 1709 sub default_postprocess_code {
 1710   my $evalString_ref = shift;
 1711   $evalString_ref;
 1712 }
 1713 
 1714 sub dumpvar {
 1715     my ($packageName) = @_;
 1716 
 1717     local(*alias);
 1718 
 1719     sub emit {
 1720       print @_;
 1721     }
 1722 
 1723     *stash = *{"${packageName}::"};
 1724     $, = "  ";
 1725 
 1726     emit "Content-type: text/html\n\n<PRE>\n";
 1727 
 1728 
 1729     while ( ($varName, $globValue) = each %stash) {
 1730         emit "$varName\n";
 1731 
 1732   *alias = $globValue;
 1733   next if $varName=~/main/;
 1734 
 1735   #if (defined($alias) ) {  # get rid of defined since this is deprecated
 1736   if ($alias ) {
 1737       emit "  \$$varName $alias \n";
 1738   }
 1739 
 1740   if ( @alias) {
 1741       emit "  \@$varName @alias \n";
 1742   }
 1743   if (%alias ) {
 1744       emit "  %$varName \n";
 1745       foreach $key (keys %alias) {
 1746           emit "    $key => $alias{$key}\n";
 1747       }
 1748 
 1749 
 1750 
 1751   }
 1752     }
 1753     emit "</PRE></PRE>";
 1754 
 1755 
 1756 }
 1757 use strict;
 1758 
 1759 #### for error checking and debugging purposes
 1760 sub pretty_print_rh {
 1761   my $rh = shift;
 1762   foreach my $key (sort keys %{$rh})  {
 1763     warn "  $key => ",$rh->{$key},"\n";
 1764   }
 1765 }
 1766 # end evaluation subroutines
 1767 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9