[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 6249 - (download) (as text) (annotate)
Fri May 14 11:39:02 2010 UTC (9 years, 8 months ago) by gage
File size: 22888 byte(s)
major update which adds objective methods to the basic code of PG.
HEAD should be considered more beta than usual for a few days until minor glitches
are shaken out.
new modules needed:

PGcore PGalias PGresource PGloadfiles PGanswergroup PGresponsegroup  Tie::IxHash

    1 ################################################################################
    2 # WeBWorK Online Homework Delivery System
    3 # Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/
    4 # $CVSHeader: pg/macros/PG.pl,v 1.40 2009/06/25 23:28:44 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;
   21   our @EXPORT_OK = qw( not_null);
   22 }
   23 our $internal_debug_messages = [];
   24 
   25 use PGanswergroup;
   26 use PGresponsegroup;
   27 use PGrandom;
   28 use PGalias;
   29 use PGloadfiles;
   30 use WeBWorK::PG::IO;
   31 use Tie::IxHash;
   32 
   33 ##################################
   34 # Utility macro
   35 ##################################
   36 
   37 sub not_null {        # empty arrays, empty hashes and strings containing only whitespace are all NULL
   38     my $item = shift;
   39   return 0 unless defined($item);
   40   if (ref($item)=~/ARRAY/) {
   41     return scalar(@{$item});     # return the length
   42   } elsif (ref($item)=~/HASH/) {
   43       return scalar( keys %{$item});
   44   } else {   # string case return 1 if none empty
   45     return ($item =~ /\S/)? 1:0;
   46   }
   47 }
   48 
   49 ##################################
   50 # PGcore object
   51 ##################################
   52 
   53 sub new {
   54   my $class = shift;
   55   my $envir = shift;  #pointer to environment hash
   56   warn "PGcore must be called with an environment" unless ref($envir) eq 'HASH';
   57   #warn "creating a new PGcore object";
   58   my %options = @_;
   59   my $self = {
   60     OUTPUT_ARRAY              => [],          # holds output body text
   61     HEADER_ARRAY              => [],         # holds output for the header text
   62 #   PG_ANSWERS                => [],  # holds answers with labels
   63 #   PG_UNLABELED_ANSWERS      => [],  # holds
   64     PG_ANSWERS_HASH           => {},  # holds label=>answer pairs
   65     PERSISTENCE_HASH           => {}, # holds other data, besides answers, which persists during a session and beyond
   66 #   PG_persistence_hash       => {},  # stores information (other than answers) from one session to another
   67     answer_eval_count         => 0,
   68     answer_blank_count        => 0,
   69     unlabeled_answer_blank_count =>0,
   70     unlabeled_answer_eval_count  => 0,
   71     KEPT_EXTRA_ANSWERS        => [],
   72     ANSWER_PREFIX             => 'AnSwEr',
   73     ARRAY_PREFIX              => 'ArRaY',
   74     vec_num                   => 0,     # for distinguishing matrices
   75     QUIZ_PREFIX               => '',
   76     SECTION_PREFIX            => '',  # might be used for sequential (compound) questions?
   77 
   78     PG_ACTIVE                 => 1,   # turn to zero to stop processing
   79     submittedAnswers          => 0,   # have any answers been submitted? is this the first time this session?
   80     PG_session_persistence_hash =>{}, # stores data from one invoction of the session to the next.
   81     PG_original_problem_seed  => 0,
   82     PG_random_generator     => undef,
   83     PG_alias                  => undef,
   84     PG_problem_grader         => undef,
   85     displayMode               => undef,
   86     envir                     => $envir,
   87     gifs_created              => {},
   88     external_refs             => {},      # record of external references
   89     %options,                                   # allows overrides and initialization
   90   };
   91   bless $self, $class;
   92   tie %{$self->{PG_ANSWERS_HASH}}, "Tie::IxHash";  # creates a Hash with order
   93   $self->initialize;
   94   return $self;
   95 }
   96 
   97 sub initialize {
   98   my $self = shift;
   99   warn "environment is not defined in PGcore" unless ref($self->{envir}) eq 'HASH';
  100 
  101 
  102 
  103 
  104   $self->{displayMode}                = $self->{envir}->{displayMode};
  105   $self->{PG_original_problem_seed}   = $self->{envir}->{problemSeed};
  106   $self->{PG_random_generator}        = new PGrandom( $self->{PG_original_problem_seed});
  107 
  108     $self->{tempDirectory}              = $self->{envir}->{tempDirectory};
  109   $self->{PG_problem_grader}    = $self->{envir}->{PROBLEM_GRADER_TO_USE};
  110     $self->{PG_alias}             = new PGalias($self->{envir});
  111     $self->{PG_loadMacros}        = new PGloadfiles($self->{envir});
  112   $self->{PG_FLAGS} = {
  113     showpartialCorrectAnswers => 1,
  114     showHint                  => 1,
  115     hintExists          => 0,
  116     showHintLimit             => 0,
  117     solutionExists            => 0,
  118     WARNING_messages          => [],
  119     DEBUG_messages            => [],
  120     recordSubmittedAnswers    => 1,
  121     refreshCAchedImages       => 0,
  122 #   ANSWER_ENTRY_ORDER        => [],  # may not be needed if we ue Tie:IxHash
  123     comment                   => '',  # implement as array?
  124 
  125 
  126 
  127   };
  128 
  129 }
  130 
  131 
  132 ####################################################################
  133 
  134 =head1 DESCRIPTION
  135 
  136 This file provides the fundamental macros that define the PG language. It
  137 maintains a problem's text, header text, and answers:
  138 
  139 =over
  140 
  141 =item *
  142 
  143 Problem text: The text to appear in the body of the problem. See TEXT()
  144 below.
  145 
  146 =item *
  147 
  148 Header text: When a problem is processed in an HTML-based display mode,
  149 this variable can contain text that the caller should place in the HEAD of the
  150 resulting HTML page. See HEADER_TEXT() below.
  151 
  152 =item *
  153 
  154 Implicitly-labeled answers: Answers that have not been explicitly
  155 assigned names, and are associated with their answer blanks by the order in
  156 which they appear in the problem. These types of answers are designated using
  157 the ANS() macro.
  158 
  159 =item *
  160 
  161 Explicitly-labeled answers: Answers that have been explicitly assigned
  162 names with the LABELED_ANS() macro, or a macro that uses it. An explicitly-
  163 labeled answer is associated with its answer blank by name.
  164 
  165 =item *
  166 
  167 "Extra" answers: Names of answer blanks that do not have a 1-to-1
  168 correspondance to an answer evaluator. For example, in matrix problems, there
  169 will be several input fields that correspond to the same answer evaluator.
  170 
  171 =back
  172 
  173 =head1 USAGE
  174 
  175 This file is automatically loaded into the namespace of every PG problem. The
  176 macros within can then be called to define the structure of the problem.
  177 
  178 DOCUMENT() should be the first executable statement in any problem. It
  179 initializes vriables and defines the problem environment.
  180 
  181 ENDDOCUMENT() must be the last executable statement in any problem. It packs
  182 up the results of problem processing for delivery back to WeBWorK.
  183 
  184 The HEADER_TEXT(), TEXT(), and ANS() macros add to the header text string,
  185 body text string, and answer evaluator queue, respectively.
  186 
  187 =cut
  188 
  189 
  190 =item HEADER_TEXT()
  191 
  192  HEADER_TEXT("string1", "string2", "string3");
  193 
  194 HEADER_TEXT() concatenates its arguments and appends them to the stored header
  195 text string. It can be used more than once in a file.
  196 
  197 The macro is used for material which is destined to be placed in the HEAD of
  198 the page when in HTML mode, such as JavaScript code.
  199 
  200 Spaces are placed between the arguments during concatenation, but no spaces are
  201 introduced between the existing content of the header text string and the new
  202 content being appended.
  203 
  204 =cut
  205 
  206 # ^function HEADER_TEXT
  207 # ^uses $STRINGforHEADER_TEXT
  208 sub HEADER_TEXT {
  209   my $self = shift;
  210   push @{$self->{HEADER_ARRAY}}, map { (defined($_) )?$_:'' } @_;
  211   $self->{HEADER_ARRAY}  ;
  212 }
  213 
  214 =item TEXT()
  215 
  216  TEXT("string1", "string2", "string3");
  217 
  218 TEXT() concatenates its arguments and appends them to the stored problem text
  219 string. It is used to define the text which will appear in the body of the
  220 problem. It can be used more than once in a file.
  221 
  222 This macro has no effect if rendering has been stopped with the STOP_RENDERING()
  223 macro.
  224 
  225 This macro defines text which will appear in the problem. All text must be
  226 passed to this macro, passed to another macro that calls this macro, or included
  227 in a BEGIN_TEXT/END_TEXT block, which uses this macro internally. No other
  228 statements in a PG file will directly appear in the output. Think of this as the
  229 "print" function for the PG language.
  230 
  231 Spaces are placed between the arguments during concatenation, but no spaces are
  232 introduced between the existing content of the header text string and the new
  233 content being appended.
  234 
  235 =cut
  236 
  237 # ^function TEXT
  238 # ^uses $PG_STOP_FLAG
  239 # ^uses $STRINGforOUTPUT
  240 
  241 sub TEXT {
  242   my $self = shift;    #FIXME  filter for undefined entries replace by "";
  243   push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ;
  244   $self->{OUTPUT_ARRAY};
  245 }
  246 
  247 
  248 =item LABELED_ANS()
  249 
  250  TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2"));
  251  LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2);
  252 
  253 Adds the answer evaluators listed to the list of labeled answer evaluators.
  254 They will be paired with labeled answer rules (a.k.a. answer blanks) in the
  255 order entered. This allows pairing of answer evaluators and answer rules that
  256 may not have been entered in the same order.
  257 
  258 =cut
  259 
  260 # ^function NAMED_ANS
  261 # ^uses &LABELED_ANS
  262 sub NAMED_ANS {
  263   &LABELED_ANS;
  264 }
  265 
  266 =item NAMED_ANS()
  267 
  268 Old name for LABELED_ANS(). DEPRECATED.
  269 
  270 =cut
  271 
  272 # ^function NAMED_ANS
  273 # ^uses $PG_STOP_FLAG
  274 sub LABELED_ANS{
  275   my $self = shift;
  276   my @in = @_;
  277   while (@in ) {
  278     my $label    = shift @in;
  279     $label       = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label);
  280     my $ans_eval = shift @in;
  281     $self->WARN("<BR><B>Error in LABELED_ANS:|$label|</B>
  282           -- inputs must be references to AnswerEvaluator objects or subroutines<BR>")
  283       unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/  ;
  284   if (defined($self->{PG_ANSWERS_HASH}->{$label})  ){
  285     $self->{PG_ANSWERS_HASH}->{$label}->insert(ans_label => $label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE});
  286   } else {
  287       $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE});
  288     }
  289     $self->{answer_eval_count}++;
  290   }
  291   $self->{PG_ANSWERS_HASH};
  292 }
  293 
  294 
  295 =item ANS()
  296 
  297  TEXT(ans_rule(), ans_rule(), ans_rule());
  298  ANS($answer_evaluator1, $answer_evaluator2, $answer_evaluator3);
  299 
  300 Adds the answer evaluators listed to the list of unlabeled answer evaluators.
  301 They will be paired with unlabeled answer rules (a.k.a. answer blanks) in the
  302 order entered. This is the standard method for entering answers.
  303 
  304 In the above example, answer_evaluator1 will be associated with the first
  305 answer rule, answer_evaluator2 with the second, and answer_evaluator3 with the
  306 third. In practice, the arguments to ANS() will usually be calls to an answer
  307 evaluator generator such as the cmp() method of MathObjects or the num_cmp()
  308 macro in L<PGanswermacros.pl>.
  309 
  310 =cut
  311 
  312 # ^function ANS
  313 # ^uses $PG_STOP_FLAG
  314 # ^uses @PG_ANSWERS
  315 
  316 sub ANS{
  317   my $self = shift;
  318   my @in = @_;
  319   while (@in ) {
  320          # create new label
  321          $self->{unlabeled_answer_eval_count}++;
  322          my $label = $self->new_label($self->{unlabeled_answer_eval_count});
  323          my $evaluator = shift @in;
  324      $self->LABELED_ANS($label, $evaluator);
  325   }
  326   $self->{PG_ANSWERS_HASH};
  327 }
  328 
  329 
  330 
  331 
  332 =item STOP_RENDERING()
  333 
  334  STOP_RENDERING() unless all_answers_are_correct();
  335 
  336 Temporarily suspends accumulation of problem text and storing of answer blanks
  337 and answer evaluators until RESUME_RENDERING() is called.
  338 
  339 =cut
  340 
  341 # ^function STOP_RENDERING
  342 # ^uses $PG_STOP_FLAG
  343 sub STOP_RENDERING {
  344   my $self = shift;
  345   $self->{PG_ACTIVE}=0;
  346   "";
  347 }
  348 
  349 =item RESUME_RENDERING()
  350 
  351  RESUME_RENDERING();
  352 
  353 Resumes accumulating problem text and storing answer blanks and answer
  354 evaluators. Reverses the effect of STOP_RENDERING().
  355 
  356 =cut
  357 
  358 # ^function RESUME_RENDERING
  359 # ^uses $PG_STOP_FLAG
  360 sub RESUME_RENDERING {
  361   my $self = shift;
  362   $self->{PG_ACTIVE}=1;
  363   "";
  364 }
  365 ########
  366 # Internal methods
  367 #########
  368 sub new_label {     #creates a new label for unlabeled submissions ASNWER_PREFIX.$number
  369   my $self         = shift;
  370   my $number       = shift;
  371   $self->{QUIZ_PREFIX}.$self->{ANSWER_PREFIX}.sprintf("%04u", $number);
  372 }
  373 sub new_array_label {     #creates a new label for unlabeled submissions ASNWER_PREFIX.$number
  374   my $self         = shift;
  375   my $number       = shift;
  376   $self->{QUIZ_PREFIX}.$self->{ARRAY_PREFIX}.sprintf("%04u", $number);
  377 }
  378 sub new_array_element_label {     #creates a new label for unlabeled submissions ARRAY_PREFIX.$number
  379   my $self              = shift;
  380   my $ans_label         = shift;  # name of the PGanswer group holding this array
  381   my $row_num           = shift;
  382   my $col_num           = shift;
  383   my %options           = @_;
  384   my $vec_num           = (defined $options{vec_num})?$options{vec_num}: 0 ;
  385   $self->{QUIZ_PREFIX}.$ans_label.'__'.$vec_num.':'.$row_num.':'.$col_num.'__';
  386 }
  387 sub new_answer_name  {     # bit of a legacy item
  388   &new_label;
  389 }
  390 
  391 
  392 sub record_ans_name {      # the labels in the PGanswer group and response group should match in this case
  393   my $self = shift;
  394   my $label = shift;
  395   my $value = shift;
  396   $self->internal_debug_message("record_ans_name $label $value");
  397   my $response_group = new PGresponsegroup($label,$label,$value);
  398   if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
  399     $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
  400                                                response  => $response_group,
  401                                                active    => $self->{PG_ACTIVE});
  402   } else {
  403       $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label,
  404                                                  response  => $response_group,
  405                                                  active    => $self->{PG_ACTIVE});
  406     }
  407     $self->{answer_blank_count}++;
  408   $label;
  409 }
  410 
  411 sub record_array_name {  # currently the same as record ans group
  412   my $self = shift;
  413   my $label = shift;
  414   my $value = shift;
  415   my $response_group = new PGresponsegroup($label,$label,$value);
  416   if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
  417     $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
  418                                                response   => $response_group,
  419                                                active     => $self->{PG_ACTIVE});
  420   } else {
  421       $self->{PG_ANSWERS_HASH}->{$label} = PGanswergroup->new($label,
  422                                                  response   => $response_group,
  423                                                  active     => $self->{PG_ACTIVE});
  424     }
  425     $self->{answer_blank_count}++;
  426     #$self->{PG_ANSWERS_HASH}->{$label}->{response}->clear;  #why is this ?
  427   $label;
  428 
  429 }
  430 sub extend_ans_group {         # modifies the group type
  431   my $self = shift;
  432   my $label = shift;
  433   my @response_list = @_;
  434   my $answer_group  = $self->{PG_ANSWERS_HASH}->{$label};
  435   if (ref($answer_group) =~/PGanswergroup/) {
  436       $answer_group->append_responses(@response_list);
  437     } else {
  438       $self->WARN("The answer |$label| has not yet been defined, you cannot extend it.",caller() );
  439 
  440     }
  441     $label;
  442 }
  443 sub record_unlabeled_ans_name {
  444   my $self = shift;
  445     $self->{unlabeled_answer_blank_count}++;
  446     my $label = $self->new_label($self->{unlabeled_answer_blank_count});
  447     $self->record_ans_name($label);
  448     $label;
  449 }
  450 sub record_unlabeled_array_name {
  451   my $self = shift;
  452     $self->{unlabeled_answer_blank_count}++;
  453     my $ans_label = $self->new_array_label($self->{unlabeled_answer_blank_count});
  454     $self->record_array_name($ans_label);
  455 }
  456 sub store_persistent_data {  # will store strings only (so far)
  457   my $self = shift;
  458   my $label = shift;
  459   my @content = @_;
  460   $self->internal_debug_message("storing $label in PERSISTENCE_HASH");
  461   if (defined($self->{PERSISTENCE_HASH}->{$label}) ) {
  462     warn "can' overwrite $label in persistent data";
  463   } else {
  464       $self->{PERSISTENCE_HASH}->{$label} = join("",@content);  #need base64 encoding?
  465     }
  466   $label;
  467 }
  468 sub check_answer_hash {
  469   my $self = shift;
  470   foreach my $key (keys %{ $self->{PG_ANSWERS_HASH} }) {
  471       my $ans_eval = $self->{PG_ANSWERS_HASH}->{$key}->{ans_eval};
  472     unless (ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ) {
  473       warn "The answer group labeled $key is missing an answer evaluator";
  474     }
  475     unless (ref( $self->{PG_ANSWERS_HASH}->{$key}->{response} ) =~ /PGresponsegroup/ ) {
  476       warn "The answer group labeled $key is missing answer blanks ";
  477     }
  478   }
  479 }
  480 
  481 sub PG_restricted_eval {
  482   my $self = shift;
  483   WeBWorK::PG::Translator::PG_restricted_eval(@_);
  484 }
  485 
  486 # sub AUTOLOAD {
  487 #   my $self = shift;
  488 #
  489 #   my $type = ref($self) or die "$self is not an object";
  490 #
  491 #   # $AUTOLOAD is sent in by Perl and is the full name of the object (i.e. main::blah::blah_more)
  492 #   my $name = $PGcore::AUTOLOAD;
  493 #   $name =~ s/.*://; #strips fully-qualified portion
  494 #
  495 #   unless ( exists $self->{'_permitted'}->{$name} ) { die "Can't find '$name' field in object of class '$type'";}
  496 #
  497 #   if (@_) {
  498 #     return $self->{$name} = shift; #set the variable to the first parameter
  499 #   } else {
  500 #     return $self->($name); #if no parameters just return the value
  501 #   }
  502 # }
  503 
  504 sub append_debug_message {
  505     my $self = shift;
  506   my @str = @_;
  507   push @{$self->{DEBUG_messages}}, @str;
  508 }
  509 sub get_debug_messages {
  510   my $self = shift;
  511   $self->{DEBUG_messages};
  512 }
  513 sub DESTROY {
  514   # doing nothing about destruction, hope that isn't dangerous
  515 }
  516 
  517 sub WARN {
  518   warn(@_);
  519 }
  520 
  521 
  522 # This creates on the fly graphs
  523 
  524 =head2 insertGraph
  525 
  526   # returns a path to the file containing the graph image.
  527   $filePath = insertGraph($graphObject);
  528 
  529 insertGraph writes a GIF or PNG image file to the gif subdirectory of the
  530 current course's HTML temp directory. The file name is obtained from the graph
  531 object. Warnings are issued if errors occur while writing to the file.
  532 
  533 Returns a string containing the full path to the temporary file containing the
  534 image. This is most often used in the construct
  535 
  536   TEXT(alias(insertGraph($graph)));
  537 
  538 where alias converts the directory address to a URL when serving HTML pages and
  539 insures that an EPS file is generated when creating TeX code for downloading.
  540 
  541 =cut
  542 
  543 # ^function insertGraph
  544 # ^uses $WWPlot::use_png
  545 # ^uses convertPath
  546 # ^uses surePathToTmpFile
  547 # ^uses PG_restricted_eval
  548 # ^uses $refreshCachedImages
  549 # ^uses $templateDirectory
  550 # ^uses %envir
  551 sub insertGraph {
  552   # Convert the image to GIF and print it on standard output
  553   my $self     = shift;
  554   my $graph    = shift;
  555   my $extension = ($WWPlot::use_png) ? '.png' : '.gif';
  556   my $fileName = $graph->imageName  . $extension;
  557   my $filePath = $self->convertPath("gif/$fileName");
  558   my $templateDirectory = $self->{envir}->{templateDirectory};
  559   $filePath = $self->surePathToTmpFile( $filePath );
  560   my $refreshCachedImages = $self->PG_restricted_eval(q!$refreshCachedImages!);
  561   # Check to see if we already have this graph, or if we have to make it
  562   if( not -e $filePath # does it exist?
  563     or ((stat "$templateDirectory"."$main::envir{fileName}")[9] > (stat $filePath)[9]) # source has changed
  564     or $graph->imageName =~ /Undefined_Set/ # problems from SetMaker and its ilk should always be redone
  565     or $refreshCachedImages
  566   ) {
  567     #createFile($filePath, $main::tmp_file_permission, $main::numericalGroupID);
  568     local(*OUTPUT);  # create local file handle so it won't overwrite other open files.
  569     open(OUTPUT, ">$filePath")||warn ("$0","Can't open $filePath<BR>","");
  570     chmod( 0777, $filePath);
  571     print OUTPUT $graph->draw|| warn("$0","Can't print graph to $filePath<BR>","");
  572     close(OUTPUT)||warn("$0","Can't close $filePath<BR>","");
  573   }
  574   $filePath;
  575 }
  576 
  577 =head1 Macros from IO.pm
  578 
  579     includePGtext
  580     read_whole_problem_file
  581     read_whole_file
  582     convertPath
  583     getDirDelim
  584     fileFromPath
  585     directoryFromPath
  586     createFile
  587     createDirectory
  588 
  589 =cut
  590 
  591 sub includePGtext {
  592   my $self = shift;
  593   WeBWorK::PG::IO::includePGtext(@_);
  594  };
  595 sub read_whole_problem_file {
  596   my $self = shift;
  597   WeBWorK::PG::IO::read_whole_problem_file(@_);
  598  };
  599 sub read_whole_file {
  600   my $self = shift;
  601   WeBWorK::PG::IO::read_whole_file(@_);
  602  };
  603 sub convertPath {
  604   my $self = shift;
  605   WeBWorK::PG::IO::convertPath(@_);
  606  };
  607 sub getDirDelim {
  608   my $self = shift;
  609   WeBWorK::PG::IO::getDirDelim(@_);
  610  };
  611 sub fileFromPath {
  612   my $self = shift;
  613   WeBWorK::PG::IO::fileFromPath(@_);
  614  };
  615 sub directoryFromPath {
  616   my $self = shift;
  617   WeBWorK::PG::IO::directoryFromPath(@_);
  618  };
  619 sub createFile {
  620   my $self = shift;
  621   WeBWorK::PG::IO::createFile(@_);
  622  };
  623 sub createDirectory {
  624   my $self = shift;
  625   WeBWorK::PG::IO::createDirectory(@_);
  626  };
  627 
  628 sub tempDirectory {
  629   my $self = shift;
  630   return $self->{tempDirectory};
  631 }
  632 
  633 
  634 =head2 surePathToTmpFile
  635 
  636   $path = surePathToTmpFile($path);
  637 
  638 Creates all of the intermediate directories between the tempDirectory
  639 
  640 If $path begins with the tempDirectory path, then the
  641 path is treated as absolute. Otherwise, the path is treated as relative the the
  642 course temp directory.
  643 
  644 =cut
  645 
  646 # A very useful macro for making sure that all of the directories to a file have been constructed.
  647 
  648 # ^function surePathToTmpFile
  649 # ^uses getCourseTempDirectory
  650 # ^uses createDirectory
  651 
  652 
  653 sub surePathToTmpFile {
  654   # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/
  655   # the input path must be either the full path, or the path relative to this tmp sub directory
  656 
  657   my $self = shift;
  658   my $path = shift;
  659   my $delim = "/";
  660   my $tmpDirectory = $self->tempDirectory();
  661   unless ( -e $tmpDirectory) {   # if by some unlucky chance the tmpDirectory hasn't been created, create it.
  662       my $parentDirectory =  $tmpDirectory;
  663       $parentDirectory =~s|/$||;  # remove a trailing /
  664       $parentDirectory =~s|/\w*$||; # remove last node
  665       my ($perms, $groupID) = (stat $parentDirectory)[2,5];
  666     createDirectory($tmpDirectory, $perms, $groupID)
  667         or warn "Failed to create directory at $path";
  668 
  669   }
  670   # use the permissions/group on the temp directory itself as a template
  671   my ($perms, $groupID) = (stat $tmpDirectory)[2,5];
  672   #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n";
  673 
  674   # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment
  675   $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|;
  676   #$path = convertPath($path);
  677 
  678   # find the nodes on the given path
  679         my @nodes = split("$delim",$path);
  680 
  681   # create new path
  682   $path = $tmpDirectory; #convertPath("$tmpDirectory");
  683 
  684   while (@nodes>1) {
  685     $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
  686     unless (-e $path) {
  687       #system("mkdir $path");
  688       #createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID)
  689       createDirectory($path, $perms, $groupID)
  690         or warn "Failed to create directory at $path";
  691     }
  692 
  693   }
  694 
  695   $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
  696   #system(qq!echo "" > $path! );
  697   return $path;
  698 }
  699 
  700 sub internal_debug_message {
  701     my $self = shift;
  702   my @str = @_;
  703   push @{$internal_debug_messages}, @str;
  704 }
  705 sub get_internal_debug_messages {
  706   my $self = shift;
  707   $internal_debug_messages;
  708 }
  709 sub clear_internal_debug_messages {
  710   my $self = shift;
  711   $internal_debug_messages=[];
  712 }
  713 
  714 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9