[system] / trunk / pg / lib / PGcore.pm Repository:
ViewVC logotype

Diff of /trunk/pg/lib/PGcore.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 6256 Revision 6505
1################################################################################ 1################################################################################
2# WeBWorK Online Homework Delivery System 2# WeBWorK Online Homework Delivery System
3# Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/ 3# Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/
4# $CVSHeader: pg/lib/PGcore.pm,v 1.2 2010/05/14 12:31:19 gage Exp $ 4# $CVSHeader: pg/lib/PGcore.pm,v 1.6 2010/05/25 22:47:52 gage Exp $
5# 5#
6# This program is free software; you can redistribute it and/or modify it under 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 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 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. 9# version, or (b) the "Artistic License" which comes with this package.
15################################################################################ 15################################################################################
16package PGcore; 16package PGcore;
17 17
18use strict; 18use strict;
19BEGIN { 19BEGIN {
20 use Exporter; 20 use Exporter 'import';
21 our @EXPORT_OK = qw( not_null); 21 our @EXPORT_OK = qw(not_null pretty_print);
22} 22}
23our $internal_debug_messages = []; 23our $internal_debug_messages = [];
24
24 25
25use PGanswergroup; 26use PGanswergroup;
26use PGresponsegroup; 27use PGresponsegroup;
27use PGrandom; 28use PGrandom;
28use PGalias; 29use PGalias;
29use PGloadfiles; 30use PGloadfiles;
30use WeBWorK::PG::IO; 31use WeBWorK::PG::IO(); # don't important any command directly
31use Tie::IxHash; 32use Tie::IxHash;
32 33use MIME::Base64;
33################################## 34##################################
34# Utility macro 35# Utility macro
35################################## 36##################################
36 37
37=head2 Utility Macros 38=head2 Utility Macros
38 39
40
41=head4 not_null
42
39 not_null(item) returns 1 or 0 43 not_null(item) returns 1 or 0
40 44
41 empty arrays, empty hashes, strings containing only whitespace are all NULL and return 0 45 empty arrays, empty hashes, strings containing only whitespace are all NULL and return 0
42 all undefined quantities are null and return 0 46 all undefined quantities are null and return 0
43 47
54 } else { # string case return 1 if none empty 58 } else { # string case return 1 if none empty
55 return ($item =~ /\S/)? 1:0; 59 return ($item =~ /\S/)? 1:0;
56 } 60 }
57} 61}
58 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
69This 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
76sub 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}
59################################## 111##################################
60# PGcore object 112# PGcore object
61################################## 113##################################
62 114
63sub new { 115sub new {
67 #warn "creating a new PGcore object"; 119 #warn "creating a new PGcore object";
68 my %options = @_; 120 my %options = @_;
69 my $self = { 121 my $self = {
70 OUTPUT_ARRAY => [], # holds output body text 122 OUTPUT_ARRAY => [], # holds output body text
71 HEADER_ARRAY => [], # holds output for the header text 123 HEADER_ARRAY => [], # holds output for the header text
72# PG_ANSWERS => [], # holds answers with labels 124# PG_ANSWERS => [], # holds answers with labels # deprecated
73# PG_UNLABELED_ANSWERS => [], # holds 125# PG_UNLABELED_ANSWERS => [], # holds unlabeled ans. #deprecated -replaced by PG_ANSWERS_HASH
74 PG_ANSWERS_HASH => {}, # holds label=>answer pairs 126 PG_ANSWERS_HASH => {}, # holds label=>answer pairs
75 PERSISTENCE_HASH => {}, # holds other data, besides answers, which persists during a session and beyond 127 PERSISTENCE_HASH => {}, # holds other data, besides answers, which persists during a session and beyond
76# PG_persistence_hash => {}, # stores information (other than answers) from one session to another
77 answer_eval_count => 0, 128 answer_eval_count => 0,
78 answer_blank_count => 0, 129 answer_blank_count => 0,
79 unlabeled_answer_blank_count =>0, 130 unlabeled_answer_blank_count =>0,
80 unlabeled_answer_eval_count => 0, 131 unlabeled_answer_eval_count => 0,
81 KEPT_EXTRA_ANSWERS => [], 132 KEPT_EXTRA_ANSWERS => [],
82 ANSWER_PREFIX => 'AnSwEr', 133 ANSWER_PREFIX => 'AnSwEr',
83 ARRAY_PREFIX => 'ArRaY', 134 ARRAY_PREFIX => 'ArRaY',
84 vec_num => 0, # for distinguishing matrices 135 vec_num => 0, # for distinguishing matrices
85 QUIZ_PREFIX => '', 136 QUIZ_PREFIX => $envir->{QUIZ_PREFIX},
86 SECTION_PREFIX => '', # might be used for sequential (compound) questions? 137 SECTION_PREFIX => '', # might be used for sequential (compound) questions?
87 138
88 PG_ACTIVE => 1, # turn to zero to stop processing 139 PG_ACTIVE => 1, # toggle to zero to stop processing
89 submittedAnswers => 0, # have any answers been submitted? is this the first time this session? 140 submittedAnswers => 0, # have any answers been submitted? is this the first time this session?
90 PG_session_persistence_hash =>{}, # stores data from one invoction of the session to the next. 141 PG_session_persistence_hash =>{}, # stores data from one invoction of the session to the next.
91 PG_original_problem_seed => 0, 142 PG_original_problem_seed => 0,
92 PG_random_generator => undef, 143 PG_random_generator => undef,
93 PG_alias => undef, 144 PG_alias => undef,
126 showHintLimit => 0, 177 showHintLimit => 0,
127 solutionExists => 0, 178 solutionExists => 0,
128 WARNING_messages => [], 179 WARNING_messages => [],
129 DEBUG_messages => [], 180 DEBUG_messages => [],
130 recordSubmittedAnswers => 1, 181 recordSubmittedAnswers => 1,
131 refreshCAchedImages => 0, 182 refreshCachedImages => 0,
132# ANSWER_ENTRY_ORDER => [], # may not be needed if we ue Tie:IxHash 183# ANSWER_ENTRY_ORDER => [], # may not be needed if we ue Tie:IxHash
133 comment => '', # implement as array? 184 comment => '', # implement as array?
134 185
135 186
136 187
252 my $self = shift; #FIXME filter for undefined entries replace by ""; 303 my $self = shift; #FIXME filter for undefined entries replace by "";
253 push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ; 304 push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ;
254 $self->{OUTPUT_ARRAY}; 305 $self->{OUTPUT_ARRAY};
255} 306}
256 307
308sub 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 }
257 322
323}
258=item LABELED_ANS() 324=item LABELED_ANS()
259 325
260 TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2")); 326 TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2"));
261 LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2); 327 LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2);
262 328
284sub LABELED_ANS{ 350sub LABELED_ANS{
285 my $self = shift; 351 my $self = shift;
286 my @in = @_; 352 my @in = @_;
287 while (@in ) { 353 while (@in ) {
288 my $label = shift @in; 354 my $label = shift @in;
289 $label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label); 355 #$label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label);
290 my $ans_eval = shift @in; 356 my $ans_eval = shift @in;
291 $self->WARN("<BR><B>Error in LABELED_ANS:|$label|</B> 357 $self->warning_message("<BR><B>Error in LABELED_ANS:|$label|</B>
292 -- inputs must be references to AnswerEvaluator objects or subroutines<BR>") 358 -- inputs must be references to AnswerEvaluator objects or subroutines<BR>")
293 unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ; 359 unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ;
294 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ){ 360 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ){
295 $self->{PG_ANSWERS_HASH}->{$label}->insert(ans_label => $label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE}); 361 $self->{PG_ANSWERS_HASH}->{$label}->insert(ans_label => $label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE});
296 } else { 362 } else {
401 467
402sub record_ans_name { # the labels in the PGanswer group and response group should match in this case 468sub record_ans_name { # the labels in the PGanswer group and response group should match in this case
403 my $self = shift; 469 my $self = shift;
404 my $label = shift; 470 my $label = shift;
405 my $value = shift; 471 my $value = shift;
406 $self->internal_debug_message("record_ans_name $label $value"); 472 #$self->internal_debug_message("PGcore::record_ans_name: $label $value");
407 my $response_group = new PGresponsegroup($label,$label,$value); 473 my $response_group = new PGresponsegroup($label,$label,$value);
408 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) { 474 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
409 $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label, 475 $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
410 response => $response_group, 476 response => $response_group,
411 active => $self->{PG_ACTIVE}); 477 active => $self->{PG_ACTIVE});
416 } 482 }
417 $self->{answer_blank_count}++; 483 $self->{answer_blank_count}++;
418 $label; 484 $label;
419} 485}
420 486
421sub record_array_name { # currently the same as record ans group 487sub record_array_name { # currently the same as record ans name
422 my $self = shift; 488 my $self = shift;
423 my $label = shift; 489 my $label = shift;
424 my $value = shift; 490 my $value = shift;
425 my $response_group = new PGresponsegroup($label,$label,$value); 491 my $response_group = new PGresponsegroup($label,$label,$value);
426 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) { 492 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
443 my @response_list = @_; 509 my @response_list = @_;
444 my $answer_group = $self->{PG_ANSWERS_HASH}->{$label}; 510 my $answer_group = $self->{PG_ANSWERS_HASH}->{$label};
445 if (ref($answer_group) =~/PGanswergroup/) { 511 if (ref($answer_group) =~/PGanswergroup/) {
446 $answer_group->append_responses(@response_list); 512 $answer_group->append_responses(@response_list);
447 } else { 513 } else {
448 $self->WARN("The answer |$label| has not yet been defined, you cannot extend it.",caller() ); 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
449 518
450 } 519 }
451 $label; 520 $label;
452} 521}
453sub record_unlabeled_ans_name { 522sub record_unlabeled_ans_name {
465} 534}
466sub store_persistent_data { # will store strings only (so far) 535sub store_persistent_data { # will store strings only (so far)
467 my $self = shift; 536 my $self = shift;
468 my $label = shift; 537 my $label = shift;
469 my @content = @_; 538 my @content = @_;
470 $self->internal_debug_message("storing $label in PERSISTENCE_HASH"); 539 $self->internal_debug_message("PGcore::store_persistent_data: storing $label in PERSISTENCE_HASH");
471 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) { 540 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) {
472 warn "can' overwrite $label in persistent data"; 541 warn "can' overwrite $label in persistent data";
473 } else { 542 } else {
474 $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding? 543 $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding?
475 } 544 }
509# } else { 578# } else {
510# return $self->($name); #if no parameters just return the value 579# return $self->($name); #if no parameters just return the value
511# } 580# }
512# } 581# }
513 582
583
584# Sometimes a question author needs to code or decode base64 directly
585sub decode_base64 ($) {
586 my $self = shift;
587 my $str = shift;
588 MIME::Base64::decode_base64($str);
589}
590
591sub encode_base64 ($;$) {
592 my $self = shift;
593 my $str = shift;
594 my $option = shift;
595 MIME::Base64::encode_base64($str);
596}
514sub append_debug_message { 597sub debug_message {
515 my $self = shift; 598 my $self = shift;
516 my @str = @_; 599 my @str = @_;
517 push @{$self->{DEBUG_messages}}, @str; 600 push @{$self->{flags}->{DEBUG_messages}}, @str;
518} 601}
519sub get_debug_messages { 602sub get_debug_messages {
520 my $self = shift; 603 my $self = shift;
521 $self->{DEBUG_messages}; 604 $self->{flags}->{DEBUG_messages};
522} 605}
606sub warning_message {
607 my $self = shift;
608 my @str = @_;
609 push @{$self->{flags}->{WARNING_messages}}, @str;
610}
611sub get_warning_messages {
612 my $self = shift;
613 $self->{flags}->{WARNING_messages};
614}
615
616sub internal_debug_message {
617 my $self = shift;
618 my @str = @_;
619 push @{$internal_debug_messages}, @str;
620}
621sub get_internal_debug_messages {
622 my $self = shift;
623 $internal_debug_messages;
624}
625sub clear_internal_debug_messages {
626 my $self = shift;
627 $internal_debug_messages=[];
628}
629
523sub DESTROY { 630sub DESTROY {
524 # doing nothing about destruction, hope that isn't dangerous 631 # doing nothing about destruction, hope that isn't dangerous
525} 632}
526 633
527sub WARN { 634# sub WARN {
528 warn(@_); 635# warn(@_);
529} 636# }
530 637
531 638
532# This creates on the fly graphs 639# This creates on the fly graphs
533 640
534=head2 insertGraph 641=head2 insertGraph
666 773
667 my $self = shift; 774 my $self = shift;
668 my $path = shift; 775 my $path = shift;
669 my $delim = "/"; 776 my $delim = "/";
670 my $tmpDirectory = $self->tempDirectory(); 777 my $tmpDirectory = $self->tempDirectory();
778#warn "\nTMP tmpDirectory $tmpDirectory";
671 unless ( -e $tmpDirectory) { # if by some unlucky chance the tmpDirectory hasn't been created, create it. 779 unless ( -e $tmpDirectory) { # if by some unlucky chance the tmpDirectory hasn't been created, create it.
672 my $parentDirectory = $tmpDirectory; 780 my $parentDirectory = $tmpDirectory;
673 $parentDirectory =~s|/$||; # remove a trailing / 781 $parentDirectory =~s|/$||; # remove a trailing /
674 $parentDirectory =~s|/\w*$||; # remove last node 782 $parentDirectory =~s|/\w*$||; # remove last node
675 my ($perms, $groupID) = (stat $parentDirectory)[2,5]; 783 my ($perms, $groupID) = (stat $parentDirectory)[2,5];
784 #FIXME where is the parentDirectory defined??
785#warn "Creating tmp directory at $tmpDirectory, perms $perms groupID $groupID";
676 createDirectory($tmpDirectory, $perms, $groupID) 786 $self->createDirectory($tmpDirectory, $perms, $groupID)
677 or warn "Failed to create directory at $path"; 787 or warn "Failed to create parent tmp directory at $path";
678 788
679 } 789 }
680 # use the permissions/group on the temp directory itself as a template 790 # use the permissions/group on the temp directory itself as a template
681 my ($perms, $groupID) = (stat $tmpDirectory)[2,5]; 791 my ($perms, $groupID) = (stat $tmpDirectory)[2,5];
682 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n"; 792#warn "&urePathToTmpFile: directory=$tmpDirectory, perms=$perms, groupID=$groupID\n";
683 793
684 # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment 794 # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment
685 $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|; 795 $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|;
686 #$path = convertPath($path); 796 #$path = $self->convertPath($path);
687 797
688 # find the nodes on the given path 798 # find the nodes on the given path
689 my @nodes = split("$delim",$path); 799 my @nodes = split("$delim",$path);
690 800
691 # create new path 801 # create new path
692 $path = $tmpDirectory; #convertPath("$tmpDirectory"); 802 $path = $tmpDirectory; #convertPath("$tmpDirectory");
693 803
694 while (@nodes>1) { 804 while (@nodes>1) {
695 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/"); 805 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
806#warn "\PATH is now $path";
696 unless (-e $path) { 807 unless (-e $path) {
697 #system("mkdir $path"); 808 #system("mkdir $path");
698 #createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID) 809 #createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID)
810#warn "PATH $path perms $perms groupID $groupID";
699 createDirectory($path, $perms, $groupID) 811 $self->createDirectory($path, $perms, $groupID)
700 or warn "Failed to create directory at $path"; 812 or warn "Failed to create directory at $path with permissions $perms and groupID $groupID";
701 } 813 }
702 814
703 } 815 }
704 816
705 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 817 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
706 #system(qq!echo "" > $path! ); 818 #system(qq!echo "" > $path! );
707 return $path; 819 return $path;
708} 820}
709 821
710sub internal_debug_message {
711 my $self = shift;
712 my @str = @_;
713 push @{$internal_debug_messages}, @str;
714}
715sub get_internal_debug_messages {
716 my $self = shift;
717 $internal_debug_messages;
718}
719sub clear_internal_debug_messages {
720 my $self = shift;
721 $internal_debug_messages=[];
722}
723 822
7241; 8231;

Legend:
Removed from v.6256  
changed lines
  Added in v.6505

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9