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