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