[system] / trunk / xmlrpc / modules / Webwork_save.pm Repository:
ViewVC logotype

Annotation of /trunk/xmlrpc/modules/Webwork_save.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 279 - (view) (download) (as text)

1 : gage 279 #!/usr/local/bin/perl -w
2 :    
3 :     # Copyright (C) 2001 Michael Gage
4 :    
5 :     ###############################################################################
6 :     # The initial code simply initializes variables, defines addresses
7 :     # for directories, defines some simple subroutines responders used in debugging
8 :     # and makes sure that the appropriate CPAN library modules
9 :     # are available. The main code begins below that with the initialization
10 :     # of the PGtranslator5 module.
11 :     ###############################################################################
12 :     package Webwork;
13 :    
14 :     use strict;
15 :     use sigtrap;
16 :     use Carp;
17 :     use Benchmark;
18 :    
19 :     print "using the perl version of MIME::Base64\n";
20 :     use MIME::Base64 qw( encode_base64 decode_base64);
21 :    
22 :    
23 :     # These libraries contain files which must at least be available, even though
24 :     # only Global.pm is actively used.
25 :    
26 :     use lib "/u/gage/webwork/system/lib/", "/u/gage/webwork/system/courseScripts";
27 :    
28 :     ###############################################################################
29 :    
30 :     BEGIN{
31 :     my $GLOBAL_INIT = "/u/gage/webwork/system/lib/Global.pm";
32 :     print "Opening $GLOBAL_INIT\n";
33 :     require $GLOBAL_INIT or die $GLOBAL_INIT;
34 :     import Global;
35 :     }
36 :    
37 :     my $PGTRANSLATOR = "/u/gage/xmlrpc/experiments/PGtranslator5.pm";
38 :    
39 :     require $PGTRANSLATOR or die "Can't open $PGTRANSLATOR";
40 :    
41 :     ###############################################################################
42 :     # List and address myof available problemlibraries
43 :     ###############################################################################
44 :    
45 :    
46 :     %my $libraryPath = '/u/gage/webwork/ww_prob_lib/';
47 :    
48 :     my %AVAILABLE_PROBLEM_LIBRARIES = ( ww_prob_lib => '/u/gage/webwork/ww_prob_lib/',
49 :     indiana_prob_lib => '/u/gage/webwork/Indiana_prob_lib/',
50 :     capaOK_lib => '/ww/webwork/courses1/capaOK/templates/',
51 :     capa_lib => '/ww/webwork/courses/capa/templates/',
52 :     prob_lib_cvs => '/ww/webwork/courses/WW_Prob_Lib_CVS/templates/',
53 :     maa_100 => '/ww/webwork/courses/maa100/templates/',
54 :     teitel_physics121 => '/ww/webwork/courses/teitel-phy121/templates/',
55 :     );
56 :    
57 :     ###############################################################################
58 :     # Configure daemon:
59 :     ###############################################################################
60 :     my $courseScriptsDirectory = '/u/gage/webwork/system/courseScripts/';
61 :     my $macroDirectory = '/u/gage/xmlrpc/experiments/macros/';
62 :     my $scriptDirectory = '/u/gage/webwork/system/scripts/';
63 :     my $templateDirectory = '/u/gage/webwork/ww_prob_lib/';
64 :    
65 :     $Global::courseTempDirectory = '/ww/htdocs/tmp/gage_course/';
66 :     $Global::courseTempURL = '';
67 :    
68 :     my $displayMode = 'HTML';
69 :    
70 :     my $PG_PL = "${courseScriptsDirectory}PG.pl";
71 :     my $DANGEROUS_MACROS_PL = "${courseScriptsDirectory}dangerousMacros.pl";
72 :     my @MODULE_LIST = ( "Exporter", "DynaLoader", "GD", "WWPlot", "Fun",
73 :     "Circle", "Label", "PGrandom", "Units", "Hermite",
74 :     "List", "Match","Multiple", "Select", "AlgParser",
75 :     "AnswerHash", "Fraction", "VectorField", "Complex1",
76 :     "Complex", "MatrixReal1", "Matrix","Distributions",
77 :     "Regression"
78 :     );
79 :     my @EXTRA_PACKAGES = ( "AlgParserWithImplicitExpand", "Expr",
80 :     "ExprWithImplicitExpand", "AnswerEvaluator",
81 :     "AnswerEvaluatorMaker"
82 :     );
83 :     my $INITIAL_MACRO_PACKAGES = <<END_OF_TEXT;
84 :     DOCUMENT();
85 :     loadMacros(
86 :     "PGbasicmacros.pl",
87 :     "PGchoicemacros.pl",
88 :     "PGanswermacros.pl",
89 :     "PGnumericalmacros.pl",
90 :     "PGgraphmacros.pl",
91 :     "PGauxiliaryFunctions.pl",
92 :     "PGmatrixmacros.pl",
93 :     "PGcomplexmacros.pl",
94 :     "PGstatisticsmacros.pl"
95 :    
96 :     );
97 :    
98 :     ENDDOCUMENT();
99 :    
100 :     END_OF_TEXT
101 :    
102 :     ###############################################################################
103 :     #
104 :     ###############################################################################
105 :    
106 :     ###############################################################################
107 :     ###############################################################################
108 :    
109 :     print "ok so far\n";
110 :    
111 :    
112 :    
113 :     ###############################################################################
114 :     # The following code initializes an instantiation of PGtranslator5 in the
115 :     # parent process. This initialized object is then share with each of the
116 :     # children forked from this parent process by the daemon.
117 :     #
118 :     # As far as I can tell, the child processes don't share any variable values even
119 :     # though their namespaces are the same.
120 :     ###############################################################################
121 :    
122 :    
123 :     my $dummy_envir = { courseScriptsDirectory => $courseScriptsDirectory,
124 :     displayMode => $displayMode,
125 :     macroDirectory => $macroDirectory};
126 :     my $pt = new PGtranslator5; #pt stands for problem translator;
127 :     $pt ->rh_directories( { courseScriptsDirectory => $courseScriptsDirectory,
128 :     macroDirectory => $macroDirectory,
129 :     scriptDirectory => $scriptDirectory ,
130 :     templateDirectory => $templateDirectory,
131 :     tempDirectory => $tempDirectory,
132 :     }
133 :     );
134 :     $pt -> evaluate_modules( @MODULE_LIST);
135 :     $pt -> load_extra_packages( @EXTRA_PACKAGES );
136 :     $pt -> environment($dummy_envir);
137 :     $pt->initialize();
138 :     $pt -> unrestricted_load($PG_PL );
139 :     $pt -> unrestricted_load($DANGEROUS_MACROS_PL);
140 :     $pt-> set_mask();
141 :     #
142 :    
143 :    
144 :     $INITIAL_MACRO_PACKAGES =~ tr /\r/\n/;
145 :     $pt->source_string( $INITIAL_MACRO_PACKAGES );
146 :     $pt ->rf_safety_filter( \&safetyFilter); # install blank safety filter
147 :     $pt ->translate();
148 :     ################################################################################
149 :     ## This ends the initialization of the PGtranslator object
150 :     ################################################################################
151 :    
152 :     ###############################################################################
153 :     # This subroutine is called by the child process. It reinitializes its copy of the
154 :     # PGtranslator5 object. The unrestricted_load and loadMacros subroutines of PGtranslator5
155 :     # have been modified so that if &_PG_init is already defined then nothing
156 :     # is read in but the initialization subroutine is run instead.
157 :     ###############################################################################
158 :    
159 :     sub renderProblem {
160 :     my $rh = shift;
161 :     my $beginTime = new Benchmark;
162 :     $Global::WARNINGS = "";
163 :     $pt->environment($rh->{envir});
164 :     #$pt->{safe_cache} = $safe_cmpt_cache;
165 :     $pt->initialize();
166 :     $pt -> unrestricted_load($PG_PL);
167 :     $pt -> unrestricted_load($DANGEROUS_MACROS_PL);
168 :     $pt-> set_mask();
169 :    
170 :     my $string = decode_base64( $rh ->{source} );
171 :     $string =~ tr /\r/\n/;
172 :    
173 :     $pt->source_string( $string );
174 :     $pt ->rf_safety_filter( \&safetyFilter); # install blank safety filter
175 :     $pt ->translate();
176 :    
177 :    
178 :     # Determine which problem grader to use
179 :     #$pt->rf_problem_grader($pt->rf_std_problem_grader); #this is the default
180 :     my $problem_grader_to_use = $pt->rh_flags->{PROBLEM_GRADER_TO_USE};
181 :    
182 :     if ( defined($problem_grader_to_use) and $problem_grader_to_use ) { # if defined and non-empty
183 :     if ($problem_grader_to_use eq 'std_problem_grader') {
184 :     # Reset problem grader to standard problem grader.
185 :     $pt->rf_problem_grader($pt->rf_std_problem_grader);
186 :     } elsif ($problem_grader_to_use eq 'avg_problem_grader') {
187 :     # Reset problem grader to average problem grader.
188 :     $pt->rf_problem_grader($pt->rf_avg_problem_grader);
189 :     } elsif (ref($problem_grader_to_use) eq 'CODE') {
190 :     # Set problem grader to instructor defined problem grader -- use cautiously.
191 :     $pt->rf_problem_grader($problem_grader_to_use)
192 :     } else {
193 :     warn "Error: Could not understand problem grader flag $problem_grader_to_use";
194 :     #this is the default set by the translator and used if the flag is not understood
195 :     #$pt->rf_problem_grader($pt->rf_std_problem_grader);
196 :     }
197 :    
198 :     } else {#this is the default set by the translator and used if no flag is set.
199 :     $pt->rf_problem_grader($pt->rf_std_problem_grader);
200 :     }
201 :    
202 :     # creates and stores a hash of answer results: $rh_answer_results
203 :     $pt -> process_answers($rh->{envir}->{inputs_ref});
204 :    
205 :    
206 :     $pt->rh_problem_state({ recorded_score => $rh->{problem_state}->{recorded_score},
207 :     num_of_correct_ans => $rh->{problem_state}->{num_of_correct_ans} ,
208 :     num_of_incorrect_ans => $rh->{problem_state}->{num_of_incorrect_ans}
209 :     } );
210 :     my %PG_FLAGS = $pt->h_flags;
211 :     my $ra_answer_entry_order = ( defined($PG_FLAGS{ANSWER_ENTRY_ORDER}) ) ?
212 :     $PG_FLAGS{ANSWER_ENTRY_ORDER} : [ keys %{$pt->rh_evaluated_answers} ] ;
213 :     my $answers_submitted = 0;
214 :     $answers_submitted = 1 if defined( $rh->{answer_form_submitted} ) and 1 == $rh->{answer_form_submitted};
215 :    
216 :     my ($rh_problem_result,$rh_problem_state) = $pt->grade_problem( answers_submitted => $answers_submitted,
217 :     ANSWER_ENTRY_ORDER => $ra_answer_entry_order
218 :     ); # grades the problem.
219 :     # protect image data for delivery via XML-RPC.
220 :     # Don't send code data.
221 :     my %PG_flag=();
222 :     # foreach my $key (keys %PG_FLAGS) {
223 :     # if ($key eq 'dynamic_images' ) {
224 :     # foreach my $ikey (keys %{$PG_FLAGS{'dynamic_images'} }) {
225 :     # $PG_flag{'dynamic_images'}->{$ikey} =
226 :     # encode_base64($PG_FLAGS{'dynamic_images'}->{$ikey});
227 :     # }
228 :     # } elsif (ref($PG_FLAGS{$key}) eq '' or ref($PG_FLAGS{$key}) =~ /SCALAR|HASH/) {
229 :     # $PG_flag{$key} = $PG_FLAGS{$key} ;
230 :     # }
231 :     # }
232 :    
233 :     my $endTime = new Benchmark;
234 :     my $out = {
235 :     text => encode_base64( ${$pt ->r_text()} ),
236 :     header_text => encode_base64( ${ $pt->r_header } ),
237 :     answers => $pt->rh_evaluated_answers,
238 :     compute_time => logTimingInfo($beginTime, $endTime),
239 :     errors => $pt-> errors(),
240 :     WARNINGS => encode_base64($Global::WARNINGS ),
241 :     problem_result => $rh_problem_result,
242 :     problem_state => $rh_problem_state,
243 :     PG_flag => \%PG_flag
244 :     };
245 :     $out;
246 :    
247 :     }
248 :    
249 :     ###############################################################################
250 :     # This ends the main subroutine executed by the child process in responding to
251 :     # a request. The other subroutines are auxiliary.
252 :     ###############################################################################
253 :    
254 :    
255 :     sub safetyFilter {
256 :     my $answer = shift; # accepts one answer and checks it
257 :     my $submittedAnswer = $answer;
258 :     $answer = '' unless defined $answer;
259 :     my ($errorno, $answerIsCorrectQ);
260 :     $answer =~ tr/\000-\037/ /;
261 :     #### Return if answer field is empty ########
262 :     unless ($answer =~ /\S/) {
263 :     # $errorno = "<BR>No answer was submitted.";
264 :     $errorno = 0; ## don't report blank answer as error
265 :    
266 :     return ($answer,$errorno);
267 :     }
268 :     ######### replace ^ with ** (for exponentiation)
269 :     # $answer =~ s/\^/**/g;
270 :     ######### Return if forbidden characters are found
271 :     unless ($answer =~ /^[a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)]+$/ ) {
272 :     $answer =~ tr/a-zA-Z0-9_\-\+ \t\/@%\*\.\n^\(\)/#/c;
273 :     $errorno = "<BR>There are forbidden characters in your answer: $submittedAnswer<BR>";
274 :    
275 :     return ($answer,$errorno);
276 :     }
277 :    
278 :     $errorno = 0;
279 :     return($answer, $errorno);
280 :     }
281 :    
282 :    
283 :     sub logTimingInfo{
284 :     my ($beginTime,$endTime,) = @_;
285 :     my $out = "";
286 :     $out .= timestr( timediff($endTime , $beginTime) ) . " seconds elapsed \n\n";
287 :     $out;
288 :     }
289 :    
290 :     ###############
291 :    
292 :     sub echo {
293 :     my $in= shift;
294 :     return(ref($in));
295 :     }
296 :     sub hello {
297 :     print "Receiving request for hello world\n";
298 :     return "Hello world";
299 :     }
300 :     sub pretty_print_rh {
301 :     my $rh = shift;
302 :     my $out = "";
303 :     my $type = ref($rh);
304 :     if ( ref($rh) =~/HASH/ ) {
305 :     foreach my $key (sort keys %{$rh}) {
306 :     $out .= " $key => " . pretty_print_rh( $rh->{$key} ) . "\n";
307 :     }
308 :     } elsif ( ref($rh) =~ /SCALAR/ ) {
309 :     $out = "scalar reference ". ${$rh};
310 :     } elsif ( ref($rh) =~/Base64/ ) {
311 :     $out .= "base64 reference " .$$rh;
312 :     } else {
313 :     $out = $rh;
314 :     }
315 :     if (defined($type) ) {
316 :     $out .= "type = $type \n";
317 :     }
318 :     return $out;
319 :     }
320 :    
321 :     #sub xmlquit {
322 :     # print "exiting daemon\n";
323 :     # return "";
324 :     #}
325 :    
326 :     ###############################################################################
327 :     #OTHER SERVICES
328 :     ###############################################################################
329 :    
330 :     my $PASSWORD = 'geometry';
331 :    
332 :     use File::stat;
333 :     sub readFile {
334 :     my $rh = shift;
335 :     local($|)=1;
336 :     my $out = {};
337 :     my $filePath = $rh->{filePath};
338 :     unless ($rh->{pw} eq $PASSWORD ) {
339 :     $out->{error}=404;
340 :     return($out);
341 :     }
342 :     if ( defined($AVAILABLE_PROBLEM_LIBRARIES{$rh->{library_name}} ) ) {
343 :     $filePath = $AVAILABLE_PROBLEM_LIBRARIES{$rh->{library_name}} . $filePath;
344 :     } else {
345 :     $out->{error} = "Could not find library:".$rh->{library_name}.":";
346 :     return($out);
347 :     }
348 :    
349 :     if (-r $filePath) {
350 :     open IN, "<$filePath";
351 :     local($/)=undef;
352 :     my $text = <IN>;
353 :     $out->{text}= encode_base64($text);
354 :     my $sb=stat($filePath);
355 :     $out->{size}=$sb->size;
356 :     $out->{path}=$filePath;
357 :     $out->{permissions}=$sb->mode&07777;
358 :     $out->{modTime}=scalar localtime $sb->mtime;
359 :     close(IN);
360 :     } else {
361 :     $out->{error} = "Could not read file at |$filePath|";
362 :     }
363 :     return($out);
364 :     }
365 :    
366 :    
367 :    
368 :     use File::Find;
369 :     sub listLib {
370 :     my $rh = shift;
371 :     my $out = {};
372 :     my $dirPath;
373 :     unless ($rh->{pw} eq $PASSWORD ) {
374 :     $out->{error}=404;
375 :     return($out);
376 :     }
377 :    
378 :     if ( defined($AVAILABLE_PROBLEM_LIBRARIES{$rh->{library_name}} ) ) {
379 :     $dirPath = $AVAILABLE_PROBLEM_LIBRARIES{$rh->{library_name}} ;
380 :     } else {
381 :     $out->{error} = "Could not find library:".$rh->{library_name}.":";
382 :     return($out);
383 :     }
384 :    
385 :     my @outListLib;
386 :     my $wanted = sub {
387 :     my $name = $File::Find::name;
388 :     my @out=();
389 :     if ($name =~/\S/ ) {
390 :     $name =~ s|^$dirPath||o; # cut the first directory
391 :     push(@outListLib, "$name\n") if $name =~/\.pg/;
392 :     }
393 :     };
394 :     my $command = $rh->{command};
395 :     $command = 'all' unless defined($command);
396 :     $command eq 'all' && do {print "$dirPath\n\n";
397 :     find($wanted, $dirPath);
398 :     @outListLib = sort @outListLib;
399 :     $out->{ra_out} = \@outListLib;
400 :     $out->{text} = join("", sort @outListLib);
401 :     return($out);
402 :     };
403 :     $command eq 'setsOnly' && do {
404 :     if ( opendir(DIR, $dirPath) ) {
405 :     my @fileList=();
406 :     while (defined(my $file = readdir(DIR))) {
407 :     push(@fileList,$file) if -d "$dirPath/$file";
408 :    
409 :     }
410 :     $out->{text} = join("\n",sort @fileList);
411 :     closedir(DIR);
412 :     } else {
413 :     $out->{error}= "Can't open directory $dirPath";
414 :     }
415 :     return($out);
416 :     };
417 :     $command eq 'listSet' && do { my $dirPath2 = $dirPath . $rh->{set};
418 :    
419 :     if ( opendir(DIR, $dirPath2) ) {
420 :     my @fileList =();
421 :     while (defined(my $file = readdir(DIR))) {
422 :     if (-d "$dirPath2/$file") {
423 :     push(@fileList, "$file/${file}.pg");
424 :    
425 :     } elsif ($file =~ /.pg$/ ) { # file ends in .pg
426 :     push(@fileList, $file);
427 :    
428 :     }
429 :    
430 :    
431 :     }
432 :     $out->{text} = join("\n",sort @fileList);
433 :     closedir(DIR);
434 :     } else {
435 :     $out->{error}= "Can't open directory $dirPath2";
436 :     }
437 :    
438 :     return($out);
439 :     };
440 :     # else
441 :     $out->{error}="Unrecognized command $command";
442 :     $out;
443 :     }
444 :    

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9