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