[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 6883 - (download) (as text) (annotate)
Thu Jun 23 01:19:10 2011 UTC (8 years, 7 months ago) by gage
File size: 27173 byte(s)
updated PG to allow material to be placed before the question main form



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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9