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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9