[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 51 - (download) (as text) (annotate)
Thu Jun 21 20:53:03 2001 UTC (18 years, 8 months ago) by sam
File size: 50477 byte(s)
Fixed headers to include $Id$

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9