[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 6292 - (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 :    
34 :     ##################################
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 : mgage 6292 # PG_ANSWERS => [], # holds answers with labels # deprecated
125 :     # PG_UNLABELED_ANSWERS => [], # holds unlabeled ans. #deprecated -replaced by PG_ANSWERS_HASH
126 : gage 6249 PG_ANSWERS_HASH => {}, # holds label=>answer pairs
127 :     PERSISTENCE_HASH => {}, # holds other data, besides answers, which persists during a session and beyond
128 :     answer_eval_count => 0,
129 :     answer_blank_count => 0,
130 :     unlabeled_answer_blank_count =>0,
131 :     unlabeled_answer_eval_count => 0,
132 :     KEPT_EXTRA_ANSWERS => [],
133 :     ANSWER_PREFIX => 'AnSwEr',
134 :     ARRAY_PREFIX => 'ArRaY',
135 :     vec_num => 0, # for distinguishing matrices
136 : gage 6280 QUIZ_PREFIX => $envir->{QUIZ_PREFIX},
137 : gage 6249 SECTION_PREFIX => '', # might be used for sequential (compound) questions?
138 :    
139 : mgage 6292 PG_ACTIVE => 1, # toggle to zero to stop processing
140 : gage 6249 submittedAnswers => 0, # have any answers been submitted? is this the first time this session?
141 :     PG_session_persistence_hash =>{}, # stores data from one invoction of the session to the next.
142 :     PG_original_problem_seed => 0,
143 :     PG_random_generator => undef,
144 :     PG_alias => undef,
145 :     PG_problem_grader => undef,
146 :     displayMode => undef,
147 :     envir => $envir,
148 :     gifs_created => {},
149 :     external_refs => {}, # record of external references
150 :     %options, # allows overrides and initialization
151 :     };
152 :     bless $self, $class;
153 :     tie %{$self->{PG_ANSWERS_HASH}}, "Tie::IxHash"; # creates a Hash with order
154 :     $self->initialize;
155 :     return $self;
156 :     }
157 :    
158 :     sub initialize {
159 :     my $self = shift;
160 :     warn "environment is not defined in PGcore" unless ref($self->{envir}) eq 'HASH';
161 :    
162 :    
163 :    
164 :    
165 :     $self->{displayMode} = $self->{envir}->{displayMode};
166 :     $self->{PG_original_problem_seed} = $self->{envir}->{problemSeed};
167 :     $self->{PG_random_generator} = new PGrandom( $self->{PG_original_problem_seed});
168 :    
169 :     $self->{tempDirectory} = $self->{envir}->{tempDirectory};
170 :     $self->{PG_problem_grader} = $self->{envir}->{PROBLEM_GRADER_TO_USE};
171 :     $self->{PG_alias} = new PGalias($self->{envir});
172 :     $self->{PG_loadMacros} = new PGloadfiles($self->{envir});
173 : gage 6256 $self->{flags} = {
174 : gage 6249 showpartialCorrectAnswers => 1,
175 :     showHint => 1,
176 :     hintExists => 0,
177 :     showHintLimit => 0,
178 :     solutionExists => 0,
179 :     WARNING_messages => [],
180 :     DEBUG_messages => [],
181 :     recordSubmittedAnswers => 1,
182 :     refreshCAchedImages => 0,
183 :     # ANSWER_ENTRY_ORDER => [], # may not be needed if we ue Tie:IxHash
184 :     comment => '', # implement as array?
185 :    
186 :    
187 :    
188 :     };
189 :    
190 :     }
191 :    
192 :    
193 :     ####################################################################
194 :    
195 :     =head1 DESCRIPTION
196 :    
197 :     This file provides the fundamental macros that define the PG language. It
198 :     maintains a problem's text, header text, and answers:
199 :    
200 :     =over
201 :    
202 :     =item *
203 :    
204 :     Problem text: The text to appear in the body of the problem. See TEXT()
205 :     below.
206 :    
207 :     =item *
208 :    
209 :     Header text: When a problem is processed in an HTML-based display mode,
210 :     this variable can contain text that the caller should place in the HEAD of the
211 :     resulting HTML page. See HEADER_TEXT() below.
212 :    
213 :     =item *
214 :    
215 :     Implicitly-labeled answers: Answers that have not been explicitly
216 :     assigned names, and are associated with their answer blanks by the order in
217 :     which they appear in the problem. These types of answers are designated using
218 :     the ANS() macro.
219 :    
220 :     =item *
221 :    
222 :     Explicitly-labeled answers: Answers that have been explicitly assigned
223 :     names with the LABELED_ANS() macro, or a macro that uses it. An explicitly-
224 :     labeled answer is associated with its answer blank by name.
225 :    
226 :     =item *
227 :    
228 :     "Extra" answers: Names of answer blanks that do not have a 1-to-1
229 :     correspondance to an answer evaluator. For example, in matrix problems, there
230 :     will be several input fields that correspond to the same answer evaluator.
231 :    
232 :     =back
233 :    
234 :     =head1 USAGE
235 :    
236 :     This file is automatically loaded into the namespace of every PG problem. The
237 :     macros within can then be called to define the structure of the problem.
238 :    
239 :     DOCUMENT() should be the first executable statement in any problem. It
240 :     initializes vriables and defines the problem environment.
241 :    
242 :     ENDDOCUMENT() must be the last executable statement in any problem. It packs
243 :     up the results of problem processing for delivery back to WeBWorK.
244 :    
245 :     The HEADER_TEXT(), TEXT(), and ANS() macros add to the header text string,
246 :     body text string, and answer evaluator queue, respectively.
247 :    
248 :     =cut
249 :    
250 :    
251 :     =item HEADER_TEXT()
252 :    
253 :     HEADER_TEXT("string1", "string2", "string3");
254 :    
255 :     HEADER_TEXT() concatenates its arguments and appends them to the stored header
256 :     text string. It can be used more than once in a file.
257 :    
258 :     The macro is used for material which is destined to be placed in the HEAD of
259 :     the page when in HTML mode, such as JavaScript code.
260 :    
261 :     Spaces are placed between the arguments during concatenation, but no spaces are
262 :     introduced between the existing content of the header text string and the new
263 :     content being appended.
264 :    
265 :     =cut
266 :    
267 :     # ^function HEADER_TEXT
268 :     # ^uses $STRINGforHEADER_TEXT
269 :     sub HEADER_TEXT {
270 :     my $self = shift;
271 :     push @{$self->{HEADER_ARRAY}}, map { (defined($_) )?$_:'' } @_;
272 :     $self->{HEADER_ARRAY} ;
273 :     }
274 :    
275 :     =item TEXT()
276 :    
277 :     TEXT("string1", "string2", "string3");
278 :    
279 :     TEXT() concatenates its arguments and appends them to the stored problem text
280 :     string. It is used to define the text which will appear in the body of the
281 :     problem. It can be used more than once in a file.
282 :    
283 :     This macro has no effect if rendering has been stopped with the STOP_RENDERING()
284 :     macro.
285 :    
286 :     This macro defines text which will appear in the problem. All text must be
287 :     passed to this macro, passed to another macro that calls this macro, or included
288 :     in a BEGIN_TEXT/END_TEXT block, which uses this macro internally. No other
289 :     statements in a PG file will directly appear in the output. Think of this as the
290 :     "print" function for the PG language.
291 :    
292 :     Spaces are placed between the arguments during concatenation, but no spaces are
293 :     introduced between the existing content of the header text string and the new
294 :     content being appended.
295 :    
296 :     =cut
297 :    
298 :     # ^function TEXT
299 :     # ^uses $PG_STOP_FLAG
300 :     # ^uses $STRINGforOUTPUT
301 :    
302 :     sub TEXT {
303 :     my $self = shift; #FIXME filter for undefined entries replace by "";
304 :     push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ;
305 :     $self->{OUTPUT_ARRAY};
306 :     }
307 :    
308 : mgage 6292 sub envir {
309 :     my $self = shift;
310 :     my $in_key = shift;
311 :     if ( not_null($in_key) ) {
312 :     if (defined ($self->{envir}->{$in_key} ) ) {
313 :     $self->{envir}->{$in_key};
314 :     } else {
315 :     warn "\$envir{$in_key} is not defined\n";
316 :     return '';
317 :     }
318 :     } else {
319 :     warn "<h3> Environment</h3>".pretty_print($self->{envir});
320 :     return '';
321 :     }
322 : gage 6249
323 : mgage 6292 }
324 : gage 6249 =item LABELED_ANS()
325 :    
326 :     TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2"));
327 :     LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2);
328 :    
329 :     Adds the answer evaluators listed to the list of labeled answer evaluators.
330 :     They will be paired with labeled answer rules (a.k.a. answer blanks) in the
331 :     order entered. This allows pairing of answer evaluators and answer rules that
332 :     may not have been entered in the same order.
333 :    
334 :     =cut
335 :    
336 :     # ^function NAMED_ANS
337 :     # ^uses &LABELED_ANS
338 :     sub NAMED_ANS {
339 :     &LABELED_ANS;
340 :     }
341 :    
342 :     =item NAMED_ANS()
343 :    
344 :     Old name for LABELED_ANS(). DEPRECATED.
345 :    
346 :     =cut
347 :    
348 :     # ^function NAMED_ANS
349 :     # ^uses $PG_STOP_FLAG
350 :     sub LABELED_ANS{
351 :     my $self = shift;
352 :     my @in = @_;
353 :     while (@in ) {
354 :     my $label = shift @in;
355 : gage 6280 #$label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label);
356 : gage 6249 my $ans_eval = shift @in;
357 :     $self->WARN("<BR><B>Error in LABELED_ANS:|$label|</B>
358 :     -- inputs must be references to AnswerEvaluator objects or subroutines<BR>")
359 :     unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ;
360 :     if (defined($self->{PG_ANSWERS_HASH}->{$label}) ){
361 :     $self->{PG_ANSWERS_HASH}->{$label}->insert(ans_label => $label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE});
362 :     } else {
363 :     $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE});
364 :     }
365 :     $self->{answer_eval_count}++;
366 :     }
367 :     $self->{PG_ANSWERS_HASH};
368 :     }
369 :    
370 :    
371 :     =item ANS()
372 :    
373 :     TEXT(ans_rule(), ans_rule(), ans_rule());
374 :     ANS($answer_evaluator1, $answer_evaluator2, $answer_evaluator3);
375 :    
376 :     Adds the answer evaluators listed to the list of unlabeled answer evaluators.
377 :     They will be paired with unlabeled answer rules (a.k.a. answer blanks) in the
378 :     order entered. This is the standard method for entering answers.
379 :    
380 :     In the above example, answer_evaluator1 will be associated with the first
381 :     answer rule, answer_evaluator2 with the second, and answer_evaluator3 with the
382 :     third. In practice, the arguments to ANS() will usually be calls to an answer
383 :     evaluator generator such as the cmp() method of MathObjects or the num_cmp()
384 :     macro in L<PGanswermacros.pl>.
385 :    
386 :     =cut
387 :    
388 :     # ^function ANS
389 :     # ^uses $PG_STOP_FLAG
390 :     # ^uses @PG_ANSWERS
391 :    
392 :     sub ANS{
393 :     my $self = shift;
394 :     my @in = @_;
395 :     while (@in ) {
396 :     # create new label
397 :     $self->{unlabeled_answer_eval_count}++;
398 :     my $label = $self->new_label($self->{unlabeled_answer_eval_count});
399 :     my $evaluator = shift @in;
400 :     $self->LABELED_ANS($label, $evaluator);
401 :     }
402 :     $self->{PG_ANSWERS_HASH};
403 :     }
404 :    
405 :    
406 :    
407 :    
408 :     =item STOP_RENDERING()
409 :    
410 :     STOP_RENDERING() unless all_answers_are_correct();
411 :    
412 :     Temporarily suspends accumulation of problem text and storing of answer blanks
413 :     and answer evaluators until RESUME_RENDERING() is called.
414 :    
415 :     =cut
416 :    
417 :     # ^function STOP_RENDERING
418 :     # ^uses $PG_STOP_FLAG
419 :     sub STOP_RENDERING {
420 :     my $self = shift;
421 :     $self->{PG_ACTIVE}=0;
422 :     "";
423 :     }
424 :    
425 :     =item RESUME_RENDERING()
426 :    
427 :     RESUME_RENDERING();
428 :    
429 :     Resumes accumulating problem text and storing answer blanks and answer
430 :     evaluators. Reverses the effect of STOP_RENDERING().
431 :    
432 :     =cut
433 :    
434 :     # ^function RESUME_RENDERING
435 :     # ^uses $PG_STOP_FLAG
436 :     sub RESUME_RENDERING {
437 :     my $self = shift;
438 :     $self->{PG_ACTIVE}=1;
439 :     "";
440 :     }
441 :     ########
442 :     # Internal methods
443 :     #########
444 :     sub new_label { #creates a new label for unlabeled submissions ASNWER_PREFIX.$number
445 :     my $self = shift;
446 :     my $number = shift;
447 :     $self->{QUIZ_PREFIX}.$self->{ANSWER_PREFIX}.sprintf("%04u", $number);
448 :     }
449 :     sub new_array_label { #creates a new label for unlabeled submissions ASNWER_PREFIX.$number
450 :     my $self = shift;
451 :     my $number = shift;
452 :     $self->{QUIZ_PREFIX}.$self->{ARRAY_PREFIX}.sprintf("%04u", $number);
453 :     }
454 :     sub new_array_element_label { #creates a new label for unlabeled submissions ARRAY_PREFIX.$number
455 :     my $self = shift;
456 :     my $ans_label = shift; # name of the PGanswer group holding this array
457 :     my $row_num = shift;
458 :     my $col_num = shift;
459 :     my %options = @_;
460 :     my $vec_num = (defined $options{vec_num})?$options{vec_num}: 0 ;
461 :     $self->{QUIZ_PREFIX}.$ans_label.'__'.$vec_num.':'.$row_num.':'.$col_num.'__';
462 :     }
463 :     sub new_answer_name { # bit of a legacy item
464 :     &new_label;
465 :     }
466 :    
467 :    
468 :     sub record_ans_name { # the labels in the PGanswer group and response group should match in this case
469 :     my $self = shift;
470 :     my $label = shift;
471 :     my $value = shift;
472 : mgage 6292 #$self->internal_debug_message("PGcore::record_ans_name: $label $value");
473 : gage 6249 my $response_group = new PGresponsegroup($label,$label,$value);
474 :     if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
475 :     $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
476 :     response => $response_group,
477 :     active => $self->{PG_ACTIVE});
478 :     } else {
479 :     $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label,
480 :     response => $response_group,
481 :     active => $self->{PG_ACTIVE});
482 :     }
483 :     $self->{answer_blank_count}++;
484 :     $label;
485 :     }
486 :    
487 :     sub record_array_name { # currently the same as record ans group
488 :     my $self = shift;
489 :     my $label = shift;
490 :     my $value = shift;
491 :     my $response_group = new PGresponsegroup($label,$label,$value);
492 :     if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
493 :     $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
494 :     response => $response_group,
495 :     active => $self->{PG_ACTIVE});
496 :     } else {
497 :     $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label,
498 :     response => $response_group,
499 :     active => $self->{PG_ACTIVE});
500 :     }
501 :     $self->{answer_blank_count}++;
502 :     #$self->{PG_ANSWERS_HASH}->{$label}->{response}->clear; #why is this ?
503 :     $label;
504 :    
505 :     }
506 :     sub extend_ans_group { # modifies the group type
507 :     my $self = shift;
508 :     my $label = shift;
509 :     my @response_list = @_;
510 :     my $answer_group = $self->{PG_ANSWERS_HASH}->{$label};
511 :     if (ref($answer_group) =~/PGanswergroup/) {
512 :     $answer_group->append_responses(@response_list);
513 :     } else {
514 :     $self->WARN("The answer |$label| has not yet been defined, you cannot extend it.",caller() );
515 :    
516 :     }
517 :     $label;
518 :     }
519 :     sub record_unlabeled_ans_name {
520 :     my $self = shift;
521 :     $self->{unlabeled_answer_blank_count}++;
522 :     my $label = $self->new_label($self->{unlabeled_answer_blank_count});
523 :     $self->record_ans_name($label);
524 :     $label;
525 :     }
526 :     sub record_unlabeled_array_name {
527 :     my $self = shift;
528 :     $self->{unlabeled_answer_blank_count}++;
529 :     my $ans_label = $self->new_array_label($self->{unlabeled_answer_blank_count});
530 :     $self->record_array_name($ans_label);
531 :     }
532 :     sub store_persistent_data { # will store strings only (so far)
533 :     my $self = shift;
534 :     my $label = shift;
535 :     my @content = @_;
536 : mgage 6292 $self->internal_debug_message("PGcore::store_persistent_data: storing $label in PERSISTENCE_HASH");
537 : gage 6249 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) {
538 :     warn "can' overwrite $label in persistent data";
539 :     } else {
540 :     $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding?
541 :     }
542 :     $label;
543 :     }
544 :     sub check_answer_hash {
545 :     my $self = shift;
546 :     foreach my $key (keys %{ $self->{PG_ANSWERS_HASH} }) {
547 :     my $ans_eval = $self->{PG_ANSWERS_HASH}->{$key}->{ans_eval};
548 :     unless (ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ) {
549 :     warn "The answer group labeled $key is missing an answer evaluator";
550 :     }
551 :     unless (ref( $self->{PG_ANSWERS_HASH}->{$key}->{response} ) =~ /PGresponsegroup/ ) {
552 :     warn "The answer group labeled $key is missing answer blanks ";
553 :     }
554 :     }
555 :     }
556 :    
557 :     sub PG_restricted_eval {
558 :     my $self = shift;
559 :     WeBWorK::PG::Translator::PG_restricted_eval(@_);
560 :     }
561 :    
562 :     # sub AUTOLOAD {
563 :     # my $self = shift;
564 :     #
565 :     # my $type = ref($self) or die "$self is not an object";
566 :     #
567 :     # # $AUTOLOAD is sent in by Perl and is the full name of the object (i.e. main::blah::blah_more)
568 :     # my $name = $PGcore::AUTOLOAD;
569 :     # $name =~ s/.*://; #strips fully-qualified portion
570 :     #
571 :     # unless ( exists $self->{'_permitted'}->{$name} ) { die "Can't find '$name' field in object of class '$type'";}
572 :     #
573 :     # if (@_) {
574 :     # return $self->{$name} = shift; #set the variable to the first parameter
575 :     # } else {
576 :     # return $self->($name); #if no parameters just return the value
577 :     # }
578 :     # }
579 :    
580 : mgage 6292
581 :    
582 :     sub debug_message {
583 : gage 6249 my $self = shift;
584 :     my @str = @_;
585 : mgage 6292 push @{$self->{flags}->{DEBUG_messages}}, @str;
586 : gage 6249 }
587 :     sub get_debug_messages {
588 :     my $self = shift;
589 : mgage 6292 $self->{flags}->{DEBUG_messages};
590 : gage 6249 }
591 : mgage 6292
592 :     sub internal_debug_message {
593 :     my $self = shift;
594 :     my @str = @_;
595 :     push @{$internal_debug_messages}, @str;
596 :     }
597 :     sub get_internal_debug_messages {
598 :     my $self = shift;
599 :     $internal_debug_messages;
600 :     }
601 :     sub clear_internal_debug_messages {
602 :     my $self = shift;
603 :     $internal_debug_messages=[];
604 :     }
605 :    
606 : gage 6249 sub DESTROY {
607 :     # doing nothing about destruction, hope that isn't dangerous
608 :     }
609 :    
610 :     sub WARN {
611 :     warn(@_);
612 :     }
613 :    
614 :    
615 :     # This creates on the fly graphs
616 :    
617 :     =head2 insertGraph
618 :    
619 :     # returns a path to the file containing the graph image.
620 :     $filePath = insertGraph($graphObject);
621 :    
622 :     insertGraph writes a GIF or PNG image file to the gif subdirectory of the
623 :     current course's HTML temp directory. The file name is obtained from the graph
624 :     object. Warnings are issued if errors occur while writing to the file.
625 :    
626 :     Returns a string containing the full path to the temporary file containing the
627 :     image. This is most often used in the construct
628 :    
629 :     TEXT(alias(insertGraph($graph)));
630 :    
631 :     where alias converts the directory address to a URL when serving HTML pages and
632 :     insures that an EPS file is generated when creating TeX code for downloading.
633 :    
634 :     =cut
635 :    
636 :     # ^function insertGraph
637 :     # ^uses $WWPlot::use_png
638 :     # ^uses convertPath
639 :     # ^uses surePathToTmpFile
640 :     # ^uses PG_restricted_eval
641 :     # ^uses $refreshCachedImages
642 :     # ^uses $templateDirectory
643 :     # ^uses %envir
644 :     sub insertGraph {
645 :     # Convert the image to GIF and print it on standard output
646 :     my $self = shift;
647 :     my $graph = shift;
648 :     my $extension = ($WWPlot::use_png) ? '.png' : '.gif';
649 :     my $fileName = $graph->imageName . $extension;
650 :     my $filePath = $self->convertPath("gif/$fileName");
651 :     my $templateDirectory = $self->{envir}->{templateDirectory};
652 :     $filePath = $self->surePathToTmpFile( $filePath );
653 :     my $refreshCachedImages = $self->PG_restricted_eval(q!$refreshCachedImages!);
654 :     # Check to see if we already have this graph, or if we have to make it
655 :     if( not -e $filePath # does it exist?
656 :     or ((stat "$templateDirectory"."$main::envir{fileName}")[9] > (stat $filePath)[9]) # source has changed
657 :     or $graph->imageName =~ /Undefined_Set/ # problems from SetMaker and its ilk should always be redone
658 :     or $refreshCachedImages
659 :     ) {
660 :     #createFile($filePath, $main::tmp_file_permission, $main::numericalGroupID);
661 :     local(*OUTPUT); # create local file handle so it won't overwrite other open files.
662 :     open(OUTPUT, ">$filePath")||warn ("$0","Can't open $filePath<BR>","");
663 :     chmod( 0777, $filePath);
664 :     print OUTPUT $graph->draw|| warn("$0","Can't print graph to $filePath<BR>","");
665 :     close(OUTPUT)||warn("$0","Can't close $filePath<BR>","");
666 :     }
667 :     $filePath;
668 :     }
669 :    
670 :     =head1 Macros from IO.pm
671 :    
672 :     includePGtext
673 :     read_whole_problem_file
674 :     read_whole_file
675 :     convertPath
676 :     getDirDelim
677 :     fileFromPath
678 :     directoryFromPath
679 :     createFile
680 :     createDirectory
681 :    
682 :     =cut
683 :    
684 :     sub includePGtext {
685 :     my $self = shift;
686 :     WeBWorK::PG::IO::includePGtext(@_);
687 :     };
688 :     sub read_whole_problem_file {
689 :     my $self = shift;
690 :     WeBWorK::PG::IO::read_whole_problem_file(@_);
691 :     };
692 :     sub read_whole_file {
693 :     my $self = shift;
694 :     WeBWorK::PG::IO::read_whole_file(@_);
695 :     };
696 :     sub convertPath {
697 :     my $self = shift;
698 :     WeBWorK::PG::IO::convertPath(@_);
699 :     };
700 :     sub getDirDelim {
701 :     my $self = shift;
702 :     WeBWorK::PG::IO::getDirDelim(@_);
703 :     };
704 :     sub fileFromPath {
705 :     my $self = shift;
706 :     WeBWorK::PG::IO::fileFromPath(@_);
707 :     };
708 :     sub directoryFromPath {
709 :     my $self = shift;
710 :     WeBWorK::PG::IO::directoryFromPath(@_);
711 :     };
712 :     sub createFile {
713 :     my $self = shift;
714 :     WeBWorK::PG::IO::createFile(@_);
715 :     };
716 :     sub createDirectory {
717 :     my $self = shift;
718 :     WeBWorK::PG::IO::createDirectory(@_);
719 :     };
720 :    
721 :     sub tempDirectory {
722 :     my $self = shift;
723 :     return $self->{tempDirectory};
724 :     }
725 :    
726 :    
727 :     =head2 surePathToTmpFile
728 :    
729 :     $path = surePathToTmpFile($path);
730 :    
731 :     Creates all of the intermediate directories between the tempDirectory
732 :    
733 :     If $path begins with the tempDirectory path, then the
734 :     path is treated as absolute. Otherwise, the path is treated as relative the the
735 :     course temp directory.
736 :    
737 :     =cut
738 :    
739 :     # A very useful macro for making sure that all of the directories to a file have been constructed.
740 :    
741 :     # ^function surePathToTmpFile
742 :     # ^uses getCourseTempDirectory
743 :     # ^uses createDirectory
744 :    
745 :    
746 :     sub surePathToTmpFile {
747 :     # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/
748 :     # the input path must be either the full path, or the path relative to this tmp sub directory
749 :    
750 :     my $self = shift;
751 :     my $path = shift;
752 :     my $delim = "/";
753 :     my $tmpDirectory = $self->tempDirectory();
754 : gage 6261 #warn "\nTMP tmpDirectory $tmpDirectory";
755 : gage 6249 unless ( -e $tmpDirectory) { # if by some unlucky chance the tmpDirectory hasn't been created, create it.
756 :     my $parentDirectory = $tmpDirectory;
757 :     $parentDirectory =~s|/$||; # remove a trailing /
758 :     $parentDirectory =~s|/\w*$||; # remove last node
759 :     my ($perms, $groupID) = (stat $parentDirectory)[2,5];
760 : gage 6261 #FIXME where is the parentDirectory defined??
761 :     #warn "Creating tmp directory at $tmpDirectory, perms $perms groupID $groupID";
762 :     $self->createDirectory($tmpDirectory, $perms, $groupID)
763 :     or warn "Failed to create parent tmp directory at $path";
764 : gage 6249
765 :     }
766 :     # use the permissions/group on the temp directory itself as a template
767 :     my ($perms, $groupID) = (stat $tmpDirectory)[2,5];
768 : gage 6261 #warn "&urePathToTmpFile: directory=$tmpDirectory, perms=$perms, groupID=$groupID\n";
769 : gage 6249
770 :     # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment
771 :     $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|;
772 : gage 6261 #$path = $self->convertPath($path);
773 : gage 6249
774 :     # find the nodes on the given path
775 :     my @nodes = split("$delim",$path);
776 :    
777 :     # create new path
778 :     $path = $tmpDirectory; #convertPath("$tmpDirectory");
779 :    
780 :     while (@nodes>1) {
781 :     $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
782 : gage 6261 #warn "\PATH is now $path";
783 : gage 6249 unless (-e $path) {
784 :     #system("mkdir $path");
785 :     #createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID)
786 : gage 6261 #warn "PATH $path perms $perms groupID $groupID";
787 :     $self->createDirectory($path, $perms, $groupID)
788 :     or warn "Failed to create directory at $path with permissions $perms and groupID $groupID";
789 : gage 6249 }
790 :    
791 :     }
792 :    
793 :     $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
794 :     #system(qq!echo "" > $path! );
795 :     return $path;
796 :     }
797 :    
798 :    
799 :     1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9