[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 4388 - (download) (as text) (annotate)
Sat Aug 19 23:31:38 2006 UTC (13 years, 3 months ago) by dpvc
File size: 56639 byte(s)
Fixed the problem I pointed out at MathFest where some errors were not
being reported in the traditional num_cmp() function.  (Things like
'x+3' in a numeric field would not be reported as an error and x would
be treated as 0).  This is due to a change in version 1.14 when Sam
was normalizing the error reporting code; he didn't notice that warn
had been rerouted to die in PG_answer_eval().  I have replaced it.

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9