[system] / trunk / webwork / system / lib / PGtranslator.pm Repository:
ViewVC logotype

View of /trunk/webwork/system/lib/PGtranslator.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 100 - (download) (as text) (annotate)
Wed Aug 8 02:13:25 2001 UTC (18 years, 4 months ago) by gage
File size: 50668 byte(s)
replaced \&main::PG_floating_point_exception_handler by
&Global::PG_floating_point_exception_handler

since the exception handler was moved under the package Global section of Global.pm
when the BEGIN block was moved in version 1.6

It's possible that  the floating point exception handler available for bad  answers
hasn't been working
properly for awhile.

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9