Parent Directory
| 
Revision Log
switch to use WWSafe.pm
1 ################################################################################ 2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project 3 # $Id$ 4 ################################################################################ 5 6 package WeBWorK::PG::Translator; 7 8 use strict; 9 use warnings; 10 use Opcode; 11 use WWSafe; 12 use Net::SMTP; 13 use WeBWorK::PG::IO; 14 15 #use PadWalker; # used for processing error messages 16 #use Data::Dumper; 17 18 19 # loading GD within the Safe compartment has occasionally caused infinite recursion 20 # Putting these use statements here seems to avoid this problem 21 # It is not clear that this is essential once things are working properly. 22 #use Exporter; 23 #use DynaLoader; 24 25 26 =head1 NAME 27 28 WeBWorK::PG::Translator - Evaluate PG code and evaluate answers safely 29 30 =head1 SYNPOSIS 31 32 my $pt = new WeBWorK::PG::Translator; # create a translator; 33 $pt->environment(\%envir); # provide the environment variable for the problem 34 $pt->initialize(); # initialize the translator 35 $pt-> set_mask(); # set the operation mask for the translator safe compartment 36 $pt->source_string($source); # provide the source string for the problem 37 38 $pt -> unrestricted_load("${courseScriptsDirectory}PG.pl"); 39 $pt -> unrestricted_load("${courseScriptsDirectory}dangerousMacros.pl"); 40 # load the unprotected macro files 41 # these files are evaluated with the Safe compartment wide open 42 # other macros are loaded from within the problem using loadMacros 43 44 $pt ->translate(); # translate the problem (the out following 4 pieces of information are created) 45 46 $PG_PROBLEM_TEXT_ARRAY_REF = $pt->ra_text(); # output text for the body of the HTML file (in array form) 47 $PG_PROBLEM_TEXT_REF = $pt->r_text(); # output text for the body of the HTML file 48 $PG_HEADER_TEXT_REF = $pt->r_header;#\$PG_HEADER_TEXT; # text for the header of the HTML file 49 $PG_ANSWER_HASH_REF = $pt->rh_correct_answers; # a hash of answer evaluators 50 $PG_FLAGS_REF = $pt ->rh_flags; # misc. status flags. 51 52 $pt -> process_answers(\%inputs); # evaluates all of the answers using submitted answers from %input 53 54 my $rh_answer_results = $pt->rh_evaluated_answers; # provides a hash of the results of evaluating the answers. 55 my $rh_problem_result = $pt->grade_problem; # grades the problem using the default problem grading method. 56 57 =head1 DESCRIPTION 58 59 This module defines an object which will translate a problem written in the Problem Generating (PG) language 60 61 =cut 62 63 =head2 be_strict 64 65 This creates a substitute for C<use strict;> which cannot be used in PG problem 66 sets or PG macro files. Use this way to imitate the behavior of C<use strict;> 67 68 BEGIN { 69 be_strict(); # an alias for use strict. 70 # This means that all global variable 71 # must contain main:: as a prefix. 72 } 73 74 =cut 75 76 BEGIN { 77 # allows the use of strict within macro packages. 78 sub be_strict { 79 require 'ww_strict.pm'; 80 strict::import(); 81 } 82 83 # also define in Main::, for PG modules. 84 sub Main::be_strict { &be_strict } 85 } 86 87 =head2 evaluate_modules 88 89 Usage: $obj -> evaluate_modules('WWPlot', 'Fun', 'Circle'); 90 $obj -> evaluate_modules('reset'); 91 92 Adds the modules WWPlot.pm, Fun.pm and Circle.pm in the courseScripts directory to the list of modules 93 which can be used by the PG problems. The keyword 'reset' or 'erase' erases the list of modules already loaded 94 95 =cut 96 97 98 sub evaluate_modules { 99 my $self = shift; 100 my @modules = @_; 101 local $SIG{__DIE__} = "DEFAULT"; # we're going to be eval()ing code 102 foreach (@modules) { 103 #warn "attempting to load $_\n"; 104 # ensure that the name is in fact a base name 105 s/\.pm$// and warn "fixing your broken package name: $_.pm => $_"; 106 # call runtime_use on the package name 107 # don't worry -- runtime_use won't load a package twice! 108 #eval { runtime_use $_ }; # 109 eval "package Main; require $_; import $_"; # change for WW1 110 warn "Failed to evaluate module $_: $@" if $@; 111 # record this in the appropriate place 112 push @{$self->{ra_included_modules}}, "\%${_}::"; 113 } 114 } 115 # old code for runtime_use 116 # if ( -r "${courseScriptsDirectory}${module_name}.pm" ) { 117 # eval(qq! require "${courseScriptsDirectory}${module_name}.pm"; import ${module_name};! ); 118 # warn "Errors in including the module ${courseScriptsDirectory}$module_name.pm $@" if $@; 119 # } else { 120 # eval(qq! require "${module_name}.pm"; import ${module_name};! ); 121 # warn "Errors in including either the module $module_name.pm or ${courseScriptsDirectory}${module_name}.pm $@" if $@; 122 # } 123 =head2 load_extra_packages 124 125 Usage: $obj -> load_extra_packages('AlgParserWithImplicitExpand', 126 'Expr','ExprWithImplicitExpand'); 127 128 Loads extra packages for modules that contain more than one package. Works in conjunction with 129 evaluate_modules. It is assumed that the file containing the extra packages (along with the base 130 pachage name which is the same as the name of the file minus the .pm extension) has already been 131 loaded using evaluate_modules 132 =cut 133 134 sub load_extra_packages{ 135 my $self = shift; 136 my @package_list = @_; 137 my $package_name; 138 139 foreach (@package_list) { 140 # ensure that the name is in fact a base name 141 s/\.pm$// and warn "fixing your broken package name: $_.pm => $_"; 142 # import symbols from the extra package 143 import $_; 144 warn "Failed to evaluate module $_: $@" if $@; 145 # record this in the appropriate place 146 push @{$self->{ra_included_modules}}, "\%${_}::"; 147 } 148 } 149 150 =head2 new 151 Creates the translator object. 152 153 =cut 154 155 156 sub new { 157 my $class = shift; 158 my $safe_cmpt = new Safe; #('PG_priv'); 159 my $self = { 160 preprocess_code => \&default_preprocess_code, 161 postprocess_code => \&default_postprocess_code, 162 envir => undef, 163 PG_PROBLEM_TEXT_ARRAY_REF => [], 164 PG_PROBLEM_TEXT_REF => 0, 165 PG_HEADER_TEXT_REF => 0, 166 PG_ANSWER_HASH_REF => {}, 167 PG_FLAGS_REF => {}, 168 rh_pgcore => undef, # ref to PGcore object 169 safe => $safe_cmpt, 170 safe_compartment_name => $safe_cmpt->root, 171 errors => "", 172 source => "", 173 rh_correct_answers => {}, 174 rh_student_answers => {}, 175 rh_evaluated_answers => {}, 176 rh_problem_result => {}, 177 rh_problem_state => { 178 recorded_score => 0, # the score recorded in the data base 179 num_of_correct_ans => 0, # the number of correct attempts at doing the problem 180 num_of_incorrect_ans => 0, # the number of incorrect attempts 181 }, 182 rf_problem_grader => \&std_problem_grader, 183 rf_safety_filter => \&safetyFilter, 184 # ra_included_modules is now populated independantly of @class_modules: 185 ra_included_modules => [], # [ @class_modules ], 186 rh_directories => {}, 187 }; 188 bless $self, $class; 189 } 190 191 =pod 192 193 (b) The following routines defined within the PG module are shared: 194 195 &be_strict 196 &read_whole_problem_file 197 &convertPath 198 &surePathToTmpFile 199 &fileFromPath 200 &directoryFromPath 201 &createFile 202 203 &includePGtext 204 205 &PG_answer_eval 206 &PG_restricted_eval 207 208 &send_mail_to 209 &PGsort 210 211 In addition the environment hash C<%envir> is shared. This variable is unpacked 212 when PG.pl is run and provides most of the environment variables for each problem 213 template. 214 215 =for html 216 217 <A href = 218 "${Global::webworkDocsURL}techdescription/pglanguage/PGenvironment.html"> environment variables</A> 219 220 =cut 221 222 223 =pod 224 225 (c) Sharing macros: 226 227 The macros shared with the safe compartment are 228 229 '&read_whole_problem_file' 230 '&convertPath' 231 '&surePathToTmpFile' 232 '&fileFromPath' 233 '&directoryFromPath' 234 '&createFile' 235 '&PG_answer_eval' 236 '&PG_restricted_eval' 237 '&be_strict' 238 '&send_mail_to' 239 '&PGsort' 240 '&dumpvar' 241 '&includePGtext' 242 243 =cut 244 245 # SHARE variables and routines with safe compartment 246 # 247 # Some symbols are defined here (or in the IO module), and used inside the safe 248 # compartment. Under WeBWorK 1.x, functions defined here had access to the 249 # Global:: namespace, which contained course-specific data such things as 250 # directory locations, the address of the SMTP server, and so on. Under WeBWorK 251 # 2, there is no longer a global namespace. To get around this, IO functions 252 # which need access to course-specific data are now defined in the IO.pl macro 253 # file, which has access to the problem environment. Several entries have been 254 # added to the problem environment to support this move. 255 # 256 257 258 # Useful for timing portions of the translating process 259 # The timer $WeBWorK::timer is defined in the module WeBWorK.pm 260 # You must make sure that the code in that script for initialzing the 261 # timer is active. 262 263 sub time_it { 264 my $msg = shift; 265 $WeBWorK::timer->continue("PG macro:". $msg) if defined($WeBWorK::timer); 266 } 267 268 my %shared_subroutine_hash = ( 269 'time_it' => __PACKAGE__, 270 '&PG_answer_eval' => __PACKAGE__, 271 '&PG_restricted_eval' => __PACKAGE__, 272 '&PG_macro_file_eval' => __PACKAGE__, 273 '&be_strict' => __PACKAGE__, 274 '&PGsort' => __PACKAGE__, 275 '&dumpvar' => __PACKAGE__, 276 %WeBWorK::PG::IO::SHARE, # add names from WeBWorK::PG::IO and WeBWorK::PG::IO::* 277 ); 278 279 sub initialize { 280 my $self = shift; 281 my $safe_cmpt = $self->{safe}; 282 #print "initializing safeCompartment",$safe_cmpt -> root(), "\n"; 283 284 $safe_cmpt -> share(keys %shared_subroutine_hash); 285 no strict; 286 local(%envir) = %{ $self ->{envir} }; 287 $safe_cmpt -> share('%envir'); 288 #local($rf_answer_eval) = sub { $self->PG_answer_eval(@_); }; 289 #local($rf_restricted_eval) = sub { $self->PG_restricted_eval(@_); }; 290 #$safe_cmpt -> share('$rf_answer_eval'); 291 #$safe_cmpt -> share('$rf_restricted_eval'); 292 use strict; 293 294 $safe_cmpt -> share_from('main', $self->{ra_included_modules} ); 295 # the above line will get changed when we fix the PG modules thing. heh heh. 296 } 297 298 299 ################################################################ 300 # Preloading the macro files 301 ################################################################ 302 303 # Preloading the macro files can significantly speed up the translation process. 304 # Files are read into a separate safe compartment (typically Safe::Root1::) 305 # This means that all non-explicit subroutine references and those explicitly prefixed by main:: 306 # are prefixed by Safe::Root1:: 307 # These subroutines (but not the constants) are then explicitly exported to the current 308 # safe compartment Safe::Rootx:: 309 310 # Although they are not large, it is important to import PG.pl and dangerousMacros.pl into the 311 # cached safe compartment as well. This is because a call in PGbasicmacros.pl to NEW_ANSWER_NAME 312 # which is defined in PG.pl would actually be a call to Safe::Root1::NEW_ANSWER_NAME since 313 # PGbasicmacros is compiled into the SAfe::Root1:: compartment. If PG.pl has only been compiled into 314 # the current Safe compartment, this call will fail. There are many calls between PG.pl, dangerousMacros, 315 # PGbasicmacros and PGanswermacros so it is easiest to have all of them defined in Safe::Root1:: 316 # There subroutines are still available in the current safe compartment. 317 # Sharing the hash %Safe::Root1:: in the current compartment means that any references to Safe::Root1::NEW_ANSWER_NAME 318 # will be found as long as NEW_ANSWER_NAME has been defined in Safe::Root1:: 319 # 320 # Constants and references to subroutines in other macro files have to be handled carefully in preloaded files. 321 # For example a call to main::display_matrix (defined in PGmatrixmacros.pl) will become Safe::Root1::display_matrix and 322 # will fail since PGmatrixmacros.pl is loaded only into the current safe compartment Safe::Rootx::. 323 # The value of main:: has to be evaluated at runtime in order to make this work. Hence something like 324 # my $temp_code = eval('\&main::display_matrix'); 325 # &$temp_code($matrix_object_to_be_displayed); 326 # in PGanswermacros.pl 327 # would reference the run time value of main::, namely Safe::Rootx:: 328 # There may be a clearer or more efficient way to obtain the runtime value of main:: 329 330 331 sub pre_load_macro_files { 332 time_it("Begin pre_load_macro_files"); 333 my $self = shift; 334 my $cached_safe_cmpt = shift; 335 my $dirName = shift; 336 my @fileNameList = @_; 337 my $debugON = 0; # This helps with debugging the loading of macro files 338 339 ################################################################ 340 # prepare safe_cache 341 ################################################################ 342 $cached_safe_cmpt -> share(keys %shared_subroutine_hash); 343 no strict; 344 local(%envir) = %{ $self ->{envir} }; 345 $cached_safe_cmpt -> share('%envir'); 346 use strict; 347 $cached_safe_cmpt -> share_from('main', $self->{ra_included_modules} ); 348 $cached_safe_cmpt->mask(Opcode::full_opset()); # allow no operations 349 $cached_safe_cmpt->permit(qw( :default )); 350 $cached_safe_cmpt->permit(qw(time)); # used to determine whether solutions are visible. 351 $cached_safe_cmpt->permit(qw( atan2 sin cos exp log sqrt )); 352 353 # just to make sure we'll deny some things specifically 354 $cached_safe_cmpt->deny(qw(entereval)); 355 $cached_safe_cmpt->deny(qw ( unlink symlink system exec )); 356 $cached_safe_cmpt->deny(qw(print require)); 357 358 ################################################################ 359 # read in macro files 360 ################################################################ 361 362 foreach my $fileName (@fileNameList) { 363 # determine whether the file has already been loaded by checking for 364 # subroutine named _${macro_file_name}_init 365 my $macro_file_name = $fileName; 366 $macro_file_name =~s/\.pl//; # trim off the extension 367 $macro_file_name =~s/\.pg//; # sometimes the extension is .pg (e.g. CAPA files) 368 my $init_subroutine_name = "_${macro_file_name}_init"; 369 my $macro_file_loaded = defined(&{$cached_safe_cmpt->root."::$init_subroutine_name"}) ? 1 : 0; 370 371 372 if ( $macro_file_loaded ) { 373 warn "$macro_file_name is already loaded" if $debugON; 374 }else { 375 warn "reading and evaluating $macro_file_name from $dirName/$fileName" if $debugON; 376 ### read in file 377 my $filePath = "$dirName/$fileName"; 378 local(*MACROFILE); 379 local($/); 380 $/ = undef; # allows us to treat the file as a single line 381 open(MACROFILE, "<$filePath") || die "Cannot open file: $filePath"; 382 my $string = <MACROFILE>; 383 close(MACROFILE); 384 385 386 ################################################################ 387 # Evaluate macro files 388 ################################################################ 389 # FIXME The following hardwired behavior should be modifiable 390 # either in the procedure call or in global.conf: 391 # 392 # PG.pl, IO.pl and dangerousMacros.pl are loaded without restriction 393 # All other files are loaded with restriction 394 # 395 # construct a regex that matches only these three files safely 396 my @unrestricted_files = (); # no longer needed? FIXME w/PG.pl dangerousMacros.pl IO.pl/; 397 my $unrestricted_files = join("|", map { quotemeta } @unrestricted_files); 398 399 my $store_mask; 400 if ($fileName =~ /^($unrestricted_files)$/) { 401 $store_mask = $cached_safe_cmpt->mask(); 402 $cached_safe_cmpt ->mask(Opcode::empty_opset()); 403 } 404 $cached_safe_cmpt -> reval('BEGIN{push @main::__eval__,__FILE__}; package main; ' .$string); 405 warn "preload Macros: errors in compiling $macro_file_name:<br> $@" if $@; 406 $self->{envir}{__files__}{$cached_safe_cmpt->reval('pop @main::__eval__')} = $filePath; 407 if ($fileName =~ /^($unrestricted_files)$/) { 408 $cached_safe_cmpt ->mask($store_mask); 409 warn "mask restored after $fileName" if $debugON; 410 } 411 412 413 } 414 } 415 416 ################################################################################ 417 # load symbol table 418 ################################################################################ 419 warn "begin loading symbol table " if $debugON; 420 no strict 'refs'; 421 my %symbolHash = %{$cached_safe_cmpt->root.'::'}; 422 use strict 'refs'; 423 my @subroutine_names; 424 425 foreach my $name (keys %symbolHash) { 426 # weed out internal symbols 427 next if $name =~ /^(INC|_|__ANON__|main::)$/; 428 if ( defined(&{*{$symbolHash{$name}}}) ) { 429 # warn "subroutine $name" if $debugON;; 430 push(@subroutine_names, "&$name"); 431 } 432 } 433 434 warn "Loading symbols into active safe compartment:<br> ", join(" ",sort @subroutine_names) if $debugON; 435 $self->{safe} -> share_from($cached_safe_cmpt->root,[@subroutine_names]); 436 437 # Also need to share the cached safe compartment symbol hash in the current safe compartment. 438 # This is necessary because the macro files have been read into the cached safe compartment 439 # So all subroutines have the implied names Safe::Root1::subroutine 440 # When they call each other we need to make sure that they can reach each other 441 # through the Safe::Root1 symbol table. 442 443 $self->{safe} -> share('%'.$cached_safe_cmpt->root.'::'); 444 warn 'Sharing '.'%'. $cached_safe_cmpt->root. '::' if $debugON; 445 time_it("End pre_load_macro_files"); 446 # return empty string. 447 ''; 448 } 449 450 sub environment{ 451 my $self = shift; 452 my $envirref = shift; 453 if ( defined($envirref) ) { 454 if (ref($envirref) eq 'HASH') { 455 %{ $self -> {envir} } = %$envirref; 456 } else { 457 $self ->{errors} .= "ERROR: The environment method for PG_translate objects requires a reference to a hash"; 458 } 459 } 460 $self->{envir} ; #reference to current environment 461 } 462 463 =head2 Safe compartment pass through macros 464 465 466 467 =cut 468 469 sub mask { 470 my $self = shift; 471 my $mask = shift; 472 my $safe_compartment = $self->{safe}; 473 $safe_compartment->mask($mask); 474 } 475 sub permit { 476 my $self = shift; 477 my @array = shift; 478 my $safe_compartment = $self->{safe}; 479 $safe_compartment->permit(@array); 480 } 481 sub deny { 482 483 my $self = shift; 484 my @array = shift; 485 my $safe_compartment = $self->{safe}; 486 $safe_compartment->deny(@array); 487 } 488 sub share_from { 489 my $self = shift; 490 my $pckg_name = shift; 491 my $array_ref =shift; 492 my $safe_compartment = $self->{safe}; 493 $safe_compartment->share_from($pckg_name,$array_ref); 494 } 495 496 sub source_string { 497 my $self = shift; 498 my $temp = shift; 499 my $out; 500 if ( ref($temp) eq 'SCALAR') { 501 $self->{source} = $$temp; 502 $out = $self->{source}; 503 } elsif ($temp) { 504 $self->{source} = $temp; 505 $out = $self->{source}; 506 } 507 $self -> {source}; 508 } 509 510 sub source_file { 511 my $self = shift; 512 my $filePath = shift; 513 local(*SOURCEFILE); 514 local($/); 515 $/ = undef; # allows us to treat the file as a single line 516 my $err = ""; 517 if ( open(SOURCEFILE, "<$filePath") ) { 518 $self -> {source} = <SOURCEFILE>; 519 close(SOURCEFILE); 520 } else { 521 $self->{errors} .= "Can't open file: $filePath"; 522 croak( "Can't open file: $filePath\n" ); 523 } 524 525 526 527 $err; 528 } 529 530 531 532 sub unrestricted_load { 533 my $self = shift; 534 my $filePath = shift; 535 my $safe_cmpt = $self ->{safe}; 536 my $store_mask = $safe_cmpt->mask(); 537 $safe_cmpt->mask(Opcode::empty_opset()); 538 my $safe_cmpt_package_name = $safe_cmpt->root(); 539 540 my $macro_file_name = fileFromPath($filePath); 541 $macro_file_name =~s/\.pl//; # trim off the extenstion 542 my $export_subroutine_name = "_${macro_file_name}_export"; 543 my $init_subroutine_name = "${safe_cmpt_package_name}::_${macro_file_name}_init"; 544 545 my $local_errors = ""; 546 no strict; 547 # warn "dangerousMacros main:: contains <br>\n ".join("<br>\n ", %main::) if $debugON; 548 my $init_subroutine = eval { \&{$init_subroutine_name} }; 549 warn "No init routine for $init_subroutine_name: $@" if $debugON and $@; 550 use strict; 551 my $macro_file_loaded = ref($init_subroutine) =~ /CODE/; 552 553 #print STDERR "$macro_file_name has not yet been loaded\n" unless $macro_file_loaded; 554 unless ($macro_file_loaded) { 555 ## load the $filePath file 556 ## Using rdo insures that the $filePath file is loaded for every problem, allowing initializations to occur. 557 ## Ordinary mortals should not be fooling with the fundamental macros in these files. 558 my $local_errors = ""; 559 if (-r $filePath ) { 560 my $rdoResult = $safe_cmpt->rdo($filePath); 561 #warn "unrestricted load: $filePath\n"; 562 $local_errors ="\nThere were problems compiling the file:\n $filePath\n $@\n" if $@; 563 $self ->{errors} .= $local_errors if $local_errors; 564 use strict; 565 } else { 566 $local_errors = "Can't open file $filePath for reading\n"; 567 $self ->{errors} .= $local_errors if $local_errors; 568 } 569 $safe_cmpt -> mask($store_mask); 570 571 } 572 # try again to define the initization subroutine 573 $init_subroutine = eval { \&{"$init_subroutine_name"} }; 574 $macro_file_loaded = ref($init_subroutine) =~ /CODE/; 575 if ( $macro_file_loaded ) { 576 577 #warn "unrestricted load: initializing $macro_file_name $init_subroutine" ; 578 &$init_subroutine(); 579 } 580 $local_errors .= "\nUnknown error. Unable to load $filePath\n" if ($local_errors eq '' and not $macro_file_loaded); 581 #print STDERR "$filePath is properly loaded\n\n" if $macro_file_loaded; 582 $local_errors; 583 } 584 585 sub nameSpace { 586 my $self = shift; 587 $self->{safe}->root; 588 } 589 590 sub a_text { 591 my $self = shift; 592 @{$self->{PG_PROBLEM_TEXT_ARRAY_REF}}; 593 } 594 595 sub header { 596 my $self = shift; 597 ${$self->{PG_HEADER_TEXT_REF}}; 598 } 599 600 sub h_flags { 601 my $self = shift; 602 %{$self->{PG_FLAGS_REF}}; 603 } 604 605 sub rh_flags { 606 my $self = shift; 607 $self->{PG_FLAGS_REF}; 608 } 609 sub h_answers{ 610 my $self = shift; 611 %{$self->{PG_ANSWER_HASH_REF}}; 612 } 613 614 sub ra_text { 615 my $self = shift; 616 $self->{PG_PROBLEM_TEXT_ARRAY_REF}; 617 618 } 619 620 sub r_text { 621 my $self = shift; 622 $self->{PG_PROBLEM_TEXT_REF}; 623 } 624 625 sub r_header { 626 my $self = shift; 627 $self->{PG_HEADER_TEXT_REF}; 628 } 629 630 sub rh_directories { 631 my $self = shift; 632 my $rh_directories = shift; 633 $self->{rh_directories}=$rh_directories if ref($rh_directories) eq 'HASH'; 634 $self->{rh_directories}; 635 } 636 637 sub rh_correct_answers { 638 my $self = shift; 639 my @in = @_; 640 return $self->{rh_correct_answers} if @in == 0; 641 642 if ( ref($in[0]) eq 'HASH' ) { 643 $self->{rh_correct_answers} = { %{ $in[0] } }; # store a copy of the hash 644 } else { 645 $self->{rh_correct_answers} = { @in }; # store a copy of the hash 646 } 647 $self->{rh_correct_answers} 648 } 649 650 sub rf_problem_grader { 651 my $self = shift; 652 my $in = shift; 653 return $self->{rf_problem_grader} unless defined($in); 654 if (ref($in) =~/CODE/ ) { 655 $self->{rf_problem_grader} = $in; 656 } else { 657 die "ERROR: Attempted to install a problem grader which was not a reference to a subroutine."; 658 } 659 $self->{rf_problem_grader} 660 } 661 662 663 sub errors{ 664 my $self = shift; 665 $self->{errors}; 666 } 667 668 669 670 =head2 set_mask 671 672 673 674 675 676 677 (e) Now we close the safe compartment. Only the certain operations can be used 678 within PG problems and the PG macro files. These include the subroutines 679 shared with the safe compartment as defined above and most Perl commands which 680 do not involve file access, access to the system or evaluation. 681 682 Specifically the following are allowed 683 684 time() 685 # gives the current Unix time 686 # used to determine whether solutions are visible. 687 atan, sin cos exp log sqrt 688 # arithemetic commands -- more are defined in PGauxiliaryFunctions.pl 689 690 The following are specifically not allowed: 691 692 eval() 693 unlink, symlink, system, exec 694 print require 695 696 697 698 =cut 699 700 ############################################################################## 701 702 ## restrict the operations allowed within the safe compartment 703 704 sub set_mask { 705 my $self = shift; 706 my $safe_cmpt = $self ->{safe}; 707 $safe_cmpt->mask(Opcode::full_opset()); # allow no operations 708 $safe_cmpt->permit(qw( :default )); 709 $safe_cmpt->permit(qw(time)); # used to determine whether solutions are visible. 710 $safe_cmpt->permit(qw( atan2 sin cos exp log sqrt )); 711 712 # just to make sure we'll deny some things specifically 713 $safe_cmpt->deny(qw(entereval)); 714 $safe_cmpt->deny(qw ( unlink symlink system exec )); 715 $safe_cmpt->deny(qw(print require)); 716 } 717 718 ############################################################################ 719 720 =head2 PG_errorMessage 721 722 This routine processes error messages by fixing file names and adding 723 traceback information. It loops through the function calls via 724 caller() in order to give more information about where the error 725 occurred. Since the loadMacros() files and the .pg file itself are 726 handled via various kinds of eval calls, the caller() information does 727 not contain the file names. So we have saved them in the 728 $main::__files__ hash, which we look up here and use to replace the 729 (eval nnn) file names that are in the caller stack. We shorten the 730 filenames by removing the templates or root directories when possible, 731 so they are easier to read. 732 733 We skip any nested calls to Parser:: or Value:: so that these act more like 734 perl built-in functions. 735 736 We stop when we find a routine in the WeBWorK:: package, or an __ANON__ 737 routine, in order to avoid reporting the PG translator calls that 738 surround the pg file. Finally, there is usually one more eval before 739 that, so we remove it as well. 740 741 File names are shortened, when possible, by replacing the templates 742 directory with [TMPL], the WeBWorK root directory by [WW] and 743 the PG root directory by [PG]. 744 745 =cut 746 747 sub PG_errorMessage { 748 my $return = shift; my $frame = 2; # return can be 'message' or 'traceback' 749 my $message = join("\n",@_); $message =~ s/\.?\s+$//; 750 my $files = eval ('$main::__files__'); $files = {} unless $files; 751 my $tmpl = $files->{tmpl} || '$'; 752 my $root = $files->{root} || '$'; 753 my $pg = $files->{pg} || '$'; 754 # 755 # Fix initial message file names 756 # 757 $message =~ s! $tmpl! [TMPL]!g; $message =~ s! $root! [WW]!g; $message =~ s! $pg! [PG]!g; 758 $message =~ s/(\(eval \d+\)) (line (\d+))/$2 of $1/; 759 while ($message =~ m/of (?:file )?(\(eval \d+\))/ && defined($files->{$1})) { 760 my $name = $files->{$1}; 761 $name =~ s!^$tmpl![TMPL]!; $name =~ s!^$root![WW]!; $name =~ s!^$pg![PG]!; 762 $message =~ s/\(eval \d+\)/$name/g; 763 } 764 # 765 # Return just the message if that's all we want, or 766 # if the message already includes a stack trace 767 # 768 return $message."\n" if $return eq 'message' || $message =~ m/\n Died within/; 769 # 770 # Look through caller stack for traceback information 771 # 772 my @trace = ($message); 773 my $skipParser = (caller(3))[3] =~ m/^(Parser|Value)::/; 774 while (my ($pkg,$file,$line,$subname) = caller($frame++)) { 775 last if ($subname =~ m/^(Safe::reval|main::__ANON__)/); 776 next if $skipParser && $subname =~ m/^(Parser|Value)::/; # skip Parser and Value calls 777 next if $subname =~ m/__ANON__/; 778 $file = $files->{$file} || $file; 779 $file =~ s!^$tmpl![TMPL]!; $file =~ s!^$root![WW]!; $file =~ s!^$pg![PG]!; 780 $message = " from within $subname called at line $line of $file"; 781 push @trace, $message; $skipParser = 0; 782 } 783 splice(@trace,1,1) while $trace[1] && $trace[1] =~ m/within \(eval\)/; 784 pop @trace while $trace[-1] && $trace[-1] =~ m/within \(eval\)/; 785 $trace[1] =~ s/ from/ Died/ if $trace[1]; 786 # 787 # report the full traceback 788 # 789 return join("\n",@trace,''); 790 } 791 792 =head2 PG_undef_var_check 793 794 =pod 795 796 Produces warnings of this type in order to help you guess which local variable is undefined 797 Warning: Use of uninitialized value in concatenation (.) or string at mpu.cgi line 25. 798 Possible variables are: 799 '$GLOBAL_VARIABLE' => \'global', 800 '$t' => \undef, 801 '$s' => \'regular output' 802 803 804 805 806 =cut 807 808 sub PG_undef_var_check { 809 if($_[0] !~ /^Use of uninitialized value/) { 810 return @_; 811 } else { 812 # If there are objects, the output can be VERY large when you increase this 813 local $Data::Dumper::Maxdepth = 2; 814 # takes all lexical variables from caller-nemaspace 815 my $possibles = Data::Dumper::Dumper({ %{PadWalker::peek_my(1)}, %{PadWalker::peek_our(1)} }); 816 817 $possibles ne "\$VAR1 = {};\n" ? ($possibles =~ s/^.*?\n(.*)\n.*?\n$/$1/ms) : ($possibles = ''); 818 return "Warning: " . join(', ', @_) . "Possible variables are:\n$possibles\n"; 819 } 820 821 } 822 ############################################################################ 823 824 =head2 Translate 825 826 827 =cut 828 829 sub translate { 830 my $self = shift; 831 my @PROBLEM_TEXT_OUTPUT = (); 832 my $safe_cmpt = $self ->{safe}; 833 my $evalString = $self -> {source}; 834 $self ->{errors} .= qq{ERROR: This problem file was empty!\n} unless ($evalString) ; 835 $self ->{errors} .= qq{ERROR: You must define the environment before translating.} 836 unless defined( $self->{envir} ); 837 838 # install handlers for warn and die that call PG_errorMessage. 839 # if the existing signal handler is not a coderef, the built-in warn or 840 # die function is called. this does not account for the case where the 841 # handler is set to "IGNORE" or to the name of a function. in these cases 842 # the built-in function will be called. 843 844 my $outer_sig_warn = $SIG{__WARN__}; 845 local $SIG{__WARN__} = sub { 846 ref $outer_sig_warn eq "CODE" 847 ? &$outer_sig_warn(PG_errorMessage('message', $_[0])) 848 : warn PG_errorMessage('message', $_[0]); 849 }; 850 851 my $outer_sig_die = $SIG{__DIE__}; 852 local $SIG{__DIE__} = sub { 853 ref $outer_sig_die eq "CODE" 854 ? &$outer_sig_die(PG_errorMessage('traceback', $_[0])) 855 : die PG_errorMessage('traceback', $_[0]); 856 }; 857 858 =pod 859 860 (3) B<Preprocess the problem text> 861 862 The input text is subjected to two global replacements. 863 First every incidence of 864 865 BEGIN_TEXT 866 problem text 867 END_TEXT 868 869 is replaced by 870 871 TEXT( EV3( <<'END_TEXT' ) ); 872 problem text 873 END_TEXT 874 875 The first construction is syntactic sugar for the second. This is explained 876 in C<PGbasicmacros.pl>. 877 878 Second every incidence 879 of \ (backslash) is replaced by \\ (double backslash). Third each incidence of 880 ~~ is replaced by a single backslash. 881 882 This is done to alleviate a basic 883 incompatibility between TeX and Perl. TeX uses backslashes constantly to denote 884 a command word (as opposed to text which is to be entered literally). Perl 885 uses backslash to escape the following symbol. This escape 886 mechanism takes place immediately when a Perl script is compiled and takes 887 place throughout the code and within every quoted string (both double and single 888 quoted strings) with the single exception of single quoted "here" documents. 889 That is backlashes which appear in 890 891 TEXT(<<'EOF'); 892 ... text including \{ \} for example 893 EOF 894 895 are the only ones not immediately evaluated. This behavior makes it very difficult 896 to use TeX notation for defining mathematics within text. 897 898 The initial global 899 replacement, before compiling a PG problem, allows one to use backslashes within 900 text without doubling them. (The anomolous behavior inside single quoted "here" 901 documents is compensated for by the behavior of the evaluation macro EV3.) This 902 makes typing TeX easy, but introduces one difficulty in entering normal Perl code. 903 904 The second global replacement provides a work around for this -- use ~~ when you 905 would ordinarily use a backslash in Perl code. 906 In order to define a carriage return use ~~n rather than \n; in order to define 907 a reference to a variable you must use ~~@array rather than \@array. This is 908 annoying and a source of simple compiler errors, but must be lived with. 909 910 The problems are not evaluated in strict mode, so global variables can be used 911 without warnings. 912 913 914 915 =cut 916 917 ############################################################################ 918 919 920 ########################################## 921 ###### PG preprocessing code ############# 922 ########################################## 923 924 $evalString = &{$self->{preprocess_code}}($evalString); 925 926 927 # # default_preprocess_code 928 # # BEGIN_TEXT and END_TEXT must occur on a line by themselves. 929 # $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g; 930 # $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3\(<<'END_TEXT'\)\);\n/g; 931 # $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT 932 # 933 # $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict 934 # $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments 935 936 937 =pod 938 939 (4) B<Evaluate the problem text> 940 941 Evaluate the text within the safe compartment. Save the errors. The safe 942 compartment is a new one unless the $safeCompartment was set to zero in which 943 case the previously defined safe compartment is used. (See item 1.) 944 945 =cut 946 947 my ($PG_PROBLEM_TEXT_REF, $PG_HEADER_TEXT_REF, $PG_ANSWER_HASH_REF, $PG_FLAGS_REF, $PGcore) 948 =$safe_cmpt->reval(" $evalString"); 949 #warn "using safe compartment ", $safe_cmpt->root; 950 # This section could use some more error messages. In particular if a problem doesn't produce the right output, the user needs 951 # information about which problem was at fault. 952 # 953 # 954 955 ################# 956 # FIXME The various warning message tracks are still being sorted out 957 # WARNING and DEBUG tracks are being handled elsewhere (in Problem.pm?) 958 ################# 959 $self->{errors} .= $@; 960 961 962 # $self->{errors}.=join(CGI::br(), @{$PGcore->{flags}->{WARNING_messages}} ); 963 # $self->{errors}.=join(CGI::br(), @{$PGcore->{flags}->{DEBUG_messages }} ); 964 ####################################################################### 965 966 # push(@PROBLEM_TEXT_OUTPUT , split(/(\n)/,$$PG_PROBLEM_TEXT_REF) ) if defined($$PG_PROBLEM_TEXT_REF ); 967 push(@PROBLEM_TEXT_OUTPUT , split(/^/,$$PG_PROBLEM_TEXT_REF) ) if ref($PG_PROBLEM_TEXT_REF ) eq 'SCALAR'; 968 ## This is better than using defined($$PG_PROBLEM_TEXT_REF) 969 ## Because more pleasant feedback is given 970 ## when the problem doesn't render. 971 # try to get the \n to appear at the end of the line 972 973 use strict; 974 ############################################################################# 975 ########## end EVALUATION code ########### 976 ############################################################################# 977 978 ########################################## 979 ###### PG postprocessing code ############# 980 ########################################## 981 $PG_PROBLEM_TEXT_REF = &{$self->{postprocess_code}}($PG_PROBLEM_TEXT_REF); 982 983 984 =pod 985 986 (5) B<Process errors> 987 988 The error provided by Perl 989 is truncated slightly and returned. In the text 990 string which would normally contain the rendered problem. 991 992 The original text string is given line numbers and concatenated to 993 the errors. 994 995 =cut 996 997 998 999 ########################################## 1000 ###### PG error processing code ########## 1001 ########################################## 1002 my (@input,$lineNumber,$line); 1003 if ($self -> {errors}) { 1004 #($self -> {errors}) =~ s/</</g; 1005 #($self -> {errors}) =~ s/>/>/g; 1006 #try to clean up errors so they will look ok 1007 $self ->{errors} =~ s/\[[^\]]+?\] [^ ]+?\.pl://gm; #erase [Fri Dec 31 12:58:30 1999] processProblem7.pl: 1008 #$self -> {errors} =~ s/eval\s+'(.|[\n|r])*$//; 1009 #end trying to clean up errors so they will look ok 1010 1011 1012 push(@PROBLEM_TEXT_OUTPUT , qq!\n<A NAME="problem! . 1013 $self->{envir} ->{'probNum'} . 1014 qq!"><PRE> Problem!. 1015 $self->{envir} ->{'probNum'}. 1016 qq!\nERROR caught by Translator while processing problem file:! . 1017 $self->{envir}->{'probFileName'}. 1018 "\n****************\r\n" . 1019 $self -> {errors}."\r\n" . 1020 "****************<BR>\n"); 1021 1022 push(@PROBLEM_TEXT_OUTPUT , "------Input Read\r\n"); 1023 $self->{source} =~ s/</</g; 1024 @input=split("\n", $self->{source}); 1025 $lineNumber = 1; 1026 foreach $line (@input) { 1027 chomp($line); 1028 push(@PROBLEM_TEXT_OUTPUT, "$lineNumber\t\t$line\r\n"); 1029 $lineNumber ++; 1030 } 1031 push(@PROBLEM_TEXT_OUTPUT ,"\n-----<BR></PRE>\r\n"); 1032 1033 1034 1035 } 1036 1037 =pod 1038 1039 (6) B<Prepare return values> 1040 1041 Returns: 1042 $PG_PROBLEM_TEXT_ARRAY_REF -- Reference to a string containing the rendered text. 1043 $PG_HEADER_TEXT_REF -- Reference to a string containing material to placed in the header (for use by JavaScript) 1044 $PG_ANSWER_HASH_REF -- Reference to an array containing the answer evaluators. 1045 $PG_FLAGS_REF -- Reference to a hash containing flags and other references: 1046 'error_flag' is set to 1 if there were errors in rendering 1047 $PGcore -- the PGcore object 1048 1049 =cut 1050 1051 ## we need to make sure that the other output variables are defined 1052 1053 ## If the eval failed with errors, one or more of these variables won't be defined. 1054 $PG_ANSWER_HASH_REF = {} unless defined($PG_ANSWER_HASH_REF); 1055 $PG_HEADER_TEXT_REF = \( "" ) unless defined($PG_HEADER_TEXT_REF); 1056 $PG_FLAGS_REF = {} unless defined($PG_FLAGS_REF); 1057 1058 $PG_FLAGS_REF->{'error_flag'} = 1 if $self -> {errors}; 1059 my $PG_PROBLEM_TEXT = join("",@PROBLEM_TEXT_OUTPUT); 1060 1061 $self ->{ PG_PROBLEM_TEXT_REF } = \$PG_PROBLEM_TEXT; 1062 $self ->{ PG_PROBLEM_TEXT_ARRAY_REF } = \@PROBLEM_TEXT_OUTPUT; 1063 $self ->{ PG_HEADER_TEXT_REF } = $PG_HEADER_TEXT_REF; 1064 $self ->{ rh_correct_answers } = $PG_ANSWER_HASH_REF; 1065 $self ->{ PG_FLAGS_REF } = $PG_FLAGS_REF; 1066 $self ->{ rh_pgcore } = $PGcore; 1067 1068 #warn "PGcore is ", ref($PGcore), " in Translator"; 1069 #$self ->{errors}; 1070 } # end translate 1071 1072 1073 =head2 Answer evaluation methods 1074 1075 =cut 1076 1077 =head3 access methods 1078 1079 $obj->rh_student_answers 1080 1081 =cut 1082 1083 1084 1085 sub rh_evaluated_answers { 1086 my $self = shift; 1087 my @in = @_; 1088 return $self->{rh_evaluated_answers} if @in == 0; 1089 1090 if ( ref($in[0]) eq 'HASH' ) { 1091 $self->{rh_evaluated_answers} = { %{ $in[0] } }; # store a copy of the hash 1092 } else { 1093 $self->{rh_evaluated_answers} = { @in }; # store a copy of the hash 1094 } 1095 $self->{rh_evaluated_answers}; 1096 } 1097 sub rh_problem_result { 1098 my $self = shift; 1099 my @in = @_; 1100 return $self->{rh_problem_result} if @in == 0; 1101 1102 if ( ref($in[0]) eq 'HASH' ) { 1103 $self->{rh_problem_result} = { %{ $in[0] } }; # store a copy of the hash 1104 } else { 1105 $self->{rh_problem_result} = { @in }; # store a copy of the hash 1106 } 1107 $self->{rh_problem_result}; 1108 } 1109 sub rh_problem_state { 1110 my $self = shift; 1111 my @in = @_; 1112 return $self->{rh_problem_state} if @in == 0; 1113 1114 if ( ref($in[0]) eq 'HASH' ) { 1115 $self->{rh_problem_state} = { %{ $in[0] } }; # store a copy of the hash 1116 } else { 1117 $self->{rh_problem_state} = { @in }; # store a copy of the hash 1118 } 1119 $self->{rh_problem_state}; 1120 } 1121 1122 1123 =head3 process_answers 1124 1125 1126 $obj->process_answers() 1127 1128 1129 =cut 1130 1131 1132 sub process_answers{ 1133 my $self = shift; 1134 my @in = @_; 1135 my %h_student_answers; 1136 if (ref($in[0]) eq 'HASH' ) { 1137 %h_student_answers = %{ $in[0] }; #receiving a reference to a hash of answers 1138 } else { 1139 %h_student_answers = @in; # receiving a hash of answers 1140 } 1141 my $rh_correct_answers = $self->rh_correct_answers(); 1142 my @answer_entry_order = ( defined($self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER}) ) ? 1143 @{$self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER}} : keys %{$rh_correct_answers}; 1144 1145 # define custom warn/die handlers for answer evaluation. these used to be inside 1146 # the foreach loop around the conditional involving $rf_fun, but for efficiency 1147 # we've moved it out here. This means that the handlers will be active during the 1148 # code before and after the actual answer evaluation. 1149 1150 my $outer_sig_warn = $SIG{__WARN__}; 1151 local $SIG{__WARN__} = sub { 1152 ref $outer_sig_warn eq "CODE" 1153 ? &$outer_sig_warn(PG_errorMessage('message', $_[0])) 1154 : warn PG_errorMessage('message', $_[0]); 1155 }; 1156 1157 # the die handler is a closure over %errorTable and $outer_sig_die. 1158 # 1159 # %errorTable accumulates a "full" error message for each error that occurs during 1160 # answer evaluation. then, right after the evaluation (which is done within a call 1161 # to Safe::reval), $@ is checked and it's value is looked up in %errorTable to get 1162 # the full error to report. 1163 # 1164 # my question: why is this a hash? this is die, so once one occurs, we exit the reval. 1165 # wouldn't it be sufficient to have a scalar like $backtrace_for_last_error? 1166 # 1167 # Note that %errorTable is cleared for each answer. 1168 my %errorTable; 1169 my $outer_sig_die = $SIG{__DIE__}; 1170 local $SIG{__DIE__} = sub { 1171 1172 # this chunk taken from dpvc's original handler 1173 my $fullerror = PG_errorMessage('traceback', @_); 1174 my ($error,$traceback) = split /\n/, $fullerror, 2; 1175 $fullerror =~ s/\n /<BR> /g; $fullerror =~ s/\n/<BR>/g; 1176 $error .= "\n"; 1177 $errorTable{$error} = $fullerror; 1178 # end of dpvc's original code 1179 1180 ref $outer_sig_die eq "CODE" 1181 ? &$outer_sig_die($error) 1182 : die $error; 1183 }; 1184 1185 # apply each instructors answer to the corresponding student answer 1186 1187 foreach my $ans_name ( @answer_entry_order ) { 1188 my ($ans, $errors) = $self->filter_answer( $h_student_answers{$ans_name} ); 1189 no strict; 1190 # evaluate the answers inside the safe compartment. 1191 local($rf_fun,$temp_ans) = (undef,undef); 1192 if ( defined($rh_correct_answers ->{$ans_name} ) ) { 1193 $rf_fun = $rh_correct_answers->{$ans_name}; 1194 } else { 1195 warn "There is no answer evaluator for the question labeled $ans_name"; 1196 } 1197 $temp_ans = $ans; 1198 $temp_ans = '' unless defined($temp_ans); #make sure that answer is always defined 1199 # in case the answer evaluator forgets to check 1200 $self->{safe}->share('$rf_fun','$temp_ans'); 1201 1202 # clear %errorTable for each problem 1203 %errorTable = (); # is the error table being used? perhaps by math objects? 1204 1205 my $rh_ans_evaluation_result; 1206 if (ref($rf_fun) eq 'CODE' ) { 1207 $rh_ans_evaluation_result = $self->{safe} ->reval( '&{ $rf_fun }($temp_ans, ans_label => \''.$ans_name.'\')' ) ; 1208 warn "Error in Translator.pm::process_answers: Answer $ans_name: |$temp_ans|\n $@\n" if $@; 1209 } elsif (ref($rf_fun) =~ /AnswerEvaluator/) { 1210 $rh_ans_evaluation_result = $self->{safe} ->reval('$rf_fun->evaluate($temp_ans, ans_label => \''.$ans_name.'\')'); 1211 $@ = $errorTable{$@} if $@ && defined($errorTable{$@}); #Are we redefining error messages here? 1212 warn "Error in Translator.pm::process_answers: Answer $ans_name: |$temp_ans|\n $@\n" if $@; 1213 warn "Evaluation error: Answer $ans_name:<BR>\n", 1214 $rh_ans_evaluation_result->error_flag(), " :: ", 1215 $rh_ans_evaluation_result->error_message(),"<BR>\n" 1216 if defined($rh_ans_evaluation_result) 1217 and defined($rh_ans_evaluation_result->error_flag()); 1218 } else { 1219 warn "Error in Translator.pm::process_answers: Answer $ans_name:<BR>\n Unrecognized evaluator type |", ref($rf_fun), "|"; 1220 } 1221 1222 use strict; 1223 unless ( ( ref($rh_ans_evaluation_result) eq 'HASH') or ( ref($rh_ans_evaluation_result) eq 'AnswerHash') ) { 1224 warn "Error in Translator.pm::process_answers: Answer $ans_name:<BR>\n 1225 Answer evaluators must return a hash or an AnswerHash type, not type |", 1226 ref($rh_ans_evaluation_result), "|"; 1227 } 1228 $rh_ans_evaluation_result ->{ans_message} .= "$errors \n" if $errors; 1229 $rh_ans_evaluation_result ->{ans_name} = $ans_name; 1230 $self->{rh_evaluated_answers}->{$ans_name} = $rh_ans_evaluation_result; 1231 } 1232 $self->rh_evaluated_answers; 1233 } 1234 1235 1236 1237 =head3 grade_problem 1238 1239 $obj->rh_problem_state(%problem_state); # sets the current problem state 1240 $obj->grade_problem(%form_options); 1241 1242 1243 =cut 1244 1245 1246 sub grade_problem { 1247 my $self = shift; 1248 no strict; 1249 local %rf_options = @_; 1250 local $rf_grader = $self->{rf_problem_grader}; 1251 local $rh_answers = $self->{rh_evaluated_answers}; 1252 local $rh_state = $self->{rh_problem_state}; 1253 $self->{safe}->share('$rf_grader','$rh_answers','$rh_state','%rf_options'); 1254 ############################################ 1255 # 1256 # FIXME 1257 # warning messages are not being transmitted from this evaluation 1258 # ?????? 1259 ############################################ 1260 1261 ($self->{rh_problem_result},$self->{rh_problem_state}) = 1262 $self->{safe}->reval('&{$rf_grader}($rh_answers,$rh_state,%rf_options)'); 1263 use strict; 1264 die $@ if $@; 1265 ($self->{rh_problem_result}, $self->{rh_problem_state}); 1266 } 1267 1268 sub rf_std_problem_grader { 1269 my $self = shift; 1270 return \&std_problem_grader; 1271 } 1272 sub old_std_problem_grader{ 1273 my $rh_evaluated_answers = shift; 1274 my %flags = @_; # not doing anything with these yet 1275 my %evaluated_answers = %{$rh_evaluated_answers}; 1276 my $allAnswersCorrectQ=1; 1277 foreach my $ans_name (keys %evaluated_answers) { 1278 # I'm not sure if this check is really useful. 1279 if (ref($evaluated_answers{$ans_name} ) eq 'HASH' ) { 1280 $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} ); 1281 } else { 1282 warn "Error: Answer $ans_name is not a hash"; 1283 warn "$evaluated_answers{$ans_name}"; 1284 } 1285 } 1286 # Notice that "all answers are correct" if there are no questions. 1287 { score => $allAnswersCorrectQ, 1288 prev_tries => 0, 1289 partial_credit => $allAnswersCorrectQ, 1290 errors => "", 1291 type => 'old_std_problem_grader', 1292 flags => {}, # not doing anything with these yet 1293 }; # hash output 1294 1295 } 1296 1297 ##################################### 1298 # This is a model for plug-in problem graders 1299 ##################################### 1300 1301 sub std_problem_grader{ 1302 my $rh_evaluated_answers = shift; 1303 my $rh_problem_state = shift; 1304 my %form_options = @_; 1305 my %evaluated_answers = %{$rh_evaluated_answers}; 1306 # The hash $rh_evaluated_answers typically contains: 1307 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 1308 1309 # By default the old problem state is simply passed back out again. 1310 my %problem_state = %$rh_problem_state; 1311 1312 1313 # %form_options might include 1314 # The user login name 1315 # The permission level of the user 1316 # The studentLogin name for this psvn. 1317 # Whether the form is asking for a refresh or is submitting a new answer. 1318 1319 # initial setup of the answer 1320 my %problem_result = ( score => 0, 1321 errors => '', 1322 type => 'std_problem_grader', 1323 msg => '', 1324 ); 1325 # Checks 1326 1327 my $ansCount = keys %evaluated_answers; # get the number of answers 1328 unless ($ansCount > 0 ) { 1329 $problem_result{msg} = "This problem did not ask any questions."; 1330 return(\%problem_result,\%problem_state); 1331 } 1332 1333 if ($ansCount > 1 ) { 1334 $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' ; 1335 } 1336 1337 unless (defined( $form_options{answers_submitted}) and $form_options{answers_submitted} == 1) { 1338 return(\%problem_result,\%problem_state); 1339 } 1340 1341 my $allAnswersCorrectQ=1; 1342 foreach my $ans_name (keys %evaluated_answers) { 1343 # I'm not sure if this check is really useful. 1344 if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) { 1345 $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} ); 1346 } else { 1347 warn "Error: Answer $ans_name is not a hash"; 1348 warn "$evaluated_answers{$ans_name}"; 1349 warn "This probably means that the answer evaluator is for this answer is not working correctly."; 1350 $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; 1351 } 1352 } 1353 # report the results 1354 $problem_result{score} = $allAnswersCorrectQ; 1355 1356 # I don't like to put in this bit of code. 1357 # It makes it hard to construct error free problem graders 1358 # I would prefer to know that the problem score was numeric. 1359 unless ($problem_state{recorded_score} =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ) { 1360 $problem_state{recorded_score} = 0; # This gets rid of non-numeric scores 1361 } 1362 # 1363 if ($allAnswersCorrectQ == 1 or $problem_state{recorded_score} == 1) { 1364 $problem_state{recorded_score} = 1; 1365 } else { 1366 $problem_state{recorded_score} = 0; 1367 } 1368 1369 $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1; 1370 $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0; 1371 (\%problem_result, \%problem_state); 1372 } 1373 sub rf_avg_problem_grader { 1374 my $self = shift; 1375 return \&avg_problem_grader; 1376 } 1377 sub avg_problem_grader{ 1378 my $rh_evaluated_answers = shift; 1379 my $rh_problem_state = shift; 1380 my %form_options = @_; 1381 my %evaluated_answers = %{$rh_evaluated_answers}; 1382 # The hash $rh_evaluated_answers typically contains: 1383 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 1384 1385 # By default the old problem state is simply passed back out again. 1386 my %problem_state = %$rh_problem_state; 1387 1388 1389 # %form_options might include 1390 # The user login name 1391 # The permission level of the user 1392 # The studentLogin name for this psvn. 1393 # Whether the form is asking for a refresh or is submitting a new answer. 1394 1395 # initial setup of the answer 1396 my $total=0; 1397 my %problem_result = ( 1398 score => 0, 1399 errors => '', 1400 type => 'avg_problem_grader', 1401 msg => '', 1402 ); 1403 my $count = keys %evaluated_answers; 1404 $problem_result{msg} = 'You can earn partial credit on this problem.' if $count >1; 1405 # Return unless answers have been submitted 1406 unless ($form_options{answers_submitted} == 1) { 1407 return(\%problem_result,\%problem_state); 1408 } 1409 # Answers have been submitted -- process them. 1410 foreach my $ans_name (keys %evaluated_answers) { 1411 $total += $evaluated_answers{$ans_name}->{score}; 1412 } 1413 # Calculate score rounded to three places to avoid roundoff problems 1414 $problem_result{score} = ($count) ? $total/$count : 0 ; # give zero if no answers have been evaluated. 1415 # increase recorded score if the current score is greater. 1416 $problem_state{recorded_score}=0 unless defined $problem_state{recorded_score}; 1417 $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score}; 1418 1419 1420 $problem_state{num_of_correct_ans}++ if $total == $count; 1421 $problem_state{num_of_incorrect_ans}++ if $total < $count ; 1422 warn "Error in grading this problem the total $total is larger than $count" if $total > $count; 1423 (\%problem_result, \%problem_state); 1424 1425 } 1426 =head3 safetyFilter 1427 1428 ($filtered_ans, $errors) = $obj ->filter_ans($ans) 1429 $obj ->rf_safety_filter() 1430 1431 =cut 1432 1433 sub filter_answer { 1434 my $self = shift; 1435 my $ans = shift; 1436 my @filtered_answers; 1437 my $errors=''; 1438 if (ref($ans) eq 'ARRAY') { #handle the case where the answer comes from several inputs with the same name 1439 # In many cases this will be passed as a reference to an array 1440 # if it is passed as a single string (separated by \0 characters) as 1441 # some early versions of CGI behave, then 1442 # it is unclear what will happen when the answer is filtered. 1443 foreach my $item (@{$ans}) { 1444 my ($filtered_ans, $error) = &{ $self->{rf_safety_filter} } ($item); 1445 push(@filtered_answers, $filtered_ans); 1446 $errors .= " ". $error if $error; # add error message if error is non-zero. 1447 } 1448 (\@filtered_answers,$errors); 1449 1450 } else { 1451 &{ $self->{rf_safety_filter} } ($ans); 1452 } 1453 1454 } 1455 sub rf_safety_filter { 1456 my $self = shift; 1457 my $rf_filter = shift; 1458 $self->{rf_safety_filter} = $rf_filter if $rf_filter and ref($rf_filter) eq 'CODE'; 1459 warn "The safety_filter must be a reference to a subroutine" unless ref($rf_filter) eq 'CODE' ; 1460 $self->{rf_safety_filter} 1461 } 1462 sub safetyFilter { 1463 my $answer = shift; # accepts one answer and checks it 1464 my $submittedAnswer = $answer; 1465 $answer = '' unless defined $answer; 1466 my ($errorno); 1467 $answer =~ tr/\000-\037/ /; 1468 #### Return if answer field is empty ######## 1469 unless ($answer =~ /\S/) { 1470 # $errorno = "<BR>No answer was submitted."; 1471 $errorno = 0; ## don't report blank answer as error 1472 1473 return ($answer,$errorno); 1474 } 1475 ######### replace ^ with ** (for exponentiation) 1476 # $answer =~ s/\^/**/g; 1477 ######### Return if forbidden characters are found 1478 unless ($answer =~ /^[a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)]+$/ ) { 1479 $answer =~ tr/a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)/#/c; 1480 $errorno = "<BR>There are forbidden characters in your answer: $submittedAnswer<BR>"; 1481 1482 return ($answer,$errorno); 1483 } 1484 1485 $errorno = 0; 1486 return($answer, $errorno); 1487 } 1488 1489 ## Check submittedAnswer for forbidden characters, etc. 1490 # ($submittedAnswer,$errorno) = safetyFilter($submittedAnswer); 1491 # $errors .= "No answer was submitted.<BR>" if $errorno == 1; 1492 # $errors .= "There are forbidden characters in your answer: $submittedAnswer<BR>" if $errorno ==2; 1493 # 1494 ## Check correctAnswer for forbidden characters, etc. 1495 # unless (ref($correctAnswer) ) { #skip check if $correctAnswer is a function 1496 # ($correctAnswer,$errorno) = safetyFilter($correctAnswer); 1497 # $errors .= "No correct answer is given in the statement of the problem. 1498 # Please report this to your instructor.<BR>" if $errorno == 1; 1499 # $errors .= "There are forbidden characters in the problems answer. 1500 # Please report this to your instructor.<BR>" if $errorno == 2; 1501 # } 1502 1503 1504 1505 =head2 PGsort 1506 1507 Because of the way sort is optimized in Perl, the symbols $a and $b 1508 have special significance. 1509 1510 C<sort {$a<=>$b} @list> 1511 C<sort {$a cmp $b} @list> 1512 1513 sorts the list numerically and lexically respectively. 1514 1515 If C<my $a;> is used in a problem, before the sort routine is defined in a macro, then 1516 things get badly confused. To correct this the macro PGsort is defined below. It is 1517 evaluated before the problem template is read. In PGbasicmacros.pl, the two subroutines 1518 1519 PGsort sub { $_[0] < $_[1] }, @list; 1520 PGsort sub { $_[0] lt $_[1] }, @list; 1521 1522 (called num_sort and lex_sort) provide slightly slower, but safer, routines for the PG language. 1523 (The subroutines for ordering are B<required>. Note the commas!) 1524 1525 =cut 1526 1527 # This sort can cause troubles because of its special use of $a and $b 1528 # Putting it in dangerousMacros.pl worked frequently, but not always. 1529 # In particular ANS( ans_eva1 ans_eval2) caused trouble. 1530 # One answer at a time did not --- very strange. 1531 # This was replaced by a quick sort routine because the original subroutine 1532 # did not work with Safe when Perl was built with ithreads 1533 1534 #sub PGsort { 1535 # my $sort_order = shift; 1536 # die "Must supply an ordering function with PGsort: PGsort sub {\$a cmp \$b }, \@list\n" unless ref($sort_order) eq 'CODE'; 1537 # sort {&$sort_order($a,$b)} @_; 1538 #} 1539 1540 # quicksort 1541 sub PGsort { 1542 my $cmp = shift; 1543 die "Must supply an ordering function with PGsort: PGsort sub {\$_[0] < \$_[1] }, \@list\n" unless ref($cmp) eq 'CODE'; 1544 if (@_ == 0) { return () } 1545 else { 1546 my $b_item = shift; 1547 my ($small, $large); 1548 my $a_item; 1549 for $a_item (@_) { 1550 push @{&$cmp($a_item, $b_item) ? $small : $large}, $a_item; 1551 } 1552 return (PGsort($cmp, @$small), $b_item, PGsort($cmp, @$large)); 1553 } 1554 } 1555 1556 1557 =head2 includePGtext 1558 1559 includePGtext($string_ref, $envir_ref) 1560 1561 Calls C<createPGtext> recursively with the $safeCompartment variable set to 0 1562 so that the rendering continues in the current safe compartment. The output 1563 is the same as the output from createPGtext. This is used in processing 1564 some of the sample CAPA files. 1565 1566 =cut 1567 1568 #this is a method for importing additional PG files from within one PG file. 1569 # sub includePGtext { 1570 # my $self = shift; 1571 # my $string_ref =shift; 1572 # my $envir_ref = shift; 1573 # $self->environment($envir_ref); 1574 # $self->createPGtext($string_ref); 1575 # } 1576 # evaluation macros 1577 1578 1579 1580 no strict; # this is important -- I guess because eval operates on code which is not written with strict in mind. 1581 1582 1583 1584 =head2 PG_restricted_eval 1585 1586 PG_restricted_eval($string) 1587 1588 Evaluated in package 'main'. Result of last statement is returned. 1589 When called from within a safe compartment the safe compartment package 1590 is 'main'. 1591 1592 1593 =cut 1594 1595 # Remember, eval STRING evaluates code in the current lexical context, so any 1596 # lexicals available here will also be available in the evaluated code. So we 1597 # move the actual eval into a helper function called PG_restricted_eval_helper, 1598 # which doesn't need to have any lexicals. 1599 sub PG_restricted_eval { 1600 my $string = shift; 1601 my $out = PG_restricted_eval_helper($string); 1602 my $err = $@; 1603 my $err_report = $err if $err =~ /\S/; 1604 return wantarray ? ($out, $err, $err_report) : $out; 1605 } 1606 1607 # This is a helper that doesn't use any lexicals. See above. 1608 sub PG_restricted_eval_helper { 1609 no strict; 1610 local $SIG{__WARN__} = "DEFAULT"; 1611 local $SIG{__DIE__} = "DEFAULT"; 1612 return eval("package main;\n" . $_[0]); 1613 } 1614 1615 sub PG_macro_file_eval { # would like to modify this so that it requires use strict on the files that it evaluates. 1616 my $string = shift; 1617 my ($pck,$file,$line) = caller; 1618 1619 local $SIG{__WARN__} = "DEFAULT"; 1620 local $SIG{__DIE__} = "DEFAULT"; 1621 1622 no strict; 1623 my $out = eval ("package main; be_strict();\n" . $string ); 1624 my $errors =$@; 1625 my $full_error_report = "PG_macro_file_eval detected error at line $line of file $file \n" 1626 . $errors . 1627 "The calling package is $pck\n" if defined($errors) && $errors =~/\S/; 1628 use strict; 1629 1630 return (wantarray) ? ($out, $errors,$full_error_report) : $out; 1631 } 1632 =head2 PG_answer_eval 1633 1634 1635 PG_answer_eval($string) 1636 1637 Evaluated in package defined by the current safe compartment. 1638 Result of last statement is returned. 1639 When called from within a safe compartment the safe compartment package 1640 is 'main'. 1641 1642 There is still some confusion about how these two evaluation subroutines work 1643 and how best to define them. It is useful to have two evaluation procedures 1644 since at some point one might like to make the answer evaluations more stringent. 1645 1646 =cut 1647 1648 1649 sub PG_answer_eval { 1650 local($string) = shift; # I made this local just in case -- see PG_restricted_eval 1651 my $errors = ''; 1652 my $full_error_report = ''; 1653 my ($pck,$file,$line) = caller; 1654 # Because of the global variable $PG::compartment_name and $PG::safe_cmpt 1655 # only one problem safe compartment can be active at a time. 1656 # This might cause problems at some point. In that case a cleverer way 1657 # of insuring that the package stays in scope until the answer is evaluated 1658 # will be required. 1659 1660 # This is pretty tricky and doesn't always work right. 1661 # We seem to need PG_priv instead of main when PG_answer_eval is called within a completion 1662 # 'package PG_priv; ' 1663 1664 local $SIG{__WARN__} = sub {die(@_)}; # make warn die, so all errors are reported. 1665 local $SIG{__DIE__} = "DEFAULT"; 1666 1667 no strict; 1668 my $out = eval('package main;'.$string); 1669 $out = '' unless defined($out); 1670 $errors .= $@; 1671 $full_error_report = "ERROR: at line $line of file $file 1672 $errors 1673 The calling package is $pck\n" if defined($errors) && $errors =~/\S/; 1674 use strict; 1675 1676 return (wantarray) ? ($out, $errors,$full_error_report) : $out; 1677 1678 1679 } 1680 1681 # sub original_preprocess_code { 1682 # my $evalString = shift; 1683 # # BEGIN_TEXT and END_TEXT must occur on a line by themselves. 1684 # $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g; 1685 # $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3\(<<'END_TEXT'\)\);\n/g; 1686 # $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT 1687 # 1688 # $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict 1689 # $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments 1690 # $evalString; 1691 # } 1692 sub default_preprocess_code { 1693 my $evalString = shift; 1694 # BEGIN_TEXT and END_TEXT must occur on a line by themselves. 1695 $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g; 1696 $evalString =~ s/\n\s*END_PGML[\s;]*\n/\nEND_PGML\n/g; 1697 $evalString =~ s/\n\s*END_SOLUTION[\s;]*\n/\nEND_SOLUTION\n/g; 1698 $evalString =~ s/\n\s*END_HINT[\s;]*\n/\nEND_HINT\n/g; 1699 $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3P\(<<'END_TEXT'\)\);\n/g; 1700 $evalString =~ s/\n\s*BEGIN_PGML[\s;]*\n/\nTEXT\(PGML::Format2\(<<'END_PGML'\)\);\n/g; 1701 $evalString =~ s/\n\s*BEGIN_SOLUTION[\s;]*\n/\nSOLUTION\(EV3P\(<<'END_SOLUTION'\)\);\n/g; 1702 $evalString =~ s/\n\s*BEGIN_HINT[\s;]*\n/\nHINT\(EV3P\(<<'END_HINT'\)\);\n/g; 1703 $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT 1704 1705 $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict 1706 $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments 1707 $evalString; 1708 } 1709 sub default_postprocess_code { 1710 my $evalString_ref = shift; 1711 $evalString_ref; 1712 } 1713 1714 sub dumpvar { 1715 my ($packageName) = @_; 1716 1717 local(*alias); 1718 1719 sub emit { 1720 print @_; 1721 } 1722 1723 *stash = *{"${packageName}::"}; 1724 $, = " "; 1725 1726 emit "Content-type: text/html\n\n<PRE>\n"; 1727 1728 1729 while ( ($varName, $globValue) = each %stash) { 1730 emit "$varName\n"; 1731 1732 *alias = $globValue; 1733 next if $varName=~/main/; 1734 1735 #if (defined($alias) ) { # get rid of defined since this is deprecated 1736 if ($alias ) { 1737 emit " \$$varName $alias \n"; 1738 } 1739 1740 if ( @alias) { 1741 emit " \@$varName @alias \n"; 1742 } 1743 if (%alias ) { 1744 emit " %$varName \n"; 1745 foreach $key (keys %alias) { 1746 emit " $key => $alias{$key}\n"; 1747 } 1748 1749 1750 1751 } 1752 } 1753 emit "</PRE></PRE>"; 1754 1755 1756 } 1757 use strict; 1758 1759 #### for error checking and debugging purposes 1760 sub pretty_print_rh { 1761 my $rh = shift; 1762 foreach my $key (sort keys %{$rh}) { 1763 warn " $key => ",$rh->{$key},"\n"; 1764 } 1765 } 1766 # end evaluation subroutines 1767 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |