[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 415 Revision 794
1################################################################################
2# WeBWorK mod_perl (c) 2000-2002 WeBWorK Project
3# $Id$
4################################################################################
5
1package WeBWorK::ContentGenerator::Problem; 6package WeBWorK::ContentGenerator::Problem;
2use base qw(WeBWorK::ContentGenerator); 7
8=head1 NAME
9
10WeBWorK::ContentGenerator::Problem - Allow a student to interact with a problem.
11
12=cut
3 13
4use strict; 14use strict;
5use warnings; 15use warnings;
6use Apache::Constants qw(:common);
7use WeBWorK::ContentGenerator; 16use base qw(WeBWorK::ContentGenerator);
17use CGI qw();
18use File::Temp qw(tempdir);
19use WeBWorK::Form;
8use WeBWorK::PG; 20use WeBWorK::PG;
21use WeBWorK::PG::IO;
22use WeBWorK::Utils qw(writeLog encodeAnswers decodeAnswers ref2string);
9 23
10# "Classic" form fields from processProblem8.pl 24############################################################
11# 25#
12# user - user ID 26# user
13# key - session key 27# effectiveUser
14# course - course name 28# key
15# probSetKey - USUALLY known as the PSVN
16# probNum - problem number a.k.a. ID a.k.a. name
17# 29#
18# Mode - display mode (HTML, HTML_tth, or typeset or whatever it's called) 30# displayMode
19# show_old_answers - whether or not student's old answers should be filled in 31# showOldAnswers
20# ShowAns - asks for correct answer to be shown -- only available for instructors 32# showCorrectAnswers
21# answer$i - student answers 33# showHints
22# showEdit - checks if the ShowEditor button should be shown and clicked 34# showSolutions
23# showSol - checks if the solution button ishould be shown and clicked
24# 35#
25# source - contains modified problem source when called from the web-based problem editor 36# AnSwEr# - answer blanks in problem
26# seed - contains problem seed when called from the web-based problem editor 37#
27# readSourceFromHTMLQ - if true, problem is read from 'source' instead of file 38# redisplay - name of the "Redisplay Problem" button
28# action - submit button clicked to invoke script (alledgedly) 39# submitAnswers - name of "Submit Answers" button
29# 'Save updated version' 40#
30# 'Read problem from disk' 41############################################################
31# 'Submit Answers' 42
32# 'Preview Answers' 43sub pre_header_initialize {
33# 'Preview Again' 44 my ($self, $setName, $problemNumber) = @_;
34# probFileName - name of the PG file being edited 45 my $courseEnv = $self->{courseEnvironment};
35# languageType - afaik, always set to 'pg' 46 my $r = $self->{r};
47 my $userName = $r->param('user');
48 my $effectiveUserName = $r->param('effectiveUser');
49
50 ##### database setup #####
51
52 my $cldb = WeBWorK::DB::Classlist->new($courseEnv);
53 my $wwdb = WeBWorK::DB::WW->new($courseEnv);
54 my $authdb = WeBWorK::DB::Auth->new($courseEnv);
55
56 my $user = $cldb->getUser($userName);
57 my $effectiveUser = $cldb->getUser($effectiveUserName);
58 my $set = $wwdb->getSet($effectiveUserName, $setName);
59 my $problem = $wwdb->getProblem($effectiveUserName, $setName, $problemNumber);
60 my $psvn = $wwdb->getPSVN($effectiveUserName, $setName);
61 my $permissionLevel = $authdb->getPermissions($userName);
62
63 $self->{cldb} = $cldb;
64 $self->{wwdb} = $wwdb;
65 $self->{authdb} = $authdb;
66
67 $self->{userName} = $userName;
68 $self->{user} = $user;
69 $self->{effectiveUser} = $effectiveUser;
70 $self->{set} = $set;
71 $self->{problem} = $problem;
72 $self->{permissionLevel} = $permissionLevel;
73
74 ##### form processing #####
75
76 # set options from form fields (see comment at top of file for names)
77 my $displayMode = $r->param("displayMode") || $courseEnv->{pg}->{options}->{displayMode};
78 my $redisplay = $r->param("redisplay");
79 my $submitAnswers = $r->param("submitAnswers");
80 my $checkAnswers = $r->param("checkAnswers");
81 my $previewAnswers = $r->param("previewAnswers");
82
83 # coerce form fields into CGI::Vars format
84 my $formFields = { WeBWorK::Form->new_from_paramable($r)->Vars };
85
86 $self->{displayMode} = $displayMode;
87 $self->{redisplay} = $redisplay;
88 $self->{submitAnswers} = $submitAnswers;
89 $self->{checkAnswers} = $checkAnswers;
90 $self->{previewAnswers} = $previewAnswers;
91 $self->{formFields} = $formFields;
92
93 ##### permissions #####
94
95 # are we allowed to view this problem?
96 $self->{isOpen} = time >= $set->open_date || $permissionLevel > 0;
97 return unless $self->{isOpen};
98
99 # what does the user want to do?
100 my %want = (
101 showOldAnswers => $r->param("showOldAnswers") || $courseEnv->{pg}->{options}->{showOldAnswers},
102 showCorrectAnswers => $r->param("showCorrectAnswers") || $courseEnv->{pg}->{options}->{showCorrectAnswers},
103 showHints => $r->param("showHints") || $courseEnv->{pg}->{options}->{showHints},
104 showSolutions => $r->param("showSolutions") || $courseEnv->{pg}->{options}->{showSolutions},
105 recordAnswers => $submitAnswers,
106 checkAnswers => $checkAnswers,
107 );
108
109 # are certain options enforced?
110 my %must = (
111 showOldAnswers => 0,
112 showCorrectAnswers => 0,
113 showHints => 0,
114 showSolutions => 0,
115 recordAnswers => mustRecordAnswers($permissionLevel),
116 checkAnswers => 0,
117 );
118
119 # does the user have permission to use certain options?
120 my %can = (
121 showOldAnswers => 1,
122 showCorrectAnswers => canShowCorrectAnswers($permissionLevel, $set->answer_date),
123 showHints => 1,
124 showSolutions => canShowSolutions($permissionLevel, $set->answer_date),
125 recordAnswers => canRecordAnswers($permissionLevel, $set->open_date, $set->due_date,
126 $problem->max_attempts, $problem->num_correct + $problem->num_incorrect + 1),
127 # attempts=num_correct+num_incorrect+1, as this happens before updating $problem
128 checkAnswers => canCheckAnswers($permissionLevel, $set->answer_date),
129 );
130
131 # final values for options
132 my %will;
133 foreach (keys %must) {
134 $will{$_} = $can{$_} && ($want{$_} || $must{$_});
135 }
136
137 ##### sticky answers #####
138
139 if (not $submitAnswers and $will{showOldAnswers}) {
140 # do this only if new answers are NOT being submitted
141 my %oldAnswers = decodeAnswers($problem->last_answer);
142 $formFields->{$_} = $oldAnswers{$_} foreach keys %oldAnswers;
143 }
144
145 ##### translation #####
146
147 my $pg = WeBWorK::PG->new(
148 $courseEnv,
149 $effectiveUser,
150 $r->param('key'),
151 $set,
152 $problem,
153 $psvn,
154 $formFields,
155 { # translation options
156 displayMode => $displayMode,
157 showHints => $will{showHints},
158 showSolutions => $will{showSolutions},
159 refreshMath2img => $will{showHints} || $will{showSolutions},
160 processAnswers => 1,
161 },
162 );
163
164 ##### fix hint/solution options #####
165
166 $can{showHints} &&= $pg->{flags}->{hintExists};
167 $can{showSolutions} &&= $pg->{flags}->{solutionExists};
168
169 ##### store fields #####
170
171 $self->{want} = \%want;
172 $self->{must} = \%must;
173 $self->{can} = \%can;
174 $self->{will} = \%will;
175
176 $self->{pg} = $pg;
177}
178
179sub if_warnings($$) {
180 my ($self, $arg) = @_;
181 return 0 unless $self->{isOpen};
182 return $self->{pg}->{warnings} ne "";
183}
184
185sub if_errors($$) {
186 my ($self, $arg) = @_;
187 return 0 unless $self->{isOpen};
188 return $self->{pg}->{flags}->{error_flag};
189}
190
191sub head {
192 my $self = shift;
193 return "" unless $self->{isOpen};
194 return $self->{pg}->{head_text} if $self->{pg}->{head_text};
195}
196
197sub path {
198 my $self = shift;
199 my $args = $_[-1];
200 my $setName = $self->{set}->id;
201 my $problemNumber = $self->{problem}->id;
202
203 my $ce = $self->{courseEnvironment};
204 my $root = $ce->{webworkURLs}->{root};
205 my $courseName = $ce->{courseName};
206 return $self->pathMacro($args,
207 "Home" => "$root",
208 $courseName => "$root/$courseName",
209 $setName => "$root/$courseName/$setName",
210 "Problem $problemNumber" => "",
211 );
212}
213
214sub siblings {
215 my $self = shift;
216 my $setName = $self->{set}->id;
217 my $problemNumber = $self->{problem}->id;
218
219 my $ce = $self->{courseEnvironment};
220 my $root = $ce->{webworkURLs}->{root};
221 my $courseName = $ce->{courseName};
222
223 print CGI::strong("Problems"), CGI::br();
224
225 my $wwdb = $self->{wwdb};
226 my $effectiveUser = $self->{r}->param("effectiveUser");
227 my @problems;
228 push @problems, $wwdb->getProblem($effectiveUser, $setName, $_)
229 foreach ($wwdb->getProblems($effectiveUser, $setName));
230 foreach my $problem (sort { $a->id <=> $b->id } @problems) {
231 print CGI::a({-href=>"$root/$courseName/$setName/".$problem->id."/?"
232 . $self->url_authen_args . "&displayMode=" . $self->{displayMode}},
233 "Problem ".$problem->id), CGI::br();
234 }
235}
236
237sub nav {
238 my $self = shift;
239 my $args = $_[-1];
240 my $setName = $self->{set}->id;
241 my $problemNumber = $self->{problem}->id;
242
243 my $ce = $self->{courseEnvironment};
244 my $root = $ce->{webworkURLs}->{root};
245 my $courseName = $ce->{courseName};
246
247 my $wwdb = $self->{wwdb};
248 my $effectiveUser = $self->{r}->param("effectiveUser");
249 my $tail = "&displayMode=".$self->{displayMode};
250
251 my @links = ("Problem List" , "$root/$courseName/$setName", "ProbList");
252
253 my $prevProblem = $wwdb->getProblem($effectiveUser, $setName, $problemNumber-1);
254 my $nextProblem = $wwdb->getProblem($effectiveUser, $setName, $problemNumber+1);
255 unshift @links, "Previous Problem" , ($prevProblem
256 ? "$root/$courseName/$setName/".$prevProblem->id
257 : "") , "Prev";
258 push @links, "Next Problem" , ($nextProblem
259 ? "$root/$courseName/$setName/".$nextProblem->id
260 : "") , "Next";
261
262 return $self->navMacro($args, $tail, @links);
263}
36 264
37sub title { 265sub title {
38 my ($self, $problem_set, $problem) = @_; 266 my $self = shift;
39 my $r = $self->{r}; 267 my $setName = $self->{set}->id;
40 my $user = $r->param('user'); 268 my $problemNumber = $self->{problem}->id;
41 return "Problem $problem of problem set $problem_set for $user"; 269
270 return "$setName : Problem $problemNumber";
42} 271}
43 272
44sub body { 273sub body {
45 my ($self, $problem_set, $problem) = @_; 274 my $self = shift;
46 275
47 # we have to call init_translator like this: 276 return CGI::p(CGI::font({-color=>"red"}, "This problem is not available because the problem set that contains it is not yet open."))
48 my $pt = WeBWorK::PG->new($courseEnv, $userName, $setName, $problemNumber, $formData); 277 unless $self->{isOpen};
49 278
50 # 279 # unpack some useful variables
280 my $r = $self->{r};
281 my $wwdb = $self->{wwdb};
282 my $set = $self->{set};
283 my $problem = $self->{problem};
284 my $permissionLevel = $self->{permissionLevel};
285 my $submitAnswers = $self->{submitAnswers};
286 my $checkAnswers = $self->{checkAnswers};
287 my $previewAnswers = $self->{previewAnswers};
288 my %want = %{ $self->{want} };
289 my %can = %{ $self->{can} };
290 my %must = %{ $self->{must} };
291 my %will = %{ $self->{will} };
292 my $pg = $self->{pg};
51 293
52 # ----- this is not a place of honor ----- 294 ##### translation errors? #####
53 295
54 # Run the problem (output the html text) but also store it within the object. 296 if ($pg->{flags}->{error_flag}) {
55 # The correct answers are also calculated and stored within the object 297 return $self->errorOutput($pg->{errors}, $pg->{body_text});
56 $pt ->translate(); 298 }
57 299
58 # print problem output 300 ##### answer processing #####
59 print "Problem goes here<p>\n";
60 print "Problem output <br>\n";
61 print "<HR>";
62 print ${$pt->r_text()};
63 print "<HR>";
64 print "<p>End of problem output<br>";
65 301
66 302 # if answers were submitted:
67 # print source code 303 if ($submitAnswers) {
68 print "Source code<pre>\n"; 304 # store answers in DB for sticky answers
69 print $SOURCE1; 305 my %answersToStore;
70 print "</pre>End source code<p>"; 306 my %answerHash = %{ $pg->{answers} };
71 307 $answersToStore{$_} = $answerHash{$_}->{original_student_ans}
72 # The format for the output is described here. We'll need a local variable 308 foreach (keys %answerHash);
73 # to handle the warnings. From within the problem the warning command 309 my $answerString = encodeAnswers(%answersToStore,
74 # has been slaved to the __WARNINGS__ routine which is defined in Global. 310 @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} });
75 # We'll need to provide an alternate mechanism. 311 $problem->last_answer($answerString);
76 # The base64 encoding is only needed for xml transmission. 312 $wwdb->setProblem($problem);
77 print "<hr>"; 313
78 print "Warnings output<br>"; 314 # store state in DB if it makes sense
79 my $WARNINGS = "Let this be a warning:"; 315 if ($will{recordAnswers}) {
80 316 $problem->attempted(1);
81 print $WARNINGS; 317 $problem->status($pg->{state}->{recorded_score});
82 318 $problem->num_correct($pg->{state}->{num_of_correct_ans});
83 # Install the standard problem grader. See gage/xmlrpc/daemon.pm or processProblem8 for detailed 319 $problem->num_incorrect($pg->{state}->{num_of_incorrect_ans});
84 # code on how to choose which problem grader to install, depending on courseEnvironment and problem data. 320 $wwdb->setProblem($problem);
85 # See also PG.pl which provides for problem by problem overrides. 321 # write to the transaction log, just to make sure
86 $pt->rf_problem_grader($pt->rf_std_problem_grader); 322 writeLog($self->{courseEnvironment}, "transaction",
87 323 $problem->id."\t".
88 # creates and stores a hash of answer results inside the object: $rh_answer_results 324 $problem->set_id."\t".
89 $pt -> process_answers($rh->{envir}->{inputs_ref}); 325 $problem->login_id."\t".
90 326 $problem->source_file."\t".
91 327 $problem->value."\t".
92 # THE UPDATE AND GRADING LOGIC COULD USE AN OVERHAUL. IT WAS SOMEWHAT CONSTRAINED 328 $problem->max_attempts."\t".
93 # BY LEGACY CONDITIONS IN THE ORIGINAL PROCESSPROBLEM8. IT'S NOT BAD 329 $problem->problem_seed."\t".
94 # BUT IT COULD PROBABLY BE MADE A LITTLE MORE STRAIGHT FORWARD. 330 $problem->status."\t".
95 # 331 $problem->attempted."\t".
96 # updates the problem state stored by the translator object from the problemEnvironment data 332 $problem->last_answer."\t".
97 333 $problem->num_correct."\t".
98 # $pt->rh_problem_state({ recorded_score => $rh->{problem_state}->{recorded_score}, 334 $problem->num_incorrect
99 # num_of_correct_ans => $rh->{problem_state}->{num_of_correct_ans} , 335 );
100 # num_of_incorrect_ans => $rh->{problem_state}->{num_of_incorrect_ans}
101 # } );
102
103 # grade the problem (and update the problem state again.)
104 #
105 # Define an entry order -- the default is the order they are received from the browser.
106 # (Which as I understand it is NOT guaranteed to be the Left->Right Up-> Down order we're
107 # used to in the West.
108
109 my %PG_FLAGS = $pt->h_flags;
110 my $ra_answer_entry_order = ( defined($PG_FLAGS{ANSWER_ENTRY_ORDER}) ) ?
111 $PG_FLAGS{ANSWER_ENTRY_ORDER} : [ keys %{$pt->rh_evaluated_answers} ] ;
112 # Decide whether any answers were submitted.
113 my $answers_submitted = 0;
114 $answers_submitted = 1 if defined( $rh->{answer_form_submitted} ) and 1 == $rh->{answer_form_submitted};
115 # If there are answers, grade them
116 my ($rh_problem_result,$rh_problem_state) = $pt->grade_problem( answers_submitted => $answers_submitted,
117 ANSWER_ENTRY_ORDER => $ra_answer_entry_order
118 ); # grades the problem.
119
120 # Output format expected by Webwork.pm (and I believe processProblem8, but check.)
121 my $out = {
122 text => ${$pt ->r_text()}, # encode_base64( ${$pt ->r_text()} ),
123 header_text => $pt->r_header, # encode_base64( ${ $pt->r_header } ),
124 answers => $pt->rh_evaluated_answers,
125 errors => $pt-> errors(),
126 WARNINGS => $WARNINGS, #encode_base64($WARNINGS ),
127 problem_result => $rh_problem_result,
128 problem_state => $rh_problem_state,
129 PG_flag => \%PG_FLAGS
130 };
131
132 # Debugging printout of environment tables
133 print "<P>Request item<P>\n\n";
134 print "<TABLE border=\"3\">";
135 print $self->print_form_data('<tr><td>','</td><td>','</td></tr>');
136 print "</table>\n";
137 print "path info <br>\n";
138 print $r->path_info();
139 print "<P>\n\ncourseEnvironment<P>\n\n";
140 print pretty_print_rh($courseEnvironment);
141 print "<P>\n\nproblemEnvironment<P>\n\n";
142 print pretty_print_rh($problemEnvir_rh);
143
144 "";
145}
146
147sub pretty_print_rh {
148 my $r_input = shift;
149 my $out = '';
150 if ( not ref($r_input) ) {
151 $out = $r_input; # not a reference
152 } elsif (is_hash_ref($r_input)) {
153 local($^W) = 0;
154 $out .= "<TABLE border = \"2\" cellpadding = \"3\" BGCOLOR = \"#FFFFFF\">";
155 foreach my $key (sort keys %$r_input ) {
156 $out .= "<tr><TD> $key</TD><TD>=&gt;</td><td>&nbsp;".pretty_print_rh($r_input->{$key}) . "</td></tr>";
157 } 336 }
158 $out .="</table>"; 337 }
159 } elsif (is_array_ref($r_input) ) { 338 # logging student answers
160 my @array = @$r_input; 339 my $pastAnswerLog = undef;
161 $out .= "( " ; 340 if (defined( $self->{courseEnvironment}->{webworkFiles}->{logs}->{'pastAnswerList'} )) {
162 while (@array) { 341
163 $out .= pretty_print_rh(shift @array) . " , "; 342 $pastAnswerLog = $self->{courseEnvironment}->{webworkFiles}->{logs}->{'pastAnswerList'};
343
344 if ($submitAnswers and defined($pastAnswerLog) ) {
345 my $answerString = "";
346 my %answerHash = %{ $pg->{answers} };
347 $answerString = $answerString . $answerHash{$_}->{original_student_ans}."\t"
348 foreach (sort keys %answerHash);
349 writeLog($self->{courseEnvironment}, "pastAnswerList",
350 '|'.$problem->login_id.
351 '|'.$problem->set_id.
352 '|'.$problem->id.'|'."\t".
353 time()."\t".
354 $answerString,
355
356 );
357
164 } 358 }
165 $out .= " )"; 359
166 } elsif (ref($r_input) eq 'CODE') { 360 }
167 $out = "$r_input"; 361 # end logging student answers
362
363 ##### output #####
364 print CGI::start_div({class=>"problemHeader"});
365 # attempt summary
366 if ($submitAnswers or $will{showCorrectAnswers}) {
367 # print this if user submitted answers OR requested correct answers
368 print $self->attemptResults($pg, $submitAnswers,
369 $will{showCorrectAnswers},
370 $pg->{flags}->{showPartialCorrectAnswers}, 1, 0);
371 } elsif ($checkAnswers) {
372 # print this if user previewed answers
373 print $self->attemptResults($pg, 1, 0, 1, 1, 0);
374 # show attempt answers
375 # don't show correct answers
376 # show attempt results (correctness)
377 # don't show attempt previews
378 } elsif ($previewAnswers) {
379 # print this if user previewed answers
380 print $self->attemptResults($pg, 1, 0, 0, 0, 1);
381 # show attempt answers
382 # don't show correct answers
383 # don't show attempt results (correctness)
384 # show attempt previews
385 }
386
387 print CGI::end_div();
388
389 print CGI::start_div({class=>"problem"});
390 #print CGI::hr();
391 # main form
392 print
393 CGI::startform("POST", $r->uri),
394 $self->hidden_authen_fields,
395 CGI::p($pg->{body_text}),
396 CGI::p($pg->{result}->{msg} ? CGI::b("Note: ") : "", CGI::i($pg->{result}->{msg})),
397 CGI::p(
398 ($can{recordAnswers}
399 ? CGI::submit(-name=>"submitAnswers",
400 -label=>"Submit Answers")
401 : ""),
402 ($can{checkAnswers}
403 ? CGI::submit(-name=>"checkAnswers",
404 -label=>"Check Answers")
405 : ""),
406 CGI::submit(-name=>"previewAnswers",
407 -label=>"Preview Answers"),
408 );
409 print CGI::end_div();
410
411 print CGI::start_div({class=>"scoreSummary"});
412 # score summary
413 my $attempts = $problem->num_correct + $problem->num_incorrect;
414 my $attemptsNoun = $attempts != 1 ? "times" : "time";
415 my $lastScore = int ($problem->status * 100) . "%";
416 my ($attemptsLeft, $attemptsLeftNoun);
417 if ($problem->max_attempts == -1) {
418 # unlimited attempts
419 $attemptsLeft = "unlimited";
420 $attemptsLeftNoun = "attempts";
168 } else { 421 } else {
169 $out = $r_input; 422 $attemptsLeft = $problem->max_attempts - $attempts;
423 $attemptsLeftNoun = $attemptsLeft == 1 ? "attempt" : "attempts";
424 }
425
426 my $setClosed = 0;
427 my $setClosedMessage;
428 if (time < $set->open_date or time > $set->due_date) {
429 $setClosed = 1;
430 $setClosedMessage = "This problem set is closed.";
431 if ($permissionLevel > 0) {
432 $setClosedMessage .= " Since you are a privileged user, additional attempts will be recorded.";
433 } else {
434 $setClosedMessage .= " Additional attempts will not be recorded.";
170 } 435 }
171 $out; 436 }
172} 437 print CGI::p(
438 "You have attempted this problem $attempts $attemptsNoun.", CGI::br(),
439 $problem->attempted
440 ? "Your recorded score is $lastScore." . CGI::br()
441 : "",
442 $setClosed ? $setClosedMessage : "You have $attemptsLeft $attemptsLeftNoun remaining."
443 );
444 print CGI::end_div();
445 print CGI::hr(), CGI::start_div({class=>"viewOptions"});
446 print
447 $self->viewOptions(),CGI::end_div(),
448 CGI::endform();
449
450 print CGI::start_div({class=>"problemFooter"});
451 # feedback form
452 my $ce = $self->{courseEnvironment};
453 my $root = $ce->{webworkURLs}->{root};
454 my $courseName = $ce->{courseName};
455 my $feedbackURL = "$root/$courseName/feedback/";
456
457 # arguments for answer inspection button
458 my $prof_url = $ce->{webworkURLs}->{oldProf};
459 my $cgi_url = $prof_url;
460 $cgi_url=~ s|/[^/]*$||; # clip profLogin.pl
461 my $authen_args = $self->url_authen_args();
462 my $showPastAnswersURL = "$cgi_url/showPastAnswers.pl";
463
464 #print feedback form
465 print
466 CGI::start_form(-method=>"POST", -action=>$feedbackURL),"\n",
467 $self->hidden_authen_fields,"\n",
468 CGI::hidden("module", __PACKAGE__),"\n",
469 CGI::hidden("set", $set->id),"\n",
470 CGI::hidden("problem", $problem->id),"\n",
471 CGI::hidden("displayMode", $self->{displayMode}),"\n",
472 CGI::hidden("showOldAnswers", $will{showOldAnswers}),"\n",
473 CGI::hidden("showCorrectAnswers", $will{showCorrectAnswers}),"\n",
474 CGI::hidden("showHints", $will{showHints}),"\n",
475 CGI::hidden("showSolutions", $will{showSolutions}),"\n",
476 CGI::p({-align=>"right"},
477 CGI::submit(-name=>"feedbackForm", -label=>"Send Feedback")
478 ),
479 CGI::endform(),"\n";
480 # print answer inspection button
481 if ($self->{permissionLevel} >0) {
482
173 483
174sub is_hash_ref { 484 print "\n",
485 CGI::start_form(-method=>"POST",-action=>$showPastAnswersURL,-target=>"information"),"\n",
486 $self->hidden_authen_fields,"\n",
487 CGI::hidden(-name => 'course', -value=>$courseName), "\n",
488 CGI::hidden(-name => 'probNum', -value=>$problem->id), "\n",
489 CGI::hidden(-name => 'setNum', -value=>$problem->set_id), "\n",
490 CGI::hidden(-name => 'User', -value=>$problem->login_id), "\n",
491 CGI::submit(-name => 'action', -value=>'Show Past Answers'), "\n",
492 CGI::endform();
493
494
495
496 }
497 print CGI::end_div();
498 # end answer inspection button
499 # warning output
500 if ($pg->{warnings} ne "") {
501 print CGI::hr(), $self->warningOutput($pg->{warnings});
502 }
503
504 # debugging stuff
505 if (0) {
506 print
507 CGI::hr(),
508 CGI::h2("debugging information"),
509 CGI::h3("form fields"),
510 ref2string($self->{formFields}),
511 CGI::h3("user object"),
512 ref2string($self->{user}),
513 CGI::h3("set object"),
514 ref2string($set),
515 CGI::h3("problem object"),
516 ref2string($problem),
517 CGI::h3("PG object"),
518 ref2string($pg, {'WeBWorK::PG::Translator' => 1});
519 }
520
521 return "";
522}
523
524##### output utilities #####
525
526sub attemptResults($$$$$$) {
527 my $self = shift;
175 my $in =shift; 528 my $pg = shift;
176 my $save_SIG_die_trap = $SIG{__DIE__}; 529 my $showAttemptAnswers = shift;
177 $SIG{__DIE__} = sub {CORE::die(@_) }; 530 my $showCorrectAnswers = shift;
178 my $out = eval{ %{ $in } }; 531 my $showAttemptResults = $showAttemptAnswers && shift;
179 $out = ($@ eq '') ? 1 : 0; 532 my $showSummary = shift;
180 $@=''; 533 my $showAttemptPreview = shift || 0;
181 $SIG{__DIE__} = $save_SIG_die_trap; 534 my $problemResult = $pg->{result}; # the overall result of the problem
182 $out; 535 my @answerNames = @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} };
536
537 my $showMessages = $showAttemptAnswers && grep { $pg->{answers}->{$_}->{ans_message} } @answerNames;
538
539 my $header = CGI::th("Part");
540 $header .= $showAttemptAnswers ? CGI::th("Entered") : "";
541 $header .= $showAttemptPreview ? CGI::th("Answer Preview") : "";
542 $header .= $showCorrectAnswers ? CGI::th("Correct") : "";
543 $header .= $showAttemptResults ? CGI::th("Result") : "";
544 $header .= $showMessages ? CGI::th("messages") : "";
545 my @tableRows = ( $header );
546 my $numCorrect;
547 foreach my $name (@answerNames) {
548 my $answerResult = $pg->{answers}->{$name};
549 my $studentAnswer = $answerResult->{student_ans}; # original_student_ans
550 my $preview = ($showAttemptPreview
551 ? $self->previewAnswer($answerResult)
552 : "");
553 my $correctAnswer = $answerResult->{correct_ans};
554 my $answerScore = $answerResult->{score};
555 my $answerMessage = $showMessages ? $answerResult->{ans_message} : "";
556
557 $numCorrect += $answerScore > 0;
558 my $resultString = $answerScore ? "correct" : "incorrect";
559
560 # get rid of the goofy prefix on the answer names (supposedly, the format
561 # of the answer names is changeable. this only fixes it for "AnSwEr"
562 $name =~ s/^AnSwEr//;
563
564 my $row = CGI::td($name);
565 $row .= $showAttemptAnswers ? CGI::td($studentAnswer) : "";
566 $row .= $showAttemptPreview ? CGI::td($preview) : "";
567 $row .= $showCorrectAnswers ? CGI::td($correctAnswer) : "";
568 $row .= $showAttemptResults ? CGI::td($resultString) : "";
569 $row .= $answerMessage ? CGI::td($answerMessage) : "";
570 push @tableRows, $row;
571 }
572
573 my $numIncorrectNoun = scalar @answerNames == 1 ? "question" : "questions";
574 my $scorePercent = int ($problemResult->{score} * 100) . "\%";
575 my $summary = "On this attempt, you answered $numCorrect out of "
576 . scalar @answerNames . " $numIncorrectNoun correct, for a score of $scorePercent.";
577 return CGI::table({-class=>"attemptResults"}, CGI::Tr(\@tableRows)) . ($showSummary ? CGI::p($summary) : "");
183} 578}
184sub is_array_ref { 579
580sub viewOptions($) {
185 my $in =shift; 581 my $self = shift;
186 my $save_SIG_die_trap = $SIG{__DIE__}; 582 my $displayMode = $self->{displayMode};
187 $SIG{__DIE__} = sub {CORE::die(@_) }; 583 my %must = %{ $self->{must} };
188 my $out = eval{ @{ $in } }; 584 my %can = %{ $self->{can} };
189 $out = ($@ eq '') ? 1 : 0; 585 my %will = %{ $self->{will} };
190 $@=''; 586
191 $SIG{__DIE__} = $save_SIG_die_trap; 587 my $optionLine;
192 $out; 588 $can{showOldAnswers} and $optionLine .= join "",
589 "Show: &nbsp;",
590 CGI::checkbox(
591 -name => "showOldAnswers",
592 -checked => $will{showOldAnswers},
593 -label => "Saved answers",
594 ), "&nbsp;&nbsp;";
595 $can{showCorrectAnswers} and $optionLine .= join "",
596 CGI::checkbox(
597 -name => "showCorrectAnswers",
598 -checked => $will{showCorrectAnswers},
599 -label => "Correct answers",
600 ), "&nbsp;&nbsp;";
601 $can{showHints} and $optionLine .= join "",
602 CGI::checkbox(
603 -name => "showHints",
604 -checked => $will{showHints},
605 -label => "Hints",
606 ), "&nbsp;&nbsp;";
607 $can{showSolutions} and $optionLine .= join "",
608 CGI::checkbox(
609 -name => "showSolutions",
610 -checked => $will{showSolutions},
611 -label => "Solutions",
612 ), "&nbsp;&nbsp;";
613 $optionLine and $optionLine .= join "", CGI::br();
614
615 return CGI::div({-style=>"border: thin groove; padding: 1ex; margin: 2ex"},
616 "View equations as: &nbsp;",
617 CGI::radio_group(
618 -name => "displayMode",
619 -values => ['plainText', 'formattedText', 'images'],
620 -default => $displayMode,
621 -labels => {
622 plainText => "plain text",
623 formattedText => "formatted text",
624 images => "images",
625 }
626 ), CGI::br(),
627 $optionLine,
628 CGI::submit(-name=>"redisplay", -label=>"Redisplay Problem"),
629 );
630}
631
632sub previewAnswer($$) {
633 my ($self, $answerResult) = @_;
634 my $ce = $self->{courseEnvironment};
635 my $effectiveUser = $self->{effectiveUser};
636 my $set = $self->{set};
637 my $problem = $self->{problem};
638 my $displayMode = $self->{displayMode};
639
640 # note: right now, we have to do things completely differently when we are
641 # rendering math from INSIDE the translator and from OUTSIDE the translator.
642 # so we'll just deal with each case explicitly here. there's some code
643 # duplication that can be dealt with later by abstracting out tth/dvipng/etc.
644
645 my $tex = $answerResult->{preview_latex_string};
646
647 return "" unless $tex;
648
649 if ($displayMode eq "plainText") {
650 return $tex;
651 } elsif ($displayMode eq "formattedText") {
652 my $tthCommand = $ce->{externalPrograms}->{tth}
653 . " -L -f5 -r 2> /dev/null <<END_OF_INPUT; echo > /dev/null\n"
654 . "\\(".$tex."\\)\n"
655 . "END_OF_INPUT\n";
656
657 # call tth
658 my $result = `$tthCommand`;
659 if ($?) {
660 return "<b>[tth failed: $? $@]</b>";
661 }
662 return $result;
663 } elsif ($displayMode eq "images") {
664 # how are we going to name this?
665 my $targetPathCommon = "/png/"
666 . $effectiveUser->id . "."
667 . $set->id . "."
668 . $problem->id . "."
669 . $answerResult->{ans_name} . ".png";
670
671 # figure out where to put things
672 my $wd = tempdir("webwork-dvipng-XXXXXXXX", DIR => $ce->{courseDirs}->{html_temp});
673 my $latex = $ce->{externalPrograms}->{latex};
674 my $dvipng = $ce->{externalPrograms}->{dvipng};
675 my $targetPath = $ce->{courseDirs}->{html_temp} . $targetPathCommon;
676 # should use surePathToTmpFile, but we have to
677 # isolate it from the problem enivronment first
678 my $targetURL = $ce->{courseURLs}->{html_temp} . $targetPathCommon;
679
680 # call dvipng to generate a preview
681 warn $tex;
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>";
687 }
688 }
689}
690##### logging subroutine ####
691
692
693
694##### permission queries #####
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...
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;
193} 734}
194 735
1951; 7361;
196
197__END__
198
199my $foo =0;
200
201# The warning mechanism. This needs to be turned into an object of its own
202###############
203## Error message routines cribbed from CGI
204###############
205
206BEGIN { #error message routines cribbed from CGI
207
208 my $CarpLevel = 0; # How many extra package levels to skip on carp.
209 my $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
210
211 sub longmess {
212 my $error = shift;
213 my $mess = "";
214 my $i = 1 + $CarpLevel;
215 my ($pack,$file,$line,$sub,$eval,$require);
216
217 while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) {
218 if ($error =~ m/\n$/) {
219 $mess .= $error;
220 }
221 else {
222 if (defined $eval) {
223 if ($require) {
224 $sub = "require $eval";
225 }
226 else {
227 $eval =~ s/[\\\']/\\$&/g;
228 if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
229 substr($eval,$MaxEvalLen) = '...';
230 }
231 $sub = "eval '$eval'";
232 }
233 }
234 elsif ($sub eq '(eval)') {
235 $sub = 'eval {...}';
236 }
237
238 $mess .= "\t$sub " if $error eq "called";
239 $mess .= "$error at $file line $line\n";
240 }
241
242 $error = "called";
243 }
244
245 $mess || $error;
246 }
247}
248###############
249### Our error messages for giving maximum feedback to the user for errors within problems.
250###############
251BEGIN {
252 sub PG_floating_point_exception_handler { # 1st argument is signal name
253 my($sig) = @_;
254 print "Content-type: text/html\n\n<H4>There was a floating point arithmetic error (exception SIG$sig )</H4>--perhaps
255 you divided by zero or took the square root of a negative number?
256 <BR>\n Use the back button to return to the previous page and recheck your entries.<BR>\n";
257 exit(0);
258 }
259
260 $SIG{'FPE'} = \&PG_floating_point_exception_handler;
261#!/usr/bin/perl -w
262 sub PG_warnings_handler {
263 my @input = @_;
264 my $msg_string = longmess(@_);
265 my @msg_array = split("\n",$msg_string);
266 my $out_string = '';
267
268 # Extra stack information is provided in this next block
269 # If the warning message does NOT end in \n then a line
270 # number is appended (see Perl manual about warn function)
271 # The presence of the line number is detected below and extra
272 # stack information is added.
273 # To suppress the line number and the extra stack information
274 # add \n to the end of a warn message (in .pl files. In .pg
275 # files add ~~n instead
276
277 if ($input[$#input]=~/line \d*\.\s*$/) {
278 $out_string .= "##More details: <BR>\n----";
279 foreach my $line (@msg_array) {
280 chomp($line);
281 next unless $line =~/\w+\:\:/;
282 $out_string .= "----" .$line . "<BR>\n";
283 }
284 }
285
286 $Global::WARNINGS .="* " . join("<BR>",@input) . "<BR>\n" . $out_string .
287 "<BR>\n--------------------------------------<BR>\n<BR>\n";
288 $Global::background_plain_url = $Global::background_warn_url;
289 $Global::bg_color = '#FF99CC'; #for warnings -- this change may come too late
290 }
291
292 $SIG{__WARN__}=\&PG_warnings_handler;
293
294 $SIG{__DIE__} = sub {
295 my $message = longmess(@_);
296 $message =~ s/\n/<BR>\n/;
297 my ($package, $filename, $line) = caller();
298 # use standard die for errors eminating from XML::Parser::Expat
299 # it uses a trapped eval which sometimes fails -- apparently on purpose
300 # and the error is handled by Expat itself. We don't want
301 # to interfer with that.
302
303 if ($package eq 'XML::Parser::Expat') {
304 die @_;
305 }
306 #print "$package $filename $line \n";
307 print
308 "Content-type: text/html\r\n\r\n <h4>Software error</h4> <p>\n\n$message\n<p>\n
309 Please inform the webwork meister.<p>\n
310 In addition to the error message above the following warnings were detected:
311 <HR>
312 $Global::WARNINGS;
313 <HR>
314 It's sometimes hard to tell exactly what has gone wrong since the
315 full error message may have been sent to
316 standard error instead of to standard out.
317 <p> To debug you can
318 <ul>
319 <li> guess what went wrong and try to fix it.
320 <li> call the offending script directly from the command line
321 of unix
322 <li> enable the debugging features by redefining
323 \$cgiURL in Global.pm and checking the redirection scripts in
324 system/cgi. This will force the standard error to be placed
325 in the standard out pipe as well.
326 <li> Run tail -f error_log <br>
327 from the unix command line to see error messages from the webserver.
328 The standard error output is being placed in the error_log file for the apache
329 web server. To run this command you have to be in the directory containing the
330 error_log or enter the full path name of the error_log. <p>
331 In a standard apache installation, this file is at /usr/local/apache/logs/error_log<p>
332 In a RedHat Linux installation, this file is at /var/log/httpd/error_log<p>
333 At Rochester this file is at /ww/logs/error_log.
334 </ul>
335 Good luck.<p>\n" ;
336 };
337
338
339
340}
Legend:
Removed from v.415  
changed lines
  Added in v.794
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9