Parent Directory
| 
Revision Log
fixed a logic error in Problem.pm affecting $can{submitAnswers}
-sam
1 ################################################################################ 2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project 3 # $Id$ 4 ################################################################################ 5 6 package WeBWorK::ContentGenerator::Problem; 7 8 =head1 NAME 9 10 WeBWorK::ContentGenerator::Problem - Allow a student to interact with a problem. 11 12 =cut 13 14 use strict; 15 use warnings; 16 use base qw(WeBWorK::ContentGenerator); 17 use CGI qw(); 18 use WeBWorK::Form; 19 use WeBWorK::PG; 20 use WeBWorK::Utils qw(writeLog encodeAnswers decodeAnswers ref2string); 21 22 ############################################################ 23 # 24 # user 25 # key 26 # 27 # displayMode 28 # showOldAnswers 29 # showCorrectAnswers 30 # showHints 31 # showSolutions 32 # 33 # AnSwEr# - answer blanks in problem 34 # 35 # redisplay - name of the "Redisplay Problem" button 36 # submitAnswers - name of "Submit Answers" button 37 # 38 ############################################################ 39 40 sub pre_header_initialize { 41 my ($self, $setName, $problemNumber) = @_; 42 my $courseEnv = $self->{courseEnvironment}; 43 my $r = $self->{r}; 44 my $userName = $r->param('user'); 45 46 ##### database setup ##### 47 48 my $cldb = WeBWorK::DB::Classlist->new($courseEnv); 49 my $wwdb = WeBWorK::DB::WW->new($courseEnv); 50 my $authdb = WeBWorK::DB::Auth->new($courseEnv); 51 52 my $user = $cldb->getUser($userName); 53 my $set = $wwdb->getSet($userName, $setName); 54 my $problem = $wwdb->getProblem($userName, $setName, $problemNumber); 55 my $psvn = $wwdb->getPSVN($userName, $setName); 56 my $permissionLevel = $authdb->getPermissions($userName); 57 58 ##### form processing ##### 59 60 # set options from form fields (see comment at top of file for names) 61 my $displayMode = $r->param("displayMode") || $courseEnv->{pg}->{options}->{displayMode}; 62 my $redisplay = $r->param("redisplay"); 63 my $submitAnswers = $r->param("submitAnswers"); 64 65 # coerce form fields into CGI::Vars format 66 my $formFields = { WeBWorK::Form->new_from_paramable($r)->Vars }; 67 68 ##### permissions ##### 69 70 # what does the user want to do? 71 my %want = ( 72 showOldAnswers => $r->param("showOldAnswers") || $courseEnv->{pg}->{options}->{showOldAnswers}, 73 showCorrectAnswers => $r->param("showCorrectAnswers") || $courseEnv->{pg}->{options}->{showCorrectAnswers}, 74 showHints => $r->param("showHints") || $courseEnv->{pg}->{options}->{showHints}, 75 showSolutions => $r->param("showSolutions") || $courseEnv->{pg}->{options}->{showSolutions}, 76 recordAnswers => $r->param("recordAnswers") || 1, 77 ); 78 79 # are certain options enforced? 80 my %must = ( 81 showOldAnswers => 0, 82 showCorrectAnswers => 0, 83 showHints => 0, 84 showSolutions => 0, 85 recordAnswers => mustRecordAnswers($permissionLevel), 86 ); 87 88 # does the user have permission to use certain options? 89 my %can = ( 90 showOldAnswers => 1, 91 showCorrectAnswers => canShowCorrectAnswers($permissionLevel, $set->answer_date), 92 showHints => 1, 93 showSolutions => canShowSolutions($permissionLevel, $set->answer_date), 94 recordAnswers => canRecordAnswers($permissionLevel, $set->open_date, $set->due_date, 95 $problem->max_attempts, $problem->num_correct + $problem->num_incorrect + 1), 96 # num_correct+num_incorrect+1 -- as this happens before updating $problem 97 ); 98 99 # final values for options 100 my %will; 101 foreach (keys %must) { 102 $will{$_} = $can{$_} && ($want{$_} || $must{$_}); 103 #warn "$_: can? $can{$_} want? $want{$_} must? $must{$_} will? $will{$_}\n"; 104 } 105 106 ##### sticky answers ##### 107 108 if (not $submitAnswers and $will{showOldAnswers}) { 109 # do this only if new answers are NOT being submitted 110 my %oldAnswers = decodeAnswers($problem->last_answer); 111 $formFields->{$_} = $oldAnswers{$_} foreach keys %oldAnswers; 112 } 113 114 ##### translation ##### 115 116 my $pg = WeBWorK::PG->new( 117 $courseEnv, 118 $user, 119 $r->param('key'), 120 $set, 121 $problem, 122 $psvn, 123 $formFields, 124 { # translation options 125 displayMode => $displayMode, 126 showHints => $will{showHints}, 127 showSolutions => $will{showSolutions}, 128 refreshMath2img => $will{showHints} || $will{showSolutions}, 129 # try leaving processAnswers on all the time? 130 processAnswers => 1, #$submitAnswers ? 1 : 0, 131 }, 132 ); 133 134 ##### store fields ##### 135 136 $self->{cldb} = $cldb; 137 $self->{wwdb} = $wwdb; 138 $self->{authdb} = $authdb; 139 140 $self->{user} = $user; 141 $self->{set} = $set; 142 $self->{problem} = $problem; 143 $self->{permissionLevel} = $permissionLevel; 144 145 $self->{displayMode} = $displayMode; 146 $self->{redisplay} = $redisplay; 147 $self->{submitAnswers} = $submitAnswers; 148 $self->{formFields} = $formFields; 149 150 $self->{want} = \%want; 151 $self->{must} = \%must; 152 $self->{can} = \%can; 153 $self->{will} = \%will; 154 155 $self->{pg} = $pg; 156 } 157 158 sub if_warnings($$) { 159 my ($self, $arg) = @_; 160 return $self->{pg}->{warnings} ne ""; 161 } 162 163 sub if_errors($$) { 164 my ($self, $arg) = @_; 165 return $self->{pg}->{flags}->{error_flag}; 166 } 167 168 sub head { 169 my $self = shift; 170 171 return $self->{pg}->{head_text} if $self->{pg}->{head_text}; 172 } 173 174 sub path { 175 my $self = shift; 176 my $args = $_[-1]; 177 my $setName = $self->{set}->id; 178 my $problemNumber = $self->{problem}->id; 179 180 my $ce = $self->{courseEnvironment}; 181 my $root = $ce->{webworkURLs}->{root}; 182 my $courseName = $ce->{courseName}; 183 return $self->pathMacro($args, 184 "Home" => "$root", 185 $courseName => "$root/$courseName", 186 $setName => "$root/$courseName/$setName", 187 "Problem $problemNumber" => "", 188 ); 189 } 190 191 sub siblings { 192 my $self = shift; 193 my $setName = $self->{set}->id; 194 my $problemNumber = $self->{problem}->id; 195 196 my $ce = $self->{courseEnvironment}; 197 my $root = $ce->{webworkURLs}->{root}; 198 my $courseName = $ce->{courseName}; 199 200 print CGI::strong("Problems"), CGI::br(); 201 202 my $wwdb = $self->{wwdb}; 203 my $user = $self->{r}->param("user"); 204 my @problems; 205 push @problems, $wwdb->getProblem($user, $setName, $_) 206 foreach ($wwdb->getProblems($user, $setName)); 207 foreach my $problem (sort { $a->id <=> $b->id } @problems) { 208 print CGI::a({-href=>"$root/$courseName/$setName/".$problem->id."/?" 209 . $self->url_authen_args}, "Problem ".$problem->id), CGI::br(); 210 } 211 } 212 213 sub nav { 214 my $self = shift; 215 my $args = $_[-1]; 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 my $wwdb = $self->{wwdb}; 224 my $user = $self->{r}->param("user"); 225 226 my @links = ("Problem List" => "$root/$courseName/$setName"); 227 228 my $prevProblem = $wwdb->getProblem($user, $setName, $problemNumber-1); 229 my $nextProblem = $wwdb->getProblem($user, $setName, $problemNumber+1); 230 unshift @links, "Previous Problem" => $prevProblem 231 ? "$root/$courseName/$setName/".$prevProblem->id 232 : ""; 233 push @links, "Next Problem" => $nextProblem 234 ? "$root/$courseName/$setName/".$nextProblem->id 235 : ""; 236 237 return $self->navMacro($args, @links); 238 } 239 240 sub title { 241 my $self = shift; 242 my $setName = $self->{set}->id; 243 my $problemNumber = $self->{problem}->id; 244 245 return "$setName : Problem $problemNumber"; 246 } 247 248 sub body { 249 my $self = shift; 250 251 # unpack some useful variables 252 my $r = $self->{r}; 253 my $wwdb = $self->{wwdb}; 254 my $set = $self->{set}; 255 my $problem = $self->{problem}; 256 my $permissionLevel = $self->{permissionLevel}; 257 my $submitAnswers = $self->{submitAnswers}; 258 my %will = %{ $self->{will} }; 259 my $pg = $self->{pg}; 260 261 ##### translation errors? ##### 262 263 if ($pg->{flags}->{error_flag}) { 264 return translationError($pg->{errors}, $pg->{body_text}); 265 } 266 267 ##### answer processing ##### 268 269 # if answers were submitted: 270 if ($submitAnswers) { 271 # store answers in DB for sticky answers 272 my %answersToStore; 273 my %answerHash = %{ $pg->{answers} }; 274 $answersToStore{$_} = $answerHash{$_}->{original_student_ans} 275 foreach (keys %answerHash); 276 my $answerString = encodeAnswers(%answersToStore, 277 @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} }); 278 $problem->last_answer($answerString); 279 $wwdb->setProblem($problem); 280 281 # store state in DB if it makes sense 282 if ($will{recordAnswers}) { 283 $problem->attempted(1); 284 $problem->status($pg->{state}->{recorded_score}); 285 $problem->num_correct($pg->{state}->{num_of_correct_ans}); 286 $problem->num_incorrect($pg->{state}->{num_of_incorrect_ans}); 287 $wwdb->setProblem($problem); 288 # write to the transaction log, just to make sure 289 writeLog($self->{courseEnvironment}, "transaction", 290 $problem->id."\t". 291 $problem->set_id."\t". 292 $problem->login_id."\t". 293 $problem->source_file."\t". 294 $problem->value."\t". 295 $problem->max_attempts."\t". 296 $problem->problem_seed."\t". 297 $problem->status."\t". 298 $problem->attempted."\t". 299 $problem->last_answer."\t". 300 $problem->num_correct."\t". 301 $problem->num_incorrect 302 ); 303 } 304 } 305 306 ##### output ##### 307 308 # attempt summary 309 if ($submitAnswers or $will{showCorrectAnswers}) { 310 # print this if user submitted answers OR requested correct answers 311 print attemptResults($pg, $submitAnswers, $will{showCorrectAnswers}, 312 $pg->{flags}->{showPartialCorrectAnswers}); 313 } 314 315 # score summary 316 my $attempts = $problem->num_correct + $problem->num_incorrect; 317 my $attemptsNoun = $attempts != 1 ? "times" : "time"; 318 my $lastScore = int ($problem->status * 100) . "%"; 319 my ($attemptsLeft, $attemptsLeftNoun); 320 if ($problem->max_attempts == -1) { 321 # unlimited attempts 322 $attemptsLeft = "unlimited"; 323 $attemptsLeftNoun = "attempts"; 324 } else { 325 $attemptsLeft = $problem->max_attempts - $attempts; 326 $attemptsLeftNoun = $attemptsLeft == 1 ? "attempt" : "attempts"; 327 } 328 my $setClosedMessage; 329 if (time < $set->open_date or time > $set->due_date) { 330 $setClosedMessage = "This problem set is closed."; 331 if ($permissionLevel > 0) { 332 $setClosedMessage .= " Since you are a privileged user, additional attempts will be recorded."; 333 } else { 334 $setClosedMessage .= " Additional attempts will not be recorded."; 335 } 336 } 337 print CGI::p( 338 "You have attempted this problem $attempts $attemptsNoun.", CGI::br(), 339 $problem->attempted 340 ? "Your recorded score is $lastScore." . CGI::br() 341 : "", 342 "You have $attemptsLeft $attemptsLeftNoun remaining.", CGI::br(), 343 $setClosedMessage, 344 ); 345 346 # BY THE WAY.......... 347 # we have to figure out some way to tell the student if their NEW answer, 348 # on THIS attempt, has been recorded. however, this is decided in part by 349 # the grader, so is there any way for us to know? we can rule out several 350 # cases where the answer is NOT being recorded, because of things decided 351 # in &canRecordAnswers... 352 353 print CGI::hr(); 354 355 # main form 356 print 357 CGI::startform("POST", $r->uri), 358 $self->hidden_authen_fields, 359 $self->viewOptions, 360 CGI::p(CGI::i($pg->{result}->{msg})), 361 CGI::p($pg->{body_text}), 362 CGI::p(CGI::submit(-name=>"submitAnswers", -label=>"Submit Answers")), 363 CGI::endform(); 364 365 # warning output 366 if ($pg->{warnings} ne "") { 367 print CGI::hr(), warningOutput($pg->{warnings}); 368 } 369 370 # debugging stuff 371 #print 372 # hr(), 373 # h2("debugging information"), 374 # h3("form fields"), 375 # ref2string($formFields), 376 # h3("user object"), 377 # ref2string($user), 378 # h3("set object"), 379 # ref2string($set), 380 # h3("problem object"), 381 # ref2string($problem), 382 # h3("PG object"), 383 # ref2string($pg, {'WeBWorK::PG::Translator' => 1}); 384 385 return ""; 386 } 387 388 ##### output utilities ##### 389 390 # this is used by ProblemSet.pm too, so don't fuck it up 391 sub translationError($$) { 392 my ($error, $details) = @_; 393 return 394 CGI::h2("Software Error"), 395 CGI::p(<<EOF), 396 WeBWorK has encountered a software error while attempting to process this problem. 397 It is likely that there is an error in the problem itself. 398 If you are a student, contact your professor to have the error corrected. 399 If you are a professor, please consut the error output below for more informaiton. 400 EOF 401 CGI::h3("Error messages"), CGI::blockquote(CGI::pre($error)), 402 CGI::h3("Error context"), CGI::blockquote(CGI::pre($details)); 403 } 404 405 # this is used by ProblemSet.pm too, so don't fuck it up 406 sub warningOutput($) { 407 my $warnings = shift; 408 409 return 410 CGI::h2("Software Warnings"), 411 CGI::p(<<EOF), 412 WeBWorK has encountered warnings while attempting to process this problem. 413 It is likely that this indicates an error or ambiguity in the problem itself. 414 If you are a student, contact your professor to have the problem corrected. 415 If you are a professor, please consut the error output below for more informaiton. 416 EOF 417 CGI::h3("Warning messages"), 418 CGI::blockquote(CGI::pre($warnings)), 419 ; 420 } 421 422 sub attemptResults($$$) { 423 my $pg = shift; 424 my $showAttemptAnswers = shift; 425 my $showCorrectAnswers = shift; 426 my $showAttemptResults = $showAttemptAnswers && shift; 427 my $problemResult = $pg->{result}; # the overall result of the problem 428 my @answerNames = @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} }; 429 430 my $header = CGI::th("answer"); 431 $header .= $showAttemptAnswers ? CGI::th("attempt") : ""; 432 $header .= $showCorrectAnswers ? CGI::th("correct") : ""; 433 $header .= $showAttemptResults ? CGI::th("result") : ""; 434 $header .= $showAttemptAnswers ? CGI::th("messages") : ""; 435 my @tableRows = ( $header ); 436 my $numCorrect; 437 foreach my $name (@answerNames) { 438 my $answerResult = $pg->{answers}->{$name}; 439 my $studentAnswer = $answerResult->{student_ans}; # original_student_ans 440 my $correctAnswer = $answerResult->{correct_ans}; 441 my $answerScore = $answerResult->{score}; 442 my $answerMessage = $showAttemptAnswers ? $answerResult->{ans_message} : ""; 443 444 $numCorrect += $answerScore > 0; 445 my $resultString = $answerScore ? "correct" : "incorrect"; 446 447 # get rid of the goofy prefix on the answer names (supposedly, the format 448 # of the answer names is changeable. this only fixes 449 $name =~ s/^AnSwEr//; 450 451 my $row = CGI::td($name); 452 $row .= $showAttemptAnswers ? CGI::td($studentAnswer) : ""; 453 $row .= $showCorrectAnswers ? CGI::td($correctAnswer) : ""; 454 $row .= $showAttemptResults ? CGI::td($resultString) : ""; 455 $row .= $answerMessage ? CGI::td($answerMessage) : ""; 456 push @tableRows, $row; 457 } 458 459 my $numCorrectNoun = $numCorrect == 1 ? "question" : "questions"; 460 my $scorePercent = int ($problemResult->{score} * 100) . "\%"; 461 my $summary = "On this attempt, you answered $numCorrect $numCorrectNoun out of " 462 . scalar @answerNames . " correct, for a score of $scorePercent."; 463 return CGI::table({-border=>1}, CGI::Tr(\@tableRows)) . CGI::p($summary); 464 } 465 466 sub viewOptions($) { 467 my $self = shift; 468 my $displayMode = $self->{displayMode}; 469 my %must = %{ $self->{must} }; 470 my %can = %{ $self->{can} }; 471 my %will = %{ $self->{will} }; 472 473 my $optionLine; 474 $can{showOldAnswers} and $optionLine .= join "", 475 "Show: ", 476 CGI::checkbox( 477 -name => "showOldAnswers", 478 -checked => $will{showOldAnswers}, 479 -label => "Saved answers", 480 ), " "; 481 $can{showCorrectAnswers} and $optionLine .= join "", 482 CGI::checkbox( 483 -name => "showCorrectAnswers", 484 -checked => $will{showCorrectAnswers}, 485 -label => "Correct answers", 486 ), " "; 487 $can{showHints} and $optionLine .= join "", 488 CGI::checkbox( 489 -name => "showHints", 490 -checked => $will{showHints}, 491 -label => "Hints", 492 ), " "; 493 $can{showSolutions} and $optionLine .= join "", 494 CGI::checkbox( 495 -name => "showSolutions", 496 -checked => $will{showSolutions}, 497 -label => "Solutions", 498 ), " "; 499 $optionLine and $optionLine .= join "", CGI::br(); 500 501 return CGI::div({-style=>"border: thin groove; padding: 1ex; margin: 2ex"}, 502 "View equations as: ", 503 CGI::radio_group( 504 -name => "displayMode", 505 -values => ['plainText', 'formattedText', 'images'], 506 -default => $displayMode, 507 -labels => { 508 plainText => "plain text", 509 formattedText => "formatted text", 510 images => "images", 511 } 512 ), CGI::br(), 513 $optionLine, 514 CGI::submit(-name=>"redisplay", -label=>"Redisplay Problem"), 515 ); 516 } 517 518 ##### permission queries ##### 519 520 # this stuff should be abstracted out into the permissions system 521 # however, the permission system only knows about things in the 522 # course environment and the username. hmmm... 523 524 # also, i should fix these so that they have a consistent calling 525 # format -- perhaps: 526 # canPERM($courseEnv, $user, $set, $problem, $permissionLevel) 527 528 sub canShowCorrectAnswers($$) { 529 my ($permissionLevel, $answerDate) = @_; 530 return $permissionLevel > 0 || time > $answerDate; 531 } 532 533 sub canShowSolutions($$) { 534 my ($permissionLevel, $answerDate) = @_; 535 return canShowCorrectAnswers($permissionLevel, $answerDate); 536 } 537 538 sub canRecordAnswers($$$$$) { 539 my ($permissionLevel, $openDate, $dueDate, $maxAttempts, $attempts) = @_; 540 my $permHigh = $permissionLevel > 0; 541 my $timeOK = time >= $openDate && time <= $dueDate; 542 my $attemptsOK = $maxAttempts == -1 || $attempts <= $maxAttempts; 543 my $recordAnswers = $permHigh || ($timeOK && $attemptsOK); 544 return $recordAnswers; 545 } 546 547 sub mustRecordAnswers($) { 548 my ($permissionLevel) = @_; 549 return $permissionLevel == 0; 550 } 551 552 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |