Parent Directory
| 
Revision Log
Moved PGTranslator and IOGlue into WeBWorK::PG
1 package PGtranslator; 2 3 use strict; 4 use warnings; 5 use Opcode; 6 use Safe; 7 use Net::SMTP; 8 use IOGlue; 9 10 use Exporter; 11 use DynaLoader; 12 13 BEGIN { 14 sub be_strict { # allows the use of strict within macro packages. 15 require 'strict.pm'; 16 strict::import(); 17 } 18 } 19 20 my @class_modules = (); 21 22 sub new { 23 my $class = shift; 24 my $safe_cmpt = new Safe; #('PG_priv'); 25 my $self = { 26 envir => undef, 27 PG_PROBLEM_TEXT_ARRAY_REF => [], 28 PG_PROBLEM_TEXT_REF => 0, 29 PG_HEADER_TEXT_REF => 0, 30 PG_ANSWER_HASH_REF => {}, 31 PG_FLAGS_REF => {}, 32 safe => $safe_cmpt, 33 safe_compartment_name => $safe_cmpt->root, 34 errors => "", 35 source => "", 36 rh_correct_answers => {}, 37 rh_student_answers => {}, 38 rh_evaluated_answers => {}, 39 rh_problem_result => {}, 40 rh_problem_state => { 41 recorded_score => 0, # the score recorded in the data base 42 num_of_correct_ans => 0, # the number of correct attempts at doing the problem 43 num_of_incorrect_ans => 0, # the number of incorrect attempts 44 }, 45 rf_problem_grader => \&std_problem_grader, 46 rf_safety_filter => \&safetyFilter, 47 ra_included_modules => [ 48 @class_modules 49 ], 50 rh_directories => {}, 51 }; 52 bless $self, $class; 53 } 54 55 sub evaluate_modules{ 56 my $self = shift; 57 my @modules = @_; 58 # temporary - 59 # We need a method for setting the course directory without calling Global. 60 61 my $courseScriptsDirectory = $self->rh_directories->{courseScriptsDirectory}; 62 my $save_SIG_die_trap = $SIG{__DIE__}; 63 local $SIG{__DIE__} = sub {CORE::die(@_) }; 64 while (@modules) { 65 my $module_name = shift @modules; 66 $module_name =~ s/\.pm$//; # remove trailing .pm if someone forgot 67 if ($module_name eq 'reset' or $module_name eq 'erase' ) { 68 @class_modules = (); 69 next; 70 } 71 if ( -r "${courseScriptsDirectory}${module_name}.pm" ) { 72 eval(qq! require "${courseScriptsDirectory}${module_name}.pm"; import ${module_name};! ); 73 warn "Errors in including the module ${courseScriptsDirectory}$module_name.pm $@" if $@; 74 } else { 75 eval(qq! require "${module_name}.pm"; import ${module_name};! ); 76 warn "Errors in including either the module $module_name.pm or ${courseScriptsDirectory}${module_name}.pm $@" if $@; 77 } 78 push(@class_modules, "\%${module_name}::"); 79 print STDERR "loading $module_name\n"; 80 } 81 #$SIG{__DIE__} = $save_SIG_die_trap; 82 } 83 84 sub load_extra_packages{ 85 my $self = shift; 86 my @package_list = @_; 87 my $package_name; 88 89 foreach $package_name (@package_list) { 90 eval(qq! import ${package_name};! ); 91 warn "Errors in importing the package $package_name $@" if $@; 92 push(@class_modules, "\%${package_name}::"); 93 } 94 } 95 96 ############################################################################## 97 # SHARE variables and routines with safe compartment 98 my %shared_subroutine_hash = ( 99 '&read_whole_problem_file' => 'PGtranslator', #the values are dummies. 100 '&convertPath' => 'PGtranslator', 101 '&surePathToTmpFile' => 'PGtranslator', 102 '&fileFromPath' => 'PGtranslator', 103 '&directoryFromPath' => 'PGtranslator', 104 '&createFile' => 'PGtranslator', 105 '&PG_answer_eval' => 'PGtranslator', 106 '&PG_restricted_eval' => 'PGtranslator', 107 '&be_strict' => 'PGtranslator', 108 '&send_mail_to' => 'PGtranslator', 109 '&PGsort' => 'PGtranslator', 110 '&dumpvar' => 'PGtranslator', 111 '&includePGtext' => 'PGtranslator', 112 ); 113 114 sub initialize { 115 my $self = shift; 116 my $safe_cmpt = $self->{safe}; 117 #print "initializing safeCompartment",$safe_cmpt -> root(), "\n"; 118 119 $safe_cmpt -> share(keys %shared_subroutine_hash); 120 no strict; 121 local(%envir) = %{ $self ->{envir} }; 122 $safe_cmpt -> share('%envir'); 123 # local($rf_answer_eval) = sub { $self->PG_answer_eval(@_); }; 124 # local($rf_restricted_eval) = sub { $self->PG_restricted_eval(@_); }; 125 # $safe_cmpt -> share('$rf_answer_eval'); 126 # $safe_cmpt -> share('$rf_restricted_eval'); 127 128 use strict; 129 130 # end experiment 131 $self->{ra_included_modules} = [@class_modules]; 132 $safe_cmpt -> share_from('main', $self->{ra_included_modules} ); #$self ->{ra_included_modules} 133 134 } 135 136 sub environment{ 137 my $self = shift; 138 my $envirref = shift; 139 if ( defined($envirref) ) { 140 if (ref($envirref) eq 'HASH') { 141 %{ $self -> {envir} } = %$envirref; 142 } else { 143 $self ->{errors} .= "ERROR: The environment method for PG_translate objects requires a reference to a hash"; 144 } 145 } 146 $self->{envir} ; #reference to current environment 147 } 148 149 sub mask { 150 my $self = shift; 151 my $mask = shift; 152 my $safe_compartment = $self->{safe}; 153 $safe_compartment->mask($mask); 154 } 155 sub permit { 156 my $self = shift; 157 my @array = shift; 158 my $safe_compartment = $self->{safe}; 159 $safe_compartment->permit(@array); 160 } 161 sub deny { 162 163 my $self = shift; 164 my @array = shift; 165 my $safe_compartment = $self->{safe}; 166 $safe_compartment->deny(@array); 167 } 168 sub share_from { 169 my $self = shift; 170 my $pckg_name = shift; 171 my $array_ref =shift; 172 my $safe_compartment = $self->{safe}; 173 $safe_compartment->share_from($pckg_name,$array_ref); 174 } 175 176 sub source_string { 177 my $self = shift; 178 my $temp = shift; 179 my $out; 180 if ( ref($temp) eq 'SCALAR') { 181 $self->{source} = $$temp; 182 $out = $self->{source}; 183 } elsif ($temp) { 184 $self->{source} = $temp; 185 $out = $self->{source}; 186 } 187 $self -> {source}; 188 } 189 190 sub source_file { 191 my $self = shift; 192 my $filePath = shift; 193 local(*SOURCEFILE); 194 local($/); 195 $/ = undef; # allows us to treat the file as a single line 196 my $err = ""; 197 if ( open(SOURCEFILE, "<$filePath") ) { 198 $self -> {source} = <SOURCEFILE>; 199 close(SOURCEFILE); 200 } else { 201 $self->{errors} .= "Can't open file: $filePath"; 202 croak( "Can't open file: $filePath\n" ); 203 } 204 205 206 207 $err; 208 } 209 210 211 212 sub unrestricted_load { 213 my $self = shift; 214 my $filePath = shift; 215 my $safe_cmpt = $self ->{safe}; 216 my $store_mask = $safe_cmpt->mask(); 217 $safe_cmpt->mask(Opcode::empty_opset()); 218 my $safe_cmpt_package_name = $safe_cmpt->root(); 219 220 my $macro_file_name = fileFromPath($filePath); 221 $macro_file_name =~s/\.pl//; # trim off the extenstion 222 my $export_subroutine_name = "_${macro_file_name}_export"; 223 my $init_subroutine_name = "_${macro_file_name}_init"; 224 my $macro_file_loaded; 225 my $local_errors = ""; 226 no strict; 227 $macro_file_loaded = defined(&{"${safe_cmpt_package_name}::$init_subroutine_name"} ); 228 print STDERR "$macro_file_name has not yet been loaded\n" unless $macro_file_loaded; 229 unless ($macro_file_loaded) { 230 # print "loading $filePath\n"; 231 ## load the $filePath file 232 ## Using rdo insures that the $filePath file is loaded for every problem, allowing initializations to occur. 233 ## Ordinary mortals should not be fooling with the fundamental macros in these files. 234 my $local_errors = ""; 235 if (-r $filePath ) { 236 $safe_cmpt -> rdo( "$filePath" ) ; 237 #warn "There were problems compiling the file: $filePath: <BR>--$@" if $@; 238 $local_errors ="\nThere were problems compiling the file:\n $filePath\n $@\n" if $@; 239 $self ->{errors} .= $local_errors if $local_errors; 240 use strict; 241 } else { 242 $local_errors = "Can't open file $filePath for reading\n"; 243 $self ->{errors} .= $local_errors if $local_errors; 244 } 245 $safe_cmpt -> mask($store_mask); 246 247 } 248 $macro_file_loaded = defined(&{"${safe_cmpt_package_name}::$init_subroutine_name"} ); 249 $local_errors .= "\nUnknown error. Unable to load $filePath\n" if ($local_errors eq '' and not $macro_file_loaded); 250 print STDERR "$filePath is properly loaded\n\n" if $macro_file_loaded; 251 $local_errors; 252 } 253 254 sub nameSpace { 255 my $self = shift; 256 $self->{safe}->root; 257 } 258 259 sub a_text { 260 my $self = shift; 261 @{$self->{PG_PROBLEM_TEXT_ARRAY_REF}}; 262 } 263 264 sub header { 265 my $self = shift; 266 ${$self->{PG_HEADER_TEXT_REF}}; 267 } 268 269 sub h_flags { 270 my $self = shift; 271 %{$self->{PG_FLAGS_REF}}; 272 } 273 274 sub rh_flags { 275 my $self = shift; 276 $self->{PG_FLAGS_REF}; 277 } 278 sub h_answers{ 279 my $self = shift; 280 %{$self->{PG_ANSWER_HASH_REF}}; 281 } 282 283 sub ra_text { 284 my $self = shift; 285 $self->{PG_PROBLEM_TEXT_ARRAY_REF}; 286 287 } 288 289 sub r_text { 290 my $self = shift; 291 $self->{PG_PROBLEM_TEXT_REF}; 292 } 293 294 sub r_header { 295 my $self = shift; 296 $self->{PG_HEADER_TEXT_REF}; 297 } 298 299 sub rh_directories { 300 my $self = shift; 301 my $rh_directories = shift; 302 $self->{rh_directories}=$rh_directories if ref($rh_directories) eq 'HASH'; 303 $self->{rh_directories}; 304 } 305 306 sub rh_correct_answers { 307 my $self = shift; 308 my @in = @_; 309 return $self->{rh_correct_answers} if @in == 0; 310 311 if ( ref($in[0]) eq 'HASH' ) { 312 $self->{rh_correct_answers} = { %{ $in[0] } }; # store a copy of the hash 313 } else { 314 $self->{rh_correct_answers} = { @in }; # store a copy of the hash 315 } 316 $self->{rh_correct_answers} 317 } 318 319 sub rf_problem_grader { 320 my $self = shift; 321 my $in = shift; 322 return $self->{rf_problem_grader} unless defined($in); 323 if (ref($in) =~/CODE/ ) { 324 $self->{rf_problem_grader} = $in; 325 } else { 326 die "ERROR: Attempted to install a problem grader which was not a reference to a subroutine."; 327 } 328 $self->{rf_problem_grader} 329 } 330 331 332 sub errors{ 333 my $self = shift; 334 $self->{errors}; 335 } 336 337 ############################################################################## 338 339 ## restrict the operations allowed within the safe compartment 340 341 sub set_mask { 342 my $self = shift; 343 my $safe_cmpt = $self ->{safe}; 344 $safe_cmpt->mask(Opcode::full_opset()); # allow no operations 345 $safe_cmpt->permit(qw( :default )); 346 $safe_cmpt->permit(qw(time)); # used to determine whether solutions are visible. 347 $safe_cmpt->permit(qw( atan2 sin cos exp log sqrt )); 348 349 # just to make sure we'll deny some things specifically 350 $safe_cmpt->deny(qw(entereval)); 351 $safe_cmpt->deny(qw ( unlink symlink system exec )); 352 $safe_cmpt->deny(qw(print require)); 353 } 354 355 ############################################################################ 356 357 358 sub translate { 359 my $self = shift; 360 my @PROBLEM_TEXT_OUTPUT = (); 361 my $safe_cmpt = $self ->{safe}; 362 my $evalString = $self -> {source}; 363 $self ->{errors} .= qq{ERROR: This problem file was empty!\n} unless ($evalString) ; 364 $self ->{errors} .= qq{ERROR: You must define the environment before translating.} 365 unless defined( $self->{envir} ); 366 # reset the error detection 367 my $save_SIG_die_trap = $SIG{__DIE__}; 368 $SIG{__DIE__} = sub {CORE::die(@_) }; 369 370 ############################################################################ 371 372 373 ########################################## 374 ###### PG preprocessing code ############# 375 ########################################## 376 # BEGIN_TEXT and END_TEXT must occur on a line by themselves. 377 $evalString =~ s/\n\s*END_TEXT[\s;]*\n/\nEND_TEXT\n/g; 378 $evalString =~ s/\n\s*BEGIN_TEXT[\s;]*\n/\nTEXT\(EV3\(<<'END_TEXT'\)\);\n/g; 379 $evalString =~ s/ENDDOCUMENT.*/ENDDOCUMENT();/s; # remove text after ENDDOCUMENT 380 381 $evalString =~ s/\\/\\\\/g; # \ can't be used for escapes because of TeX conflict 382 $evalString =~ s/~~/\\/g; # use ~~ as escape instead, use # for comments 383 384 my ($PG_PROBLEM_TEXT_REF, $PG_HEADER_TEXT_REF, $PG_ANSWER_HASH_REF, $PG_FLAGS_REF) 385 =$safe_cmpt->reval(" $evalString"); 386 387 # This section could use some more error messages. In particular if a problem doesn't produce the right output, the user needs 388 # information about which problem was at fault. 389 # 390 # 391 392 $self->{errors} .= $@; 393 # push(@PROBLEM_TEXT_OUTPUT , split(/(\n)/,$$PG_PROBLEM_TEXT_REF) ) if defined($$PG_PROBLEM_TEXT_REF ); 394 push(@PROBLEM_TEXT_OUTPUT , split(/^/,$$PG_PROBLEM_TEXT_REF) ) if ref($PG_PROBLEM_TEXT_REF ) eq 'SCALAR'; 395 ## This is better than using defined($$PG_PROBLEM_TEXT_REF) 396 ## Because more pleasant feedback is given 397 ## when the problem doesn't render. 398 # try to get the \n to appear at the end of the line 399 400 use strict; 401 ############################################################################# 402 ########## end EVALUATION code ########### 403 ############################################################################# 404 405 ########################################## 406 ###### PG error processing code ########## 407 ########################################## 408 my (@input,$lineNumber,$line); 409 if ($self -> {errors}) { 410 #($self -> {errors}) =~ s/</</g; 411 #($self -> {errors}) =~ s/>/>/g; 412 #try to clean up errors so they will look ok 413 $self ->{errors} =~ s/\[.+?\.pl://gm; #erase [Fri Dec 31 12:58:30 1999] processProblem7.pl: 414 #$self -> {errors} =~ s/eval\s+'(.|[\n|r])*$//; 415 #end trying to clean up errors so they will look ok 416 417 418 push(@PROBLEM_TEXT_OUTPUT , qq!\n<A NAME="problem! . 419 $self->{envir} ->{'probNum'} . 420 qq!"><PRE> Problem!. 421 $self->{envir} ->{'probNum'}. 422 qq!\nERROR caught by PGtranslator while processing problem file:! . 423 $self->{envir}->{'probFileName'}. 424 "\n****************\r\n" . 425 $self -> {errors}."\r\n" . 426 "****************<BR>\n"); 427 428 push(@PROBLEM_TEXT_OUTPUT , "------Input Read\r\n"); 429 $self->{source} =~ s/</</g; 430 @input=split("\n", $self->{source}); 431 $lineNumber = 1; 432 foreach $line (@input) { 433 chomp($line); 434 push(@PROBLEM_TEXT_OUTPUT, "$lineNumber\t\t$line\r\n"); 435 $lineNumber ++; 436 } 437 push(@PROBLEM_TEXT_OUTPUT ,"\n-----<BR></PRE>\r\n"); 438 439 440 441 } 442 443 444 ## we need to make sure that the other output variables are defined 445 446 ## If the eval failed with errors, one or more of these variables won't be defined. 447 $PG_ANSWER_HASH_REF = {} unless defined($PG_ANSWER_HASH_REF); 448 $PG_HEADER_TEXT_REF = \( "" ) unless defined($PG_HEADER_TEXT_REF); 449 $PG_FLAGS_REF = {} unless defined($PG_FLAGS_REF); 450 451 $PG_FLAGS_REF->{'error_flag'} = 1 if $self -> {errors}; 452 my $PG_PROBLEM_TEXT = join("",@PROBLEM_TEXT_OUTPUT); 453 454 $self ->{ PG_PROBLEM_TEXT_REF } = \$PG_PROBLEM_TEXT; 455 $self ->{ PG_PROBLEM_TEXT_ARRAY_REF } = \@PROBLEM_TEXT_OUTPUT; 456 $self ->{ PG_HEADER_TEXT_REF } = $PG_HEADER_TEXT_REF; 457 $self ->{ rh_correct_answers } = $PG_ANSWER_HASH_REF; 458 $self ->{ PG_FLAGS_REF } = $PG_FLAGS_REF; 459 $SIG{__DIE__} = $save_SIG_die_trap; 460 $self ->{errors}; 461 } # end translate 462 463 464 sub rh_evaluated_answers { 465 my $self = shift; 466 my @in = @_; 467 return $self->{rh_evaluated_answers} if @in == 0; 468 469 if ( ref($in[0]) eq 'HASH' ) { 470 $self->{rh_evaluated_answers} = { %{ $in[0] } }; # store a copy of the hash 471 } else { 472 $self->{rh_evaluated_answers} = { @in }; # store a copy of the hash 473 } 474 $self->{rh_evaluated_answers}; 475 } 476 sub rh_problem_result { 477 my $self = shift; 478 my @in = @_; 479 return $self->{rh_problem_result} if @in == 0; 480 481 if ( ref($in[0]) eq 'HASH' ) { 482 $self->{rh_problem_result} = { %{ $in[0] } }; # store a copy of the hash 483 } else { 484 $self->{rh_problem_result} = { @in }; # store a copy of the hash 485 } 486 $self->{rh_problem_result}; 487 } 488 sub rh_problem_state { 489 my $self = shift; 490 my @in = @_; 491 return $self->{rh_problem_state} if @in == 0; 492 493 if ( ref($in[0]) eq 'HASH' ) { 494 $self->{rh_problem_state} = { %{ $in[0] } }; # store a copy of the hash 495 } else { 496 $self->{rh_problem_state} = { @in }; # store a copy of the hash 497 } 498 $self->{rh_problem_state}; 499 } 500 501 502 sub process_answers{ 503 my $self = shift; 504 my @in = @_; 505 my %h_student_answers; 506 if (ref($in[0]) eq 'HASH' ) { 507 %h_student_answers = %{ $in[0] }; #receiving a reference to a hash of answers 508 } else { 509 %h_student_answers = @in; # receiving a hash of answers 510 } 511 my $rh_correct_answers = $self->rh_correct_answers(); 512 my @answer_entry_order = ( defined($self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER}) ) ? 513 @{$self->{PG_FLAGS_REF}->{ANSWER_ENTRY_ORDER}} : keys %{$rh_correct_answers}; 514 515 # apply each instructors answer to the corresponding student answer 516 517 foreach my $ans_name ( @answer_entry_order ) { 518 my ($ans, $errors) = $self->filter_answer( $h_student_answers{$ans_name} ); 519 no strict; 520 # evaluate the answers inside the safe compartment. 521 local($rf_fun,$temp_ans) = (undef,undef); 522 if ( defined($rh_correct_answers ->{$ans_name} ) ) { 523 $rf_fun = $rh_correct_answers->{$ans_name}; 524 } else { 525 warn "There is no answer evaluator for the question labeled $ans_name"; 526 } 527 $temp_ans = $ans; 528 $temp_ans = '' unless defined($temp_ans); #make sure that answer is always defined 529 # in case the answer evaluator forgets to check 530 $self->{safe}->share('$rf_fun','$temp_ans'); 531 532 # reset the error detection 533 my $save_SIG_die_trap = $SIG{__DIE__}; 534 $SIG{__DIE__} = sub {CORE::die(@_) }; 535 my $rh_ans_evaluation_result; 536 if (ref($rf_fun) eq 'CODE' ) { 537 $rh_ans_evaluation_result = $self->{safe} ->reval( '&{ $rf_fun }($temp_ans)' ) ; 538 warn "Error in PGtranslator.pm::process_answers: Answer $ans_name:<BR>\n $@\n" if $@; 539 } elsif (ref($rf_fun) eq 'AnswerEvaluator') { 540 $rh_ans_evaluation_result = $self->{safe} ->reval('$rf_fun->evaluate($temp_ans)'); 541 warn "Error in PGtranslator.pm::process_answers: Answer $ans_name:<BR>\n $@\n" if $@; 542 warn "Evaluation error: Answer $ans_name:<BR>\n", $rh_ans_evaluation_result->error_flag(), " :: ",$rh_ans_evaluation_result->error_message(),"<BR>\n" 543 if defined($rh_ans_evaluation_result) and defined($rh_ans_evaluation_result->error_flag()); 544 } else { 545 warn "Error in PGtranslator5.pm::process_answers: Answer $ans_name:<BR>\n Unrecognized evaluator type |", ref($rf_fun), "|"; 546 } 547 548 $SIG{__DIE__} = $save_SIG_die_trap; 549 550 551 use strict; 552 unless ( ( ref($rh_ans_evaluation_result) eq 'HASH') or ( ref($rh_ans_evaluation_result) eq 'AnswerHash') ) { 553 warn "Error in PGtranslator5.pm::process_answers: Answer $ans_name:<BR>\n 554 Answer evaluators must return a hash or an AnswerHash type, not type |", 555 ref($rh_ans_evaluation_result), "|"; 556 } 557 $rh_ans_evaluation_result ->{ans_message} .= "$errors \n" if $errors; 558 $rh_ans_evaluation_result ->{ans_name} = $ans_name; 559 $self->{rh_evaluated_answers}->{$ans_name} = $rh_ans_evaluation_result; 560 561 } 562 $self->rh_evaluated_answers; 563 564 } 565 566 sub grade_problem { 567 my $self = shift; 568 my %form_options = @_; 569 my $rf_grader = $self->{rf_problem_grader}; 570 ($self->{rh_problem_result},$self->{rh_problem_state} ) = 571 &{$rf_grader}( $self -> {rh_evaluated_answers}, 572 $self -> {rh_problem_state}, 573 %form_options 574 ); 575 576 ($self->{rh_problem_result}, $self->{rh_problem_state} ) ; 577 } 578 579 sub rf_std_problem_grader { 580 my $self = shift; 581 return \&std_problem_grader; 582 } 583 sub old_std_problem_grader{ 584 my $rh_evaluated_answers = shift; 585 my %flags = @_; # not doing anything with these yet 586 my %evaluated_answers = %{$rh_evaluated_answers}; 587 my $allAnswersCorrectQ=1; 588 foreach my $ans_name (keys %evaluated_answers) { 589 # I'm not sure if this check is really useful. 590 if (ref($evaluated_answers{$ans_name} ) eq 'HASH' ) { 591 $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} ); 592 } else { 593 warn "Error: Answer $ans_name is not a hash"; 594 warn "$evaluated_answers{$ans_name}"; 595 } 596 } 597 # Notice that "all answers are correct" if there are no questions. 598 { score => $allAnswersCorrectQ, 599 prev_tries => 0, 600 partial_credit => $allAnswersCorrectQ, 601 errors => "", 602 type => 'old_std_problem_grader', 603 flags => {}, # not doing anything with these yet 604 }; # hash output 605 606 } 607 608 ##################################### 609 # This is a model for plug-in problem graders 610 ##################################### 611 612 sub std_problem_grader{ 613 my $rh_evaluated_answers = shift; 614 my $rh_problem_state = shift; 615 my %form_options = @_; 616 my %evaluated_answers = %{$rh_evaluated_answers}; 617 # The hash $rh_evaluated_answers typically contains: 618 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 619 620 # By default the old problem state is simply passed back out again. 621 my %problem_state = %$rh_problem_state; 622 623 624 # %form_options might include 625 # The user login name 626 # The permission level of the user 627 # The studentLogin name for this psvn. 628 # Whether the form is asking for a refresh or is submitting a new answer. 629 630 # initial setup of the answer 631 my %problem_result = ( score => 0, 632 errors => '', 633 type => 'std_problem_grader', 634 msg => '', 635 ); 636 # Checks 637 638 my $ansCount = keys %evaluated_answers; # get the number of answers 639 unless ($ansCount > 0 ) { 640 $problem_result{msg} = "This problem did not ask any questions."; 641 return(\%problem_result,\%problem_state); 642 } 643 644 if ($ansCount > 1 ) { 645 $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' ; 646 } 647 648 unless (defined( $form_options{answers_submitted}) and $form_options{answers_submitted} == 1) { 649 return(\%problem_result,\%problem_state); 650 } 651 652 my $allAnswersCorrectQ=1; 653 foreach my $ans_name (keys %evaluated_answers) { 654 # I'm not sure if this check is really useful. 655 if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) { 656 $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} ); 657 } else { 658 warn "Error: Answer $ans_name is not a hash"; 659 warn "$evaluated_answers{$ans_name}"; 660 warn "This probably means that the answer evaluator is for this answer is not working correctly."; 661 $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; 662 } 663 } 664 # report the results 665 $problem_result{score} = $allAnswersCorrectQ; 666 667 # I don't like to put in this bit of code. 668 # It makes it hard to construct error free problem graders 669 # I would prefer to know that the problem score was numeric. 670 unless ($problem_state{recorded_score} =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ) { 671 $problem_state{recorded_score} = 0; # This gets rid of non-numeric scores 672 } 673 # 674 if ($allAnswersCorrectQ == 1 or $problem_state{recorded_score} == 1) { 675 $problem_state{recorded_score} = 1; 676 } else { 677 $problem_state{recorded_score} = 0; 678 } 679 680 $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1; 681 $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0; 682 (\%problem_result, \%problem_state); 683 } 684 sub rf_avg_problem_grader { 685 my $self = shift; 686 return \&avg_problem_grader; 687 } 688 sub avg_problem_grader{ 689 my $rh_evaluated_answers = shift; 690 my $rh_problem_state = shift; 691 my %form_options = @_; 692 my %evaluated_answers = %{$rh_evaluated_answers}; 693 # The hash $rh_evaluated_answers typically contains: 694 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 695 696 # By default the old problem state is simply passed back out again. 697 my %problem_state = %$rh_problem_state; 698 699 700 # %form_options might include 701 # The user login name 702 # The permission level of the user 703 # The studentLogin name for this psvn. 704 # Whether the form is asking for a refresh or is submitting a new answer. 705 706 # initial setup of the answer 707 my $total=0; 708 my %problem_result = ( score => 0, 709 errors => '', 710 type => 'avg_problem_grader', 711 msg => '', 712 ); 713 my $count = keys %evaluated_answers; 714 $problem_result{msg} = 'You can earn partial credit on this problem.' if $count >1; 715 # Return unless answers have been submitted 716 unless ($form_options{answers_submitted} == 1) { 717 return(\%problem_result,\%problem_state); 718 } 719 # Answers have been submitted -- process them. 720 foreach my $ans_name (keys %evaluated_answers) { 721 $total += $evaluated_answers{$ans_name}->{score}; 722 } 723 # Calculate score rounded to three places to avoid roundoff problems 724 $problem_result{score} = $total/$count if $count; 725 # increase recorded score if the current score is greater. 726 $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score}; 727 728 729 $problem_state{num_of_correct_ans}++ if $total == $count; 730 $problem_state{num_of_incorrect_ans}++ if $total < $count ; 731 warn "Error in grading this problem the total $total is larger than $count" if $total > $count; 732 (\%problem_result, \%problem_state); 733 734 } 735 =head3 safetyFilter 736 737 ($filtered_ans, $errors) = $obj ->filter_ans($ans) 738 $obj ->rf_safety_filter() 739 740 =cut 741 742 sub filter_answer { 743 my $self = shift; 744 my $ans = shift; 745 my @filtered_answers; 746 my $errors=''; 747 if (ref($ans) eq 'ARRAY') { #handle the case where the answer comes from several inputs with the same name 748 # In many cases this will be passed as a reference to an array 749 # if it is passed as a single string (separated by \0 characters) as 750 # some early versions of CGI behave, then 751 # it is unclear what will happen when the answer is filtered. 752 foreach my $item (@{$ans}) { 753 my ($filtered_ans, $error) = &{ $self->{rf_safety_filter} } ($item); 754 push(@filtered_answers, $filtered_ans); 755 $errors .= " ". $error if $error; # add error message if error is non-zero. 756 } 757 (\@filtered_answers,$errors); 758 759 } else { 760 &{ $self->{rf_safety_filter} } ($ans); 761 } 762 763 } 764 sub rf_safety_filter { 765 my $self = shift; 766 my $rf_filter = shift; 767 $self->{rf_safety_filter} = $rf_filter if $rf_filter and ref($rf_filter) eq 'CODE'; 768 warn "The safety_filter must be a reference to a subroutine" unless ref($rf_filter) eq 'CODE' ; 769 $self->{rf_safety_filter} 770 } 771 sub safetyFilter { 772 my $answer = shift; # accepts one answer and checks it 773 my $submittedAnswer = $answer; 774 $answer = '' unless defined $answer; 775 my ($errorno); 776 $answer =~ tr/\000-\037/ /; 777 #### Return if answer field is empty ######## 778 unless ($answer =~ /\S/) { 779 # $errorno = "<BR>No answer was submitted."; 780 $errorno = 0; ## don't report blank answer as error 781 782 return ($answer,$errorno); 783 } 784 ######### replace ^ with ** (for exponentiation) 785 # $answer =~ s/\^/**/g; 786 ######### Return if forbidden characters are found 787 unless ($answer =~ /^[a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)]+$/ ) { 788 $answer =~ tr/a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)/#/c; 789 $errorno = "<BR>There are forbidden characters in your answer: $submittedAnswer<BR>"; 790 791 return ($answer,$errorno); 792 } 793 794 $errorno = 0; 795 return($answer, $errorno); 796 } 797 798 sub PGsort { 799 my $sort_order = shift; 800 die "Must supply an ordering function with PGsort: PGsort sub {\$a cmp \$b }, \@list\n" unless ref($sort_order) eq 'CODE'; 801 sort {&$sort_order($a,$b)} @_; 802 } 803 804 no strict; # this is important -- I guess because eval operates on code which is not written with strict in mind. 805 806 sub PG_restricted_eval { 807 my $string = shift; 808 my ($pck,$file,$line) = caller; 809 my $save_SIG_warn_trap = $SIG{__WARN__}; 810 $SIG{__WARN__} = sub { CORE::die @_}; 811 my $save_SIG_die_trap = $SIG{__DIE__}; 812 $SIG{__DIE__}= sub {CORE::die @_}; 813 no strict; 814 my $out = eval ("package main; " . $string ); 815 my $errors =$@; 816 my $full_error_report = "PG_restricted_eval detected error at line $line of file $file \n" 817 . $errors . 818 "The calling package is $pck\n" if defined($errors) && $errors =~/\S/; 819 use strict; 820 $SIG{__DIE__} = $save_SIG_die_trap; 821 $SIG{__WARN__} = $save_SIG_warn_trap; 822 return (wantarray) ? ($out, $errors,$full_error_report) : $out; 823 } 824 825 sub PG_answer_eval { 826 local($string) = shift; # I made this local just in case -- see PG_estricted_eval 827 my $errors = ''; 828 my $full_error_report = ''; 829 my ($pck,$file,$line) = caller; 830 # Because of the global variable $PG::compartment_name and $PG::safe_cmpt 831 # only one problem safe compartment can be active at a time. 832 # This might cause problems at some point. In that case a cleverer way 833 # of insuring that the package stays in scope until the answer is evaluated 834 # will be required. 835 836 # This is pretty tricky and doesn't always work right. 837 # We seem to need PG_priv instead of main when PG_answer_eval is called within a completion 838 # 'package PG_priv; ' 839 my $save_SIG_warn_trap = $SIG{__WARN__}; 840 $SIG{__WARN__} = sub { CORE::die @_}; 841 my $save_SIG_die_trap = $SIG{__DIE__}; 842 $SIG{__DIE__}= sub {CORE::die @_}; 843 my $save_SIG_FPE_trap= $SIG{'FPE'}; 844 #$SIG{'FPE'} = \&main::PG_floating_point_exception_handler; 845 #$SIG{'FPE'} = sub {exit(0)}; 846 no strict; 847 my $out = eval('package main;'.$string); 848 $out = '' unless defined($out); 849 $errors .=$@; 850 851 $full_error_report = "ERROR: at line $line of file $file 852 $errors 853 The calling package is $pck\n" if defined($errors) && $errors =~/\S/; 854 use strict; 855 $SIG{__DIE__} = $save_SIG_die_trap; 856 $SIG{__WARN__} = $save_SIG_warn_trap; 857 $SIG{'FPE'} = $save_SIG_FPE_trap; 858 return (wantarray) ? ($out, $errors,$full_error_report) : $out; 859 860 861 } 862 863 sub dumpvar { 864 my ($packageName) = @_; 865 866 local(*alias); 867 868 sub emit { 869 print @_; 870 } 871 872 *stash = *{"${packageName}::"}; 873 $, = " "; 874 875 emit "Content-type: text/html\n\n<PRE>\n"; 876 877 878 while ( ($varName, $globValue) = each %stash) { 879 emit "$varName\n"; 880 881 *alias = $globValue; 882 next if $varName=~/main/; 883 884 if (defined($alias) ) { 885 emit " \$$varName $alias \n"; 886 } 887 888 if ( defined(@alias) ) { 889 emit " \@$varName @alias \n"; 890 } 891 if (defined(%alias) ) { 892 emit " %$varName \n"; 893 foreach $key (keys %alias) { 894 emit " $key => $alias{$key}\n"; 895 } 896 897 898 899 } 900 } 901 emit "</PRE></PRE>"; 902 903 904 } 905 use strict; 906 907 #### for error checking and debugging purposes 908 sub pretty_print_rh { 909 my $rh = shift; 910 foreach my $key (sort keys %{$rh}) { 911 warn " $key => ",$rh->{$key},"\n"; 912 } 913 } 914 # end evaluation subroutines 915 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |