[system] / trunk / pg / lib / PGcore.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/PGcore.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6397 - (download) (as text) (annotate)
Wed Aug 25 17:27:12 2010 UTC (9 years, 6 months ago) by gage
File size: 25907 byte(s)
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/</&lt;/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>=&gt;</td><td>&nbsp;".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/</&lt;/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