[system] / trunk / xmlrpc / daemon / Webwork.pm Repository:
ViewVC logotype

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9