Parent Directory
| 
Revision Log
Made small corrections at lines 417 and 484 which were causing compile time errors in /ww/logs/error_log. (One was redefining rh_flags subroutine, the other was an uncommented fragment of a print statement.
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_correct_answers { 485 my $self = shift; 486 my @in = @_; 487 return $self->{rh_correct_answers} if @in == 0; 488 489 if ( ref($in[0]) eq 'HASH' ) { 490 $self->{rh_correct_answers} = { %{ $in[0] } }; # store a copy of the hash 491 } else { 492 $self->{rh_correct_answers} = { @in }; # store a copy of the hash 493 } 494 $self->{rh_correct_answers} 495 } 496 497 sub rf_problem_grader { 498 my $self = shift; 499 my $in = shift; 500 return $self->{rf_problem_grader} unless defined($in); 501 if (ref($in) =~/CODE/ ) { 502 $self->{rf_problem_grader} = $in; 503 } else { 504 die "ERROR: Attempted to install a problem grader which was not a reference to a subroutine."; 505 } 506 $self->{rf_problem_grader} 507 } 508 509 510 sub errors{ 511 my $self = shift; 512 $self->{errors}; 513 } 514 515 # sub DESTROY { 516 # my $self = shift; 517 # my $nameSpace = $self->nameSpace; 518 # no strict 'refs'; 519 # my $nm = "${nameSpace}::"; 520 # my $nsp = \%{"$nm"}; 521 # my @list = keys %$nsp; 522 # while (@list) { 523 # my $name = pop(@list); 524 # if ( defined(&{$nsp->{$name}}) ) { 525 # #print "checking \&$name\n"; 526 # unless (exists( $shared_subroutine_hash{"\&$name"} ) ) { 527 # undef( &{$nsp->{$name}} ); 528 # #print "destroying \&$name\n"; 529 # } else { 530 # #delete( $nsp->{$name} ); 531 # #print "what is left",join(" ",%$nsp) ,"\n\n"; 532 # } 533 # 534 # } 535 # if ( defined(${$nsp->{$name}}) ) { 536 # #undef( ${$nsp->{$name}} ); ## unless commented out download hardcopy bombs with Perl 5.6 537 # #print "destroying \$$name\n"; 538 # } 539 # if ( defined(@{$nsp->{$name}}) ) { 540 # undef( @{$nsp->{$name}} ); 541 # #print "destroying \@$name\n"; 542 # } 543 # if ( defined(%{$nsp->{$name}}) ) { 544 # undef( %{$nsp->{$name}} ) unless $name =~ /::/ ; 545 # #print "destroying \%$name\n"; 546 # } 547 # # changed for Perl 5.6 548 # delete ( $nsp->{$name} ) if defined($nsp->{$name}); # this must be uncommented in Perl 5.6 to reinitialize variables 549 # # changed for Perl 5.6 550 # #print "deleting $name\n"; 551 # #undef( @{$nsp->{$name}} ) if defined(@{$nsp->{$name}}); 552 # #undef( %{$nsp->{$name}} ) if defined(%{$nsp->{$name}}) and $name ne "main::"; 553 # } 554 # 555 # use strict; 556 # #print "\nObject going bye-bye\n"; 557 # 558 # } 559 560 =head2 set_mask 561 562 563 564 565 566 567 (e) Now we close the safe compartment. Only the certain operations can be used 568 within PG problems and the PG macro files. These include the subroutines 569 shared with the safe compartment as defined above and most Perl commands which 570 do not involve file access, access to the system or evaluation. 571 572 Specifically the following are allowed 573 574 time() 575 # gives the current Unix time 576 # used to determine whether solutions are visible. 577 atan, sin cos exp log sqrt 578 # arithemetic commands -- more are defined in PGauxiliaryFunctions.pl 579 580 The following are specifically not allowed: 581 582 eval() 583 unlink, symlink, system, exec 584 print require 585 586 587 588 =cut 589 590 ############################################################################## 591 592 ## restrict the operations allowed within the safe compartment 593 594 sub set_mask { 595 my $self = shift; 596 my $safe_cmpt = $self ->{safe}; 597 $safe_cmpt->mask(Opcode::full_opset()); # allow no operations 598 $safe_cmpt->permit(qw( :default )); 599 $safe_cmpt->permit(qw(time)); # used to determine whether solutions are visible. 600 $safe_cmpt->permit(qw( atan2 sin cos exp log sqrt )); 601 602 # just to make sure we'll deny some things specifically 603 $safe_cmpt->deny(qw(entereval)); 604 $safe_cmpt->deny(qw ( unlink symlink system exec )); 605 $safe_cmpt->deny(qw(print require)); 606 } 607 608 ############################################################################ 609 610 611 =head2 Translate 612 613 614 =cut 615 616 sub translate { 617 my $self = shift; 618 my @PROBLEM_TEXT_OUTPUT = (); 619 my $safe_cmpt = $self ->{safe}; 620 my $evalString = $self -> {source}; 621 $self ->{errors} .= qq{ERROR: This problem file was empty!\n} unless ($evalString) ; 622 $self ->{errors} .= qq{ERROR: You must define the environment before translating.} 623 unless defined( $self->{envir} ); 624 # reset the error detection 625 my $save_SIG_die_trap = $SIG{__DIE__}; 626 $SIG{__DIE__} = sub {CORE::die(@_) }; 627 628 629 630 =pod 631 632 (3) B<Preprocess the problem text> 633 634 The input text is subjected to two global replacements. 635 First every incidence of 636 637 BEGIN_TEXT 638 problem text 639 END_TEXT 640 641 is replaced by 642 643 TEXT( EV3( <<'END_TEXT' ) ); 644 problem text 645 END_TEXT 646 647 The first construction is syntactic sugar for the second. This is explained 648 in C<PGbasicmacros.pl>. 649 650 Second every incidence 651 of \ (backslash) is replaced by \\ (double backslash). Third each incidence of 652 ~~ is replaced by a single backslash. 653 654 This is done to alleviate a basic 655 incompatibility between TeX and Perl. TeX uses backslashes constantly to denote 656 a command word (as opposed to text which is to be entered literally). Perl 657 uses backslash to escape the following symbol. This escape 658 mechanism takes place immediately when a Perl script is compiled and takes 659 place throughout the code and within every quoted string (both double and single 660 quoted strings) with the single exception of single quoted "here" documents. 661 That is backlashes which appear in 662 663 TEXT(<<'EOF'); 664 ... text including \{ \} for example 665 EOF 666 667 are the only ones not immediately evaluated. This behavior makes it very difficult 668 to use TeX notation for defining mathematics within text. 669 670 The initial global 671 replacement, before compiling a PG problem, allows one to use backslashes within 672 text without doubling them. (The anomolous behavior inside single quoted "here" 673 documents is compensated for by the behavior of the evaluation macro EV3.) This 674 makes typing TeX easy, but introduces one difficulty in entering normal Perl code. 675 676 The second global replacement provides a work around for this -- use ~~ when you 677 would ordinarily use a backslash in Perl code. 678 In order to define a carriage return use ~~n rather than \n; in order to define 679 a reference to a variable you must use ~~@array rather than \@array. This is 680 annoying and a source of simple compiler errors, but must be lived with. 681 682 The problems are not evaluated in strict mode, so global variables can be used 683 without warnings. 684 685 686 687 =cut 688 689 ############################################################################ 690 691 692 ########################################## 693 ###### PG preprocessing code ############# 694 ########################################## 695 # BEGIN_TEXT and END_TEXT must occur on a line by themselves. 696 $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g; 697 $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3\(<<'END_TEXT'\)\);\n/g; 698 $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT 699 700 $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict 701 $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments 702 703 =pod 704 705 (4) B<Evaluate the problem text> 706 707 Evaluate the text within the safe compartment. Save the errors. The safe 708 compartment is a new one unless the $safeCompartment was set to zero in which 709 case the previously defined safe compartment is used. (See item 1.) 710 711 =cut 712 713 714 my ($PG_PROBLEM_TEXT_REF, $PG_HEADER_TEXT_REF, $PG_ANSWER_HASH_REF, $PG_FLAGS_REF) 715 =$safe_cmpt->reval(" $evalString"); 716 717 # This section could use some more error messages. In particular if a problem doesn't produce the right output, the user needs 718 # information about which problem was at fault. 719 # 720 # 721 722 $self->{errors} .= $@; 723 # push(@PROBLEM_TEXT_OUTPUT , split(/(\n)/,$$PG_PROBLEM_TEXT_REF) ) if defined($$PG_PROBLEM_TEXT_REF ); 724 push(@PROBLEM_TEXT_OUTPUT , split(/^/,$$PG_PROBLEM_TEXT_REF) ) if ref($PG_PROBLEM_TEXT_REF ) eq 'SCALAR'; 725 ## This is better than using defined($$PG_PROBLEM_TEXT_REF) 726 ## Because more pleasant feedback is given 727 ## when the problem doesn't render. 728 # try to get the \n to appear at the end of the line 729 730 use strict; 731 ############################################################################# 732 ########## end EVALUATION code ########### 733 ############################################################################# 734 735 =pod 736 737 (5) B<Process errors> 738 739 The error provided by Perl 740 is truncated slightly and returned. In the text 741 string which would normally contain the rendered problem. 742 743 The original text string is given line numbers and concatenated to 744 the errors. 745 746 =cut 747 748 749 750 ########################################## 751 ###### PG error processing code ########## 752 ########################################## 753 my (@input,$lineNumber,$line); 754 if ($self -> {errors}) { 755 #($self -> {errors}) =~ s/</</g; 756 #($self -> {errors}) =~ s/>/>/g; 757 #try to clean up errors so they will look ok 758 $self ->{errors} =~ s/\[.+?\.pl://gm; #erase [Fri Dec 31 12:58:30 1999] processProblem7.pl: 759 #$self -> {errors} =~ s/eval\s+'(.|[\n|r])*$//; 760 #end trying to clean up errors so they will look ok 761 762 763 push(@PROBLEM_TEXT_OUTPUT , qq!\n<A NAME="problem! . 764 $self->{envir} ->{'probNum'} . 765 qq!"><PRE> Problem!. 766 $self->{envir} ->{'probNum'}. 767 qq!\nERROR caught by PGtranslator while processing problem file:! . 768 $self->{envir}->{'probFileName'}. 769 "\n****************\r\n" . 770 $self -> {errors}."\r\n" . 771 "****************<BR>\n"); 772 773 push(@PROBLEM_TEXT_OUTPUT , "------Input Read\r\n"); 774 $self->{source} =~ s/</</g; 775 @input=split("\n", $self->{source}); 776 $lineNumber = 1; 777 foreach $line (@input) { 778 chomp($line); 779 push(@PROBLEM_TEXT_OUTPUT, "$lineNumber\t\t$line\r\n"); 780 $lineNumber ++; 781 } 782 push(@PROBLEM_TEXT_OUTPUT ,"\n-----<BR></PRE>\r\n"); 783 784 785 786 } 787 788 =pod 789 790 (6) B<Prepare return values> 791 792 Returns: 793 $PG_PROBLEM_TEXT_ARRAY_REF -- Reference to a string containing the rendered text. 794 $PG_HEADER_TEXT_REF -- Reference to a string containing material to placed in the header (for use by JavaScript) 795 $PG_ANSWER_HASH_REF -- Reference to an array containing the answer evaluators. 796 $PG_FLAGS_REF -- Reference to a hash containing flags and other references: 797 'error_flag' is set to 1 if there were errors in rendering 798 799 =cut 800 801 ## we need to make sure that the other output variables are defined 802 803 ## If the eval failed with errors, one or more of these variables won't be defined. 804 $PG_ANSWER_HASH_REF = {} unless defined($PG_ANSWER_HASH_REF); 805 $PG_HEADER_TEXT_REF = \( "" ) unless defined($PG_HEADER_TEXT_REF); 806 $PG_FLAGS_REF = {} unless defined($PG_FLAGS_REF); 807 808 $PG_FLAGS_REF->{'error_flag'} = 1 if $self -> {errors}; 809 my $PG_PROBLEM_TEXT = join("",@PROBLEM_TEXT_OUTPUT); 810 811 $self ->{ PG_PROBLEM_TEXT_REF } = \$PG_PROBLEM_TEXT; 812 $self ->{ PG_PROBLEM_TEXT_ARRAY_REF } = \@PROBLEM_TEXT_OUTPUT; 813 $self ->{ PG_HEADER_TEXT_REF } = $PG_HEADER_TEXT_REF; 814 $self ->{ rh_correct_answers } = $PG_ANSWER_HASH_REF; 815 $self ->{ PG_FLAGS_REF } = $PG_FLAGS_REF; 816 $SIG{__DIE__} = $save_SIG_die_trap; 817 $self ->{errors}; 818 } # end translate 819 820 821 =head2 Answer evaluation methods 822 823 =cut 824 825 =head3 access methods 826 827 $obj->rh_student_answers 828 829 =cut 830 831 832 833 sub rh_evaluated_answers { 834 my $self = shift; 835 my @in = @_; 836 return $self->{rh_evaluated_answers} if @in == 0; 837 838 if ( ref($in[0]) eq 'HASH' ) { 839 $self->{rh_evaluated_answers} = { %{ $in[0] } }; # store a copy of the hash 840 } else { 841 $self->{rh_evaluated_answers} = { @in }; # store a copy of the hash 842 } 843 $self->{rh_evaluated_answers}; 844 } 845 sub rh_problem_result { 846 my $self = shift; 847 my @in = @_; 848 return $self->{rh_problem_result} if @in == 0; 849 850 if ( ref($in[0]) eq 'HASH' ) { 851 $self->{rh_problem_result} = { %{ $in[0] } }; # store a copy of the hash 852 } else { 853 $self->{rh_problem_result} = { @in }; # store a copy of the hash 854 } 855 $self->{rh_problem_result}; 856 } 857 sub rh_problem_state { 858 my $self = shift; 859 my @in = @_; 860 return $self->{rh_problem_state} if @in == 0; 861 862 if ( ref($in[0]) eq 'HASH' ) { 863 $self->{rh_problem_state} = { %{ $in[0] } }; # store a copy of the hash 864 } else { 865 $self->{rh_problem_state} = { @in }; # store a copy of the hash 866 } 867 $self->{rh_problem_state}; 868 } 869 870 871 =head3 process_answers 872 873 874 $obj->process_answers() 875 876 877 =cut 878 879 880 sub process_answers{ 881 my $self = shift; 882 my @in = shift; 883 my %h_student_answers; 884 if (ref($in[0]) eq 'HASH' ) { 885 %h_student_answers = %{ $in[0] }; 886 } else { 887 %h_student_answers = @in; 888 } 889 my $rh_correct_answers = $self->rh_correct_answers(); 890 my @answer_entry_order = ( defined($self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER}) ) ? 891 @{$self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER}} : keys %{$rh_correct_answers}; 892 893 # apply each instructors answer to the corresponding student answer 894 895 foreach my $ans_name ( @answer_entry_order ) { 896 my ($ans, $errors) = $self->filter_answer( $h_student_answers{$ans_name} ); 897 no strict; 898 # evaluate the answers inside the safe compartment. 899 local($rf_fun,$temp_ans) = (undef,undef); 900 if ( defined($rh_correct_answers ->{$ans_name} ) ) { 901 $rf_fun = $rh_correct_answers->{$ans_name}; 902 } else { 903 warn "There is no answer evaluator for the question labeled $ans_name"; 904 } 905 $temp_ans = $ans; 906 $temp_ans = '' unless defined($temp_ans); #make sure that answer is always defined 907 # in case the answer evaluator forgets to check 908 $self->{safe}->share('$rf_fun','$temp_ans'); 909 910 # reset the error detection 911 my $save_SIG_die_trap = $SIG{__DIE__}; 912 $SIG{__DIE__} = sub {CORE::die(@_) }; 913 my $rh_ans_evaluation_result; 914 if (ref($rf_fun) eq 'CODE' ) { 915 $rh_ans_evaluation_result = $self->{safe} ->reval( '&{ $rf_fun }($temp_ans)' ) ; 916 warn "Error in PGtranslator.pm::process_answers: Answer $ans_name:<BR>\n $@\n" if $@; 917 } elsif (ref($rf_fun) eq 'AnswerEvaluator') { 918 $rh_ans_evaluation_result = $self->{safe} ->reval('$rf_fun->evaluate($temp_ans)'); 919 warn "Error in PGtranslator.pm::process_answers: Answer $ans_name:<BR>\n $@\n" if $@; 920 warn "Evaluation error: Answer $ans_name:<BR>\n", $rh_ans_evaluation_result->error_flag(), " :: ",$rh_ans_evaluation_result->error_message(),"<BR>\n" 921 if defined($rh_ans_evaluation_result) and defined($rh_ans_evaluation_result->error_flag()); 922 } else { 923 warn "Error in PGtranslator.pm::process_answers: Answer $ans_name:<BR>\n Unrecognized evaluator type |", ref($rf_fun), "|"; 924 } 925 926 $SIG{__DIE__} = $save_SIG_die_trap; 927 928 929 use strict; 930 unless ( ( ref($rh_ans_evaluation_result) eq 'HASH') or ( ref($rh_ans_evaluation_result) eq 'AnswerHash') ) { 931 warn "Error in PGtranslator.pm::process_answers: Answer $ans_name:<BR>\n 932 Answer evaluators must return a hash or an AnswerEvaluator type, not type |", 933 ref($rh_ans_evaluation_result), "|"; 934 } 935 $rh_ans_evaluation_result ->{ans_message} .= "$errors \n" if $errors; 936 $rh_ans_evaluation_result ->{ans_name} = $ans_name; 937 $self->{rh_evaluated_answers}->{$ans_name} = $rh_ans_evaluation_result; 938 939 } 940 $self->rh_evaluated_answers; 941 942 } 943 944 945 946 =head3 grade_problem 947 948 $obj->rh_problem_state(%problem_state); # sets the current problem state 949 $obj->grade_problem(%form_options); 950 951 952 =cut 953 954 955 sub grade_problem { 956 my $self = shift; 957 my %form_options = @_; 958 my $rf_grader = $self->{rf_problem_grader}; 959 ($self->{rh_problem_result},$self->{rh_problem_state} ) = 960 &{$rf_grader}( $self -> {rh_evaluated_answers}, 961 $self -> {rh_problem_state}, 962 %form_options 963 ); 964 965 ($self->{rh_problem_result}, $self->{rh_problem_state} ) ; 966 } 967 968 sub rf_std_problem_grader { 969 my $self = shift; 970 return \&std_problem_grader; 971 } 972 sub old_std_problem_grader{ 973 my $rh_evaluated_answers = shift; 974 my %flags = @_; # not doing anything with these yet 975 my %evaluated_answers = %{$rh_evaluated_answers}; 976 my $allAnswersCorrectQ=1; 977 foreach my $ans_name (keys %evaluated_answers) { 978 # I'm not sure if this check is really useful. 979 if (ref($evaluated_answers{$ans_name} ) eq 'HASH' ) { 980 $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} ); 981 } else { 982 warn "Error: Answer $ans_name is not a hash"; 983 warn "$evaluated_answers{$ans_name}"; 984 } 985 } 986 # Notice that "all answers are correct" if there are no questions. 987 { score => $allAnswersCorrectQ, 988 prev_tries => 0, 989 partial_credit => $allAnswersCorrectQ, 990 errors => "", 991 type => 'old_std_problem_grader', 992 flags => {}, # not doing anything with these yet 993 }; # hash output 994 995 } 996 997 ##################################### 998 # This is a model for plug-in problem graders 999 ##################################### 1000 1001 sub std_problem_grader{ 1002 my $rh_evaluated_answers = shift; 1003 my $rh_problem_state = shift; 1004 my %form_options = @_; 1005 my %evaluated_answers = %{$rh_evaluated_answers}; 1006 # The hash $rh_evaluated_answers typically contains: 1007 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 1008 1009 # By default the old problem state is simply passed back out again. 1010 my %problem_state = %$rh_problem_state; 1011 1012 1013 # %form_options might include 1014 # The user login name 1015 # The permission level of the user 1016 # The studentLogin name for this psvn. 1017 # Whether the form is asking for a refresh or is submitting a new answer. 1018 1019 # initial setup of the answer 1020 my %problem_result = ( score => 0, 1021 errors => '', 1022 type => 'std_problem_grader', 1023 msg => '', 1024 ); 1025 # Checks 1026 1027 my $ansCount = keys %evaluated_answers; # get the number of answers 1028 unless ($ansCount > 0 ) { 1029 $problem_result{msg} = "This problem did not ask any questions."; 1030 return(\%problem_result,\%problem_state); 1031 } 1032 1033 if ($ansCount > 1 ) { 1034 $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' ; 1035 } 1036 1037 unless (defined( $form_options{answers_submitted}) and $form_options{answers_submitted} == 1) { 1038 return(\%problem_result,\%problem_state); 1039 } 1040 1041 my $allAnswersCorrectQ=1; 1042 foreach my $ans_name (keys %evaluated_answers) { 1043 # I'm not sure if this check is really useful. 1044 if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) { 1045 $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} ); 1046 } else { 1047 warn "Error: Answer $ans_name is not a hash"; 1048 warn "$evaluated_answers{$ans_name}"; 1049 warn "This probably means that the answer evaluator is for this answer is not working correctly."; 1050 $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; 1051 } 1052 } 1053 # report the results 1054 $problem_result{score} = $allAnswersCorrectQ; 1055 1056 # I don't like to put in this bit of code. 1057 # It makes it hard to construct error free problem graders 1058 # I would prefer to know that the problem score was numeric. 1059 unless ($problem_state{recorded_score} =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ) { 1060 $problem_state{recorded_score} = 0; # This gets rid of non-numeric scores 1061 } 1062 # 1063 if ($allAnswersCorrectQ == 1 or $problem_state{recorded_score} == 1) { 1064 $problem_state{recorded_score} = 1; 1065 } else { 1066 $problem_state{recorded_score} = 0; 1067 } 1068 1069 $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1; 1070 $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0; 1071 (\%problem_result, \%problem_state); 1072 } 1073 sub rf_avg_problem_grader { 1074 my $self = shift; 1075 return \&avg_problem_grader; 1076 } 1077 sub avg_problem_grader{ 1078 my $rh_evaluated_answers = shift; 1079 my $rh_problem_state = shift; 1080 my %form_options = @_; 1081 my %evaluated_answers = %{$rh_evaluated_answers}; 1082 # The hash $rh_evaluated_answers typically contains: 1083 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 1084 1085 # By default the old problem state is simply passed back out again. 1086 my %problem_state = %$rh_problem_state; 1087 1088 1089 # %form_options might include 1090 # The user login name 1091 # The permission level of the user 1092 # The studentLogin name for this psvn. 1093 # Whether the form is asking for a refresh or is submitting a new answer. 1094 1095 # initial setup of the answer 1096 my $total=0; 1097 my %problem_result = ( score => 0, 1098 errors => '', 1099 type => 'avg_problem_grader', 1100 msg => '', 1101 ); 1102 my $count = keys %evaluated_answers; 1103 $problem_result{msg} = 'You can earn partial credit on this problem.' if $count >1; 1104 # Return unless answers have been submitted 1105 unless ($form_options{answers_submitted} == 1) { 1106 return(\%problem_result,\%problem_state); 1107 } 1108 # Answers have been submitted -- process them. 1109 foreach my $ans_name (keys %evaluated_answers) { 1110 $total += $evaluated_answers{$ans_name}->{score}; 1111 } 1112 # Calculate score rounded to three places to avoid roundoff problems 1113 $problem_result{score} = $total/$count if $count; 1114 # increase recorded score if the current score is greater. 1115 $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score}; 1116 1117 1118 $problem_state{num_of_correct_ans}++ if $total == $count; 1119 $problem_state{num_of_incorrect_ans}++ if $total < $count ; 1120 warn "Error in grading this problem the total $total is larger than $count" if $total > $count; 1121 (\%problem_result, \%problem_state); 1122 1123 } 1124 =head3 safetyFilter 1125 1126 ($filtered_ans, $errors) = $obj ->filter_ans($ans) 1127 $obj ->rf_safety_filter() 1128 1129 =cut 1130 1131 sub filter_answer { 1132 my $self = shift; 1133 &{ $self->{rf_safety_filter} } (@_); 1134 } 1135 sub rf_safety_filter { 1136 my $self = shift; 1137 my $rf_filter = shift; 1138 $self->{rf_safety_filter} = $rf_filter if $rf_filter and ref($rf_filter) eq 'CODE'; 1139 warn "The safety_filter must be a reference to a subroutine" unless ref($rf_filter) eq 'CODE' ; 1140 $self->{rf_safety_filter} 1141 } 1142 sub safetyFilter { 1143 my $answer = shift; # accepts one answer and checks it 1144 my $submittedAnswer = $answer; 1145 $answer = '' unless defined $answer; 1146 my ($errorno, $answerIsCorrectQ); 1147 $answer =~ tr/\000-\037/ /; 1148 #### Return if answer field is empty ######## 1149 unless ($answer =~ /\S/) { 1150 # $errorno = "<BR>No answer was submitted."; 1151 $errorno = 0; ## don't report blank answer as error 1152 1153 return ($answer,$errorno); 1154 } 1155 ######### replace ^ with ** (for exponentiation) 1156 # $answer =~ s/\^/**/g; 1157 ######### Return if forbidden characters are found 1158 unless ($answer =~ /^[a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)]+$/ ) { 1159 $answer =~ tr/a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)/#/c; 1160 $errorno = "<BR>There are forbidden characters in your answer: $submittedAnswer<BR>"; 1161 1162 return ($answer,$errorno); 1163 } 1164 1165 $errorno = 0; 1166 return($answer, $errorno); 1167 } 1168 1169 ## Check submittedAnswer for forbidden characters, etc. 1170 # ($submittedAnswer,$errorno) = safetyFilter($submittedAnswer); 1171 # $errors .= "No answer was submitted.<BR>" if $errorno == 1; 1172 # $errors .= "There are forbidden characters in your answer: $submittedAnswer<BR>" if $errorno ==2; 1173 # 1174 ## Check correctAnswer for forbidden characters, etc. 1175 # unless (ref($correctAnswer) ) { #skip check if $correctAnswer is a function 1176 # ($correctAnswer,$errorno) = safetyFilter($correctAnswer); 1177 # $errors .= "No correct answer is given in the statement of the problem. 1178 # Please report this to your instructor.<BR>" if $errorno == 1; 1179 # $errors .= "There are forbidden characters in the problems answer. 1180 # Please report this to your instructor.<BR>" if $errorno == 2; 1181 # } 1182 1183 =head2 Private functions (not methods) 1184 1185 1186 1187 =cut 1188 1189 1190 #private functions 1191 1192 sub includePGtext { 1193 my $evalString = shift; 1194 if (ref($evalString) eq 'SCALAR') { 1195 $evalString = $$evalString; 1196 } 1197 $evalString =~ s/\nBEGIN_TEXT/TEXT\(EV3\(<<'END_TEXT'\)\);/g; 1198 $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict 1199 $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments 1200 no strict; 1201 eval("package main; $evalString") ; 1202 my $errors = $@; 1203 die eval(q! "ERROR in included file:\n$main::envir{probFileName}\n $errors\n"!) if $errors; 1204 use strict; 1205 ''; 1206 } 1207 1208 1209 #private IO functions 1210 1211 my $REMOTE_HOST = (defined( $ENV{'REMOTE_HOST'} ) ) ? $ENV{'REMOTE_HOST'}: 'unknown host'; 1212 my $REMOTE_ADDR = (defined( $ENV{'REMOTE_ADDR'}) ) ? $ENV{'REMOTE_ADDR'}: 'unknown address'; 1213 1214 =head2 send_mail_to 1215 1216 send_mail_to($user_address,'subject'=>$subject,'body'=>$body) 1217 1218 Returns: 1 if the address is ok, otherwise a fatal error is signaled using wwerror. 1219 1220 Sends $body to the address specified by $user_address provided that 1221 the address appears in C<@{$Global::PG_environment{'ALLOW_MAIL_TO'}}>. 1222 1223 This subroutine is likely to be fragile and to require tweaking when installed 1224 in a new environment. It uses the unix application C<sendmail>. 1225 1226 =cut 1227 1228 1229 sub send_mail_to { 1230 my $user_address = shift; # user must be an instructor 1231 my %options = @_; 1232 my $subject = ''; 1233 $subject = $options{'subject'} if defined($options{'subject'}); 1234 my $msg_body = ''; 1235 $msg_body =$options{'body'} if defined($options{'body'}); 1236 my @mail_to_allowed_list = (); 1237 @mail_to_allowed_list = @{ $options{'ALLOW_MAIL_TO'} } if defined($options{'ALLOW_MAIL_TO'}); 1238 my $out; 1239 1240 # check whether user is an instructor 1241 my $mailing_allowed_flag =0; 1242 1243 1244 while (@mail_to_allowed_list) { 1245 if ($user_address eq shift @mail_to_allowed_list ) { 1246 $mailing_allowed_flag =1; 1247 last; 1248 } 1249 } 1250 if ($mailing_allowed_flag) { 1251 ## mail header text: 1252 my $email_msg ="To: $user_address\n" . 1253 "X-Remote-Host: $REMOTE_HOST($REMOTE_ADDR)\n" . 1254 "Subject: $subject\n\n" . $msg_body; 1255 my $smtp = Net::SMTP->new($Global::smtpServer, Timeout=>10) || 1256 warn "Couldn't contact SMTP server."; 1257 $smtp->mail($Global::webmaster); 1258 1259 if ( $smtp->recipient($user_address)) { # this one's okay, keep going 1260 $smtp->data( $email_msg) || 1261 warn("Unknown problem sending message data to SMTP server."); 1262 } else { # we have a problem a problem with this address 1263 $smtp->reset; 1264 warn "SMTP server doesn't like this address: <$user_address>."; 1265 } 1266 $smtp->quit; 1267 1268 } else { 1269 1270 Global::wwerror("$0","There has been an error in creating this problem.\n" . 1271 "Please notify your instructor.\n\n" . 1272 "Mail is not permitted to address $user_address.\n" . 1273 "Permitted addresses are specified in the courseWeBWorK.ph file.", 1274 "","",""); 1275 $out = 0; 1276 } 1277 1278 $out; 1279 1280 } 1281 # only files are loaded first from the macroDirectory and then from the courseScriptsDirectory 1282 # files cannot be loaded from other directories. 1283 1284 1285 1286 1287 # 1288 # # these have been copied over from FILE.pl. I don't know if they need to be duplicated or not. 1289 # ## these call backs come from PGchoice -- mostly from within the alias command. 1290 # 1291 1292 =head2 read_whole_problem_file 1293 1294 read_whole_problem_file($filePath); 1295 1296 Returns: A reference to a string containing 1297 the contents of the file. 1298 1299 Don't use for huge files. The file name will have .pg appended to it if it doesn't 1300 already end in .pg. Files may become double spaced.? Check the join below. This is 1301 used in importing additional .pg files as is done in the 1302 sample problems translated from CAPA. 1303 1304 =cut 1305 1306 1307 sub read_whole_problem_file { 1308 my $filePath = shift; 1309 $filePath =~s/^\s*//; # get rid of initial spaces 1310 $filePath =~s/\s*$//; # get rid of final spaces 1311 $filePath = "$filePath.pg" unless $filePath =~ /\.pg$/; 1312 read_whole_file($filePath); 1313 } 1314 1315 sub read_whole_file { 1316 my $filePath = shift; 1317 local (*INPUT); 1318 open(INPUT, "<$filePath")|| die "$0: readWholeProblemFile subroutine: <BR>Can't read file $filePath"; 1319 local($/)=undef; 1320 my $string = <INPUT>; # can't append spaces because this causes trouble with <<'EOF' \nEOF construction 1321 close(INPUT); 1322 \$string; 1323 } 1324 1325 1326 =head2 convertPath 1327 1328 $path = convertPath($path); 1329 1330 Normalizes the delimiters in the path using delimiter from C<&getDirDelim()> 1331 which is defined in C<Global.pm>. 1332 1333 =cut 1334 1335 sub convertPath { 1336 &main::convertPath; 1337 } 1338 1339 =head2 surePathToTmpFile 1340 1341 surePathToTmpFile($path) 1342 Returns: $path 1343 1344 Defined in FILE.pl 1345 1346 Creates all of the subdirectories between the directory specified 1347 by C<&getCourseTempDirectory> and the address of the path. 1348 1349 Uses 1350 1351 &createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID) 1352 1353 The path may begin with the correct path to the temporary 1354 directory. Any other prefix causes a path relative to the temporary 1355 directory to be created. 1356 1357 The quality of the error checking could be improved. :-) 1358 1359 =cut 1360 1361 sub surePathToTmpFile { 1362 &main::surePathToTmpFile; 1363 } 1364 1365 =head2 fileFromPath 1366 1367 $fileName = fileFromPath($path) 1368 1369 Defined in C<FILE.pl>. 1370 1371 Uses C<&getDirDelim()> to determine the path delimiter. Returns the last segment 1372 of the path (after the last delimiter.) 1373 1374 =cut 1375 1376 sub fileFromPath { 1377 &main::fileFromPath; 1378 } 1379 1380 =head2 directoryFromPath 1381 1382 1383 $directoryPath = directoryFromPath($path) 1384 1385 Defined in C<FILE.pl>. 1386 1387 Uses C<&getDirDelim()> to determine the path delimiter. Returns the initial segments 1388 of the of the path (up to the last delimiter.) 1389 1390 =cut 1391 1392 sub directoryFromPath { 1393 &main::directoryFromPath; 1394 1395 } 1396 1397 =head2 createFile 1398 1399 createFile($filePath); 1400 1401 Calls C<FILE.pl> version of createFile with 1402 C<createFile($filePath,0660(permission),$Global::numericalGroupID)> 1403 1404 =cut 1405 1406 sub createFile { 1407 my $filePath = shift; 1408 &main::createFile($filePath, 0660,0); 1409 } 1410 1411 1412 1413 # This sort can cause troubles because of its special use of $a and $b 1414 # Putting it in dangerousMacros.pl worked frequently, but not always. 1415 # In particular ANS( ans_eva1 ans_eval2) caused trouble. 1416 # One answer at a time did not --- very strange. 1417 1418 1419 =head2 PGsort 1420 1421 Because of the way sort is optimized in Perl, the symbols $a and $b 1422 have special significance. 1423 1424 C<sort {$a<=>$b} @list> 1425 C<sort {$a cmp $b} @list> 1426 1427 sorts the list numerically and lexically respectively. 1428 1429 If C<my $a;> is used in a problem, before the sort routine is defined in a macro, then 1430 things get badly confused. To correct this, the following macros are defined in 1431 dangerougMacros.pl which is evaluated before the problem template is read. 1432 1433 PGsort sub { $_[0] <=> $_[1] }, @list; 1434 PGsort sub { $_[0] cmp $_[1] }, @list; 1435 1436 provide slightly slower, but safer, routines for the PG language. (The subroutines 1437 for ordering are B<required>. Note the commas!) 1438 1439 =cut 1440 1441 # This sort can cause troubles because of its special use of $a and $b 1442 # Putting it in dangerousMacros.pl worked frequently, but not always. 1443 # In particular ANS( ans_eva1 ans_eval2) caused trouble. 1444 # One answer at a time did not --- very strange. 1445 1446 sub PGsort { 1447 my $sort_order = shift; 1448 die "Must supply an ordering function with PGsort: PGsort sub {\$a cmp \$b }, \@list\n" unless ref($sort_order) eq 'CODE'; 1449 sort {&$sort_order($a,$b)} @_; 1450 } 1451 1452 =head2 includePGtext 1453 1454 includePGtext($string_ref, $envir_ref) 1455 1456 Calls C<createPGtext> recursively with the $safeCompartment variable set to 0 1457 so that the rendering continues in the current safe compartment. The output 1458 is the same as the output from createPGtext. This is used in processing 1459 some of the sample CAPA files. 1460 1461 =cut 1462 1463 #this is a method for importing additional PG files from within one PG file. 1464 # sub includePGtext { 1465 # my $self = shift; 1466 # my $string_ref =shift; 1467 # my $envir_ref = shift; 1468 # $self->environment($envir_ref); 1469 # $self->createPGtext($string_ref); 1470 # } 1471 # evaluation macros 1472 1473 1474 1475 no strict; # this is important -- I guess because eval operates on code which is not written with strict in mind. 1476 1477 1478 1479 =head2 PG_restricted_eval 1480 1481 PG_restricted_eval($string) 1482 1483 Evaluated in package 'main'. Result of last statement is returned. 1484 When called from within a safe compartment the safe compartment package 1485 is 'main'. 1486 1487 1488 =cut 1489 1490 sub PG_restricted_eval { 1491 local($string) = shift; # local seems to be essential to make sure that the right version of $string is evaluated 1492 # Using my, things would work unless the contents of $string contained '$string' 1493 # Wheeeeeeeeeeee!!!!!! 1494 my ($pck,$file,$line) = caller; 1495 my $save_SIG_warn_trap = $SIG{__WARN__}; # this change doesn't seem to make any difference in how problem warnings are propagated. 1496 $SIG{__WARN__} = sub { CORE::die @_}; 1497 my $save_SIG_die_trap = $SIG{__DIE__}; 1498 $SIG{__DIE__}= sub {CORE::die @_}; 1499 no strict; 1500 my $out = eval ("package main; " . $string ); 1501 my $errors =$@; 1502 my $full_error_report = "PG_restricted_eval detected error at line $line of file $file \n" 1503 . $errors . 1504 "The calling package is $pck\n" if defined($errors) && $errors =~/\S/; 1505 use strict; 1506 $SIG{__DIE__} = $save_SIG_die_trap; 1507 $SIG{__WARN__} = $save_SIG_warn_trap; 1508 1509 return (wantarray) ? ($out, $errors,$full_error_report) : $out; 1510 } 1511 1512 =head2 PG_answer_eval 1513 1514 1515 PG_answer_eval($string) 1516 1517 Evaluated in package defined by the current safe compartment. 1518 Result of last statement is returned. 1519 When called from within a safe compartment the safe compartment package 1520 is 'main'. 1521 1522 There is still some confusion about how these two evaluation subroutines work 1523 and how best to define them. It is useful to have two evaluation procedures 1524 since at some point one might like to make the answer evaluations more stringent. 1525 1526 =cut 1527 1528 1529 sub PG_answer_eval { 1530 local($string) = shift; # I made this local just in case -- see PG_estricted_eval 1531 my $errors = ''; 1532 my $full_error_report = ''; 1533 my ($pck,$file,$line) = caller; 1534 # Because of the global variable $PG::compartment_name and $PG::safe_cmpt 1535 # only one problem safe compartment can be active at a time. 1536 # This might cause problems at some point. In that case a cleverer way 1537 # of insuring that the package stays in scope until the answer is evaluated 1538 # will be required. 1539 1540 # This is pretty tricky and doesn't always work right. 1541 # We seem to need PG_priv instead of main when PG_answer_eval is called within a completion 1542 # 'package PG_priv; ' 1543 my $save_SIG_warn_trap = $SIG{__WARN__}; 1544 $SIG{__WARN__} = sub { CORE::die @_}; 1545 my $save_SIG_die_trap = $SIG{__DIE__}; 1546 $SIG{__DIE__}= sub {CORE::die @_}; 1547 my $save_SIG_FPE_trap= $SIG{'FPE'}; 1548 $SIG{'FPE'} = \&Global::PG_floating_point_exception_handler; 1549 #$SIG{'FPE'} = sub {exit(0)}; ## is this ok to comment this out? 1550 no strict; 1551 my $out = eval('package main;'.$string); 1552 $out = '' unless defined($out); 1553 $errors .=$@; 1554 1555 $full_error_report = "ERROR: at line $line of file $file 1556 $errors 1557 The calling package is $pck\n" if defined($errors) && $errors =~/\S/; 1558 use strict; 1559 $SIG{__DIE__} = $save_SIG_die_trap; 1560 $SIG{__WARN__} = $save_SIG_warn_trap; 1561 $SIG{'FPE'} = $save_SIG_FPE_trap; 1562 return (wantarray) ? ($out, $errors,$full_error_report) : $out; 1563 1564 1565 } 1566 1567 sub dumpvar { 1568 my ($packageName) = @_; 1569 1570 local(*alias); 1571 1572 sub emit { 1573 print @_; 1574 } 1575 1576 *stash = *{"${packageName}::"}; 1577 $, = " "; 1578 1579 emit "Content-type: text/html\n\n<PRE>\n"; 1580 1581 1582 while ( ($varName, $globValue) = each %stash) { 1583 emit "$varName\n"; 1584 1585 *alias = $globValue; 1586 next if $varName=~/main/; 1587 1588 if (defined($alias) ) { 1589 emit " \$$varName $alias \n"; 1590 } 1591 1592 if ( defined(@alias) ) { 1593 emit " \@$varName @alias \n"; 1594 } 1595 if (defined(%alias) ) { 1596 emit " %$varName \n"; 1597 foreach $key (keys %alias) { 1598 emit " $key => $alias{$key}\n"; 1599 } 1600 1601 1602 1603 } 1604 } 1605 emit "</PRE></PRE>"; 1606 1607 1608 } 1609 use strict; 1610 1611 #### for error checking and debugging purposes 1612 sub pretty_print_rh { 1613 my $rh = shift; 1614 foreach my $key (sort keys %{$rh}) { 1615 warn " $key => ",$rh->{$key},"\n"; 1616 } 1617 } 1618 # end evaluation subroutines 1619 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |