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