Parent Directory
| 
Revision Log
added includePGproblem to PG.pl changed comment in PGcore.pl
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: pg/lib/PGcore.pm,v 1.6 2010/05/25 22:47:52 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 'import'; 21 our @EXPORT_OK = qw(not_null pretty_print); 22 } 23 our $internal_debug_messages = []; 24 25 26 use PGanswergroup; 27 use PGresponsegroup; 28 use PGrandom; 29 use PGalias; 30 use PGloadfiles; 31 use WeBWorK::PG::IO(); # don't important any command directly 32 use Tie::IxHash; 33 use MIME::Base64; 34 ################################## 35 # Utility macro 36 ################################## 37 38 =head2 Utility Macros 39 40 41 =head4 not_null 42 43 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 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 =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/</</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>=></td><td> ".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/</</g; # protect for HTML output 108 } 109 $out; 110 } 111 ################################## 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 # PG_ANSWERS => [], # holds answers with labels # deprecated 125 # PG_UNLABELED_ANSWERS => [], # holds unlabeled ans. #deprecated -replaced by PG_ANSWERS_HASH 126 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 QUIZ_PREFIX => $envir->{QUIZ_PREFIX}, 137 SECTION_PREFIX => '', # might be used for sequential (compound) questions? 138 139 PG_ACTIVE => 1, # toggle to zero to stop processing 140 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 $self->{flags} = { 174 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 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 323 } 324 =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 #$label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label); 356 my $ans_eval = shift @in; 357 $self->warning_message("<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 #$self->internal_debug_message("PGcore::record_ans_name: $label $value"); 473 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 name 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->warning_message("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 $self->internal_debug_message("PGcore::store_persistent_data: storing $label in PERSISTENCE_HASH"); 537 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 581 # Sometimes a question author needs to code or decode base64 directly 582 sub decode_base64 ($) { 583 my $self = shift; 584 my $str = shift; 585 MIME::Base64::decode_base64($str); 586 } 587 588 sub encode_base64 ($;$) { 589 my $self = shift; 590 my $str = shift; 591 my $option = shift; 592 MIME::Base64::encode_base64($str); 593 } 594 sub debug_message { 595 my $self = shift; 596 my @str = @_; 597 push @{$self->{flags}->{DEBUG_messages}}, @str; 598 } 599 sub get_debug_messages { 600 my $self = shift; 601 $self->{flags}->{DEBUG_messages}; 602 } 603 sub warning_message { 604 my $self = shift; 605 my @str = @_; 606 push @{$self->{flags}->{WARNING_messages}}, @str; 607 } 608 sub get_warning_messages { 609 my $self = shift; 610 $self->{flags}->{WARNING_messages}; 611 } 612 613 sub internal_debug_message { 614 my $self = shift; 615 my @str = @_; 616 push @{$internal_debug_messages}, @str; 617 } 618 sub get_internal_debug_messages { 619 my $self = shift; 620 $internal_debug_messages; 621 } 622 sub clear_internal_debug_messages { 623 my $self = shift; 624 $internal_debug_messages=[]; 625 } 626 627 sub DESTROY { 628 # doing nothing about destruction, hope that isn't dangerous 629 } 630 631 # sub WARN { 632 # warn(@_); 633 # } 634 635 636 # This creates on the fly graphs 637 638 =head2 insertGraph 639 640 # returns a path to the file containing the graph image. 641 $filePath = insertGraph($graphObject); 642 643 insertGraph writes a GIF or PNG image file to the gif subdirectory of the 644 current course's HTML temp directory. The file name is obtained from the graph 645 object. Warnings are issued if errors occur while writing to the file. 646 647 Returns a string containing the full path to the temporary file containing the 648 image. This is most often used in the construct 649 650 TEXT(alias(insertGraph($graph))); 651 652 where alias converts the directory address to a URL when serving HTML pages and 653 insures that an EPS file is generated when creating TeX code for downloading. 654 655 =cut 656 657 # ^function insertGraph 658 # ^uses $WWPlot::use_png 659 # ^uses convertPath 660 # ^uses surePathToTmpFile 661 # ^uses PG_restricted_eval 662 # ^uses $refreshCachedImages 663 # ^uses $templateDirectory 664 # ^uses %envir 665 sub insertGraph { 666 # Convert the image to GIF and print it on standard output 667 my $self = shift; 668 my $graph = shift; 669 my $extension = ($WWPlot::use_png) ? '.png' : '.gif'; 670 my $fileName = $graph->imageName . $extension; 671 my $filePath = $self->convertPath("gif/$fileName"); 672 my $templateDirectory = $self->{envir}->{templateDirectory}; 673 $filePath = $self->surePathToTmpFile( $filePath ); 674 my $refreshCachedImages = $self->PG_restricted_eval(q!$refreshCachedImages!); 675 # Check to see if we already have this graph, or if we have to make it 676 if( not -e $filePath # does it exist? 677 or ((stat "$templateDirectory"."$main::envir{fileName}")[9] > (stat $filePath)[9]) # source has changed 678 or $graph->imageName =~ /Undefined_Set/ # problems from SetMaker and its ilk should always be redone 679 or $refreshCachedImages 680 ) { 681 #createFile($filePath, $main::tmp_file_permission, $main::numericalGroupID); 682 local(*OUTPUT); # create local file handle so it won't overwrite other open files. 683 open(OUTPUT, ">$filePath")||warn ("$0","Can't open $filePath<BR>",""); 684 chmod( 0777, $filePath); 685 print OUTPUT $graph->draw|| warn("$0","Can't print graph to $filePath<BR>",""); 686 close(OUTPUT)||warn("$0","Can't close $filePath<BR>",""); 687 } 688 $filePath; 689 } 690 691 =head1 Macros from IO.pm 692 693 includePGtext 694 read_whole_problem_file 695 read_whole_file 696 convertPath 697 getDirDelim 698 fileFromPath 699 directoryFromPath 700 createFile 701 createDirectory 702 703 =cut 704 705 sub includePGtext { 706 my $self = shift; 707 WeBWorK::PG::IO::includePGtext(@_); 708 }; 709 sub read_whole_problem_file { 710 my $self = shift; 711 WeBWorK::PG::IO::read_whole_problem_file(@_); 712 }; 713 sub read_whole_file { 714 my $self = shift; 715 WeBWorK::PG::IO::read_whole_file(@_); 716 }; 717 sub convertPath { 718 my $self = shift; 719 WeBWorK::PG::IO::convertPath(@_); 720 }; 721 sub getDirDelim { 722 my $self = shift; 723 WeBWorK::PG::IO::getDirDelim(@_); 724 }; 725 sub fileFromPath { 726 my $self = shift; 727 WeBWorK::PG::IO::fileFromPath(@_); 728 }; 729 sub directoryFromPath { 730 my $self = shift; 731 WeBWorK::PG::IO::directoryFromPath(@_); 732 }; 733 sub createFile { 734 my $self = shift; 735 WeBWorK::PG::IO::createFile(@_); 736 }; 737 sub createDirectory { 738 my $self = shift; 739 WeBWorK::PG::IO::createDirectory(@_); 740 }; 741 742 sub tempDirectory { 743 my $self = shift; 744 return $self->{tempDirectory}; 745 } 746 747 748 =head2 surePathToTmpFile 749 750 $path = surePathToTmpFile($path); 751 752 Creates all of the intermediate directories between the tempDirectory 753 754 If $path begins with the tempDirectory path, then the 755 path is treated as absolute. Otherwise, the path is treated as relative the the 756 course temp directory. 757 758 =cut 759 760 # A very useful macro for making sure that all of the directories to a file have been constructed. 761 762 # ^function surePathToTmpFile 763 # ^uses getCourseTempDirectory 764 # ^uses createDirectory 765 766 767 sub surePathToTmpFile { 768 # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/ 769 # the input path must be either the full path, or the path relative to this tmp sub directory 770 771 my $self = shift; 772 my $path = shift; 773 my $delim = "/"; 774 my $tmpDirectory = $self->tempDirectory(); 775 #warn "\nTMP tmpDirectory $tmpDirectory"; 776 unless ( -e $tmpDirectory) { # if by some unlucky chance the tmpDirectory hasn't been created, create it. 777 my $parentDirectory = $tmpDirectory; 778 $parentDirectory =~s|/$||; # remove a trailing / 779 $parentDirectory =~s|/\w*$||; # remove last node 780 my ($perms, $groupID) = (stat $parentDirectory)[2,5]; 781 #FIXME where is the parentDirectory defined?? 782 #warn "Creating tmp directory at $tmpDirectory, perms $perms groupID $groupID"; 783 $self->createDirectory($tmpDirectory, $perms, $groupID) 784 or warn "Failed to create parent tmp directory at $path"; 785 786 } 787 # use the permissions/group on the temp directory itself as a template 788 my ($perms, $groupID) = (stat $tmpDirectory)[2,5]; 789 #warn "&urePathToTmpFile: directory=$tmpDirectory, perms=$perms, groupID=$groupID\n"; 790 791 # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment 792 $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|; 793 #$path = $self->convertPath($path); 794 795 # find the nodes on the given path 796 my @nodes = split("$delim",$path); 797 798 # create new path 799 $path = $tmpDirectory; #convertPath("$tmpDirectory"); 800 801 while (@nodes>1) { 802 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/"); 803 #warn "\PATH is now $path"; 804 unless (-e $path) { 805 #system("mkdir $path"); 806 #createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID) 807 #warn "PATH $path perms $perms groupID $groupID"; 808 $self->createDirectory($path, $perms, $groupID) 809 or warn "Failed to create directory at $path with permissions $perms and groupID $groupID"; 810 } 811 812 } 813 814 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 815 #system(qq!echo "" > $path! ); 816 return $path; 817 } 818 819 820 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |