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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9