--- trunk/webwork2/lib/WeBWorK/ContentGenerator/Problem.pm 2002/06/20 21:26:16 399 +++ trunk/webwork2/lib/WeBWorK/ContentGenerator/Problem.pm 2003/01/13 19:44:20 704 @@ -1,666 +1,655 @@ -package WeBWorK::ContentGenerator::Problem; -our @ISA = qw(WeBWorK::ContentGenerator); +################################################################################ +# WeBWorK mod_perl (c) 2000-2002 WeBWorK Project +# $Id$ +################################################################################ -use strict; -use warnings; -use lib '/home/malsyned/xmlrpc/daemon'; -use lib '/Users/gage/webwork-modperl/lib'; -use PGtranslator5; -use WeBWorK::ContentGenerator; -use Apache::Constants qw(:common); - -############################################################################### -# Configuration -############################################################################### -my $USER_DIRECTORY = '/Users/gage'; -my $COURSE_SCRIPTS_DIRECTORY = "$USER_DIRECTORY/webwork/system/courseScripts/"; -my $MACRO_DIRECTORY = "$USER_DIRECTORY/webwork-modperl/courses/demoCourse/templates/macros/"; -my $TEMPLATE_DIRECTORY = "$USER_DIRECTORY/rochester_problib/"; -my $TEMP_URL = "http://127.0.0.1/~gage/rochester_problibtmp/"; -##my $HTML_DIRECTORY = "/Users/gage/Sites/rochester_problib/" #already obtained from courseEnvironment -my $HTML_URL = "http://127.0.0.1/~gage/rochester_problib/"; -my $TEMP_DIRECTORY = ""; # has to be here... for now - -############################################################################### -# End configuration -############################################################################### +package WeBWorK::ContentGenerator::Problem; -sub title { - my ($self, $problem_set, $problem) = @_; - my $r = $self->{r}; - my $user = $r->param('user'); - return "Problem $problem of problem set $problem_set for $user"; -} +=head1 NAME -############################################################################### -# -# INITIALIZATION -# -# The following code initializes an instantiation of PGtranslator5 in the -# parent process. This initialized object is then share with each of the -# children forked from this parent process by the daemon. -# -# As far as I can tell, the child processes don't share any variable values even -# though their namespaces are the same. -############################################################################### -# First some dummy values to use for testing. -# These should be available from the problemEnvironment(it might be ok to assume that PG and dangerousMacros -# live in the courseScripts (system level macros) directory. - -#print STDERR "Begin intitalization\n"; -my $dummy_envir = { courseScriptsDirectory => $COURSE_SCRIPTS_DIRECTORY, - displayMode => 'HTML_tth', - macroDirectory => $MACRO_DIRECTORY, - cgiURL => 'foo_cgiURL'}; - - -my $PG_PL = "${COURSE_SCRIPTS_DIRECTORY}PG.pl"; -my $DANGEROUS_MACROS_PL = "${COURSE_SCRIPTS_DIRECTORY}dangerousMacros.pl"; -my @MODULE_LIST = ( "Exporter", "DynaLoader", "GD", "WWPlot", "Fun", - "Circle", "Label", "PGrandom", "Units", "Hermite", - "List", "Match","Multiple", "Select", "AlgParser", - "AnswerHash", "Fraction", "VectorField", "Complex1", - "Complex", "MatrixReal1", "Matrix","Distributions", - "Regression" -); -my @EXTRA_PACKAGES = ( "AlgParserWithImplicitExpand", "Expr", - "ExprWithImplicitExpand", "AnswerEvaluator", - -); -my $INITIAL_MACRO_PACKAGES = <{courseEnvironment}; my $r = $self->{r}; - my $courseEnvironment = $self->{courseEnvironment}; - my $user = $r->param('user'); + my $userName = $r->param('user'); + my $effectiveUserName = $r->param('effectiveUser'); - my $rh = {}; # this needs to be set to a hash containing CGI params + ##### database setup ##### + my $cldb = WeBWorK::DB::Classlist->new($courseEnv); + my $wwdb = WeBWorK::DB::WW->new($courseEnv); + my $authdb = WeBWorK::DB::Auth->new($courseEnv); + + my $user = $cldb->getUser($userName); + my $effectiveUser = $cldb->getUser($effectiveUserName); + my $set = $wwdb->getSet($effectiveUserName, $setName); + my $problem = $wwdb->getProblem($effectiveUserName, $setName, $problemNumber); + my $psvn = $wwdb->getPSVN($effectiveUserName, $setName); + my $permissionLevel = $authdb->getPermissions($userName); + + ##### form processing ##### + + # set options from form fields (see comment at top of file for names) + my $displayMode = $r->param("displayMode") || $courseEnv->{pg}->{options}->{displayMode}; + my $redisplay = $r->param("redisplay"); + my $submitAnswers = $r->param("submitAnswers"); + my $previewAnswers = $r->param("previewAnswers"); + + # coerce form fields into CGI::Vars format + my $formFields = { WeBWorK::Form->new_from_paramable($r)->Vars }; + + ##### permissions ##### + + # what does the user want to do? + my %want = ( + showOldAnswers => $r->param("showOldAnswers") || $courseEnv->{pg}->{options}->{showOldAnswers}, + showCorrectAnswers => $r->param("showCorrectAnswers") || $courseEnv->{pg}->{options}->{showCorrectAnswers}, + showHints => $r->param("showHints") || $courseEnv->{pg}->{options}->{showHints}, + showSolutions => $r->param("showSolutions") || $courseEnv->{pg}->{options}->{showSolutions}, + recordAnswers => $r->param("recordAnswers") || 1, + ); - my $SOURCE1 = readFile("$problem_set/$problem.pg"); - print STDERR "SOURCEFILE: \n$SOURCE1\n\n"; + # are certain options enforced? + my %must = ( + showOldAnswers => 0, + showCorrectAnswers => 0, + showHints => 0, + showSolutions => 0, + recordAnswers => mustRecordAnswers($permissionLevel), + ); - ########################################################################### - # The pg problem class should have a method for installing it's problemEnvironment - ########################################################################### + # does the user have permission to use certain options? + my %can = ( + showOldAnswers => 1, + showCorrectAnswers => canShowCorrectAnswers($permissionLevel, $set->answer_date), + showHints => 1, + showSolutions => canShowSolutions($permissionLevel, $set->answer_date), + recordAnswers => canRecordAnswers($permissionLevel, $set->open_date, $set->due_date, + $problem->max_attempts, $problem->num_correct + $problem->num_incorrect + 1), + # num_correct+num_incorrect+1 -- as this happens before updating $problem + ); - my $problemEnvir_rh = defineProblemEnvir($self); + # final values for options + my %will; + foreach (keys %must) { + $will{$_} = $can{$_} && ($want{$_} || $must{$_}); + } - - ################################################################################## - # Prime the PGtranslator object and set it loose - ################################################################################## + ##### sticky answers ##### - - ############################################################################### - - ############################################################################### - #Create the PG translator. - ############################################################################### + if (not $submitAnswers and $will{showOldAnswers}) { + # do this only if new answers are NOT being submitted + my %oldAnswers = decodeAnswers($problem->last_answer); + $formFields->{$_} = $oldAnswers{$_} foreach keys %oldAnswers; + } - my $pt = new PGtranslator5; #pt stands for problem translator; + ##### translation ##### + my $pg = WeBWorK::PG->new( + $courseEnv, + $effectiveUser, + $r->param('key'), + $set, + $problem, + $psvn, + $formFields, + { # translation options + displayMode => $displayMode, + showHints => $will{showHints}, + showSolutions => $will{showSolutions}, + refreshMath2img => $will{showHints} || $will{showSolutions}, + processAnswers => 1, + }, + ); - # All of these hard coded directories need to be drawn from courseEnvironment. - # In addition I don't think that PGtranslator uses this stack internally yet. - # Passing these directories through the problemEnvironment variable is what - # is currently being done, but I don't think it is quite right, at least for most - # of them. + ##### fix hint/solution options ##### + $can{showHints} &&= $pg->{flags}->{hintExists}; + $can{showSolutions} &&= $pg->{flags}->{solutionExists}; - $pt ->rh_directories( { courseScriptsDirectory => $COURSE_SCRIPTS_DIRECTORY, - macroDirectory => $MACRO_DIRECTORY, - , - templateDirectory => $TEMPLATE_DIRECTORY, - tempDirectory => $TEMP_DIRECTORY, - } - ); + ##### store fields ##### - ############################################################################### - # First we load the modules from courseScripts directory. - # These do the "heavy lifting" in terms of formatting, creating graphs, and - # performing other heavy duty algorithms. - # - ############################################################################### - - $pt -> evaluate_modules( @MODULE_LIST); - $pt -> load_extra_packages( @EXTRA_PACKAGES ); - - ############################################################################### - # Load the environment constants. Some are used by the PGtranslator object but - # most of them are installed inside the Safe compartment where the problem - # runs. - ############################################################################### - #$pt -> environment($dummy_envir); - $pt -> environment($problemEnvir_rh); - - - # I've forgotten what this does exactly :-) - $pt->initialize(); - - ############################################################################### - # PG.pl contains the basic code which defines the problem interface, input and output. - # dangerousMacros.pl contains subroutines which have access to the hard drive and - # and the directory structure. All use of external resources by the problem is supposed - # to go through these subroutines. The idea is to put the potentially dangerous - # algorithms in on place so they can be watched closely. - # These two files are evaluated in the Safe compartment without any restrictions. - # They have full use of the perl commands. - ############################################################################### - my $loadErrors = $pt -> unrestricted_load($PG_PL ); - print STDERR "$loadErrors\n" if ($loadErrors); - $loadErrors = $pt -> unrestricted_load($DANGEROUS_MACROS_PL); - print STDERR "$loadErrors\n" if ($loadErrors); - - ############################################################################### - # Now set the mask to restrict the operations which can be performed within - # a problem or a macro file. - ############################################################################### - $pt-> set_mask(); - - # print "\nPG.pl: $PG_PL
\n"; - # print "DANGEROUS_MACROS_PL: $DANGEROUS_MACROS_PL
\n"; - # print "Print dummy environment
\n"; - # print pretty_print_rh($dummy_envir), "

