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