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