\n\n"; - - # Read in the source code for the problem - - #$INITIAL_MACRO_PACKAGES =~ tr /\r/\n/; # change everything to unix line endings. - $SOURCE1 =~ tr /\r/\n/; - #print STDERR "Source again \n $SOURCE1"; - $pt->source_string( $SOURCE1 ); - - ############################################################################### - # Install a safety filter for screening student answers. The default is now the blank - # filter since the answer evaluators do a pretty good job of recompiling and screening - # student's answers. Still, you could prohibit back ticks, or something of the kind. - ############################################################################### - - $pt ->rf_safety_filter( \&safetyFilter); # install blank safety filter - - - print STDERR "New PGtranslator object inititialization completed.
\n"; - ################################################################################ - ## This ends the initialization of the PGtranslator object - ################################################################################ - - - ################################################################################ - # Run the problem (output the html text) but also store it within the object. - # The correct answers are also calculated and stored within the object - ################################################################################ - $pt ->translate(); - - #print problem output - print "Problem goes here

\n"; - print "Problem output
\n"; - print "################################################################################

"; - print ${$pt->r_text()}; - print "

################################################################################
"; - print "

End of problem output
"; - - - #print source code - print "Source code

\n";
-	print $SOURCE1;
-	print "
End source code

"; - ################################################################################ - # The format for the output is described here. We'll need a local variable - # to handle the warnings. From within the problem the warning command - # has been slaved to the __WARNINGS__ routine which is defined in Global. - # We'll need to provide an alternate mechanism. - # The base64 encoding is only needed for xml transmission. - ################################################################################ - print "################################################################################
"; - print "Warnings output
"; - my $WARNINGS = "Let this be a warning:"; - - print $WARNINGS; - - ################################################################################ - # Install the standard problem grader. See gage/xmlrpc/daemon.pm or processProblem8 for detailed - # code on how to choose which problem grader to install, depending on courseEnvironment and problem data. - # See also PG.pl which provides for problem by problem overrides. - ################################################################################ - - $pt->rf_problem_grader($pt->rf_std_problem_grader); - - ################################################################################ - # creates and stores a hash of answer results inside the object: $rh_answer_results - ################################################################################ - $pt -> process_answers($rh->{envir}->{inputs_ref}); - - - # THE UPDATE AND GRADING LOGIC COULD USE AN OVERHAUL. IT WAS SOMEWHAT CONSTRAINED - # BY LEGACY CONDITIONS IN THE ORIGINAL PROCESSPROBLEM8. IT'S NOT BAD - # BUT IT COULD PROBABLY BE MADE A LITTLE MORE STRAIGHT FORWARD. - ################################################################################ - # updates the problem state stored by the translator object from the problemEnvironment data - ################################################################################ - - # $pt->rh_problem_state({ recorded_score => $rh->{problem_state}->{recorded_score}, - # num_of_correct_ans => $rh->{problem_state}->{num_of_correct_ans} , - # num_of_incorrect_ans => $rh->{problem_state}->{num_of_incorrect_ans} - # } ); - ################################################################################ - # grade the problem (and update the problem state again.) - ################################################################################ - - # Define an entry order -- the default is the order they are received from the browser. - # (Which as I understand it is NOT guaranteed to be the Left->Right Up-> Down order we're - # used to in the West. - - my %PG_FLAGS = $pt->h_flags; - my $ra_answer_entry_order = ( defined($PG_FLAGS{ANSWER_ENTRY_ORDER}) ) ? - $PG_FLAGS{ANSWER_ENTRY_ORDER} : [ keys %{$pt->rh_evaluated_answers} ] ; - # Decide whether any answers were submitted. - my $answers_submitted = 0; - $answers_submitted = 1 if defined( $rh->{answer_form_submitted} ) and 1 == $rh->{answer_form_submitted}; - # If there are answers, grade them - my ($rh_problem_result,$rh_problem_state) = $pt->grade_problem( answers_submitted => $answers_submitted, - ANSWER_ENTRY_ORDER => $ra_answer_entry_order - ); # grades the problem. - - # Output format expected by Webwork.pm (and I believe processProblem8, but check.) - my $out = { - text => ${$pt ->r_text()}, # encode_base64( ${$pt ->r_text()} ), - header_text => $pt->r_header, # encode_base64( ${ $pt->r_header } ), - answers => $pt->rh_evaluated_answers, - errors => $pt-> errors(), - WARNINGS => $WARNINGS, #encode_base64($WARNINGS ), - problem_result => $rh_problem_result, - problem_state => $rh_problem_state, - PG_flag => \%PG_FLAGS - }; - ########################################################################################## - # Debugging printout of environment tables - ########################################################################################## - - print "

