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