[system] / trunk / xmlrpc / daemon / PGtranslator5.pm Repository:
ViewVC logotype

View of /trunk/xmlrpc/daemon/PGtranslator5.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 374 - (download) (as text) (annotate)
Tue Jun 18 17:55:20 2002 UTC (17 years, 3 months ago) by gage
File size: 44153 byte(s)
Deleted some debugging statements
Added a check to make sure that a macro file has actually been loaded, by checking that _$macrofile_init  has been defined.

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9