Request item

\n\n"; - print ""; - print $self->print_form_data(''); - print "
','','
\n"; - print "path info
\n"; - print $r->path_info(); - print "

\n\ncourseEnvironment

\n\n"; - print pretty_print_rh($courseEnvironment); - print "

\n\nproblemEnvironment

\n\n"; - print pretty_print_rh($problemEnvir_rh); - - ########################################################################################## - # End - ########################################################################################## - ""; -} -# End the"body" routine for the Problem object. - - -sub safetyFilter { - my $answer = shift; # accepts one answer and checks it - my $submittedAnswer = $answer; - $answer = '' unless defined $answer; - my ($errorno); - $answer =~ tr/\000-\037/ /; - #### Return if answer field is empty ######## - unless ($answer =~ /\S/) { -# $errorno = "
No answer was submitted."; - $errorno = 0; ## don't report blank answer as error - - return ($answer,$errorno); - } - ######### replace ^ with ** (for exponentiation) - # $answer =~ s/\^/**/g; - ######### Return if forbidden characters are found - unless ($answer =~ /^[a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)]+$/ ) { - $answer =~ tr/a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)/#/c; - $errorno = "
There are forbidden characters in your answer: $submittedAnswer
"; - - return ($answer,$errorno); - } + $self->{cldb} = $cldb; + $self->{wwdb} = $wwdb; + $self->{authdb} = $authdb; + + $self->{userName} = $userName; + $self->{user} = $user; + $self->{effectiveUser} = $effectiveUser; + $self->{set} = $set; + $self->{problem} = $problem; + $self->{permissionLevel} = $permissionLevel; + + $self->{displayMode} = $displayMode; + $self->{redisplay} = $redisplay; + $self->{submitAnswers} = $submitAnswers; + $self->{previewAnswers} = $previewAnswers; + $self->{formFields} = $formFields; + + $self->{want} = \%want; + $self->{must} = \%must; + $self->{can} = \%can; + $self->{will} = \%will; + + $self->{pg} = $pg; +} - $errorno = 0; - return($answer, $errorno); +sub if_warnings($$) { + my ($self, $arg) = @_; + return $self->{pg}->{warnings} ne ""; } +sub if_errors($$) { + my ($self, $arg) = @_; + return $self->{pg}->{flags}->{error_flag}; +} +sub head { + my $self = shift; + + return $self->{pg}->{head_text} if $self->{pg}->{head_text}; +} +sub path { + my $self = shift; + my $args = $_[-1]; + my $setName = $self->{set}->id; + my $problemNumber = $self->{problem}->id; + + my $ce = $self->{courseEnvironment}; + my $root = $ce->{webworkURLs}->{root}; + my $courseName = $ce->{courseName}; + return $self->pathMacro($args, + "Home" => "$root", + $courseName => "$root/$courseName", + $setName => "$root/$courseName/$setName", + "Problem $problemNumber" => "", + ); +} -######################################################################################## -# This is the problemEnvironment structure that needs to be filled out in order to provide -# information to PGtranslator which in turn supports the problem environment -######################################################################################## +sub siblings { + my $self = shift; + my $setName = $self->{set}->id; + my $problemNumber = $self->{problem}->id; + + my $ce = $self->{courseEnvironment}; + my $root = $ce->{webworkURLs}->{root}; + my $courseName = $ce->{courseName}; + + print CGI::strong("Problems"), CGI::br(); + + my $wwdb = $self->{wwdb}; + my $effectiveUser = $self->{r}->param("effectiveUser"); + my @problems; + push @problems, $wwdb->getProblem($effectiveUser, $setName, $_) + foreach ($wwdb->getProblems($effectiveUser, $setName)); + foreach my $problem (sort { $a->id <=> $b->id } @problems) { + print CGI::a({-href=>"$root/$courseName/$setName/".$problem->id."/?" + . $self->url_authen_args . "&displayMode=" . $self->{displayMode}}, + "Problem ".$problem->id), CGI::br(); + } +} -sub defineProblemEnvir { +sub nav { my $self = shift; - my $r = $self->{r}; - my $courseEnvironment = $self->{courseEnvironment}; - my %envir=(); -# $envir{'refSubmittedAnswers'} = $refSubmittedAnswers if defined($refSubmittedAnswers); - $envir{'psvnNumber'} = 123456789; - $envir{'psvn'} = 123456789; - $envir{'studentName'} = 'Jane Doe'; - $envir{'studentLogin'} = 'jd001m'; - $envir{'studentID'} = 'xxx-xx-4321'; - $envir{'sectionName'} = 'gage'; - $envir{'sectionNumber'} = '111foobar'; - $envir{'recitationName'} = 'gage_recitation'; - $envir{'recitationNumber'} = '11_foobar recitation'; - $envir{'setNumber'} = 'setAlgebraicGeometry'; - $envir{'questionNumber'} = 43; - $envir{'probNum'} = 43; - $envir{'openDate'} = 3014438528; - $envir{'formattedOpenDate'} = '3/4/02'; - $envir{'dueDate'} = 4014438528; - $envir{'formattedDueDate'} = '10/4/04'; - $envir{'answerDate'} = 4014438528; - $envir{'formattedAnswerDate'} = '10/4/04'; - $envir{'problemValue'} = 1; - $envir{'fileName'} = 'problem1'; - $envir{'probFileName'} = 'problem1'; - $envir{'languageMode'} = 'HTML_tth'; - $envir{'displayMode'} = 'HTML_tth'; - $envir{'outputMode'} = 'HTML_tth'; - $envir{'courseName'} = $courseEnvironment ->{courseName}; - $envir{'sessionKey'} = 'asdf'; - -# initialize constants for PGanswermacros.pl - $envir{'numRelPercentTolDefault'} = .1; - $envir{'numZeroLevelDefault'} = 1E-14; - $envir{'numZeroLevelTolDefault'} = 1E-12; - $envir{'numAbsTolDefault'} = .001; - $envir{'numFormatDefault'} = ''; - $envir{'functRelPercentTolDefault'} = .1; - $envir{'functZeroLevelDefault'} = 1E-14; - $envir{'functZeroLevelTolDefault'} = 1E-12; - $envir{'functAbsTolDefault'} = .001; - $envir{'functNumOfPoints'} = 3; - $envir{'functVarDefault'} = 'x'; - $envir{'functLLimitDefault'} = .0000001; - $envir{'functULimitDefault'} = .9999999; - $envir{'functMaxConstantOfIntegration'} = 1E8; -# kludge check definition of number of attempts again. The +1 is because this is used before the current answer is evaluated. - $envir{'numOfAttempts'} = 2; #&getProblemNumOfCorrectAns($probNum,$psvn) - # &getProblemNumOfIncorrectAns($probNum,$psvn)+1; + my $args = $_[-1]; + my $setName = $self->{set}->id; + my $problemNumber = $self->{problem}->id; + + my $ce = $self->{courseEnvironment}; + my $root = $ce->{webworkURLs}->{root}; + my $courseName = $ce->{courseName}; + + my $wwdb = $self->{wwdb}; + my $effectiveUser = $self->{r}->param("effectiveUser"); + my $tail = "&displayMode=".$self->{displayMode}; + + my @links = ("Problem List" => "$root/$courseName/$setName"); + + my $prevProblem = $wwdb->getProblem($effectiveUser, $setName, $problemNumber-1); + my $nextProblem = $wwdb->getProblem($effectiveUser, $setName, $problemNumber+1); + unshift @links, "Previous Problem" => $prevProblem + ? "$root/$courseName/$setName/".$prevProblem->id + : ""; + push @links, "Next Problem" => $nextProblem + ? "$root/$courseName/$setName/".$nextProblem->id + : ""; + + return $self->navMacro($args, $tail, @links); +} -# -# -# defining directorys and URLs - $envir{'templateDirectory'} = $courseEnvironment ->{courseDirs}->{templates}; -############ $envir{'classDirectory'} = $Global::classDirectory; -# $envir{'cgiDirectory'} = $Global::cgiDirectory; -# $envir{'cgiURL'} = getWebworkCgiURL(); - -# $envir{'scriptDirectory'} = $Global::scriptDirectory;##omit - $envir{'webworkDocsURL'} = 'http://webwork.math.rochester.edu'; - $envir{'externalTTHPath'} = '/usr/local/bin/tth'; +sub title { + my $self = shift; + my $setName = $self->{set}->id; + my $problemNumber = $self->{problem}->id; + return "$setName : Problem $problemNumber"; +} -# - $envir{'inputs_ref'} = $r->param; - $envir{'problemSeed'} = 3245; - $envir{'displaySolutionsQ'} = 1; - $envir{'displayHintsQ'} = 1; - -# Directory values -- do we really need them here? - $envir{courseScriptsDirectory} = $COURSE_SCRIPTS_DIRECTORY; - $envir{macroDirectory} = $MACRO_DIRECTORY; - $envir{templateDirectory} = $TEMPLATE_DIRECTORY; - $envir{tempDirectory} = $TEMP_DIRECTORY; - $envir{tempURL} = $TEMP_URL; - $envir{htmlURL} = $HTML_URL; - $envir{'htmlDirectory'} = $courseEnvironment ->{courseDirectory}->{html}; - # here is a way to pass environment variables defined in webworkCourse.ph -# my $k; -# foreach $k (keys %Global::PG_environment ) { -# $envir{$k} = $Global::PG_environment{$k}; -# } - \%envir; -} - -######################################################################################## -# This recursive pretty_print function will print a hash and its sub hashes. -######################################################################################## -sub pretty_print_rh { - my $r_input = shift; - my $out = ''; - if ( not ref($r_input) ) { - $out = $r_input; # not a reference - } elsif (is_hash_ref($r_input)) { - local($^W) = 0; - $out .= ""; - foreach my $key (sort keys %$r_input ) { - $out .= ""; - } - $out .="
$key=> ".pretty_print_rh($r_input->{$key}) . "
"; - } elsif (is_array_ref($r_input) ) { - my @array = @$r_input; - $out .= "( " ; - while (@array) { - $out .= pretty_print_rh(shift @array) . " , "; +sub body { + my $self = shift; + + # unpack some useful variables + my $r = $self->{r}; + my $wwdb = $self->{wwdb}; + my $set = $self->{set}; + my $problem = $self->{problem}; + my $permissionLevel = $self->{permissionLevel}; + my $submitAnswers = $self->{submitAnswers}; + my $previewAnswers = $self->{previewAnswers}; + my %will = %{ $self->{will} }; + my $pg = $self->{pg}; + + ##### translation errors? ##### + + if ($pg->{flags}->{error_flag}) { + return translationError($pg->{errors}, $pg->{body_text}); + } + + ##### answer processing ##### + + # if answers were submitted: + if ($submitAnswers) { + # store answers in DB for sticky answers + my %answersToStore; + my %answerHash = %{ $pg->{answers} }; + $answersToStore{$_} = $answerHash{$_}->{original_student_ans} + foreach (keys %answerHash); + my $answerString = encodeAnswers(%answersToStore, + @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} }); + $problem->last_answer($answerString); + $wwdb->setProblem($problem); + + # store state in DB if it makes sense + if ($will{recordAnswers}) { + $problem->attempted(1); + $problem->status($pg->{state}->{recorded_score}); + $problem->num_correct($pg->{state}->{num_of_correct_ans}); + $problem->num_incorrect($pg->{state}->{num_of_incorrect_ans}); + $wwdb->setProblem($problem); + # write to the transaction log, just to make sure + writeLog($self->{courseEnvironment}, "transaction", + $problem->id."\t". + $problem->set_id."\t". + $problem->login_id."\t". + $problem->source_file."\t". + $problem->value."\t". + $problem->max_attempts."\t". + $problem->problem_seed."\t". + $problem->status."\t". + $problem->attempted."\t". + $problem->last_answer."\t". + $problem->num_correct."\t". + $problem->num_incorrect + ); } - $out .= " )"; - } elsif (ref($r_input) eq 'CODE') { - $out = "$r_input"; - } else { - $out = $r_input; } - $out; -} - -sub is_hash_ref { - my $in =shift; - my $save_SIG_die_trap = $SIG{__DIE__}; - $SIG{__DIE__} = sub {CORE::die(@_) }; - my $out = eval{ %{ $in } }; - $out = ($@ eq '') ? 1 : 0; - $@=''; - $SIG{__DIE__} = $save_SIG_die_trap; - $out; -} -sub is_array_ref { - my $in =shift; - my $save_SIG_die_trap = $SIG{__DIE__}; - $SIG{__DIE__} = sub {CORE::die(@_) }; - my $out = eval{ @{ $in } }; - $out = ($@ eq '') ? 1 : 0; - $@=''; - $SIG{__DIE__} = $save_SIG_die_trap; - $out; -} - -###### -# Utility for slurping souce files -####### - -sub readFile { - my $input = shift; # The set and problem: 'set0/prob1.pg' - my $filePath =$TEMPLATE_DIRECTORY .$input; - print STDERR "Reading problem from file $filePath \n"; - print STDERR "
Reading problem from file $filePath
\n"; - my $out; - print "The file is readable = ", -r $filePath, "\n"; - if (-r $filePath) { - open IN, "<$filePath" or print STDERR "Hey, this file was supposed to be readable\n"; - local($/)=undef; - $out = ; - close(IN); + + ##### output ##### + + # attempt summary + if ($submitAnswers or $will{showCorrectAnswers}) { + # print this if user submitted answers OR requested correct answers + print $self->attemptResults($pg, $submitAnswers, $will{showCorrectAnswers}, + $pg->{flags}->{showPartialCorrectAnswers}, 0); + } elsif ($previewAnswers) { + # print this if user previewed answers + print $self->attemptResults($pg, 1, 0, 0, 1); + # don't show correctness + # don't show correct answers + } + + # score summary + my $attempts = $problem->num_correct + $problem->num_incorrect; + my $attemptsNoun = $attempts != 1 ? "times" : "time"; + my $lastScore = int ($problem->status * 100) . "%"; + my ($attemptsLeft, $attemptsLeftNoun); + if ($problem->max_attempts == -1) { + # unlimited attempts + $attemptsLeft = "unlimited"; + $attemptsLeftNoun = "attempts"; } else { - print "Could not read file at |$filePath|"; - print STDERR "Could not read file at |$filePath|"; + $attemptsLeft = $problem->max_attempts - $attempts; + $attemptsLeftNoun = $attemptsLeft == 1 ? "attempt" : "attempts"; } - return($out); + my $setClosedMessage; + if (time < $set->open_date or time > $set->due_date) { + $setClosedMessage = "This problem set is closed."; + if ($permissionLevel > 0) { + $setClosedMessage .= " Since you are a privileged user, additional attempts will be recorded."; + } else { + $setClosedMessage .= " Additional attempts will not be recorded."; + } + } + print CGI::p( + "You have attempted this problem $attempts $attemptsNoun.", CGI::br(), + $problem->attempted + ? "Your recorded score is $lastScore." . CGI::br() + : "", + "You have $attemptsLeft $attemptsLeftNoun remaining.", CGI::br(), + $setClosedMessage, + ); + + print CGI::hr(); + + # main form + print + CGI::startform("POST", $r->uri), + $self->hidden_authen_fields, + CGI::p(CGI::i($pg->{result}->{msg})), + CGI::p($pg->{body_text}), + CGI::p( + CGI::submit(-name=>"submitAnswers", -label=>"Submit Answers"), + CGI::submit(-name=>"previewAnswers", -label=>"Preview Answers"), + ), + $self->viewOptions(), + CGI::endform(); + + # feedback form + my $ce = $self->{courseEnvironment}; + my $root = $ce->{webworkURLs}->{root}; + my $courseName = $ce->{courseName}; + my $feedbackURL = "$root/$courseName/feedback/"; + print + CGI::startform("POST", $feedbackURL), + $self->hidden_authen_fields, + CGI::hidden("module", __PACKAGE__), + CGI::hidden("set", $set->id), + CGI::hidden("problem", $problem->id), + CGI::hidden("displayMode", $self->{displayMode}), + CGI::hidden("showOldAnswers", $will{showOldAnswers}), + CGI::hidden("showCorrectAnswers", $will{showCorrectAnswers}), + CGI::hidden("showHints", $will{showHints}), + CGI::hidden("showSolutions", $will{showSolutions}), + CGI::p({-align=>"right"}, + CGI::submit(-name=>"feedbackForm", -label=>"Send Feedback") + ), + CGI::endform(); + + # warning output + if ($pg->{warnings} ne "") { + print CGI::hr(), warningOutput($pg->{warnings}); + } + + # debugging stuff + #print + # CGI::hr(), + # CGI::h2("debugging information"), + # CGI::h3("form fields"), + # ref2string($self->{formFields}), + # CGI::h3("user object"), + # ref2string($self->{user}), + # CGI::h3("set object"), + # ref2string($set), + # CGI::h3("problem object"), + # ref2string($problem), + # CGI::h3("PG object"), + # ref2string($pg, {'WeBWorK::PG::Translator' => 1}); + + return ""; } -my $foo =0; +##### output utilities ##### -# The warning mechanism. This needs to be turned into an object of its own -############### -## Error message routines cribbed from CGI -############### +# this is used by ProblemSet.pm too, so don't fuck it up +sub translationError($$) { + my ($error, $details) = @_; + return + CGI::h2("Software Error"), + CGI::p(<{result}; # the overall result of the problem + my @answerNames = @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} }; + + my $showMessages = $showAttemptAnswers && grep { $pg->{answers}->{$_}->{ans_message} } @answerNames; + + my $header = CGI::th("part"); + $header .= $showAttemptAnswers ? CGI::th("entered") : ""; + $header .= $showAttemptPreview ? CGI::th("preview") : ""; + $header .= $showCorrectAnswers ? CGI::th("correct") : ""; + $header .= $showAttemptResults ? CGI::th("result") : ""; + $header .= $showMessages ? CGI::th("messages") : ""; + my @tableRows = ( $header ); + my $numCorrect; + foreach my $name (@answerNames) { + my $answerResult = $pg->{answers}->{$name}; + my $studentAnswer = $answerResult->{student_ans}; # original_student_ans + my $preview = ($showAttemptPreview + ? $self->previewAnswer($answerResult) + : ""); + my $correctAnswer = $answerResult->{correct_ans}; + my $answerScore = $answerResult->{score}; + my $answerMessage = $showMessages ? $answerResult->{ans_message} : ""; + + $numCorrect += $answerScore > 0; + my $resultString = $answerScore ? "correct" : "incorrect"; + + # get rid of the goofy prefix on the answer names (supposedly, the format + # of the answer names is changeable. this only fixes it for "AnSwEr" + $name =~ s/^AnSwEr//; + + my $row = CGI::td($name); + $row .= $showAttemptAnswers ? CGI::td($studentAnswer) : ""; + $row .= $showAttemptPreview ? CGI::td($preview) : ""; + $row .= $showCorrectAnswers ? CGI::td($correctAnswer) : ""; + $row .= $showAttemptResults ? CGI::td($resultString) : ""; + $row .= $answerMessage ? CGI::td($answerMessage) : ""; + push @tableRows, $row; + } - sub longmess { - my $error = shift; - my $mess = ""; - my $i = 1 + $CarpLevel; - my ($pack,$file,$line,$sub,$eval,$require); - - while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) { - if ($error =~ m/\n$/) { - $mess .= $error; - } - else { - if (defined $eval) { - if ($require) { - $sub = "require $eval"; - } - else { - $eval =~ s/[\\\']/\\$&/g; - if ($MaxEvalLen && length($eval) > $MaxEvalLen) { - substr($eval,$MaxEvalLen) = '...'; - } - $sub = "eval '$eval'"; - } - } - elsif ($sub eq '(eval)') { - $sub = 'eval {...}'; - } + my $numCorrectNoun = $numCorrect == 1 ? "question" : "questions"; + my $scorePercent = int ($problemResult->{score} * 100) . "\%"; + my $summary = "On this attempt, you answered $numCorrect $numCorrectNoun out of " + . scalar @answerNames . " correct, for a score of $scorePercent."; + return CGI::table({-border=>1}, CGI::Tr(\@tableRows)) . CGI::p($summary); +} - $mess .= "\t$sub " if $error eq "called"; - $mess .= "$error at $file line $line\n"; +sub viewOptions($) { + my $self = shift; + my $displayMode = $self->{displayMode}; + my %must = %{ $self->{must} }; + my %can = %{ $self->{can} }; + my %will = %{ $self->{will} }; + + my $optionLine; + $can{showOldAnswers} and $optionLine .= join "", + "Show:  ", + CGI::checkbox( + -name => "showOldAnswers", + -checked => $will{showOldAnswers}, + -label => "Saved answers", + ), "  "; + $can{showCorrectAnswers} and $optionLine .= join "", + CGI::checkbox( + -name => "showCorrectAnswers", + -checked => $will{showCorrectAnswers}, + -label => "Correct answers", + ), "  "; + $can{showHints} and $optionLine .= join "", + CGI::checkbox( + -name => "showHints", + -checked => $will{showHints}, + -label => "Hints", + ), "  "; + $can{showSolutions} and $optionLine .= join "", + CGI::checkbox( + -name => "showSolutions", + -checked => $will{showSolutions}, + -label => "Solutions", + ), "  "; + $optionLine and $optionLine .= join "", CGI::br(); + + return CGI::div({-style=>"border: thin groove; padding: 1ex; margin: 2ex"}, + "View equations as:  ", + CGI::radio_group( + -name => "displayMode", + -values => ['plainText', 'formattedText', 'images'], + -default => $displayMode, + -labels => { + plainText => "plain text", + formattedText => "formatted text", + images => "images", } - - $error = "called"; - } - - $mess || $error; - } + ), CGI::br(), + $optionLine, + CGI::submit(-name=>"redisplay", -label=>"Redisplay Problem"), + ); } -############### -### Our error messages for giving maximum feedback to the user for errors within problems. -############### -BEGIN { - sub PG_floating_point_exception_handler { # 1st argument is signal name - my($sig) = @_; - print "Content-type: text/html\n\n

