[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 6817 - (download) (as text) (annotate)
Fri May 20 02:22:16 2011 UTC (8 years, 8 months ago) by gage
File size: 26152 byte(s)
fix the coloring of matrices.  Still not completely satisfactory since only the
first element in a matrix or vector is colored.  Required that we replace the colons
in the labels with - since apparently colons are not allowed in css ids. (they worked
for HTML but not for this.)


    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       # this error message is correct but misleading for the original way
  516       # in which matrix blanks and their response evaluators are matched up
  517       # we should restore the warning message once the new matrix evaluation method is in place
  518 
  519     }
  520     $label;
  521 }
  522 sub record_unlabeled_ans_name {
  523   my $self = shift;
  524     $self->{unlabeled_answer_blank_count}++;
  525     my $label = $self->new_label($self->{unlabeled_answer_blank_count});
  526     $self->record_ans_name($label);
  527     $label;
  528 }
  529 sub record_unlabeled_array_name {
  530   my $self = shift;
  531     $self->{unlabeled_answer_blank_count}++;
  532     my $ans_label = $self->new_array_label($self->{unlabeled_answer_blank_count});
  533     $self->record_array_name($ans_label);
  534 }
  535 sub store_persistent_data {  # will store strings only (so far)
  536   my $self = shift;
  537   my $label = shift;
  538   my @content = @_;
  539   $self->internal_debug_message("PGcore::store_persistent_data: storing $label in PERSISTENCE_HASH");
  540   if (defined($self->{PERSISTENCE_HASH}->{$label}) ) {
  541     warn "can' overwrite $label in persistent data";
  542   } else {
  543       $self->{PERSISTENCE_HASH}->{$label} = join("",@content);  #need base64 encoding?
  544     }
  545   $label;
  546 }
  547 sub check_answer_hash {
  548   my $self = shift;
  549   foreach my $key (keys %{ $self->{PG_ANSWERS_HASH} }) {
  550       my $ans_eval = $self->{PG_ANSWERS_HASH}->{$key}->{ans_eval};
  551     unless (ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ) {
  552       warn "The answer group labeled $key is missing an answer evaluator";
  553     }
  554     unless (ref( $self->{PG_ANSWERS_HASH}->{$key}->{response} ) =~ /PGresponsegroup/ ) {
  555       warn "The answer group labeled $key is missing answer blanks ";
  556     }
  557   }
  558 }
  559 
  560 sub PG_restricted_eval {
  561   my $self = shift;
  562   WeBWorK::PG::Translator::PG_restricted_eval(@_);
  563 }
  564 
  565 # sub AUTOLOAD {
  566 #   my $self = shift;
  567 #
  568 #   my $type = ref($self) or die "$self is not an object";
  569 #
  570 #   # $AUTOLOAD is sent in by Perl and is the full name of the object (i.e. main::blah::blah_more)
  571 #   my $name = $PGcore::AUTOLOAD;
  572 #   $name =~ s/.*://; #strips fully-qualified portion
  573 #
  574 #   unless ( exists $self->{'_permitted'}->{$name} ) { die "Can't find '$name' field in object of class '$type'";}
  575 #
  576 #   if (@_) {
  577 #     return $self->{$name} = shift; #set the variable to the first parameter
  578 #   } else {
  579 #     return $self->($name); #if no parameters just return the value
  580 #   }
  581 # }
  582 
  583 
  584 # Sometimes a question author needs to code or decode base64 directly
  585 sub decode_base64 ($) {
  586   my $self = shift;
  587   my $str = shift;
  588   MIME::Base64::decode_base64($str);
  589 }
  590 
  591 sub encode_base64 ($;$) {
  592   my $self = shift;
  593   my $str  = shift;
  594   my $option = shift;
  595   MIME::Base64::encode_base64($str);
  596 }
  597 sub debug_message {
  598     my $self = shift;
  599   my @str = @_;
  600   push @{$self->{flags}->{DEBUG_messages}}, @str;
  601 }
  602 sub get_debug_messages {
  603   my $self = shift;
  604   $self->{flags}->{DEBUG_messages};
  605 }
  606 sub warning_message {
  607     my $self = shift;
  608   my @str = @_;
  609   push @{$self->{flags}->{WARNING_messages}}, @str;
  610 }
  611 sub get_warning_messages {
  612   my $self = shift;
  613   $self->{flags}->{WARNING_messages};
  614 }
  615 
  616 sub internal_debug_message {
  617     my $self = shift;
  618   my @str = @_;
  619   push @{$internal_debug_messages}, @str;
  620 }
  621 sub get_internal_debug_messages {
  622   my $self = shift;
  623   $internal_debug_messages;
  624 }
  625 sub clear_internal_debug_messages {
  626   my $self = shift;
  627   $internal_debug_messages=[];
  628 }
  629 
  630 sub DESTROY {
  631   # doing nothing about destruction, hope that isn't dangerous
  632 }
  633 
  634 # sub WARN {
  635 #   warn(@_);
  636 # }
  637 
  638 
  639 # This creates on the fly graphs
  640 
  641 =head2 insertGraph
  642 
  643   # returns a path to the file containing the graph image.
  644   $filePath = insertGraph($graphObject);
  645 
  646 insertGraph writes a GIF or PNG image file to the gif subdirectory of the
  647 current course's HTML temp directory. The file name is obtained from the graph
  648 object. Warnings are issued if errors occur while writing to the file.
  649 
  650 Returns a string containing the full path to the temporary file containing the
  651 image. This is most often used in the construct
  652 
  653   TEXT(alias(insertGraph($graph)));
  654 
  655 where alias converts the directory address to a URL when serving HTML pages and
  656 insures that an EPS file is generated when creating TeX code for downloading.
  657 
  658 =cut
  659 
  660 # ^function insertGraph
  661 # ^uses $WWPlot::use_png
  662 # ^uses convertPath
  663 # ^uses surePathToTmpFile
  664 # ^uses PG_restricted_eval
  665 # ^uses $refreshCachedImages
  666 # ^uses $templateDirectory
  667 # ^uses %envir
  668 sub insertGraph {
  669   # Convert the image to GIF and print it on standard output
  670   my $self     = shift;
  671   my $graph    = shift;
  672   my $extension = ($WWPlot::use_png) ? '.png' : '.gif';
  673   my $fileName = $graph->imageName  . $extension;
  674   my $filePath = $self->convertPath("gif/$fileName");
  675   my $templateDirectory = $self->{envir}->{templateDirectory};
  676   $filePath = $self->surePathToTmpFile( $filePath );
  677   my $refreshCachedImages = $self->PG_restricted_eval(q!$refreshCachedImages!);
  678   # Check to see if we already have this graph, or if we have to make it
  679   if( not -e $filePath # does it exist?
  680     or ((stat "$templateDirectory"."$main::envir{fileName}")[9] > (stat $filePath)[9]) # source has changed
  681     or $graph->imageName =~ /Undefined_Set/ # problems from SetMaker and its ilk should always be redone
  682     or $refreshCachedImages
  683   ) {
  684     #createFile($filePath, $main::tmp_file_permission, $main::numericalGroupID);
  685     local(*OUTPUT);  # create local file handle so it won't overwrite other open files.
  686     open(OUTPUT, ">$filePath")||warn ("$0","Can't open $filePath<BR>","");
  687     chmod( 0777, $filePath);
  688     print OUTPUT $graph->draw|| warn("$0","Can't print graph to $filePath<BR>","");
  689     close(OUTPUT)||warn("$0","Can't close $filePath<BR>","");
  690   }
  691   $filePath;
  692 }
  693 
  694 =head1 Macros from IO.pm
  695 
  696     includePGtext
  697     read_whole_problem_file
  698     read_whole_file
  699     convertPath
  700     getDirDelim
  701     fileFromPath
  702     directoryFromPath
  703     createFile
  704     createDirectory
  705 
  706 =cut
  707 
  708 sub includePGtext {
  709   my $self = shift;
  710   WeBWorK::PG::IO::includePGtext(@_);
  711  };
  712 sub read_whole_problem_file {
  713   my $self = shift;
  714   WeBWorK::PG::IO::read_whole_problem_file(@_);
  715  };
  716 sub read_whole_file {
  717   my $self = shift;
  718   WeBWorK::PG::IO::read_whole_file(@_);
  719  };
  720 sub convertPath {
  721   my $self = shift;
  722   WeBWorK::PG::IO::convertPath(@_);
  723  };
  724 sub getDirDelim {
  725   my $self = shift;
  726   WeBWorK::PG::IO::getDirDelim(@_);
  727  };
  728 sub fileFromPath {
  729   my $self = shift;
  730   WeBWorK::PG::IO::fileFromPath(@_);
  731  };
  732 sub directoryFromPath {
  733   my $self = shift;
  734   WeBWorK::PG::IO::directoryFromPath(@_);
  735  };
  736 sub createFile {
  737   my $self = shift;
  738   WeBWorK::PG::IO::createFile(@_);
  739  };
  740 sub createDirectory {
  741   my $self = shift;
  742   WeBWorK::PG::IO::createDirectory(@_);
  743  };
  744 
  745 sub tempDirectory {
  746   my $self = shift;
  747   return $self->{tempDirectory};
  748 }
  749 
  750 
  751 =head2 surePathToTmpFile
  752 
  753   $path = surePathToTmpFile($path);
  754 
  755 Creates all of the intermediate directories between the tempDirectory
  756 
  757 If $path begins with the tempDirectory path, then the
  758 path is treated as absolute. Otherwise, the path is treated as relative the the
  759 course temp directory.
  760 
  761 =cut
  762 
  763 # A very useful macro for making sure that all of the directories to a file have been constructed.
  764 
  765 # ^function surePathToTmpFile
  766 # ^uses getCourseTempDirectory
  767 # ^uses createDirectory
  768 
  769 
  770 sub surePathToTmpFile {
  771   # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/
  772   # the input path must be either the full path, or the path relative to this tmp sub directory
  773 
  774   my $self = shift;
  775   my $path = shift;
  776   my $delim = "/";
  777   my $tmpDirectory = $self->tempDirectory();
  778 #warn "\nTMP tmpDirectory $tmpDirectory";
  779   unless ( -e $tmpDirectory) {   # if by some unlucky chance the tmpDirectory hasn't been created, create it.
  780       my $parentDirectory =  $tmpDirectory;
  781       $parentDirectory =~s|/$||;  # remove a trailing /
  782       $parentDirectory =~s|/\w*$||; # remove last node
  783       my ($perms, $groupID) = (stat $parentDirectory)[2,5];
  784       #FIXME  where is the parentDirectory defined??
  785 #warn "Creating tmp directory at $tmpDirectory, perms $perms groupID $groupID";
  786     $self->createDirectory($tmpDirectory, $perms, $groupID)
  787         or warn "Failed to create parent tmp directory at $path";
  788 
  789   }
  790   # use the permissions/group on the temp directory itself as a template
  791   my ($perms, $groupID) = (stat $tmpDirectory)[2,5];
  792 #warn "&urePathToTmpFile: directory=$tmpDirectory, perms=$perms, groupID=$groupID\n";
  793 
  794   # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment
  795   $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|;
  796   #$path = $self->convertPath($path);
  797 
  798   # find the nodes on the given path
  799         my @nodes = split("$delim",$path);
  800 
  801   # create new path
  802   $path = $tmpDirectory; #convertPath("$tmpDirectory");
  803 
  804   while (@nodes>1) {
  805     $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
  806 #warn "\PATH is now $path";
  807     unless (-e $path) {
  808       #system("mkdir $path");
  809       #createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID)
  810 #warn "PATH $path perms $perms groupID $groupID";
  811       $self->createDirectory($path, $perms, $groupID)
  812         or warn "Failed to create directory at $path with permissions $perms and groupID $groupID";
  813     }
  814 
  815   }
  816 
  817   $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
  818   #system(qq!echo "" > $path! );
  819   return $path;
  820 }
  821 
  822 
  823 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9