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

Diff of /branches/gage_dev/webwork2/lib/WeBWorK/ContentGenerator/Problem.pm

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

Revision 423 Revision 424
1package WeBWorK::ContentGenerator::Problem; 1package WeBWorK::ContentGenerator::Problem;
2use base qw(WeBWorK::ContentGenerator); 2use base qw(WeBWorK::ContentGenerator);
3 3
4use strict; 4use strict;
5use warnings; 5use warnings;
6use Apache::Constants qw(:common); 6use CGI qw(:html :form);
7use WeBWorK::ContentGenerator; 7use WeBWorK::Utils qw(ref2string);
8use WeBWorK::PG; 8use WeBWorK::PG;
9use WeBWorK::Form;
9 10
10# "Classic" form fields from processProblem8.pl 11# NEW form fields
11# 12#
12# user - user ID 13# user
13# key - session key 14# key
14# course - course name
15# probSetKey - USUALLY known as the PSVN
16# probNum - problem number a.k.a. ID a.k.a. name
17# 15#
18# Mode - display mode (HTML, HTML_tth, or typeset or whatever it's called) 16# displayMode
19# show_old_answers - whether or not student's old answers should be filled in 17# showOldAnswers
20# ShowAns - asks for correct answer to be shown -- only available for instructors 18# showCorrectAnswers
21# answer$i - student answers 19# showHints
22# showEdit - checks if the ShowEditor button should be shown and clicked 20# showSolutions
23# showSol - checks if the solution button ishould be shown and clicked
24# 21#
25# source - contains modified problem source when called from the web-based problem editor 22# submitAnswers - name of "Submit Answers" button
26# seed - contains problem seed when called from the web-based problem editor
27# readSourceFromHTMLQ - if true, problem is read from 'source' instead of file
28# action - submit button clicked to invoke script (alledgedly)
29# 'Save updated version'
30# 'Read problem from disk'
31# 'Submit Answers'
32# 'Preview Answers'
33# 'Preview Again'
34# probFileName - name of the PG file being edited
35# languageType - afaik, always set to 'pg'
36 23
37sub title { 24sub title {
38 my ($self, $problem_set, $problem) = @_; 25 my ($self, $setName, $problemNumber) = @_;
39 my $r = $self->{r};
40 my $user = $r->param('user'); 26 my $userName = $self->{r}->param('user');
41 return "Problem $problem of problem set $problem_set for $user"; 27 return "Problem $problemNumber of problem set $setName for $userName";
42} 28}
43 29
44sub body { 30sub body {
45 my ($self, $problem_set, $problem) = @_; 31 my ($self, $setName, $problemNumber) = @_;
32 my $courseEnv = $self->{courseEnvironment};
33 my $r = $self->{r};
34 my $userName = $r->param('user');
46 35
47 # we have to call init_translator like this: 36 # fix format of setName and problem
48 my $pt = WeBWorK::PG->new($courseEnv, $userName, $setName, $problemNumber, $formData); 37 # (i want dennis to cut "set" and "prob" off before calling me)
38 $setName =~ s/^set//;
39 $problemNumber =~ s/^prob//;
49 40
50 # 41 # get database information
42 my $classlist = WeBWorK::DB::Classlist->new($courseEnv);
43 my $wwdb = WeBWorK::DB::WW->new($courseEnv);
44 my $user = $classlist->getUser($userName);
45 my $set = $wwdb->getSet($userName, $setName);
46 my $problem = $wwdb->getProblem($userName, $setName, $problemNumber);
47 my $psvn = $wwdb->getPSVN($userName, $setName);
51 48
52 # ----- this is not a place of honor ----- 49 # set options from form fields
50 my $displayMode = $r->param("displayMode") || $courseEnv->{pg}->{options}->{displayMode};
51 my $showOldAnswers = $r->param("showOldAnswers") || $courseEnv->{pg}->{options}->{showOldAnswers};
52 my $showCorrectAnswers = $r->param("showCorrectAnswers") || $courseEnv->{pg}->{options}->{showCorrectAnswers};
53 my $showHints = $r->param("showHints") || $courseEnv->{pg}->{options}->{showHints};
54 my $showSolutions = $r->param("showSolutions") || $courseEnv->{pg}->{options}->{showSolutions};
55 my $processAnswers = $r->param("submitAnswers");
53 56
54 # Run the problem (output the html text) but also store it within the object. 57 # coerce form fields into CGI::Vars format
55 # The correct answers are also calculated and stored within the object 58 my $formFields = { WeBWorK::Form->new_from_paramable($r)->Vars };
56 $pt ->translate();
57 59
58 # print problem output 60 # TODO:
59 print "Problem goes here<p>\n"; 61 # 1. enforce privs for showCorrectAnswers and showSolutions
60 print "Problem output <br>\n"; 62 # (use $PRIV = $canPRIV && $wantPRIV -- cool syntax!)
61 print "<HR>"; 63 # 2. if answers were not submitted and there are student answers in the DB,
62 print ${$pt->r_text()}; 64 # decode them and put them into $formFields for the translator
63 print "<HR>"; 65 # 3. Latex2HTML massaging code
64 print "<p>End of problem output<br>"; 66 # 4. store submitted answers hash in database for sticky answers
67 # 5. deal with the results of answer evaluation and grading :p
68 # 6. introduce a recordAnswers option, which works on the same principle as
69 # the other priv-based options
70
71 my $pg = WeBWorK::PG->new(
72 $courseEnv,
73 $r->param('user'),
74 $r->param('key'),
75 $setName,
76 $problemNumber,
77 { # translation options
78 displayMode => $displayMode,
79 showHints => $showHints,
80 showSolutions => $showSolutions,
81 processAnswers => $processAnswers,
82 },
83 $formFields
84 );
85
86# return (
87# h1("Problem.pm"),
88# table(
89# Tr(td("user"), td($r->param('userName'))),
90# Tr(td("key"), td($r->param('key'))),
91# Tr(td("set"), td($setName)),
92# Tr(td("problem"), td($problemNumber)),
93# ),
94# #pre(hash2string($pg, 0)),
95# hash2string($pg, 1),
96# );
97
98 # View options form
99 print startform("POST", $r->uri);
100 print $self->hidden_authen_fields;
101 print p("View equations as: ",
102 radio_group(
103 -name => "displayMode",
104 -values => ['plainText', 'formattedText', 'images'],
105 -default => $displayMode,
106 -labels => {
107 plainText => "plain text",
108 formattedText => "formatted text",
109 images => "images",
110 }
111 ), br(),
112 checkbox(
113 -name => "showOldAnswers",
114 -checked => $showOldAnswers,
115 -label => "Show old answers",
116 ), br(),
117 submit(-name=>'redisplay')
118 );
119 print endform();
120 print hr();
121
122 # Previous answer results
65 123
66 124
67 # print source code 125 # Problem form
68 print "Source code<pre>\n"; 126 print startform("POST", $r->uri);
69 print $SOURCE1; 127 print $self->hidden_authen_fields;
70 print "</pre>End source code<p>"; 128 print p($pg->{body_text});
129 print p(submit(-name=>"submitAnswers", -label=>"Submit Answers"));
130 print endform();
131 print hr();
71 132
72 # The format for the output is described here. We'll need a local variable 133 # debugging stuff
73 # to handle the warnings. From within the problem the warning command 134 print h2("debugging information");
74 # has been slaved to the __WARNINGS__ routine which is defined in Global. 135 print h3("form fields");
75 # We'll need to provide an alternate mechanism. 136 print ref2string($formFields);
76 # The base64 encoding is only needed for xml transmission. 137 print h3("PG object");
77 print "<hr>"; 138 print ref2string($pg, {'WeBWorK::PG::Translator' => 1});
78 print "Warnings output<br>";
79 my $WARNINGS = "Let this be a warning:";
80 139
81 print $WARNINGS; 140 return "";
82
83 # Install the standard problem grader. See gage/xmlrpc/daemon.pm or processProblem8 for detailed
84 # code on how to choose which problem grader to install, depending on courseEnvironment and problem data.
85 # See also PG.pl which provides for problem by problem overrides.
86 $pt->rf_problem_grader($pt->rf_std_problem_grader);
87
88 # creates and stores a hash of answer results inside the object: $rh_answer_results
89 $pt -> process_answers($rh->{envir}->{inputs_ref});
90
91
92 # THE UPDATE AND GRADING LOGIC COULD USE AN OVERHAUL. IT WAS SOMEWHAT CONSTRAINED
93 # BY LEGACY CONDITIONS IN THE ORIGINAL PROCESSPROBLEM8. IT'S NOT BAD
94 # BUT IT COULD PROBABLY BE MADE A LITTLE MORE STRAIGHT FORWARD.
95 #
96 # updates the problem state stored by the translator object from the problemEnvironment data
97
98 # $pt->rh_problem_state({ recorded_score => $rh->{problem_state}->{recorded_score},
99 # num_of_correct_ans => $rh->{problem_state}->{num_of_correct_ans} ,
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 }
158 $out .="</table>";
159 } elsif (is_array_ref($r_input) ) {
160 my @array = @$r_input;
161 $out .= "( " ;
162 while (@array) {
163 $out .= pretty_print_rh(shift @array) . " , ";
164 }
165 $out .= " )";
166 } elsif (ref($r_input) eq 'CODE') {
167 $out = "$r_input";
168 } else {
169 $out = $r_input;
170 }
171 $out;
172}
173
174sub is_hash_ref {
175 my $in =shift;
176 my $save_SIG_die_trap = $SIG{__DIE__};
177 $SIG{__DIE__} = sub {CORE::die(@_) };
178 my $out = eval{ %{ $in } };
179 $out = ($@ eq '') ? 1 : 0;
180 $@='';
181 $SIG{__DIE__} = $save_SIG_die_trap;
182 $out;
183}
184sub is_array_ref {
185 my $in =shift;
186 my $save_SIG_die_trap = $SIG{__DIE__};
187 $SIG{__DIE__} = sub {CORE::die(@_) };
188 my $out = eval{ @{ $in } };
189 $out = ($@ eq '') ? 1 : 0;
190 $@='';
191 $SIG{__DIE__} = $save_SIG_die_trap;
192 $out;
193} 141}
194 142
1951; 1431;
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.423  
changed lines
  Added in v.424
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9