There was a floating point arithmetic error (exception SIG$sig )

--perhaps - you divided by zero or took the square root of a negative number? -
\n Use the back button to return to the previous page and recheck your entries.
\n"; - exit(0); - } - - $SIG{'FPE'} = \&PG_floating_point_exception_handler; -#!/usr/bin/perl -w - sub PG_warnings_handler { - my @input = @_; - my $msg_string = longmess(@_); - my @msg_array = split("\n",$msg_string); - my $out_string = ''; + +sub previewAnswer($$) { + my ($self, $answerResult) = @_; + my $ce = $self->{courseEnvironment}; + my $user = $self->{user}; + my $set = $self->{set}; + my $problem = $self->{problem}; + my $displayMode = $self->{displayMode}; + + # note: right now, we have to do things completely differently when we are + # rendering math from INSIDE the translator and from OUTSIDE the translator. + # so we'll just deal with each case explicitly here. there's some code + # duplication that can be dealt with later by abstracting out tth/dvipng/etc. + + my $tex = $answerResult->{preview_latex_string}; + + if ($displayMode eq "plainText") { + return $tex; + } elsif ($displayMode eq "formattedText") { + my $tthCommand = $ce->{externalPrograms}->{tth} + . " -L -f5 -r 2> /dev/null < /dev/null\n" + . "\\($tex\\)\n" + . "END_OF_INPUT\n"; - # Extra stack information is provided in this next block - # If the warning message does NOT end in \n then a line - # number is appended (see Perl manual about warn function) - # The presence of the line number is detected below and extra - # stack information is added. - # To suppress the line number and the extra stack information - # add \n to the end of a warn message (in .pl files. In .pg - # files add ~~n instead - if ($input[$#input]=~/line \d*\.\s*$/) { - $out_string .= "##More details:
\n----"; - foreach my $line (@msg_array) { - chomp($line); - next unless $line =~/\w+\:\:/; - $out_string .= "----" .$line . "
\n"; - } + # call tth + my $result = `$tthCommand`; + if ($?) { + return "[tth failed: $? $@]"; + } + return $result; + } elsif ($displayMode eq "images") { + # how are we going to name this? + my $targetPathCommon = "/png/" + . $user->id . "." + . $set->id . "." + . $problem->id . "." + . $answerResult->{ans_name} . ".png"; + + # figure out where to put things + my $wd = tempdir("webwork-dvipng-XXXXXXXX", DIR => $ce->{courseDirs}->{html_temp}); + my $latex = $ce->{externalPrograms}->{latex}; + my $dvipng = $ce->{externalPrograms}->{dvipng}; + my $targetPath = $ce->{courseDirs}->{html_temp} . $targetPathCommon; + # should use surePathToTmpFile, but we have to + # isolate it from the problem enivronment first + my $targetURL = $ce->{courseURLs}->{html_temp} . $targetPathCommon; + + # call dvipng to generate a preview + dvipng($wd, $latex, $dvipng, $tex, $targetPath); + if (-e $targetPath) { + return "\"$tex\""; + } else { + return "[math2img failed]"; } + } +} + +##### permission queries ##### - $Global::WARNINGS .="* " . join("
",@input) . "
\n" . $out_string . - "
\n--------------------------------------
\n
\n"; - $Global::background_plain_url = $Global::background_warn_url; - $Global::bg_color = '#FF99CC'; #for warnings -- this change may come too late - } - - $SIG{__WARN__}=\&PG_warnings_handler; - - $SIG{__DIE__} = sub { - my $message = longmess(@_); - $message =~ s/\n/
\n/; - my ($package, $filename, $line) = caller(); - # use standard die for errors eminating from XML::Parser::Expat - # it uses a trapped eval which sometimes fails -- apparently on purpose - # and the error is handled by Expat itself. We don't want - # to interfer with that. - - if ($package eq 'XML::Parser::Expat') { - die @_; - } - #print "$package $filename $line \n"; - print - "Content-type: text/html\r\n\r\n

