[system] / trunk / pg / lib / PGcore.pm Repository:
ViewVC logotype

Annotation of /trunk/pg/lib/PGcore.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : gage 6249 ################################################################################
2 :     # WeBWorK Online Homework Delivery System
3 :     # Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/
4 : gage 6280 # $CVSHeader: pg/lib/PGcore.pm,v 1.6 2010/05/25 22:47:52 gage Exp $
5 : gage 6249 #
6 :     # This program is free software; you can redistribute it and/or modify it under
7 :     # the terms of either: (a) the GNU General Public License as published by the
8 :     # Free Software Foundation; either version 2, or (at your option) any later
9 :     # version, or (b) the "Artistic License" which comes with this package.
10 :     #
11 :     # This program is distributed in the hope that it will be useful, but WITHOUT
12 :     # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
13 :     # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the
14 :     # Artistic License for more details.
15 :     ################################################################################
16 :     package PGcore;
17 :    
18 :     use strict;
19 :     BEGIN {
20 : gage 6278 use Exporter 'import';
21 : mgage 6292 our @EXPORT_OK = qw(not_null pretty_print);
22 : gage 6249 }
23 :     our $internal_debug_messages = [];
24 :    
25 : gage 6278
26 : gage 6249 use PGanswergroup;
27 :     use PGresponsegroup;
28 :     use PGrandom;
29 :     use PGalias;
30 :     use PGloadfiles;
31 : gage 6261 use WeBWorK::PG::IO(); # don't important any command directly
32 : gage 6249 use Tie::IxHash;
33 : gage 6296 use MIME::Base64;
34 : gage 6249 ##################################
35 :     # Utility macro
36 :     ##################################
37 :    
38 : gage 6252 =head2 Utility Macros
39 :    
40 : mgage 6292
41 :     =head4 not_null
42 :    
43 : gage 6252 not_null(item) returns 1 or 0
44 :    
45 :     empty arrays, empty hashes, strings containing only whitespace are all NULL and return 0
46 :     all undefined quantities are null and return 0
47 :    
48 :    
49 :     =cut
50 :    
51 : gage 6249 sub not_null { # empty arrays, empty hashes and strings containing only whitespace are all NULL
52 :     my $item = shift;
53 :     return 0 unless defined($item);
54 :     if (ref($item)=~/ARRAY/) {
55 :     return scalar(@{$item}); # return the length
56 :     } elsif (ref($item)=~/HASH/) {
57 :     return scalar( keys %{$item});
58 :     } else { # string case return 1 if none empty
59 :     return ($item =~ /\S/)? 1:0;
60 :     }
61 :     }
62 :    
63 : mgage 6292 =head4 pretty_print
64 :    
65 :     Usage: warn pretty_print( $rh_hash_input)
66 :     TEXT(pretty_print($ans_hash));
67 :     TEXT(pretty_print(~~%envir ));
68 :    
69 :     This can be very useful for printing out HTML messages about objects while debugging
70 :    
71 :     =cut
72 :    
73 :     # ^function pretty_print
74 :     # ^uses lex_sort
75 :     # ^uses pretty_print
76 :     sub pretty_print { # provides html output -- NOT a method
77 :     my $r_input = shift;
78 :     my $level = shift;
79 :     $level = 4 unless defined($level);
80 :     $level--;
81 :     return '' unless $level > 0; # only print three levels of hashes (safety feature)
82 :     my $out = '';
83 :     if ( not ref($r_input) ) {
84 :     $out = $r_input if defined $r_input; # not a reference
85 :     $out =~ s/</&lt;/g ; # protect for HTML output
86 :     } elsif ("$r_input" =~/hash/i) { # this will pick up objects whose '$self' is hash and so works better than ref($r_iput).
87 :     local($^W) = 0;
88 :    
89 :     $out .= "$r_input " ."<TABLE border = \"2\" cellpadding = \"3\" BGCOLOR = \"#FFFFFF\">";
90 :    
91 :    
92 :     foreach my $key ( sort ( keys %$r_input )) {
93 :     $out .= "<tr><TD> $key</TD><TD>=&gt;</td><td>&nbsp;".pretty_print($r_input->{$key}) . "</td></tr>";
94 :     }
95 :     $out .="</table>";
96 :     } elsif (ref($r_input) eq 'ARRAY' ) {
97 :     my @array = @$r_input;
98 :     $out .= "( " ;
99 :     while (@array) {
100 :     $out .= pretty_print(shift @array, $level) . " , ";
101 :     }
102 :     $out .= " )";
103 :     } elsif (ref($r_input) eq 'CODE') {
104 :     $out = "$r_input";
105 :     } else {
106 :     $out = $r_input;
107 :     $out =~ s/</&lt;/g; # protect for HTML output
108 :     }
109 :     $out;
110 :     }
111 : gage 6249 ##################################
112 :     # PGcore object
113 :     ##################################
114 :    
115 :     sub new {
116 :     my $class = shift;
117 :     my $envir = shift; #pointer to environment hash
118 :     warn "PGcore must be called with an environment" unless ref($envir) eq 'HASH';
119 :     #warn "creating a new PGcore object";
120 :     my %options = @_;
121 :     my $self = {
122 :     OUTPUT_ARRAY => [], # holds output body text
123 :     HEADER_ARRAY => [], # holds output for the header text
124 : gage 6883 POST_HEADER_ARRAY => [],
125 : mgage 6292 # PG_ANSWERS => [], # holds answers with labels # deprecated
126 :     # PG_UNLABELED_ANSWERS => [], # holds unlabeled ans. #deprecated -replaced by PG_ANSWERS_HASH
127 : gage 6249 PG_ANSWERS_HASH => {}, # holds label=>answer pairs
128 :     PERSISTENCE_HASH => {}, # holds other data, besides answers, which persists during a session and beyond
129 :     answer_eval_count => 0,
130 :     answer_blank_count => 0,
131 :     unlabeled_answer_blank_count =>0,
132 :     unlabeled_answer_eval_count => 0,
133 :     KEPT_EXTRA_ANSWERS => [],
134 :     ANSWER_PREFIX => 'AnSwEr',
135 :     ARRAY_PREFIX => 'ArRaY',
136 :     vec_num => 0, # for distinguishing matrices
137 : gage 6280 QUIZ_PREFIX => $envir->{QUIZ_PREFIX},
138 : gage 6249 SECTION_PREFIX => '', # might be used for sequential (compound) questions?
139 :    
140 : mgage 6292 PG_ACTIVE => 1, # toggle to zero to stop processing
141 : gage 6249 submittedAnswers => 0, # have any answers been submitted? is this the first time this session?
142 :     PG_session_persistence_hash =>{}, # stores data from one invoction of the session to the next.
143 :     PG_original_problem_seed => 0,
144 :     PG_random_generator => undef,
145 :     PG_alias => undef,
146 :     PG_problem_grader => undef,
147 :     displayMode => undef,
148 :     envir => $envir,
149 :     gifs_created => {},
150 :     external_refs => {}, # record of external references
151 :     %options, # allows overrides and initialization
152 :     };
153 :     bless $self, $class;
154 :     tie %{$self->{PG_ANSWERS_HASH}}, "Tie::IxHash"; # creates a Hash with order
155 :     $self->initialize;
156 :     return $self;
157 :     }
158 :    
159 :     sub initialize {
160 :     my $self = shift;
161 :     warn "environment is not defined in PGcore" unless ref($self->{envir}) eq 'HASH';
162 :    
163 :    
164 :    
165 :    
166 :     $self->{displayMode} = $self->{envir}->{displayMode};
167 :     $self->{PG_original_problem_seed} = $self->{envir}->{problemSeed};
168 :     $self->{PG_random_generator} = new PGrandom( $self->{PG_original_problem_seed});
169 :    
170 :     $self->{tempDirectory} = $self->{envir}->{tempDirectory};
171 :     $self->{PG_problem_grader} = $self->{envir}->{PROBLEM_GRADER_TO_USE};
172 : gage 6851 $self->{PG_alias} = PGalias->new($self->{envir});
173 : gage 6249 $self->{PG_loadMacros} = new PGloadfiles($self->{envir});
174 : gage 6256 $self->{flags} = {
175 : gage 6249 showpartialCorrectAnswers => 1,
176 :     showHint => 1,
177 :     hintExists => 0,
178 :     showHintLimit => 0,
179 :     solutionExists => 0,
180 :     WARNING_messages => [],
181 :     DEBUG_messages => [],
182 :     recordSubmittedAnswers => 1,
183 : gage 6505 refreshCachedImages => 0,
184 : gage 6249 # ANSWER_ENTRY_ORDER => [], # may not be needed if we ue Tie:IxHash
185 :     comment => '', # implement as array?
186 :    
187 :    
188 :    
189 :     };
190 :    
191 :     }
192 :    
193 :    
194 :     ####################################################################
195 :    
196 :     =head1 DESCRIPTION
197 :    
198 :     This file provides the fundamental macros that define the PG language. It
199 :     maintains a problem's text, header text, and answers:
200 :    
201 :     =over
202 :    
203 :     =item *
204 :    
205 :     Problem text: The text to appear in the body of the problem. See TEXT()
206 :     below.
207 :    
208 :     =item *
209 :    
210 :     Header text: When a problem is processed in an HTML-based display mode,
211 :     this variable can contain text that the caller should place in the HEAD of the
212 :     resulting HTML page. See HEADER_TEXT() below.
213 :    
214 :     =item *
215 :    
216 :     Implicitly-labeled answers: Answers that have not been explicitly
217 :     assigned names, and are associated with their answer blanks by the order in
218 :     which they appear in the problem. These types of answers are designated using
219 :     the ANS() macro.
220 :    
221 :     =item *
222 :    
223 :     Explicitly-labeled answers: Answers that have been explicitly assigned
224 :     names with the LABELED_ANS() macro, or a macro that uses it. An explicitly-
225 :     labeled answer is associated with its answer blank by name.
226 :    
227 :     =item *
228 :    
229 :     "Extra" answers: Names of answer blanks that do not have a 1-to-1
230 :     correspondance to an answer evaluator. For example, in matrix problems, there
231 :     will be several input fields that correspond to the same answer evaluator.
232 :    
233 :     =back
234 :    
235 :     =head1 USAGE
236 :    
237 :     This file is automatically loaded into the namespace of every PG problem. The
238 :     macros within can then be called to define the structure of the problem.
239 :    
240 :     DOCUMENT() should be the first executable statement in any problem. It
241 :     initializes vriables and defines the problem environment.
242 :    
243 :     ENDDOCUMENT() must be the last executable statement in any problem. It packs
244 :     up the results of problem processing for delivery back to WeBWorK.
245 :    
246 :     The HEADER_TEXT(), TEXT(), and ANS() macros add to the header text string,
247 :     body text string, and answer evaluator queue, respectively.
248 :    
249 :     =cut
250 :    
251 :    
252 :     =item HEADER_TEXT()
253 :    
254 :     HEADER_TEXT("string1", "string2", "string3");
255 :    
256 :     HEADER_TEXT() concatenates its arguments and appends them to the stored header
257 :     text string. It can be used more than once in a file.
258 :    
259 :     The macro is used for material which is destined to be placed in the HEAD of
260 :     the page when in HTML mode, such as JavaScript code.
261 :    
262 :     Spaces are placed between the arguments during concatenation, but no spaces are
263 :     introduced between the existing content of the header text string and the new
264 :     content being appended.
265 :    
266 :     =cut
267 :    
268 : gage 6883
269 :    
270 : gage 6249 # ^function HEADER_TEXT
271 :     # ^uses $STRINGforHEADER_TEXT
272 :     sub HEADER_TEXT {
273 :     my $self = shift;
274 :     push @{$self->{HEADER_ARRAY}}, map { (defined($_) )?$_:'' } @_;
275 :     $self->{HEADER_ARRAY} ;
276 :     }
277 :    
278 : gage 6883 =item POST_HEADER_TEXT()
279 :    
280 :     POST_HEADER_TEXT("string1", "string2", "string3");
281 :    
282 :     POST_HEADER_TEXT() concatenates its arguments and appends them to the stored post_header
283 :     text string. It can be used more than once in a file.
284 :    
285 :     The macro is used for material which is destined to be placed iimmediately after the HEAD of
286 :     the page as the first item in the body, before the main problem form
287 :     when in HTML mode, such as JavaScript code.
288 :    
289 :     Spaces are placed between the arguments during concatenation, but no spaces are
290 :     introduced between the existing content of the header text string and the new
291 :     content being appended.
292 :    
293 :     =cut
294 :    
295 :     # ^function POST_HEADER_TEXT
296 :     # ^uses $STRINGforHEADER_TEXT
297 :     sub POST_HEADER_TEXT {
298 :     my $self = shift;
299 :     push @{$self->{POST_HEADER_ARRAY}}, map { (defined($_) )?$_:'' } @_;
300 :     $self->{POST_HEADER_ARRAY} ;
301 :     }
302 :    
303 :    
304 : gage 6249 =item TEXT()
305 :    
306 :     TEXT("string1", "string2", "string3");
307 :    
308 :     TEXT() concatenates its arguments and appends them to the stored problem text
309 :     string. It is used to define the text which will appear in the body of the
310 :     problem. It can be used more than once in a file.
311 :    
312 :     This macro has no effect if rendering has been stopped with the STOP_RENDERING()
313 :     macro.
314 :    
315 :     This macro defines text which will appear in the problem. All text must be
316 :     passed to this macro, passed to another macro that calls this macro, or included
317 :     in a BEGIN_TEXT/END_TEXT block, which uses this macro internally. No other
318 :     statements in a PG file will directly appear in the output. Think of this as the
319 :     "print" function for the PG language.
320 :    
321 :     Spaces are placed between the arguments during concatenation, but no spaces are
322 :     introduced between the existing content of the header text string and the new
323 :     content being appended.
324 :    
325 :     =cut
326 :    
327 :     # ^function TEXT
328 :     # ^uses $PG_STOP_FLAG
329 :     # ^uses $STRINGforOUTPUT
330 :    
331 :     sub TEXT {
332 :     my $self = shift; #FIXME filter for undefined entries replace by "";
333 :     push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ;
334 :     $self->{OUTPUT_ARRAY};
335 :     }
336 :    
337 : mgage 6292 sub envir {
338 :     my $self = shift;
339 :     my $in_key = shift;
340 :     if ( not_null($in_key) ) {
341 :     if (defined ($self->{envir}->{$in_key} ) ) {
342 :     $self->{envir}->{$in_key};
343 :     } else {
344 :     warn "\$envir{$in_key} is not defined\n";
345 :     return '';
346 :     }
347 :     } else {
348 :     warn "<h3> Environment</h3>".pretty_print($self->{envir});
349 :     return '';
350 :     }
351 : gage 6249
352 : mgage 6292 }
353 : gage 6249 =item LABELED_ANS()
354 :    
355 :     TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2"));
356 :     LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2);
357 :    
358 :     Adds the answer evaluators listed to the list of labeled answer evaluators.
359 :     They will be paired with labeled answer rules (a.k.a. answer blanks) in the
360 :     order entered. This allows pairing of answer evaluators and answer rules that
361 :     may not have been entered in the same order.
362 :    
363 :     =cut
364 :    
365 :     # ^function NAMED_ANS
366 :     # ^uses &LABELED_ANS
367 :     sub NAMED_ANS {
368 :     &LABELED_ANS;
369 :     }
370 :    
371 :     =item NAMED_ANS()
372 :    
373 :     Old name for LABELED_ANS(). DEPRECATED.
374 :    
375 :     =cut
376 :    
377 :     # ^function NAMED_ANS
378 :     # ^uses $PG_STOP_FLAG
379 :     sub LABELED_ANS{
380 :     my $self = shift;
381 :     my @in = @_;
382 :     while (@in ) {
383 :     my $label = shift @in;
384 : gage 6280 #$label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label);
385 : gage 6249 my $ans_eval = shift @in;
386 : gage 6346 $self->warning_message("<BR><B>Error in LABELED_ANS:|$label|</B>
387 : gage 6249 -- inputs must be references to AnswerEvaluator objects or subroutines<BR>")
388 :     unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ;
389 :     if (defined($self->{PG_ANSWERS_HASH}->{$label}) ){
390 :     $self->{PG_ANSWERS_HASH}->{$label}->insert(ans_label => $label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE});
391 :     } else {
392 :     $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE});
393 :     }
394 :     $self->{answer_eval_count}++;
395 :     }
396 :     $self->{PG_ANSWERS_HASH};
397 :     }
398 :    
399 :    
400 :     =item ANS()
401 :    
402 :     TEXT(ans_rule(), ans_rule(), ans_rule());
403 :     ANS($answer_evaluator1, $answer_evaluator2, $answer_evaluator3);
404 :    
405 :     Adds the answer evaluators listed to the list of unlabeled answer evaluators.
406 :     They will be paired with unlabeled answer rules (a.k.a. answer blanks) in the
407 :     order entered. This is the standard method for entering answers.
408 :    
409 :     In the above example, answer_evaluator1 will be associated with the first
410 :     answer rule, answer_evaluator2 with the second, and answer_evaluator3 with the
411 :     third. In practice, the arguments to ANS() will usually be calls to an answer
412 :     evaluator generator such as the cmp() method of MathObjects or the num_cmp()
413 :     macro in L<PGanswermacros.pl>.
414 :    
415 :     =cut
416 :    
417 :     # ^function ANS
418 :     # ^uses $PG_STOP_FLAG
419 :     # ^uses @PG_ANSWERS
420 :    
421 :     sub ANS{
422 :     my $self = shift;
423 :     my @in = @_;
424 :     while (@in ) {
425 :     # create new label
426 :     $self->{unlabeled_answer_eval_count}++;
427 :     my $label = $self->new_label($self->{unlabeled_answer_eval_count});
428 :     my $evaluator = shift @in;
429 :     $self->LABELED_ANS($label, $evaluator);
430 :     }
431 :     $self->{PG_ANSWERS_HASH};
432 :     }
433 :    
434 :    
435 :    
436 :    
437 :     =item STOP_RENDERING()
438 :    
439 :     STOP_RENDERING() unless all_answers_are_correct();
440 :    
441 :     Temporarily suspends accumulation of problem text and storing of answer blanks
442 :     and answer evaluators until RESUME_RENDERING() is called.
443 :    
444 :     =cut
445 :    
446 :     # ^function STOP_RENDERING
447 :     # ^uses $PG_STOP_FLAG
448 :     sub STOP_RENDERING {
449 :     my $self = shift;
450 :     $self->{PG_ACTIVE}=0;
451 :     "";
452 :     }
453 :    
454 :     =item RESUME_RENDERING()
455 :    
456 :     RESUME_RENDERING();
457 :    
458 :     Resumes accumulating problem text and storing answer blanks and answer
459 :     evaluators. Reverses the effect of STOP_RENDERING().
460 :    
461 :     =cut
462 :    
463 :     # ^function RESUME_RENDERING
464 :     # ^uses $PG_STOP_FLAG
465 :     sub RESUME_RENDERING {
466 :     my $self = shift;
467 :     $self->{PG_ACTIVE}=1;
468 :     "";
469 :     }
470 :     ########
471 :     # Internal methods
472 :     #########
473 :     sub new_label { #creates a new label for unlabeled submissions ASNWER_PREFIX.$number
474 :     my $self = shift;
475 :     my $number = shift;
476 :     $self->{QUIZ_PREFIX}.$self->{ANSWER_PREFIX}.sprintf("%04u", $number);
477 :     }
478 :     sub new_array_label { #creates a new label for unlabeled submissions ASNWER_PREFIX.$number
479 :     my $self = shift;
480 :     my $number = shift;
481 :     $self->{QUIZ_PREFIX}.$self->{ARRAY_PREFIX}.sprintf("%04u", $number);
482 :     }
483 :     sub new_array_element_label { #creates a new label for unlabeled submissions ARRAY_PREFIX.$number
484 :     my $self = shift;
485 :     my $ans_label = shift; # name of the PGanswer group holding this array
486 :     my $row_num = shift;
487 :     my $col_num = shift;
488 :     my %options = @_;
489 :     my $vec_num = (defined $options{vec_num})?$options{vec_num}: 0 ;
490 : gage 6817 $self->{QUIZ_PREFIX}.$ans_label.'__'.$vec_num.'-'.$row_num.'-'.$col_num.'__';
491 : gage 6249 }
492 :     sub new_answer_name { # bit of a legacy item
493 :     &new_label;
494 :     }
495 :    
496 :    
497 :     sub record_ans_name { # the labels in the PGanswer group and response group should match in this case
498 :     my $self = shift;
499 :     my $label = shift;
500 :     my $value = shift;
501 : mgage 6292 #$self->internal_debug_message("PGcore::record_ans_name: $label $value");
502 : gage 6249 my $response_group = new PGresponsegroup($label,$label,$value);
503 :     if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
504 :     $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
505 :     response => $response_group,
506 :     active => $self->{PG_ACTIVE});
507 :     } else {
508 :     $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label,
509 :     response => $response_group,
510 :     active => $self->{PG_ACTIVE});
511 :     }
512 :     $self->{answer_blank_count}++;
513 :     $label;
514 :     }
515 :    
516 : gage 6397 sub record_array_name { # currently the same as record ans name
517 : gage 6249 my $self = shift;
518 :     my $label = shift;
519 :     my $value = shift;
520 :     my $response_group = new PGresponsegroup($label,$label,$value);
521 :     if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
522 :     $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
523 :     response => $response_group,
524 :     active => $self->{PG_ACTIVE});
525 :     } else {
526 :     $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label,
527 :     response => $response_group,
528 :     active => $self->{PG_ACTIVE});
529 :     }
530 :     $self->{answer_blank_count}++;
531 :     #$self->{PG_ANSWERS_HASH}->{$label}->{response}->clear; #why is this ?
532 :     $label;
533 :    
534 :     }
535 :     sub extend_ans_group { # modifies the group type
536 :     my $self = shift;
537 :     my $label = shift;
538 :     my @response_list = @_;
539 :     my $answer_group = $self->{PG_ANSWERS_HASH}->{$label};
540 :     if (ref($answer_group) =~/PGanswergroup/) {
541 :     $answer_group->append_responses(@response_list);
542 :     } else {
543 : gage 6404 #$self->warning_message("The answer |$label| has not yet been defined, you cannot extend it.",caller() );
544 :     # this error message is correct but misleading for the original way
545 :     # in which matrix blanks and their response evaluators are matched up
546 :     # we should restore the warning message once the new matrix evaluation method is in place
547 : gage 6249
548 :     }
549 :     $label;
550 :     }
551 :     sub record_unlabeled_ans_name {
552 :     my $self = shift;
553 :     $self->{unlabeled_answer_blank_count}++;
554 :     my $label = $self->new_label($self->{unlabeled_answer_blank_count});
555 :     $self->record_ans_name($label);
556 :     $label;
557 :     }
558 :     sub record_unlabeled_array_name {
559 :     my $self = shift;
560 :     $self->{unlabeled_answer_blank_count}++;
561 :     my $ans_label = $self->new_array_label($self->{unlabeled_answer_blank_count});
562 :     $self->record_array_name($ans_label);
563 :     }
564 :     sub store_persistent_data { # will store strings only (so far)
565 :     my $self = shift;
566 :     my $label = shift;
567 :     my @content = @_;
568 : mgage 6292 $self->internal_debug_message("PGcore::store_persistent_data: storing $label in PERSISTENCE_HASH");
569 : gage 6249 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) {
570 :     warn "can' overwrite $label in persistent data";
571 :     } else {
572 :     $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding?
573 :     }
574 :     $label;
575 :     }
576 :     sub check_answer_hash {
577 :     my $self = shift;
578 :     foreach my $key (keys %{ $self->{PG_ANSWERS_HASH} }) {
579 :     my $ans_eval = $self->{PG_ANSWERS_HASH}->{$key}->{ans_eval};
580 :     unless (ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ) {
581 :     warn "The answer group labeled $key is missing an answer evaluator";
582 :     }
583 :     unless (ref( $self->{PG_ANSWERS_HASH}->{$key}->{response} ) =~ /PGresponsegroup/ ) {
584 :     warn "The answer group labeled $key is missing answer blanks ";
585 :     }
586 :     }
587 :     }
588 :    
589 :     sub PG_restricted_eval {
590 :     my $self = shift;
591 :     WeBWorK::PG::Translator::PG_restricted_eval(@_);
592 :     }
593 :    
594 :    
595 : gage 6851 =head2 base64 coding
596 : mgage 6292
597 : gage 6851 $str = decode_base64($coded_str);
598 :     $coded_str = encode_base64($str);
599 :    
600 : gage 6296 # Sometimes a question author needs to code or decode base64 directly
601 : gage 6851
602 :     =cut
603 :    
604 : gage 6296 sub decode_base64 ($) {
605 :     my $self = shift;
606 :     my $str = shift;
607 :     MIME::Base64::decode_base64($str);
608 :     }
609 : mgage 6292
610 : gage 6296 sub encode_base64 ($;$) {
611 :     my $self = shift;
612 :     my $str = shift;
613 :     my $option = shift;
614 :     MIME::Base64::encode_base64($str);
615 :     }
616 : gage 6851
617 :     =head2 Message channels
618 :    
619 :     There are three message channels
620 :     $PG->debug_message() or in PG: DEBUG_MESSAGE()
621 :     $PG->warning_message() or in PG: WARNING_MESSAGE()
622 :    
623 :     They behave the same way, it is simply convention as to how they are used.
624 :    
625 :     To report the messages use:
626 :    
627 :     $PG->get_debug_messages
628 :     $PG->get_warning_messages
629 :    
630 :     These are used in Problem.pm for example to report any errors.
631 :    
632 :     There is also
633 :    
634 :     $PG->internal_debug_message()
635 :     $PG->get_internal_debug_message
636 :     $PG->clear_internal_debug_messages();
637 :    
638 :     There were times when things were buggy enough that only the internal_debug_message which are not saved
639 :     inside the PGcore object would report.
640 :    
641 :     =cut
642 :    
643 : mgage 6292 sub debug_message {
644 : gage 6249 my $self = shift;
645 :     my @str = @_;
646 : mgage 6292 push @{$self->{flags}->{DEBUG_messages}}, @str;
647 : gage 6249 }
648 :     sub get_debug_messages {
649 :     my $self = shift;
650 : mgage 6292 $self->{flags}->{DEBUG_messages};
651 : gage 6249 }
652 : gage 6346 sub warning_message {
653 :     my $self = shift;
654 :     my @str = @_;
655 :     push @{$self->{flags}->{WARNING_messages}}, @str;
656 :     }
657 :     sub get_warning_messages {
658 :     my $self = shift;
659 :     $self->{flags}->{WARNING_messages};
660 :     }
661 : mgage 6292
662 :     sub internal_debug_message {
663 :     my $self = shift;
664 :     my @str = @_;
665 :     push @{$internal_debug_messages}, @str;
666 :     }
667 :     sub get_internal_debug_messages {
668 :     my $self = shift;
669 :     $internal_debug_messages;
670 :     }
671 :     sub clear_internal_debug_messages {
672 :     my $self = shift;
673 :     $internal_debug_messages=[];
674 :     }
675 :    
676 : gage 6249 sub DESTROY {
677 :     # doing nothing about destruction, hope that isn't dangerous
678 :     }
679 :    
680 : gage 6346 # sub WARN {
681 :     # warn(@_);
682 :     # }
683 : gage 6249
684 :    
685 :     # This creates on the fly graphs
686 :    
687 :     =head2 insertGraph
688 :    
689 :     # returns a path to the file containing the graph image.
690 :     $filePath = insertGraph($graphObject);
691 :    
692 :     insertGraph writes a GIF or PNG image file to the gif subdirectory of the
693 :     current course's HTML temp directory. The file name is obtained from the graph
694 :     object. Warnings are issued if errors occur while writing to the file.
695 :    
696 :     Returns a string containing the full path to the temporary file containing the
697 :     image. This is most often used in the construct
698 :    
699 :     TEXT(alias(insertGraph($graph)));
700 :    
701 :     where alias converts the directory address to a URL when serving HTML pages and
702 :     insures that an EPS file is generated when creating TeX code for downloading.
703 :    
704 :     =cut
705 :    
706 :     # ^function insertGraph
707 :     # ^uses $WWPlot::use_png
708 :     # ^uses convertPath
709 :     # ^uses surePathToTmpFile
710 :     # ^uses PG_restricted_eval
711 :     # ^uses $refreshCachedImages
712 :     # ^uses $templateDirectory
713 :     # ^uses %envir
714 :     sub insertGraph {
715 :     # Convert the image to GIF and print it on standard output
716 :     my $self = shift;
717 :     my $graph = shift;
718 :     my $extension = ($WWPlot::use_png) ? '.png' : '.gif';
719 :     my $fileName = $graph->imageName . $extension;
720 :     my $filePath = $self->convertPath("gif/$fileName");
721 :     my $templateDirectory = $self->{envir}->{templateDirectory};
722 :     $filePath = $self->surePathToTmpFile( $filePath );
723 :     my $refreshCachedImages = $self->PG_restricted_eval(q!$refreshCachedImages!);
724 :     # Check to see if we already have this graph, or if we have to make it
725 :     if( not -e $filePath # does it exist?
726 :     or ((stat "$templateDirectory"."$main::envir{fileName}")[9] > (stat $filePath)[9]) # source has changed
727 :     or $graph->imageName =~ /Undefined_Set/ # problems from SetMaker and its ilk should always be redone
728 :     or $refreshCachedImages
729 :     ) {
730 :     #createFile($filePath, $main::tmp_file_permission, $main::numericalGroupID);
731 :     local(*OUTPUT); # create local file handle so it won't overwrite other open files.
732 :     open(OUTPUT, ">$filePath")||warn ("$0","Can't open $filePath<BR>","");
733 :     chmod( 0777, $filePath);
734 :     print OUTPUT $graph->draw|| warn("$0","Can't print graph to $filePath<BR>","");
735 :     close(OUTPUT)||warn("$0","Can't close $filePath<BR>","");
736 :     }
737 :     $filePath;
738 :     }
739 :    
740 :     =head1 Macros from IO.pm
741 :    
742 :     includePGtext
743 :     read_whole_problem_file
744 :     read_whole_file
745 :     convertPath
746 :     getDirDelim
747 :     fileFromPath
748 :     directoryFromPath
749 :     createFile
750 :     createDirectory
751 :    
752 :     =cut
753 :    
754 :     sub includePGtext {
755 :     my $self = shift;
756 :     WeBWorK::PG::IO::includePGtext(@_);
757 :     };
758 :     sub read_whole_problem_file {
759 :     my $self = shift;
760 :     WeBWorK::PG::IO::read_whole_problem_file(@_);
761 :     };
762 :     sub read_whole_file {
763 :     my $self = shift;
764 :     WeBWorK::PG::IO::read_whole_file(@_);
765 :     };
766 :     sub convertPath {
767 :     my $self = shift;
768 :     WeBWorK::PG::IO::convertPath(@_);
769 :     };
770 :     sub getDirDelim {
771 :     my $self = shift;
772 :     WeBWorK::PG::IO::getDirDelim(@_);
773 :     };
774 :     sub fileFromPath {
775 :     my $self = shift;
776 :     WeBWorK::PG::IO::fileFromPath(@_);
777 :     };
778 :     sub directoryFromPath {
779 :     my $self = shift;
780 :     WeBWorK::PG::IO::directoryFromPath(@_);
781 :     };
782 :     sub createFile {
783 :     my $self = shift;
784 :     WeBWorK::PG::IO::createFile(@_);
785 :     };
786 :     sub createDirectory {
787 :     my $self = shift;
788 :     WeBWorK::PG::IO::createDirectory(@_);
789 :     };
790 :    
791 :     sub tempDirectory {
792 :     my $self = shift;
793 :     return $self->{tempDirectory};
794 :     }
795 :    
796 :    
797 :     =head2 surePathToTmpFile
798 :    
799 :     $path = surePathToTmpFile($path);
800 :    
801 :     Creates all of the intermediate directories between the tempDirectory
802 :    
803 :     If $path begins with the tempDirectory path, then the
804 :     path is treated as absolute. Otherwise, the path is treated as relative the the
805 :     course temp directory.
806 :    
807 :     =cut
808 :    
809 :     # A very useful macro for making sure that all of the directories to a file have been constructed.
810 :    
811 :     # ^function surePathToTmpFile
812 :     # ^uses getCourseTempDirectory
813 :     # ^uses createDirectory
814 :    
815 :    
816 :     sub surePathToTmpFile {
817 :     # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/
818 :     # the input path must be either the full path, or the path relative to this tmp sub directory
819 :    
820 :     my $self = shift;
821 :     my $path = shift;
822 :     my $delim = "/";
823 :     my $tmpDirectory = $self->tempDirectory();
824 : gage 6261 #warn "\nTMP tmpDirectory $tmpDirectory";
825 : gage 6249 unless ( -e $tmpDirectory) { # if by some unlucky chance the tmpDirectory hasn't been created, create it.
826 :     my $parentDirectory = $tmpDirectory;
827 :     $parentDirectory =~s|/$||; # remove a trailing /
828 : apizer 7138 $parentDirectory =~s|/[^/]*$||; # remove last node
829 : gage 6249 my ($perms, $groupID) = (stat $parentDirectory)[2,5];
830 : gage 6261 #FIXME where is the parentDirectory defined??
831 :     #warn "Creating tmp directory at $tmpDirectory, perms $perms groupID $groupID";
832 :     $self->createDirectory($tmpDirectory, $perms, $groupID)
833 :     or warn "Failed to create parent tmp directory at $path";
834 : gage 6249
835 :     }
836 :     # use the permissions/group on the temp directory itself as a template
837 :     my ($perms, $groupID) = (stat $tmpDirectory)[2,5];
838 : gage 6261 #warn "&urePathToTmpFile: directory=$tmpDirectory, perms=$perms, groupID=$groupID\n";
839 : gage 6249
840 :     # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment
841 :     $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|;
842 : gage 6261 #$path = $self->convertPath($path);
843 : gage 6249
844 :     # find the nodes on the given path
845 :     my @nodes = split("$delim",$path);
846 :    
847 :     # create new path
848 :     $path = $tmpDirectory; #convertPath("$tmpDirectory");
849 :    
850 :     while (@nodes>1) {
851 :     $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
852 : gage 6261 #warn "\PATH is now $path";
853 : gage 6249 unless (-e $path) {
854 :     #system("mkdir $path");
855 :     #createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID)
856 : gage 6261 #warn "PATH $path perms $perms groupID $groupID";
857 :     $self->createDirectory($path, $perms, $groupID)
858 :     or warn "Failed to create directory at $path with permissions $perms and groupID $groupID";
859 : gage 6249 }
860 :    
861 :     }
862 :    
863 :     $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
864 :     #system(qq!echo "" > $path! );
865 :     return $path;
866 :     }
867 :    
868 :    
869 :     1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9