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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 279 - (view) (download) (as text)

1 : gage 279 #!/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