[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 6296 - (download) (as text) (annotate)
Mon Jun 21 20:51:40 2010 UTC (9 years, 7 months ago) by gage
File size: 25683 byte(s)
added decode_base64 and encode_base64 routines for use in WW questions

    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->WARN("<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 group
  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->WARN("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 
  604 sub internal_debug_message {
  605     my $self = shift;
  606   my @str = @_;
  607   push @{$internal_debug_messages}, @str;
  608 }
  609 sub get_internal_debug_messages {
  610   my $self = shift;
  611   $internal_debug_messages;
  612 }
  613 sub clear_internal_debug_messages {
  614   my $self = shift;
  615   $internal_debug_messages=[];
  616 }
  617 
  618 sub DESTROY {
  619   # doing nothing about destruction, hope that isn't dangerous
  620 }
  621 
  622 sub WARN {
  623   warn(@_);
  624 }
  625 
  626 
  627 # This creates on the fly graphs
  628 
  629 =head2 insertGraph
  630 
  631   # returns a path to the file containing the graph image.
  632   $filePath = insertGraph($graphObject);
  633 
  634 insertGraph writes a GIF or PNG image file to the gif subdirectory of the
  635 current course's HTML temp directory. The file name is obtained from the graph
  636 object. Warnings are issued if errors occur while writing to the file.
  637 
  638 Returns a string containing the full path to the temporary file containing the
  639 image. This is most often used in the construct
  640 
  641   TEXT(alias(insertGraph($graph)));
  642 
  643 where alias converts the directory address to a URL when serving HTML pages and
  644 insures that an EPS file is generated when creating TeX code for downloading.
  645 
  646 =cut
  647 
  648 # ^function insertGraph
  649 # ^uses $WWPlot::use_png
  650 # ^uses convertPath
  651 # ^uses surePathToTmpFile
  652 # ^uses PG_restricted_eval
  653 # ^uses $refreshCachedImages
  654 # ^uses $templateDirectory
  655 # ^uses %envir
  656 sub insertGraph {
  657   # Convert the image to GIF and print it on standard output
  658   my $self     = shift;
  659   my $graph    = shift;
  660   my $extension = ($WWPlot::use_png) ? '.png' : '.gif';
  661   my $fileName = $graph->imageName  . $extension;
  662   my $filePath = $self->convertPath("gif/$fileName");
  663   my $templateDirectory = $self->{envir}->{templateDirectory};
  664   $filePath = $self->surePathToTmpFile( $filePath );
  665   my $refreshCachedImages = $self->PG_restricted_eval(q!$refreshCachedImages!);
  666   # Check to see if we already have this graph, or if we have to make it
  667   if( not -e $filePath # does it exist?
  668     or ((stat "$templateDirectory"."$main::envir{fileName}")[9] > (stat $filePath)[9]) # source has changed
  669     or $graph->imageName =~ /Undefined_Set/ # problems from SetMaker and its ilk should always be redone
  670     or $refreshCachedImages
  671   ) {
  672     #createFile($filePath, $main::tmp_file_permission, $main::numericalGroupID);
  673     local(*OUTPUT);  # create local file handle so it won't overwrite other open files.
  674     open(OUTPUT, ">$filePath")||warn ("$0","Can't open $filePath<BR>","");
  675     chmod( 0777, $filePath);
  676     print OUTPUT $graph->draw|| warn("$0","Can't print graph to $filePath<BR>","");
  677     close(OUTPUT)||warn("$0","Can't close $filePath<BR>","");
  678   }
  679   $filePath;
  680 }
  681 
  682 =head1 Macros from IO.pm
  683 
  684     includePGtext
  685     read_whole_problem_file
  686     read_whole_file
  687     convertPath
  688     getDirDelim
  689     fileFromPath
  690     directoryFromPath
  691     createFile
  692     createDirectory
  693 
  694 =cut
  695 
  696 sub includePGtext {
  697   my $self = shift;
  698   WeBWorK::PG::IO::includePGtext(@_);
  699  };
  700 sub read_whole_problem_file {
  701   my $self = shift;
  702   WeBWorK::PG::IO::read_whole_problem_file(@_);
  703  };
  704 sub read_whole_file {
  705   my $self = shift;
  706   WeBWorK::PG::IO::read_whole_file(@_);
  707  };
  708 sub convertPath {
  709   my $self = shift;
  710   WeBWorK::PG::IO::convertPath(@_);
  711  };
  712 sub getDirDelim {
  713   my $self = shift;
  714   WeBWorK::PG::IO::getDirDelim(@_);
  715  };
  716 sub fileFromPath {
  717   my $self = shift;
  718   WeBWorK::PG::IO::fileFromPath(@_);
  719  };
  720 sub directoryFromPath {
  721   my $self = shift;
  722   WeBWorK::PG::IO::directoryFromPath(@_);
  723  };
  724 sub createFile {
  725   my $self = shift;
  726   WeBWorK::PG::IO::createFile(@_);
  727  };
  728 sub createDirectory {
  729   my $self = shift;
  730   WeBWorK::PG::IO::createDirectory(@_);
  731  };
  732 
  733 sub tempDirectory {
  734   my $self = shift;
  735   return $self->{tempDirectory};
  736 }
  737 
  738 
  739 =head2 surePathToTmpFile
  740 
  741   $path = surePathToTmpFile($path);
  742 
  743 Creates all of the intermediate directories between the tempDirectory
  744 
  745 If $path begins with the tempDirectory path, then the
  746 path is treated as absolute. Otherwise, the path is treated as relative the the
  747 course temp directory.
  748 
  749 =cut
  750 
  751 # A very useful macro for making sure that all of the directories to a file have been constructed.
  752 
  753 # ^function surePathToTmpFile
  754 # ^uses getCourseTempDirectory
  755 # ^uses createDirectory
  756 
  757 
  758 sub surePathToTmpFile {
  759   # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/
  760   # the input path must be either the full path, or the path relative to this tmp sub directory
  761 
  762   my $self = shift;
  763   my $path = shift;
  764   my $delim = "/";
  765   my $tmpDirectory = $self->tempDirectory();
  766 #warn "\nTMP tmpDirectory $tmpDirectory";
  767   unless ( -e $tmpDirectory) {   # if by some unlucky chance the tmpDirectory hasn't been created, create it.
  768       my $parentDirectory =  $tmpDirectory;
  769       $parentDirectory =~s|/$||;  # remove a trailing /
  770       $parentDirectory =~s|/\w*$||; # remove last node
  771       my ($perms, $groupID) = (stat $parentDirectory)[2,5];
  772       #FIXME  where is the parentDirectory defined??
  773 #warn "Creating tmp directory at $tmpDirectory, perms $perms groupID $groupID";
  774     $self->createDirectory($tmpDirectory, $perms, $groupID)
  775         or warn "Failed to create parent tmp directory at $path";
  776 
  777   }
  778   # use the permissions/group on the temp directory itself as a template
  779   my ($perms, $groupID) = (stat $tmpDirectory)[2,5];
  780 #warn "&urePathToTmpFile: directory=$tmpDirectory, perms=$perms, groupID=$groupID\n";
  781 
  782   # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment
  783   $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|;
  784   #$path = $self->convertPath($path);
  785 
  786   # find the nodes on the given path
  787         my @nodes = split("$delim",$path);
  788 
  789   # create new path
  790   $path = $tmpDirectory; #convertPath("$tmpDirectory");
  791 
  792   while (@nodes>1) {
  793     $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
  794 #warn "\PATH is now $path";
  795     unless (-e $path) {
  796       #system("mkdir $path");
  797       #createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID)
  798 #warn "PATH $path perms $perms groupID $groupID";
  799       $self->createDirectory($path, $perms, $groupID)
  800         or warn "Failed to create directory at $path with permissions $perms and groupID $groupID";
  801     }
  802 
  803   }
  804 
  805   $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
  806   #system(qq!echo "" > $path! );
  807   return $path;
  808 }
  809 
  810 
  811 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9