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