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