Software error

\n\n$message\n

\n - Please inform the webwork meister.

\n - In addition to the error message above the following warnings were detected: -

- $Global::WARNINGS; -
- It's sometimes hard to tell exactly what has gone wrong since the - full error message may have been sent to - standard error instead of to standard out. -

To debug you can -

- Good luck.

\n" ; - }; +# this stuff should be abstracted out into the permissions system +# however, the permission system only knows about things in the +# course environment and the username. hmmm... + +# also, i should fix these so that they have a consistent calling +# format -- perhaps: +# canPERM($courseEnv, $user, $set, $problem, $permissionLevel) + +sub canShowCorrectAnswers($$) { + my ($permissionLevel, $answerDate) = @_; + return $permissionLevel > 0 || time > $answerDate; +} +sub canShowSolutions($$) { + my ($permissionLevel, $answerDate) = @_; + return canShowCorrectAnswers($permissionLevel, $answerDate); +} +sub canRecordAnswers($$$$$) { + my ($permissionLevel, $openDate, $dueDate, $maxAttempts, $attempts) = @_; + my $permHigh = $permissionLevel > 0; + my $timeOK = time >= $openDate && time <= $dueDate; + my $attemptsOK = $maxAttempts == -1 || $attempts <= $maxAttempts; + my $recordAnswers = $permHigh || ($timeOK && $attemptsOK); + return $recordAnswers; +} +sub mustRecordAnswers($) { + my ($permissionLevel) = @_; + return $permissionLevel == 0; } 1;