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