[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 6249 Revision 6404
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/macros/PG.pl,v 1.40 2009/06/25 23:28:44 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##################################
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
36 50
37sub not_null { # empty arrays, empty hashes and strings containing only whitespace are all NULL 51sub not_null { # empty arrays, empty hashes and strings containing only whitespace are all NULL
38 my $item = shift; 52 my $item = shift;
39 return 0 unless defined($item); 53 return 0 unless defined($item);
40 if (ref($item)=~/ARRAY/) { 54 if (ref($item)=~/ARRAY/) {
44 } else { # string case return 1 if none empty 58 } else { # string case return 1 if none empty
45 return ($item =~ /\S/)? 1:0; 59 return ($item =~ /\S/)? 1:0;
46 } 60 }
47} 61}
48 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}
49################################## 111##################################
50# PGcore object 112# PGcore object
51################################## 113##################################
52 114
53sub new { 115sub new {
57 #warn "creating a new PGcore object"; 119 #warn "creating a new PGcore object";
58 my %options = @_; 120 my %options = @_;
59 my $self = { 121 my $self = {
60 OUTPUT_ARRAY => [], # holds output body text 122 OUTPUT_ARRAY => [], # holds output body text
61 HEADER_ARRAY => [], # holds output for the header text 123 HEADER_ARRAY => [], # holds output for the header text
62# PG_ANSWERS => [], # holds answers with labels 124# PG_ANSWERS => [], # holds answers with labels # deprecated
63# PG_UNLABELED_ANSWERS => [], # holds 125# PG_UNLABELED_ANSWERS => [], # holds unlabeled ans. #deprecated -replaced by PG_ANSWERS_HASH
64 PG_ANSWERS_HASH => {}, # holds label=>answer pairs 126 PG_ANSWERS_HASH => {}, # holds label=>answer pairs
65 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
66# PG_persistence_hash => {}, # stores information (other than answers) from one session to another
67 answer_eval_count => 0, 128 answer_eval_count => 0,
68 answer_blank_count => 0, 129 answer_blank_count => 0,
69 unlabeled_answer_blank_count =>0, 130 unlabeled_answer_blank_count =>0,
70 unlabeled_answer_eval_count => 0, 131 unlabeled_answer_eval_count => 0,
71 KEPT_EXTRA_ANSWERS => [], 132 KEPT_EXTRA_ANSWERS => [],
72 ANSWER_PREFIX => 'AnSwEr', 133 ANSWER_PREFIX => 'AnSwEr',
73 ARRAY_PREFIX => 'ArRaY', 134 ARRAY_PREFIX => 'ArRaY',
74 vec_num => 0, # for distinguishing matrices 135 vec_num => 0, # for distinguishing matrices
75 QUIZ_PREFIX => '', 136 QUIZ_PREFIX => $envir->{QUIZ_PREFIX},
76 SECTION_PREFIX => '', # might be used for sequential (compound) questions? 137 SECTION_PREFIX => '', # might be used for sequential (compound) questions?
77 138
78 PG_ACTIVE => 1, # turn to zero to stop processing 139 PG_ACTIVE => 1, # toggle to zero to stop processing
79 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?
80 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.
81 PG_original_problem_seed => 0, 142 PG_original_problem_seed => 0,
82 PG_random_generator => undef, 143 PG_random_generator => undef,
83 PG_alias => undef, 144 PG_alias => undef,
107 168
108 $self->{tempDirectory} = $self->{envir}->{tempDirectory}; 169 $self->{tempDirectory} = $self->{envir}->{tempDirectory};
109 $self->{PG_problem_grader} = $self->{envir}->{PROBLEM_GRADER_TO_USE}; 170 $self->{PG_problem_grader} = $self->{envir}->{PROBLEM_GRADER_TO_USE};
110 $self->{PG_alias} = new PGalias($self->{envir}); 171 $self->{PG_alias} = new PGalias($self->{envir});
111 $self->{PG_loadMacros} = new PGloadfiles($self->{envir}); 172 $self->{PG_loadMacros} = new PGloadfiles($self->{envir});
112 $self->{PG_FLAGS} = { 173 $self->{flags} = {
113 showpartialCorrectAnswers => 1, 174 showpartialCorrectAnswers => 1,
114 showHint => 1, 175 showHint => 1,
115 hintExists => 0, 176 hintExists => 0,
116 showHintLimit => 0, 177 showHintLimit => 0,
117 solutionExists => 0, 178 solutionExists => 0,
242 my $self = shift; #FIXME filter for undefined entries replace by ""; 303 my $self = shift; #FIXME filter for undefined entries replace by "";
243 push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ; 304 push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ;
244 $self->{OUTPUT_ARRAY}; 305 $self->{OUTPUT_ARRAY};
245} 306}
246 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 }
247 322
323}
248=item LABELED_ANS() 324=item LABELED_ANS()
249 325
250 TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2")); 326 TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2"));
251 LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2); 327 LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2);
252 328
274sub LABELED_ANS{ 350sub LABELED_ANS{
275 my $self = shift; 351 my $self = shift;
276 my @in = @_; 352 my @in = @_;
277 while (@in ) { 353 while (@in ) {
278 my $label = shift @in; 354 my $label = shift @in;
279 $label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label); 355 #$label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label);
280 my $ans_eval = shift @in; 356 my $ans_eval = shift @in;
281 $self->WARN("<BR><B>Error in LABELED_ANS:|$label|</B> 357 $self->warning_message("<BR><B>Error in LABELED_ANS:|$label|</B>
282 -- inputs must be references to AnswerEvaluator objects or subroutines<BR>") 358 -- inputs must be references to AnswerEvaluator objects or subroutines<BR>")
283 unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ; 359 unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ;
284 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ){ 360 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}); 361 $self->{PG_ANSWERS_HASH}->{$label}->insert(ans_label => $label, ans_eval => $ans_eval, active=>$self->{PG_ACTIVE});
286 } else { 362 } else {
391 467
392sub 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
393 my $self = shift; 469 my $self = shift;
394 my $label = shift; 470 my $label = shift;
395 my $value = shift; 471 my $value = shift;
396 $self->internal_debug_message("record_ans_name $label $value"); 472 #$self->internal_debug_message("PGcore::record_ans_name: $label $value");
397 my $response_group = new PGresponsegroup($label,$label,$value); 473 my $response_group = new PGresponsegroup($label,$label,$value);
398 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) { 474 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
399 $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label, 475 $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
400 response => $response_group, 476 response => $response_group,
401 active => $self->{PG_ACTIVE}); 477 active => $self->{PG_ACTIVE});
406 } 482 }
407 $self->{answer_blank_count}++; 483 $self->{answer_blank_count}++;
408 $label; 484 $label;
409} 485}
410 486
411sub record_array_name { # currently the same as record ans group 487sub record_array_name { # currently the same as record ans name
412 my $self = shift; 488 my $self = shift;
413 my $label = shift; 489 my $label = shift;
414 my $value = shift; 490 my $value = shift;
415 my $response_group = new PGresponsegroup($label,$label,$value); 491 my $response_group = new PGresponsegroup($label,$label,$value);
416 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) { 492 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
433 my @response_list = @_; 509 my @response_list = @_;
434 my $answer_group = $self->{PG_ANSWERS_HASH}->{$label}; 510 my $answer_group = $self->{PG_ANSWERS_HASH}->{$label};
435 if (ref($answer_group) =~/PGanswergroup/) { 511 if (ref($answer_group) =~/PGanswergroup/) {
436 $answer_group->append_responses(@response_list); 512 $answer_group->append_responses(@response_list);
437 } else { 513 } else {
438 $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
439 518
440 } 519 }
441 $label; 520 $label;
442} 521}
443sub record_unlabeled_ans_name { 522sub record_unlabeled_ans_name {
455} 534}
456sub store_persistent_data { # will store strings only (so far) 535sub store_persistent_data { # will store strings only (so far)
457 my $self = shift; 536 my $self = shift;
458 my $label = shift; 537 my $label = shift;
459 my @content = @_; 538 my @content = @_;
460 $self->internal_debug_message("storing $label in PERSISTENCE_HASH"); 539 $self->internal_debug_message("PGcore::store_persistent_data: storing $label in PERSISTENCE_HASH");
461 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) { 540 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) {
462 warn "can' overwrite $label in persistent data"; 541 warn "can' overwrite $label in persistent data";
463 } else { 542 } else {
464 $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding? 543 $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding?
465 } 544 }
499# } else { 578# } else {
500# return $self->($name); #if no parameters just return the value 579# return $self->($name); #if no parameters just return the value
501# } 580# }
502# } 581# }
503 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}
504sub append_debug_message { 597sub debug_message {
505 my $self = shift; 598 my $self = shift;
506 my @str = @_; 599 my @str = @_;
507 push @{$self->{DEBUG_messages}}, @str; 600 push @{$self->{flags}->{DEBUG_messages}}, @str;
508} 601}
509sub get_debug_messages { 602sub get_debug_messages {
510 my $self = shift; 603 my $self = shift;
511 $self->{DEBUG_messages}; 604 $self->{flags}->{DEBUG_messages};
512} 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
513sub DESTROY { 630sub DESTROY {
514 # doing nothing about destruction, hope that isn't dangerous 631 # doing nothing about destruction, hope that isn't dangerous
515} 632}
516 633
517sub WARN { 634# sub WARN {
518 warn(@_); 635# warn(@_);
519} 636# }
520 637
521 638
522# This creates on the fly graphs 639# This creates on the fly graphs
523 640
524=head2 insertGraph 641=head2 insertGraph
656 773
657 my $self = shift; 774 my $self = shift;
658 my $path = shift; 775 my $path = shift;
659 my $delim = "/"; 776 my $delim = "/";
660 my $tmpDirectory = $self->tempDirectory(); 777 my $tmpDirectory = $self->tempDirectory();
778#warn "\nTMP tmpDirectory $tmpDirectory";
661 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.
662 my $parentDirectory = $tmpDirectory; 780 my $parentDirectory = $tmpDirectory;
663 $parentDirectory =~s|/$||; # remove a trailing / 781 $parentDirectory =~s|/$||; # remove a trailing /
664 $parentDirectory =~s|/\w*$||; # remove last node 782 $parentDirectory =~s|/\w*$||; # remove last node
665 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";
666 createDirectory($tmpDirectory, $perms, $groupID) 786 $self->createDirectory($tmpDirectory, $perms, $groupID)
667 or warn "Failed to create directory at $path"; 787 or warn "Failed to create parent tmp directory at $path";
668 788
669 } 789 }
670 # 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
671 my ($perms, $groupID) = (stat $tmpDirectory)[2,5]; 791 my ($perms, $groupID) = (stat $tmpDirectory)[2,5];
672 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n"; 792#warn "&urePathToTmpFile: directory=$tmpDirectory, perms=$perms, groupID=$groupID\n";
673 793
674 # 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
675 $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|; 795 $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|;
676 #$path = convertPath($path); 796 #$path = $self->convertPath($path);
677 797
678 # find the nodes on the given path 798 # find the nodes on the given path
679 my @nodes = split("$delim",$path); 799 my @nodes = split("$delim",$path);
680 800
681 # create new path 801 # create new path
682 $path = $tmpDirectory; #convertPath("$tmpDirectory"); 802 $path = $tmpDirectory; #convertPath("$tmpDirectory");
683 803
684 while (@nodes>1) { 804 while (@nodes>1) {
685 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/"); 805 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
806#warn "\PATH is now $path";
686 unless (-e $path) { 807 unless (-e $path) {
687 #system("mkdir $path"); 808 #system("mkdir $path");
688 #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";
689 createDirectory($path, $perms, $groupID) 811 $self->createDirectory($path, $perms, $groupID)
690 or warn "Failed to create directory at $path"; 812 or warn "Failed to create directory at $path with permissions $perms and groupID $groupID";
691 } 813 }
692 814
693 } 815 }
694 816
695 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 817 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
696 #system(qq!echo "" > $path! ); 818 #system(qq!echo "" > $path! );
697 return $path; 819 return $path;
698} 820}
699 821
700sub internal_debug_message {
701 my $self = shift;
702 my @str = @_;
703 push @{$internal_debug_messages}, @str;
704}
705sub get_internal_debug_messages {
706 my $self = shift;
707 $internal_debug_messages;
708}
709sub clear_internal_debug_messages {
710 my $self = shift;
711 $internal_debug_messages=[];
712}
713 822
7141; 8231;

Legend:
Removed from v.6249  
changed lines
  Added in v.6404

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9