[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 27 - (download) (as text) (annotate)
Tue Jun 19 20:31:39 2001 UTC (12 years, 10 months ago) by gage
File size: 50219 byte(s)
Many modifications to courseScript scripts which will insure that the
routines are re-entrant (i.e. they can be called via mod_perl and don't
need to be re-compiled for every execution run.)

Minor modifications to processProblem8.pl and to PGtranslator.pm

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9