[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 279 - (download) (as text) (annotate)
Fri May 17 21:44:04 2002 UTC (17 years, 4 months ago) by gage
File size: 50264 byte(s)
Experimental xmlrpc WeBWorK webservices

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9