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