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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9