[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 6851 - (download) (as text) (annotate)
Sat Jun 11 17:17:39 2011 UTC (8 years, 5 months ago) by gage
File size: 26927 byte(s)
?	added some warning messages to Course Admin if permissions on DATA, log and html directories are not set correctly.
?	added refreshEquations(1) to PG to force all equation images to be recalculated.

?added AddToTexPreamble($str ) to PG  to allow short macro definitions such as    \newcommand{\myVec}[#1]{\vec{#1}}
	?	this works in images mode and in hardcopy mode.  It does not work in jsMath mode (but fails gracefully).  MathJax also fails, not quite so gracefully.


Added some additional POD documentation


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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9