[system] / trunk / webwork2 / lib / WeBWorK / ContentGenerator / Problem.pm Repository:
ViewVC logotype

Diff of /trunk/webwork2/lib/WeBWorK/ContentGenerator/Problem.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 398 Revision 818
1################################################################################
2# WeBWorK mod_perl (c) 2000-2002 WeBWorK Project
3# $Id$
4################################################################################
5
1package WeBWorK::ContentGenerator::Problem; 6package WeBWorK::ContentGenerator::Problem;
2our @ISA = qw(WeBWorK::ContentGenerator); 7use base qw(WeBWorK::ContentGenerator);
8
9=head1 NAME
10
11WeBWorK::ContentGenerator::Problem - Allow a student to interact with a problem.
12
13=cut
3 14
4use strict; 15use strict;
5use warnings; 16use warnings;
6use lib '/home/malsyned/xmlrpc/daemon'; 17use CGI qw();
7use lib '/Users/gage/webwork-modperl/lib'; 18use File::Temp qw(tempdir);
8use PGtranslator5; 19use WeBWorK::Form;
9use WeBWorK::ContentGenerator; 20use WeBWorK::PG;
10use Apache::Constants qw(:common); 21use WeBWorK::PG::IO;
22use WeBWorK::Utils qw(writeLog encodeAnswers decodeAnswers ref2string);
11 23
12############################################################################### 24############################################################
13# Configuration 25#
26# user
27# effectiveUser
28# key
29#
30# displayMode
31# showOldAnswers
32# showCorrectAnswers
33# showHints
34# showSolutions
35#
36# AnSwEr# - answer blanks in problem
37#
38# redisplay - name of the "Redisplay Problem" button
39# submitAnswers - name of "Submit Answers" button
40# checkAnswers - name of the "Check Answers" button
41# previewAnswers - name of the "Preview Answers" button
42#
14############################################################################### 43############################################################
15my $USER_DIRECTORY = '/Users/gage';
16my $COURSE_SCRIPTS_DIRECTORY = "$USER_DIRECTORY/webwork/system/courseScripts/";
17my $MACRO_DIRECTORY = "$USER_DIRECTORY/webwork-modperl/courses/demoCourse/templates/macros/";
18my $TEMPLATE_DIRECTORY = "$USER_DIRECTORY/rochester_problib/";
19my $TEMP_URL = "http://127.0.0.1/~gage/rochester_problibtmp/";
20##my $HTML_DIRECTORY = "/Users/gage/Sites/rochester_problib/" #already obtained from courseEnvironment
21my $HTML_URL = "http://127.0.0.1/~gage/rochester_problib/";
22my $TEMP_DIRECTORY = ""; # has to be here... for now
23 44
24############################################################################### 45sub pre_header_initialize {
25# End configuration 46 my ($self, $setName, $problemNumber) = @_;
26############################################################################### 47 my $r = $self->{r};
48 my $courseEnv = $self->{ce};
49 my $db = $self->{db};
50 my $userName = $r->param('user');
51 my $effectiveUserName = $r->param('effectiveUser');
52
53 my $user = $db->getUser($userName);
54 my $effectiveUser = $db->getUser($effectiveUserName);
55 my $set = $db->getGlobalUserSet($effectiveUserName, $setName);
56 my $problem = $db->getGlobalUserProblem($effectiveUserName, $setName, $problemNumber);
57 my $psvn = $set->psvn();
58 my $permissionLevel = $db->getPermissionLevel($userName)->permission();
59
60 $self->{userName} = $userName;
61 $self->{user} = $user;
62 $self->{effectiveUser} = $effectiveUser;
63 $self->{set} = $set;
64 $self->{problem} = $problem;
65 $self->{permissionLevel} = $permissionLevel;
66
67 ##### form processing #####
68
69 # set options from form fields (see comment at top of file for names)
70 my $displayMode = $r->param("displayMode") || $courseEnv->{pg}->{options}->{displayMode};
71 my $redisplay = $r->param("redisplay");
72 my $submitAnswers = $r->param("submitAnswers");
73 my $checkAnswers = $r->param("checkAnswers");
74 my $previewAnswers = $r->param("previewAnswers");
75
76 # coerce form fields into CGI::Vars format
77 my $formFields = { WeBWorK::Form->new_from_paramable($r)->Vars };
78
79 $self->{displayMode} = $displayMode;
80 $self->{redisplay} = $redisplay;
81 $self->{submitAnswers} = $submitAnswers;
82 $self->{checkAnswers} = $checkAnswers;
83 $self->{previewAnswers} = $previewAnswers;
84 $self->{formFields} = $formFields;
85
86 ##### permissions #####
87
88 # are we allowed to view this problem?
89 $self->{isOpen} = time >= $set->open_date || $permissionLevel > 0;
90 return unless $self->{isOpen};
91
92 # what does the user want to do?
93 my %want = (
94 showOldAnswers => $r->param("showOldAnswers") || $courseEnv->{pg}->{options}->{showOldAnswers},
95 showCorrectAnswers => $r->param("showCorrectAnswers") || $courseEnv->{pg}->{options}->{showCorrectAnswers},
96 showHints => $r->param("showHints") || $courseEnv->{pg}->{options}->{showHints},
97 showSolutions => $r->param("showSolutions") || $courseEnv->{pg}->{options}->{showSolutions},
98 recordAnswers => $submitAnswers,
99 checkAnswers => $checkAnswers,
100 );
101
102 # are certain options enforced?
103 my %must = (
104 showOldAnswers => 0,
105 showCorrectAnswers => 0,
106 showHints => 0,
107 showSolutions => 0,
108 recordAnswers => mustRecordAnswers($permissionLevel),
109 checkAnswers => 0,
110 );
111
112 # does the user have permission to use certain options?
113 my %can = (
114 showOldAnswers => 1,
115 showCorrectAnswers => canShowCorrectAnswers($permissionLevel, $set->answer_date),
116 showHints => 1,
117 showSolutions => canShowSolutions($permissionLevel, $set->answer_date),
118 recordAnswers => canRecordAnswers($permissionLevel, $set->open_date, $set->due_date,
119 $problem->max_attempts, $problem->num_correct + $problem->num_incorrect + 1),
120 # attempts=num_correct+num_incorrect+1, as this happens before updating $problem
121 checkAnswers => canCheckAnswers($permissionLevel, $set->answer_date),
122 );
123
124 # final values for options
125 my %will;
126 foreach (keys %must) {
127 $will{$_} = $can{$_} && ($want{$_} || $must{$_});
128 }
129
130 ##### sticky answers #####
131
132 if (not $submitAnswers and $will{showOldAnswers}) {
133 # do this only if new answers are NOT being submitted
134 my %oldAnswers = decodeAnswers($problem->last_answer);
135 $formFields->{$_} = $oldAnswers{$_} foreach keys %oldAnswers;
136 }
137
138 ##### translation #####
139
140 my $pg = WeBWorK::PG->new(
141 $courseEnv,
142 $effectiveUser,
143 $r->param('key'),
144 $set,
145 $problem,
146 $psvn,
147 $formFields,
148 { # translation options
149 displayMode => $displayMode,
150 showHints => $will{showHints},
151 showSolutions => $will{showSolutions},
152 refreshMath2img => $will{showHints} || $will{showSolutions},
153 processAnswers => 1,
154 },
155 );
156
157 ##### fix hint/solution options #####
158
159 $can{showHints} &&= $pg->{flags}->{hintExists};
160 $can{showSolutions} &&= $pg->{flags}->{solutionExists};
161
162 ##### store fields #####
163
164 $self->{want} = \%want;
165 $self->{must} = \%must;
166 $self->{can} = \%can;
167 $self->{will} = \%will;
168
169 $self->{pg} = $pg;
170}
171
172sub if_warnings($$) {
173 my ($self, $arg) = @_;
174 return 0 unless $self->{isOpen};
175 return $self->{pg}->{warnings} ne "";
176}
177
178sub if_errors($$) {
179 my ($self, $arg) = @_;
180 return 0 unless $self->{isOpen};
181 return $self->{pg}->{flags}->{error_flag};
182}
183
184sub head {
185 my $self = shift;
186 return "" unless $self->{isOpen};
187 return $self->{pg}->{head_text} if $self->{pg}->{head_text};
188}
189
190sub path {
191 my $self = shift;
192 my $args = $_[-1];
193 my $setName = $self->{set}->set_id;
194 my $problemNumber = $self->{problem}->problem_id;
195
196 my $ce = $self->{ce};
197 my $root = $ce->{webworkURLs}->{root};
198 my $courseName = $ce->{courseName};
199 return $self->pathMacro($args,
200 "Home" => "$root",
201 $courseName => "$root/$courseName",
202 $setName => "$root/$courseName/$setName",
203 "Problem $problemNumber" => "",
204 );
205}
206
207sub siblings {
208 my $self = shift;
209 my $setName = $self->{set}->set_id;
210 my $problemNumber = $self->{problem}->problem_id;
211
212 my $ce = $self->{ce};
213 my $db = $self->{db};
214 my $root = $ce->{webworkURLs}->{root};
215 my $courseName = $ce->{courseName};
216
217 print CGI::strong("Problems"), CGI::br();
218
219 my $effectiveUser = $self->{r}->param("effectiveUser");
220 my @problems;
221 push @problems, $db->getGlobalUserProblem($effectiveUser, $setName, $_)
222 foreach ($db->listUserProblems($effectiveUser, $setName));
223 foreach my $problem (sort { $a->problem_id <=> $b->problem_id } @problems) {
224 print CGI::a({-href=>"$root/$courseName/$setName/".$problem->problem_id."/?"
225 . $self->url_authen_args . "&displayMode=" . $self->{displayMode}},
226 "Problem ".$problem->problem_id), CGI::br();
227 }
228}
229
230sub nav {
231 my $self = shift;
232 my $args = $_[-1];
233 my $setName = $self->{set}->set_id;
234 my $problemNumber = $self->{problem}->problem_id;
235
236 my $ce = $self->{ce};
237 my $db = $self->{db};
238 my $root = $ce->{webworkURLs}->{root};
239 my $courseName = $ce->{courseName};
240
241 my $wwdb = $self->{wwdb};
242 my $effectiveUser = $self->{r}->param("effectiveUser");
243 my $tail = "&displayMode=".$self->{displayMode};
244
245 my @links = ("Problem List" , "$root/$courseName/$setName", "navProbList");
246
247 my $prevProblem = $db->getGlobalUserProblem($effectiveUser, $setName, $problemNumber-1);
248 my $nextProblem = $db->getGlobalUserProblem($effectiveUser, $setName, $problemNumber+1);
249 unshift @links, "Previous Problem" , ($prevProblem
250 ? "$root/$courseName/$setName/".$prevProblem->problem_id
251 : "") , "navPrev";
252 push @links, "Next Problem" , ($nextProblem
253 ? "$root/$courseName/$setName/".$nextProblem->problem_id
254 : "") , "navNext";
255
256 return $self->navMacro($args, $tail, @links);
257}
27 258
28sub title { 259sub title {
29 my ($self, $problem_set, $problem) = @_; 260 my $self = shift;
30 my $r = $self->{r}; 261 my $setName = $self->{set}->set_id;
31 my $user = $r->param('user'); 262 my $problemNumber = $self->{problem}->problem_id;
32 return "Problem $problem of problem set $problem_set for $user"; 263
264 return "$setName : Problem $problemNumber";
33} 265}
34 266
35############################################################################### 267sub body {
36# 268 my $self = shift;
37# INITIALIZATION 269
38# 270 return CGI::p(CGI::font({-color=>"red"}, "This problem is not available because the problem set that contains it is not yet open."))
39# The following code initializes an instantiation of PGtranslator5 in the 271 unless $self->{isOpen};
40# parent process. This initialized object is then share with each of the 272
41# children forked from this parent process by the daemon. 273 # unpack some useful variables
42# 274 my $r = $self->{r};
43# As far as I can tell, the child processes don't share any variable values even 275 my $db = $self->{db};
44# though their namespaces are the same. 276 my $set = $self->{set};
45############################################################################### 277 my $problem = $self->{problem};
46# First some dummy values to use for testing. 278 my $permissionLevel = $self->{permissionLevel};
47# These should be available from the problemEnvironment(it might be ok to assume that PG and dangerousMacros 279 my $submitAnswers = $self->{submitAnswers};
48# live in the courseScripts (system level macros) directory. 280 my $checkAnswers = $self->{checkAnswers};
49 281 my $previewAnswers = $self->{previewAnswers};
50#print STDERR "Begin intitalization\n"; 282 my %want = %{ $self->{want} };
51my $dummy_envir = { courseScriptsDirectory => $COURSE_SCRIPTS_DIRECTORY, 283 my %can = %{ $self->{can} };
52 displayMode => 'HTML_tth', 284 my %must = %{ $self->{must} };
53 macroDirectory => $MACRO_DIRECTORY, 285 my %will = %{ $self->{will} };
54 cgiURL => 'foo_cgiURL'}; 286 my $pg = $self->{pg};
55 287
56 288 ##### translation errors? #####
57my $PG_PL = "${COURSE_SCRIPTS_DIRECTORY}PG.pl"; 289
58my $DANGEROUS_MACROS_PL = "${COURSE_SCRIPTS_DIRECTORY}dangerousMacros.pl"; 290 if ($pg->{flags}->{error_flag}) {
59my @MODULE_LIST = ( "Exporter", "DynaLoader", "GD", "WWPlot", "Fun", 291 return $self->errorOutput($pg->{errors}, $pg->{body_text});
60 "Circle", "Label", "PGrandom", "Units", "Hermite", 292 }
61 "List", "Match","Multiple", "Select", "AlgParser", 293
62 "AnswerHash", "Fraction", "VectorField", "Complex1", 294 ##### answer processing #####
63 "Complex", "MatrixReal1", "Matrix","Distributions", 295
64 "Regression" 296 # if answers were submitted:
65); 297 if ($submitAnswers) {
66my @EXTRA_PACKAGES = ( "AlgParserWithImplicitExpand", "Expr", 298 # get a "pure" (unmerged) UserProblem to modify
67 "ExprWithImplicitExpand", "AnswerEvaluator", 299 my $pureProblem = $db->getUserProblem($problem->user_id, $problem->set_id, $problem->problem_id);
68 300 # store answers in DB for sticky answers
69); 301 my %answersToStore;
70my $INITIAL_MACRO_PACKAGES = <<END_OF_TEXT; 302 my %answerHash = %{ $pg->{answers} };
71 DOCUMENT(); 303 $answersToStore{$_} = $answerHash{$_}->{original_student_ans}
72 loadMacros( 304 foreach (keys %answerHash);
73 "PGbasicmacros.pl", 305 my $answerString = encodeAnswers(%answersToStore,
74 "PGchoicemacros.pl", 306 @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} });
75 "PGanswermacros.pl", 307 $pureProblem->last_answer($answerString);
76 "PGnumericalmacros.pl", 308 $problem->last_answer($answerString);
77 "PGgraphmacros.pl", 309 $db->putUserProblem($pureProblem);
78 "PGauxiliaryFunctions.pl",
79 "PGmatrixmacros.pl",
80 "PGcomplexmacros.pl",
81 "PGstatisticsmacros.pl"
82 310
311 # store state in DB if it makes sense
312 if ($will{recordAnswers}) {
313 $problem->status($pg->{state}->{recorded_score});
314 $problem->attempted(1);
315 $problem->num_correct($pg->{state}->{num_of_correct_ans});
316 $problem->num_incorrect($pg->{state}->{num_of_incorrect_ans});
317 $pureProblem->status($pg->{state}->{recorded_score});
318 $pureProblem->attempted(1);
319 $pureProblem->num_correct($pg->{state}->{num_of_correct_ans});
320 $pureProblem->num_incorrect($pg->{state}->{num_of_incorrect_ans});
321 $db->putUserProblem($pureProblem);
322 # write to the transaction log, just to make sure
323 writeLog($self->{ce}, "transaction",
324 $problem->problem_id."\t".
325 $problem->set_id."\t".
326 $problem->user_id."\t".
327 $problem->source_file."\t".
328 $problem->value."\t".
329 $problem->max_attempts."\t".
330 $problem->problem_seed."\t".
331 $pureProblem->status."\t".
332 $pureProblem->attempted."\t".
333 $pureProblem->last_answer."\t".
334 $pureProblem->num_correct."\t".
335 $pureProblem->num_incorrect
336 );
337 }
338 }
339 # logging student answers
340 my $pastAnswerLog = undef;
341 if (defined( $self->{ce}->{webworkFiles}->{logs}->{'pastAnswerList'} )) {
342
343 $pastAnswerLog = $self->{ce}->{webworkFiles}->{logs}->{'pastAnswerList'};
344
345 if ($submitAnswers and defined($pastAnswerLog) ) {
346 my $answerString = "";
347 my %answerHash = %{ $pg->{answers} };
348 $answerString = $answerString . $answerHash{$_}->{original_student_ans}."\t"
349 foreach (sort keys %answerHash);
350 writeLog($self->{ce}, "pastAnswerList",
351 '|'.$problem->user_id.
352 '|'.$problem->set_id.
353 '|'.$problem->problem_id.'|'."\t".
354 time()."\t".
355 $answerString,
356
357 );
358
359 }
360
361 }
362 # end logging student answers
363
364 ##### output #####
365 print CGI::start_div({class=>"problemHeader"});
366 # attempt summary
367 if ($submitAnswers or $will{showCorrectAnswers}) {
368 # print this if user submitted answers OR requested correct answers
369 print $self->attemptResults($pg, $submitAnswers,
370 $will{showCorrectAnswers},
371 $pg->{flags}->{showPartialCorrectAnswers}, 1, 0);
372 } elsif ($checkAnswers) {
373 # print this if user previewed answers
374 print $self->attemptResults($pg, 1, 0, 1, 1, 0);
375 # show attempt answers
376 # don't show correct answers
377 # show attempt results (correctness)
378 # don't show attempt previews
379 } elsif ($previewAnswers) {
380 # print this if user previewed answers
381 print $self->attemptResults($pg, 1, 0, 0, 0, 1);
382 # show attempt answers
383 # don't show correct answers
384 # don't show attempt results (correctness)
385 # show attempt previews
386 }
387
388 print CGI::end_div();
389
390 print CGI::start_div({class=>"problem"});
391 #print CGI::hr();
392 # main form
393 print
394 CGI::startform("POST", $r->uri),
395 $self->hidden_authen_fields,
396 CGI::p($pg->{body_text}),
397 CGI::p($pg->{result}->{msg} ? CGI::b("Note: ") : "", CGI::i($pg->{result}->{msg})),
398 CGI::p(
399 ($can{recordAnswers}
400 ? CGI::submit(-name=>"submitAnswers",
401 -label=>"Submit Answers")
402 : ""),
403 ($can{checkAnswers}
404 ? CGI::submit(-name=>"checkAnswers",
405 -label=>"Check Answers")
406 : ""),
407 CGI::submit(-name=>"previewAnswers",
408 -label=>"Preview Answers"),
83 ); 409 );
410 print CGI::end_div();
411
412 print CGI::start_div({class=>"scoreSummary"});
413 # score summary
414 my $attempts = $problem->num_correct + $problem->num_incorrect;
415 my $attemptsNoun = $attempts != 1 ? "times" : "time";
416 my $lastScore = int ($problem->status * 100) . "%";
417 my ($attemptsLeft, $attemptsLeftNoun);
418 if ($problem->max_attempts == -1) {
419 # unlimited attempts
420 $attemptsLeft = "unlimited";
421 $attemptsLeftNoun = "attempts";
422 } else {
423 $attemptsLeft = $problem->max_attempts - $attempts;
424 $attemptsLeftNoun = $attemptsLeft == 1 ? "attempt" : "attempts";
425 }
426
427 my $setClosed = 0;
428 my $setClosedMessage;
429 if (time < $set->open_date or time > $set->due_date) {
430 $setClosed = 1;
431 $setClosedMessage = "This problem set is closed.";
432 if ($permissionLevel > 0) {
433 $setClosedMessage .= " Since you are a privileged user, additional attempts will be recorded.";
434 } else {
435 $setClosedMessage .= " Additional attempts will not be recorded.";
436 }
437 }
438 print CGI::p(
439 "You have attempted this problem $attempts $attemptsNoun.", CGI::br(),
440 $problem->attempted
441 ? "Your recorded score is $lastScore." . CGI::br()
442 : "",
443 $setClosed ? $setClosedMessage : "You have $attemptsLeft $attemptsLeftNoun remaining."
444 );
445 print CGI::end_div();
446 print CGI::hr(), CGI::start_div({class=>"viewOptions"});
447 print
448 $self->viewOptions(),CGI::end_div(),
449 CGI::endform();
84 450
85 TEXT("Hello world"); 451 print CGI::start_div({class=>"problemFooter"});
452 # feedback form
453 my $ce = $self->{ce};
454 my $root = $ce->{webworkURLs}->{root};
455 my $courseName = $ce->{courseName};
456 my $feedbackURL = "$root/$courseName/feedback/";
457
458 # arguments for answer inspection button
459 my $prof_url = $ce->{webworkURLs}->{oldProf};
460 my $cgi_url = $prof_url;
461 $cgi_url=~ s|/[^/]*$||; # clip profLogin.pl
462 my $authen_args = $self->url_authen_args();
463 my $showPastAnswersURL = "$cgi_url/showPastAnswers.pl";
464
465 #print feedback form
466 print
467 CGI::start_form(-method=>"POST", -action=>$feedbackURL),"\n",
468 $self->hidden_authen_fields,"\n",
469 CGI::hidden("module", __PACKAGE__),"\n",
470 CGI::hidden("set", $set->set_id),"\n",
471 CGI::hidden("problem", $problem->problem_id),"\n",
472 CGI::hidden("displayMode", $self->{displayMode}),"\n",
473 CGI::hidden("showOldAnswers", $will{showOldAnswers}),"\n",
474 CGI::hidden("showCorrectAnswers", $will{showCorrectAnswers}),"\n",
475 CGI::hidden("showHints", $will{showHints}),"\n",
476 CGI::hidden("showSolutions", $will{showSolutions}),"\n",
477 CGI::p({-align=>"right"},
478 CGI::submit(-name=>"feedbackForm", -label=>"Send Feedback")
479 ),
480 CGI::endform(),"\n";
481 # print answer inspection button
482 if ($self->{permissionLevel} >0) {
483
484
485 print "\n",
486 CGI::start_form(-method=>"POST",-action=>$showPastAnswersURL,-target=>"information"),"\n",
487 $self->hidden_authen_fields,"\n",
488 CGI::hidden(-name => 'course', -value=>$courseName), "\n",
489 CGI::hidden(-name => 'probNum', -value=>$problem->problem_id), "\n",
490 CGI::hidden(-name => 'setNum', -value=>$problem->set_id), "\n",
491 CGI::hidden(-name => 'User', -value=>$problem->user_id), "\n",
492 CGI::submit(-name => 'action', -value=>'Show Past Answers'), "\n",
493 CGI::endform();
494
495
496
497 }
498 print CGI::end_div();
499 # end answer inspection button
500 # warning output
501 if ($pg->{warnings} ne "") {
502 print CGI::hr(), $self->warningOutput($pg->{warnings});
503 }
504
505 # debugging stuff
506 if (0) {
507 print
508 CGI::hr(),
509 CGI::h2("debugging information"),
510 CGI::h3("form fields"),
511 ref2string($self->{formFields}),
512 CGI::h3("user object"),
513 ref2string($self->{user}),
514 CGI::h3("set object"),
515 ref2string($set),
516 CGI::h3("problem object"),
517 ref2string($problem),
518 CGI::h3("PG object"),
519 ref2string($pg, {'WeBWorK::PG::Translator' => 1});
520 }
521
522 return "";
523}
524
525##### output utilities #####
526
527sub attemptResults($$$$$$) {
528 my $self = shift;
529 my $pg = shift;
530 my $showAttemptAnswers = shift;
531 my $showCorrectAnswers = shift;
532 my $showAttemptResults = $showAttemptAnswers && shift;
533 my $showSummary = shift;
534 my $showAttemptPreview = shift || 0;
535 my $problemResult = $pg->{result}; # the overall result of the problem
536 my @answerNames = @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} };
537
538 my $showMessages = $showAttemptAnswers && grep { $pg->{answers}->{$_}->{ans_message} } @answerNames;
539
540 my $header = CGI::th("Part");
541 $header .= $showAttemptAnswers ? CGI::th("Entered") : "";
542 $header .= $showAttemptPreview ? CGI::th("Answer Preview") : "";
543 $header .= $showCorrectAnswers ? CGI::th("Correct") : "";
544 $header .= $showAttemptResults ? CGI::th("Result") : "";
545 $header .= $showMessages ? CGI::th("messages") : "";
546 my @tableRows = ( $header );
547 my $numCorrect;
548 foreach my $name (@answerNames) {
549 my $answerResult = $pg->{answers}->{$name};
550 my $studentAnswer = $answerResult->{student_ans}; # original_student_ans
551 my $preview = ($showAttemptPreview
552 ? $self->previewAnswer($answerResult)
553 : "");
554 my $correctAnswer = $answerResult->{correct_ans};
555 my $answerScore = $answerResult->{score};
556 my $answerMessage = $showMessages ? $answerResult->{ans_message} : "";
86 557
87 ENDDOCUMENT(); 558 $numCorrect += $answerScore > 0;
88 559 my $resultString = $answerScore ? "correct" : "incorrect";
89END_OF_TEXT 560
561 # get rid of the goofy prefix on the answer names (supposedly, the format
562 # of the answer names is changeable. this only fixes it for "AnSwEr"
563 $name =~ s/^AnSwEr//;
564
565 my $row = CGI::td($name);
566 $row .= $showAttemptAnswers ? CGI::td($studentAnswer) : "";
567 $row .= $showAttemptPreview ? CGI::td($preview) : "";
568 $row .= $showCorrectAnswers ? CGI::td($correctAnswer) : "";
569 $row .= $showAttemptResults ? CGI::td($resultString) : "";
570 $row .= $answerMessage ? CGI::td($answerMessage) : "";
571 push @tableRows, $row;
572 }
90 573
91#These here documents have their drawbacks. KEEP END_OF_TEXT left justified!!!!!! 574 my $numIncorrectNoun = scalar @answerNames == 1 ? "question" : "questions";
575 my $scorePercent = int ($problemResult->{score} * 100) . "\%";
576 my $summary = "On this attempt, you answered $numCorrect out of "
577 . scalar @answerNames . " $numIncorrectNoun correct, for a score of $scorePercent.";
578 return CGI::table({-class=>"attemptResults"}, CGI::Tr(\@tableRows)) . ($showSummary ? CGI::p($summary) : "");
579}
92 580
93############################################################################### 581sub viewOptions($) {
94# Now to define the body subroutine which does the hard work. 582 my $self = shift;
95############################################################################### 583 my $displayMode = $self->{displayMode};
96 584 my %must = %{ $self->{must} };
97 585 my %can = %{ $self->{can} };
98#my $SOURCE1 = $INITIAL_MACRO_PACKAGES; 586 my %will = %{ $self->{will} };
99
100sub body {
101 my ($self, $problem_set, $problem) = @_;
102 my $r = $self->{r};
103 my $courseEnvironment = $self->{courseEnvironment};
104 my $user = $r->param('user');
105 587
106 my $rh = {}; # this needs to be set to a hash containing CGI params 588 my $optionLine;
589 $can{showOldAnswers} and $optionLine .= join "",
590 "Show: &nbsp;",
591 CGI::checkbox(
592 -name => "showOldAnswers",
593 -checked => $will{showOldAnswers},
594 -label => "Saved answers",
595 ), "&nbsp;&nbsp;";
596 $can{showCorrectAnswers} and $optionLine .= join "",
597 CGI::checkbox(
598 -name => "showCorrectAnswers",
599 -checked => $will{showCorrectAnswers},
600 -label => "Correct answers",
601 ), "&nbsp;&nbsp;";
602 $can{showHints} and $optionLine .= join "",
603 CGI::checkbox(
604 -name => "showHints",
605 -checked => $will{showHints},
606 -label => "Hints",
607 ), "&nbsp;&nbsp;";
608 $can{showSolutions} and $optionLine .= join "",
609 CGI::checkbox(
610 -name => "showSolutions",
611 -checked => $will{showSolutions},
612 -label => "Solutions",
613 ), "&nbsp;&nbsp;";
614 $optionLine and $optionLine .= join "", CGI::br();
107 615
108 616 return CGI::div({-style=>"border: thin groove; padding: 1ex; margin: 2ex"},
109 my $SOURCE1 = readFile("$problem_set/$problem.pg"); 617 "View equations as: &nbsp;",
110 print STDERR "SOURCEFILE: \n$SOURCE1\n\n"; 618 CGI::radio_group(
111 619 -name => "displayMode",
112 ########################################################################### 620 -values => ['plainText', 'formattedText', 'images'],
113 # The pg problem class should have a method for installing it's problemEnvironment 621 -default => $displayMode,
114 ########################################################################### 622 -labels => {
115 623 plainText => "plain text",
116 my $problemEnvir_rh = defineProblemEnvir($self); 624 formattedText => "formatted text",
117 625 images => "images",
118
119 ##################################################################################
120 # Prime the PGtranslator object and set it loose
121 ##################################################################################
122
123
124 ###############################################################################
125 626 }
126 ############################################################################### 627 ), CGI::br(),
127 #Create the PG translator. 628 $optionLine,
128 ############################################################################### 629 CGI::submit(-name=>"redisplay", -label=>"Redisplay Problem"),
129
130 my $pt = new PGtranslator5; #pt stands for problem translator;
131
132
133 # All of these hard coded directories need to be drawn from courseEnvironment.
134 # In addition I don't think that PGtranslator uses this stack internally yet.
135 # Passing these directories through the problemEnvironment variable is what
136 # is currently being done, but I don't think it is quite right, at least for most
137 # of them.
138
139
140 $pt ->rh_directories( { courseScriptsDirectory => $COURSE_SCRIPTS_DIRECTORY,
141 macroDirectory => $MACRO_DIRECTORY,
142 ,
143 templateDirectory => $TEMPLATE_DIRECTORY,
144 tempDirectory => $TEMP_DIRECTORY,
145 }
146 ); 630 );
147
148 ###############################################################################
149 # First we load the modules from courseScripts directory.
150 # These do the "heavy lifting" in terms of formatting, creating graphs, and
151 # performing other heavy duty algorithms.
152 #
153 ###############################################################################
154
155 $pt -> evaluate_modules( @MODULE_LIST);
156 $pt -> load_extra_packages( @EXTRA_PACKAGES );
157
158 ###############################################################################
159 # Load the environment constants. Some are used by the PGtranslator object but
160 # most of them are installed inside the Safe compartment where the problem
161 # runs.
162 ###############################################################################
163 #$pt -> environment($dummy_envir);
164 $pt -> environment($problemEnvir_rh);
165
166
167 # I've forgotten what this does exactly :-)
168 $pt->initialize();
169
170 ###############################################################################
171 # PG.pl contains the basic code which defines the problem interface, input and output.
172 # dangerousMacros.pl contains subroutines which have access to the hard drive and
173 # and the directory structure. All use of external resources by the problem is supposed
174 # to go through these subroutines. The idea is to put the potentially dangerous
175 # algorithms in on place so they can be watched closely.
176 # These two files are evaluated in the Safe compartment without any restrictions.
177 # They have full use of the perl commands.
178 ###############################################################################
179 my $loadErrors = $pt -> unrestricted_load($PG_PL );
180 print STDERR "$loadErrors\n" if ($loadErrors);
181 $loadErrors = $pt -> unrestricted_load($DANGEROUS_MACROS_PL);
182 print STDERR "$loadErrors\n" if ($loadErrors);
183
184 ###############################################################################
185 # Now set the mask to restrict the operations which can be performed within
186 # a problem or a macro file.
187 ###############################################################################
188 $pt-> set_mask();
189
190 # print "\nPG.pl: $PG_PL<br>\n";
191 # print "DANGEROUS_MACROS_PL: $DANGEROUS_MACROS_PL<br>\n";
192 # print "Print dummy environment<br>\n";
193 # print pretty_print_rh($dummy_envir), "<p>\n\n";
194
195 # Read in the source code for the problem
196
197 #$INITIAL_MACRO_PACKAGES =~ tr /\r/\n/; # change everything to unix line endings.
198 $SOURCE1 =~ tr /\r/\n/;
199 #print STDERR "Source again \n $SOURCE1";
200 $pt->source_string( $SOURCE1 );
201
202 ###############################################################################
203 # Install a safety filter for screening student answers. The default is now the blank
204 # filter since the answer evaluators do a pretty good job of recompiling and screening
205 # student's answers. Still, you could prohibit back ticks, or something of the kind.
206 ###############################################################################
207
208 $pt ->rf_safety_filter( \&safetyFilter); # install blank safety filter
209
210
211 print STDERR "New PGtranslator object inititialization completed.<br>\n";
212 ################################################################################
213 ## This ends the initialization of the PGtranslator object
214 ################################################################################
215
216
217 ################################################################################
218 # Run the problem (output the html text) but also store it within the object.
219 # The correct answers are also calculated and stored within the object
220 ################################################################################
221 $pt ->translate();
222
223 #print problem output
224 print "Problem goes here<p>\n";
225 print "Problem output <br>\n";
226 print "################################################################################<br><br>";
227 print ${$pt->r_text()};
228 print "<br><br>################################################################################<br>";
229 print "<p>End of problem output<br>";
230
231
232 #print source code
233 print "Source code<pre>\n";
234 print $SOURCE1;
235 print "</pre>End source code<p>";
236 ################################################################################
237 # The format for the output is described here. We'll need a local variable
238 # to handle the warnings. From within the problem the warning command
239 # has been slaved to the __WARNINGS__ routine which is defined in Global.
240 # We'll need to provide an alternate mechanism.
241 # The base64 encoding is only needed for xml transmission.
242 ################################################################################
243 print "################################################################################<br>";
244 print "Warnings output<br>";
245 my $WARNINGS = "Let this be a warning:";
246
247 print $WARNINGS;
248
249 ################################################################################
250 # Install the standard problem grader. See gage/xmlrpc/daemon.pm or processProblem8 for detailed
251 # code on how to choose which problem grader to install, depending on courseEnvironment and problem data.
252 # See also PG.pl which provides for problem by problem overrides.
253 ################################################################################
254
255 $pt->rf_problem_grader($pt->rf_std_problem_grader);
256
257 ################################################################################
258 # creates and stores a hash of answer results inside the object: $rh_answer_results
259 ################################################################################
260 $pt -> process_answers($rh->{envir}->{inputs_ref});
261
262
263 # THE UPDATE AND GRADING LOGIC COULD USE AN OVERHAUL. IT WAS SOMEWHAT CONSTRAINED
264 # BY LEGACY CONDITIONS IN THE ORIGINAL PROCESSPROBLEM8. IT'S NOT BAD
265 # BUT IT COULD PROBABLY BE MADE A LITTLE MORE STRAIGHT FORWARD.
266 ################################################################################
267 # updates the problem state stored by the translator object from the problemEnvironment data
268 ################################################################################
269
270 # $pt->rh_problem_state({ recorded_score => $rh->{problem_state}->{recorded_score},
271 # num_of_correct_ans => $rh->{problem_state}->{num_of_correct_ans} ,
272 # num_of_incorrect_ans => $rh->{problem_state}->{num_of_incorrect_ans}
273 # } );
274 ################################################################################
275 # grade the problem (and update the problem state again.)
276 ################################################################################
277
278 # Define an entry order -- the default is the order they are received from the browser.
279 # (Which as I understand it is NOT guaranteed to be the Left->Right Up-> Down order we're
280 # used to in the West.
281
282 my %PG_FLAGS = $pt->h_flags;
283 my $ra_answer_entry_order = ( defined($PG_FLAGS{ANSWER_ENTRY_ORDER}) ) ?
284 $PG_FLAGS{ANSWER_ENTRY_ORDER} : [ keys %{$pt->rh_evaluated_answers} ] ;
285 # Decide whether any answers were submitted.
286 my $answers_submitted = 0;
287 $answers_submitted = 1 if defined( $rh->{answer_form_submitted} ) and 1 == $rh->{answer_form_submitted};
288 # If there are answers, grade them
289 my ($rh_problem_result,$rh_problem_state) = $pt->grade_problem( answers_submitted => $answers_submitted,
290 ANSWER_ENTRY_ORDER => $ra_answer_entry_order
291 ); # grades the problem.
292
293 # Output format expected by Webwork.pm (and I believe processProblem8, but check.)
294 my $out = {
295 text => ${$pt ->r_text()}, # encode_base64( ${$pt ->r_text()} ),
296 header_text => $pt->r_header, # encode_base64( ${ $pt->r_header } ),
297 answers => $pt->rh_evaluated_answers,
298 errors => $pt-> errors(),
299 WARNINGS => $WARNINGS, #encode_base64($WARNINGS ),
300 problem_result => $rh_problem_result,
301 problem_state => $rh_problem_state,
302 PG_flag => \%PG_FLAGS
303 };
304 ##########################################################################################
305 # Debugging printout of environment tables
306 ##########################################################################################
307
308 print "<P>Request item<P>\n\n";
309 print "<TABLE border=\"3\">";
310 print $self->print_form_data('<tr><td>','</td><td>','</td></tr>');
311 print "</table>\n";
312 print "path info <br>\n";
313 print $r->path_info();
314 print "<P>\n\ncourseEnvironment<P>\n\n";
315 print pretty_print_rh($courseEnvironment);
316 print "<P>\n\nproblemEnvironment<P>\n\n";
317 print pretty_print_rh($problemEnvir_rh);
318
319 ##########################################################################################
320 # End
321 ##########################################################################################
322 "";
323} 631}
324# End the"body" routine for the Problem object.
325 632
326 633sub previewAnswer($$) {
327 634 my ($self, $answerResult) = @_;
328 635 my $ce = $self->{ce};
329 636 my $effectiveUser = $self->{effectiveUser};
330 637 my $set = $self->{set};
331######################################################################################## 638 my $problem = $self->{problem};
332# This is the problemEnvironment structure that needs to be filled out in order to provide 639 my $displayMode = $self->{displayMode};
333# information to PGtranslator which in turn supports the problem environment
334########################################################################################
335
336sub defineProblemEnvir {
337 my $self = shift;
338 my $r = $self->{r};
339 my $courseEnvironment = $self->{courseEnvironment};
340 my %envir=();
341# $envir{'refSubmittedAnswers'} = $refSubmittedAnswers if defined($refSubmittedAnswers);
342 $envir{'psvnNumber'} = 123456789;
343 $envir{'psvn'} = 123456789;
344 $envir{'studentName'} = 'Jane Doe';
345 $envir{'studentLogin'} = 'jd001m';
346 $envir{'studentID'} = 'xxx-xx-4321';
347 $envir{'sectionName'} = 'gage';
348 $envir{'sectionNumber'} = '111foobar';
349 $envir{'recitationName'} = 'gage_recitation';
350 $envir{'recitationNumber'} = '11_foobar recitation';
351 $envir{'setNumber'} = 'setAlgebraicGeometry';
352 $envir{'questionNumber'} = 43;
353 $envir{'probNum'} = 43;
354 $envir{'openDate'} = 3014438528;
355 $envir{'formattedOpenDate'} = '3/4/02';
356 $envir{'dueDate'} = 4014438528;
357 $envir{'formattedDueDate'} = '10/4/04';
358 $envir{'answerDate'} = 4014438528;
359 $envir{'formattedAnswerDate'} = '10/4/04';
360 $envir{'problemValue'} = 1;
361 $envir{'fileName'} = 'problem1';
362 $envir{'probFileName'} = 'problem1';
363 $envir{'languageMode'} = 'HTML_tth';
364 $envir{'displayMode'} = 'HTML_tth';
365 $envir{'outputMode'} = 'HTML_tth';
366 $envir{'courseName'} = $courseEnvironment ->{courseName};
367 $envir{'sessionKey'} = 'asdf';
368
369# initialize constants for PGanswermacros.pl
370 $envir{'numRelPercentTolDefault'} = .1;
371 $envir{'numZeroLevelDefault'} = 1E-14;
372 $envir{'numZeroLevelTolDefault'} = 1E-12;
373 $envir{'numAbsTolDefault'} = .001;
374 $envir{'numFormatDefault'} = '';
375 $envir{'functRelPercentTolDefault'} = .1;
376 $envir{'functZeroLevelDefault'} = 1E-14;
377 $envir{'functZeroLevelTolDefault'} = 1E-12;
378 $envir{'functAbsTolDefault'} = .001;
379 $envir{'functNumOfPoints'} = 3;
380 $envir{'functVarDefault'} = 'x';
381 $envir{'functLLimitDefault'} = .0000001;
382 $envir{'functULimitDefault'} = .9999999;
383 $envir{'functMaxConstantOfIntegration'} = 1E8;
384# kludge check definition of number of attempts again. The +1 is because this is used before the current answer is evaluated.
385 $envir{'numOfAttempts'} = 2; #&getProblemNumOfCorrectAns($probNum,$psvn)
386 # &getProblemNumOfIncorrectAns($probNum,$psvn)+1;
387
388#
389#
390# defining directorys and URLs
391 $envir{'templateDirectory'} = $courseEnvironment ->{courseDirs}->{templates};
392############ $envir{'classDirectory'} = $Global::classDirectory;
393# $envir{'cgiDirectory'} = $Global::cgiDirectory;
394# $envir{'cgiURL'} = getWebworkCgiURL();
395
396# $envir{'scriptDirectory'} = $Global::scriptDirectory;##omit
397 $envir{'webworkDocsURL'} = 'http://webwork.math.rochester.edu';
398 $envir{'externalTTHPath'} = '/usr/local/bin/tth';
399 640
400 641 # note: right now, we have to do things completely differently when we are
401# 642 # rendering math from INSIDE the translator and from OUTSIDE the translator.
402 $envir{'inputs_ref'} = $r->param; 643 # so we'll just deal with each case explicitly here. there's some code
403 $envir{'problemSeed'} = 3245; 644 # duplication that can be dealt with later by abstracting out tth/dvipng/etc.
404 $envir{'displaySolutionsQ'} = 1; 645
405 $envir{'displayHintsQ'} = 1; 646 my $tex = $answerResult->{preview_latex_string};
406 647
407# Directory values -- do we really need them here? 648 return "" if $tex eq "";
408 $envir{courseScriptsDirectory} = $COURSE_SCRIPTS_DIRECTORY; 649
409 $envir{macroDirectory} = $MACRO_DIRECTORY; 650 if ($displayMode eq "plainText") {
410 $envir{templateDirectory} = $TEMPLATE_DIRECTORY; 651 return $tex;
411 $envir{tempDirectory} = $TEMP_DIRECTORY; 652 } elsif ($displayMode eq "formattedText") {
412 $envir{tempURL} = $TEMP_URL; 653 my $tthCommand = $ce->{externalPrograms}->{tth}
413 $envir{htmlURL} = $HTML_URL; 654 . " -L -f5 -r 2> /dev/null <<END_OF_INPUT; echo > /dev/null\n"
414 $envir{'htmlDirectory'} = $courseEnvironment ->{courseDirectory}->{html}; 655 . "\\(".$tex."\\)\n"
415 # here is a way to pass environment variables defined in webworkCourse.ph 656 . "END_OF_INPUT\n";
416# my $k; 657
417# foreach $k (keys %Global::PG_environment ) { 658 # call tth
418# $envir{$k} = $Global::PG_environment{$k}; 659 my $result = `$tthCommand`;
419# } 660 if ($?) {
420 \%envir; 661 return "<b>[tth failed: $? $@]</b>";
421}
422
423########################################################################################
424# This recursive pretty_print function will print a hash and its sub hashes.
425########################################################################################
426sub pretty_print_rh {
427 my $r_input = shift;
428 my $out = '';
429 if ( not ref($r_input) ) {
430 $out = $r_input; # not a reference
431 } elsif (is_hash_ref($r_input)) {
432 local($^W) = 0;
433 $out .= "<TABLE border = \"2\" cellpadding = \"3\" BGCOLOR = \"#FFFFFF\">";
434 foreach my $key (sort keys %$r_input ) {
435 $out .= "<tr><TD> $key</TD><TD>=&gt;</td><td>&nbsp;".pretty_print_rh($r_input->{$key}) . "</td></tr>";
436 } 662 }
437 $out .="</table>"; 663 return $result;
438 } elsif (is_array_ref($r_input) ) { 664 } elsif ($displayMode eq "images") {
439 my @array = @$r_input; 665 # how are we going to name this?
440 $out .= "( " ; 666 my $targetPathCommon = "/png/"
441 while (@array) { 667 . $effectiveUser->id . "."
442 $out .= pretty_print_rh(shift @array) . " , "; 668 . $set->set_id . "."
669 . $problem->problem_id . "."
670 . $answerResult->{ans_name} . ".png";
671
672 # figure out where to put things
673 my $wd = tempdir("webwork-dvipng-XXXXXXXX", DIR => $ce->{courseDirs}->{html_temp});
674 my $latex = $ce->{externalPrograms}->{latex};
675 my $dvipng = $ce->{externalPrograms}->{dvipng};
676 my $targetPath = $ce->{courseDirs}->{html_temp} . $targetPathCommon;
677 # should use surePathToTmpFile, but we have to
678 # isolate it from the problem enivronment first
679 my $targetURL = $ce->{courseURLs}->{html_temp} . $targetPathCommon;
680
681 # call dvipng to generate a preview
682 dvipng($wd, $latex, $dvipng, $tex, $targetPath);
683 if (-e $targetPath) {
684 return "<img src=\"$targetURL\" alt=\"$tex\" />";
685 } else {
686 return "<b>[math2img failed]</b>";
443 } 687 }
444 $out .= " )";
445 } elsif (ref($r_input) eq 'CODE') {
446 $out = "$r_input";
447 } else {
448 $out = $r_input;
449 }
450 $out;
451}
452
453sub is_hash_ref {
454 my $in =shift;
455 my $save_SIG_die_trap = $SIG{__DIE__};
456 $SIG{__DIE__} = sub {CORE::die(@_) };
457 my $out = eval{ %{ $in } };
458 $out = ($@ eq '') ? 1 : 0;
459 $@='';
460 $SIG{__DIE__} = $save_SIG_die_trap;
461 $out;
462}
463sub is_array_ref {
464 my $in =shift;
465 my $save_SIG_die_trap = $SIG{__DIE__};
466 $SIG{__DIE__} = sub {CORE::die(@_) };
467 my $out = eval{ @{ $in } };
468 $out = ($@ eq '') ? 1 : 0;
469 $@='';
470 $SIG{__DIE__} = $save_SIG_die_trap;
471 $out;
472}
473
474######
475# Utility for slurping souce files
476#######
477
478sub readFile {
479 my $input = shift; # The set and problem: 'set0/prob1.pg'
480 my $filePath =$TEMPLATE_DIRECTORY .$input;
481 print STDERR "Reading problem from file $filePath \n";
482 print STDERR "<br>Reading problem from file $filePath <br>\n";
483 my $out;
484 print "The file is readable = ", -r $filePath, "\n";
485 if (-r $filePath) {
486 open IN, "<$filePath" or print STDERR "Hey, this file was supposed to be readable\n";
487 local($/)=undef;
488 $out = <IN>;
489 close(IN);
490 } else {
491 print "Could not read file at |$filePath|";
492 print STDERR "Could not read file at |$filePath|";
493 }
494 return($out);
495}
496
497my $foo =0;
498
499# The warning mechanism. This needs to be turned into an object of its own
500###############
501## Error message routines cribbed from CGI
502###############
503
504BEGIN { #error message routines cribbed from CGI
505
506 my $CarpLevel = 0; # How many extra package levels to skip on carp.
507 my $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
508
509 sub longmess {
510 my $error = shift;
511 my $mess = "";
512 my $i = 1 + $CarpLevel;
513 my ($pack,$file,$line,$sub,$eval,$require);
514
515 while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) {
516 if ($error =~ m/\n$/) {
517 $mess .= $error;
518 }
519 else {
520 if (defined $eval) {
521 if ($require) {
522 $sub = "require $eval";
523 }
524 else {
525 $eval =~ s/[\\\']/\\$&/g;
526 if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
527 substr($eval,$MaxEvalLen) = '...';
528 }
529 $sub = "eval '$eval'";
530 }
531 }
532 elsif ($sub eq '(eval)') {
533 $sub = 'eval {...}';
534 }
535
536 $mess .= "\t$sub " if $error eq "called";
537 $mess .= "$error at $file line $line\n";
538 }
539
540 $error = "called";
541 } 688 }
542
543 $mess || $error;
544 }
545} 689}
546############### 690##### logging subroutine ####
547### Our error messages for giving maximum feedback to the user for errors within problems.
548###############
549BEGIN {
550 sub PG_floating_point_exception_handler { # 1st argument is signal name
551 my($sig) = @_;
552 print "Content-type: text/html\n\n<H4>There was a floating point arithmetic error (exception SIG$sig )</H4>--perhaps
553 you divided by zero or took the square root of a negative number?
554 <BR>\n Use the back button to return to the previous page and recheck your entries.<BR>\n";
555 exit(0);
556 }
557
558 $SIG{'FPE'} = \&PG_floating_point_exception_handler;
559#!/usr/bin/perl -w
560 sub PG_warnings_handler {
561 my @input = @_;
562 my $msg_string = longmess(@_);
563 my @msg_array = split("\n",$msg_string);
564 my $out_string = '';
565
566 # Extra stack information is provided in this next block
567 # If the warning message does NOT end in \n then a line
568 # number is appended (see Perl manual about warn function)
569 # The presence of the line number is detected below and extra
570 # stack information is added.
571 # To suppress the line number and the extra stack information
572 # add \n to the end of a warn message (in .pl files. In .pg
573 # files add ~~n instead
574
575 if ($input[$#input]=~/line \d*\.\s*$/) {
576 $out_string .= "##More details: <BR>\n----";
577 foreach my $line (@msg_array) {
578 chomp($line);
579 next unless $line =~/\w+\:\:/;
580 $out_string .= "----" .$line . "<BR>\n";
581 }
582 }
583 691
584 $Global::WARNINGS .="* " . join("<BR>",@input) . "<BR>\n" . $out_string .
585 "<BR>\n--------------------------------------<BR>\n<BR>\n";
586 $Global::background_plain_url = $Global::background_warn_url;
587 $Global::bg_color = '#FF99CC'; #for warnings -- this change may come too late
588 }
589 692
590 $SIG{__WARN__}=\&PG_warnings_handler;
591
592 $SIG{__DIE__} = sub {
593 my $message = longmess(@_);
594 $message =~ s/\n/<BR>\n/;
595 my ($package, $filename, $line) = caller();
596 # use standard die for errors eminating from XML::Parser::Expat
597 # it uses a trapped eval which sometimes fails -- apparently on purpose
598 # and the error is handled by Expat itself. We don't want
599 # to interfer with that.
600
601 if ($package eq 'XML::Parser::Expat') {
602 die @_;
603 }
604 #print "$package $filename $line \n";
605 print
606 "Content-type: text/html\r\n\r\n <h4>Software error</h4> <p>\n\n$message\n<p>\n
607 Please inform the webwork meister.<p>\n
608 In addition to the error message above the following warnings were detected:
609 <HR>
610 $Global::WARNINGS;
611 <HR>
612 It's sometimes hard to tell exactly what has gone wrong since the
613 full error message may have been sent to
614 standard error instead of to standard out.
615 <p> To debug you can
616 <ul>
617 <li> guess what went wrong and try to fix it.
618 <li> call the offending script directly from the command line
619 of unix
620 <li> enable the debugging features by redefining
621 \$cgiURL in Global.pm and checking the redirection scripts in
622 system/cgi. This will force the standard error to be placed
623 in the standard out pipe as well.
624 <li> Run tail -f error_log <br>
625 from the unix command line to see error messages from the webserver.
626 The standard error output is being placed in the error_log file for the apache
627 web server. To run this command you have to be in the directory containing the
628 error_log or enter the full path name of the error_log. <p>
629 In a standard apache installation, this file is at /usr/local/apache/logs/error_log<p>
630 In a RedHat Linux installation, this file is at /var/log/httpd/error_log<p>
631 At Rochester this file is at /ww/logs/error_log.
632 </ul>
633 Good luck.<p>\n" ;
634 };
635 693
694##### permission queries #####
636 695
696# this stuff should be abstracted out into the permissions system
697# however, the permission system only knows about things in the
698# course environment and the username. hmmm...
637 699
700# also, i should fix these so that they have a consistent calling
701# format -- perhaps:
702# canPERM($courseEnv, $user, $set, $problem, $permissionLevel)
703
704sub canShowCorrectAnswers($$) {
705 my ($permissionLevel, $answerDate) = @_;
706 return $permissionLevel > 0 || time > $answerDate;
707}
708
709sub canShowSolutions($$) {
710 my ($permissionLevel, $answerDate) = @_;
711 return canShowCorrectAnswers($permissionLevel, $answerDate);
712}
713
714sub canRecordAnswers($$$$$) {
715 my ($permissionLevel, $openDate, $dueDate, $maxAttempts, $attempts) = @_;
716 my $permHigh = $permissionLevel > 0;
717 my $timeOK = time >= $openDate && time <= $dueDate;
718 my $attemptsOK = $maxAttempts == -1 || $attempts <= $maxAttempts;
719 my $recordAnswers = $permHigh || ($timeOK && $attemptsOK);
720 return $recordAnswers;
721}
722
723sub canCheckAnswers($$) {
724 my ($permissionLevel, $answerDate) = @_;
725 my $permHigh = $permissionLevel > 0;
726 my $timeOK = time >= $answerDate;
727 my $recordAnswers = $permHigh || $timeOK;
728 return $recordAnswers;
729}
730
731sub mustRecordAnswers($) {
732 my ($permissionLevel) = @_;
733 return $permissionLevel == 0;
638} 734}
639 735
6401; 7361;
Legend:
Removed from v.398  
changed lines
  Added in v.818
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9