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