[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 6278 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.5 2010/05/25 22:22:27 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.
16package PGcore; 16package PGcore;
17 17
18use strict; 18use strict;
19BEGIN { 19BEGIN {
20 use Exporter 'import'; 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 25
26use PGanswergroup; 26use PGanswergroup;
28use PGrandom; 28use PGrandom;
29use PGalias; 29use PGalias;
30use PGloadfiles; 30use PGloadfiles;
31use WeBWorK::PG::IO(); # don't important any command directly 31use WeBWorK::PG::IO(); # don't important any command directly
32use Tie::IxHash; 32use Tie::IxHash;
33 33use MIME::Base64;
34################################## 34##################################
35# Utility macro 35# Utility macro
36################################## 36##################################
37 37
38=head2 Utility Macros 38=head2 Utility Macros
39 39
40
41=head4 not_null
42
40 not_null(item) returns 1 or 0 43 not_null(item) returns 1 or 0
41 44
42 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
43 all undefined quantities are null and return 0 46 all undefined quantities are null and return 0
44 47
55 } else { # string case return 1 if none empty 58 } else { # string case return 1 if none empty
56 return ($item =~ /\S/)? 1:0; 59 return ($item =~ /\S/)? 1:0;
57 } 60 }
58} 61}
59 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}
60################################## 111##################################
61# PGcore object 112# PGcore object
62################################## 113##################################
63 114
64sub new { 115sub new {
68 #warn "creating a new PGcore object"; 119 #warn "creating a new PGcore object";
69 my %options = @_; 120 my %options = @_;
70 my $self = { 121 my $self = {
71 OUTPUT_ARRAY => [], # holds output body text 122 OUTPUT_ARRAY => [], # holds output body text
72 HEADER_ARRAY => [], # holds output for the header text 123 HEADER_ARRAY => [], # holds output for the header text
73# PG_ANSWERS => [], # holds answers with labels 124# PG_ANSWERS => [], # holds answers with labels # deprecated
74# PG_UNLABELED_ANSWERS => [], # holds 125# PG_UNLABELED_ANSWERS => [], # holds unlabeled ans. #deprecated -replaced by PG_ANSWERS_HASH
75 PG_ANSWERS_HASH => {}, # holds label=>answer pairs 126 PG_ANSWERS_HASH => {}, # holds label=>answer pairs
76 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
77# PG_persistence_hash => {}, # stores information (other than answers) from one session to another
78 answer_eval_count => 0, 128 answer_eval_count => 0,
79 answer_blank_count => 0, 129 answer_blank_count => 0,
80 unlabeled_answer_blank_count =>0, 130 unlabeled_answer_blank_count =>0,
81 unlabeled_answer_eval_count => 0, 131 unlabeled_answer_eval_count => 0,
82 KEPT_EXTRA_ANSWERS => [], 132 KEPT_EXTRA_ANSWERS => [],
83 ANSWER_PREFIX => 'AnSwEr', 133 ANSWER_PREFIX => 'AnSwEr',
84 ARRAY_PREFIX => 'ArRaY', 134 ARRAY_PREFIX => 'ArRaY',
85 vec_num => 0, # for distinguishing matrices 135 vec_num => 0, # for distinguishing matrices
86 QUIZ_PREFIX => '', 136 QUIZ_PREFIX => $envir->{QUIZ_PREFIX},
87 SECTION_PREFIX => '', # might be used for sequential (compound) questions? 137 SECTION_PREFIX => '', # might be used for sequential (compound) questions?
88 138
89 PG_ACTIVE => 1, # turn to zero to stop processing 139 PG_ACTIVE => 1, # toggle to zero to stop processing
90 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?
91 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.
92 PG_original_problem_seed => 0, 142 PG_original_problem_seed => 0,
93 PG_random_generator => undef, 143 PG_random_generator => undef,
94 PG_alias => undef, 144 PG_alias => undef,
127 showHintLimit => 0, 177 showHintLimit => 0,
128 solutionExists => 0, 178 solutionExists => 0,
129 WARNING_messages => [], 179 WARNING_messages => [],
130 DEBUG_messages => [], 180 DEBUG_messages => [],
131 recordSubmittedAnswers => 1, 181 recordSubmittedAnswers => 1,
132 refreshCAchedImages => 0, 182 refreshCachedImages => 0,
133# 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
134 comment => '', # implement as array? 184 comment => '', # implement as array?
135 185
136 186
137 187
253 my $self = shift; #FIXME filter for undefined entries replace by ""; 303 my $self = shift; #FIXME filter for undefined entries replace by "";
254 push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ; 304 push @{$self->{OUTPUT_ARRAY}}, map { (defined($_) )?$_:'' } @_ ;
255 $self->{OUTPUT_ARRAY}; 305 $self->{OUTPUT_ARRAY};
256} 306}
257 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 }
258 322
323}
259=item LABELED_ANS() 324=item LABELED_ANS()
260 325
261 TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2")); 326 TEXT(labeled_ans_rule("name1"), labeled_ans_rule("name2"));
262 LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2); 327 LABELED_ANS(name1 => answer_evaluator1, name2 => answer_evaluator2);
263 328
285sub LABELED_ANS{ 350sub LABELED_ANS{
286 my $self = shift; 351 my $self = shift;
287 my @in = @_; 352 my @in = @_;
288 while (@in ) { 353 while (@in ) {
289 my $label = shift @in; 354 my $label = shift @in;
290 $label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label); 355 #$label = join("", $self->{QUIZ_PREFIX}, $self->{SECTION_PREFIX}, $label);
291 my $ans_eval = shift @in; 356 my $ans_eval = shift @in;
292 $self->WARN("<BR><B>Error in LABELED_ANS:|$label|</B> 357 $self->warning_message("<BR><B>Error in LABELED_ANS:|$label|</B>
293 -- inputs must be references to AnswerEvaluator objects or subroutines<BR>") 358 -- inputs must be references to AnswerEvaluator objects or subroutines<BR>")
294 unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ; 359 unless ref($ans_eval) =~ /CODE/ or ref($ans_eval) =~ /AnswerEvaluator/ ;
295 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ){ 360 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ){
296 $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});
297 } else { 362 } else {
402 467
403sub 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
404 my $self = shift; 469 my $self = shift;
405 my $label = shift; 470 my $label = shift;
406 my $value = shift; 471 my $value = shift;
407 $self->internal_debug_message("record_ans_name $label $value"); 472 #$self->internal_debug_message("PGcore::record_ans_name: $label $value");
408 my $response_group = new PGresponsegroup($label,$label,$value); 473 my $response_group = new PGresponsegroup($label,$label,$value);
409 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) { 474 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
410 $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label, 475 $self->{PG_ANSWERS_HASH}->{$label}->replace(ans_label => $label,
411 response => $response_group, 476 response => $response_group,
412 active => $self->{PG_ACTIVE}); 477 active => $self->{PG_ACTIVE});
417 } 482 }
418 $self->{answer_blank_count}++; 483 $self->{answer_blank_count}++;
419 $label; 484 $label;
420} 485}
421 486
422sub record_array_name { # currently the same as record ans group 487sub record_array_name { # currently the same as record ans name
423 my $self = shift; 488 my $self = shift;
424 my $label = shift; 489 my $label = shift;
425 my $value = shift; 490 my $value = shift;
426 my $response_group = new PGresponsegroup($label,$label,$value); 491 my $response_group = new PGresponsegroup($label,$label,$value);
427 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) { 492 if (defined($self->{PG_ANSWERS_HASH}->{$label}) ) {
444 my @response_list = @_; 509 my @response_list = @_;
445 my $answer_group = $self->{PG_ANSWERS_HASH}->{$label}; 510 my $answer_group = $self->{PG_ANSWERS_HASH}->{$label};
446 if (ref($answer_group) =~/PGanswergroup/) { 511 if (ref($answer_group) =~/PGanswergroup/) {
447 $answer_group->append_responses(@response_list); 512 $answer_group->append_responses(@response_list);
448 } else { 513 } else {
449 $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
450 518
451 } 519 }
452 $label; 520 $label;
453} 521}
454sub record_unlabeled_ans_name { 522sub record_unlabeled_ans_name {
466} 534}
467sub store_persistent_data { # will store strings only (so far) 535sub store_persistent_data { # will store strings only (so far)
468 my $self = shift; 536 my $self = shift;
469 my $label = shift; 537 my $label = shift;
470 my @content = @_; 538 my @content = @_;
471 $self->internal_debug_message("storing $label in PERSISTENCE_HASH"); 539 $self->internal_debug_message("PGcore::store_persistent_data: storing $label in PERSISTENCE_HASH");
472 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) { 540 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) {
473 warn "can' overwrite $label in persistent data"; 541 warn "can' overwrite $label in persistent data";
474 } else { 542 } else {
475 $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding? 543 $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding?
476 } 544 }
510# } else { 578# } else {
511# return $self->($name); #if no parameters just return the value 579# return $self->($name); #if no parameters just return the value
512# } 580# }
513# } 581# }
514 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}
515sub append_debug_message { 597sub debug_message {
516 my $self = shift; 598 my $self = shift;
517 my @str = @_; 599 my @str = @_;
518 push @{$self->{DEBUG_messages}}, @str; 600 push @{$self->{flags}->{DEBUG_messages}}, @str;
519} 601}
520sub get_debug_messages { 602sub get_debug_messages {
521 my $self = shift; 603 my $self = shift;
522 $self->{DEBUG_messages}; 604 $self->{flags}->{DEBUG_messages};
523} 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
524sub DESTROY { 630sub DESTROY {
525 # doing nothing about destruction, hope that isn't dangerous 631 # doing nothing about destruction, hope that isn't dangerous
526} 632}
527 633
528sub WARN { 634# sub WARN {
529 warn(@_); 635# warn(@_);
530} 636# }
531 637
532 638
533# This creates on the fly graphs 639# This creates on the fly graphs
534 640
535=head2 insertGraph 641=head2 insertGraph
711 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 817 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
712 #system(qq!echo "" > $path! ); 818 #system(qq!echo "" > $path! );
713 return $path; 819 return $path;
714} 820}
715 821
716sub internal_debug_message {
717 my $self = shift;
718 my @str = @_;
719 push @{$internal_debug_messages}, @str;
720}
721sub get_internal_debug_messages {
722 my $self = shift;
723 $internal_debug_messages;
724}
725sub clear_internal_debug_messages {
726 my $self = shift;
727 $internal_debug_messages=[];
728}
729 822
7301; 8231;

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9