[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 6280 Revision 6397
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 => [],
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 => $envir->{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,
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
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() );
450 515
451 } 516 }
452 $label; 517 $label;
453} 518}
454sub record_unlabeled_ans_name { 519sub record_unlabeled_ans_name {
466} 531}
467sub store_persistent_data { # will store strings only (so far) 532sub store_persistent_data { # will store strings only (so far)
468 my $self = shift; 533 my $self = shift;
469 my $label = shift; 534 my $label = shift;
470 my @content = @_; 535 my @content = @_;
471 $self->internal_debug_message("storing $label in PERSISTENCE_HASH"); 536 $self->internal_debug_message("PGcore::store_persistent_data: storing $label in PERSISTENCE_HASH");
472 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) { 537 if (defined($self->{PERSISTENCE_HASH}->{$label}) ) {
473 warn "can' overwrite $label in persistent data"; 538 warn "can' overwrite $label in persistent data";
474 } else { 539 } else {
475 $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding? 540 $self->{PERSISTENCE_HASH}->{$label} = join("",@content); #need base64 encoding?
476 } 541 }
510# } else { 575# } else {
511# return $self->($name); #if no parameters just return the value 576# return $self->($name); #if no parameters just return the value
512# } 577# }
513# } 578# }
514 579
580
581# Sometimes a question author needs to code or decode base64 directly
582sub decode_base64 ($) {
583 my $self = shift;
584 my $str = shift;
585 MIME::Base64::decode_base64($str);
586}
587
588sub encode_base64 ($;$) {
589 my $self = shift;
590 my $str = shift;
591 my $option = shift;
592 MIME::Base64::encode_base64($str);
593}
515sub append_debug_message { 594sub debug_message {
516 my $self = shift; 595 my $self = shift;
517 my @str = @_; 596 my @str = @_;
518 push @{$self->{DEBUG_messages}}, @str; 597 push @{$self->{flags}->{DEBUG_messages}}, @str;
519} 598}
520sub get_debug_messages { 599sub get_debug_messages {
521 my $self = shift; 600 my $self = shift;
522 $self->{DEBUG_messages}; 601 $self->{flags}->{DEBUG_messages};
523} 602}
603sub warning_message {
604 my $self = shift;
605 my @str = @_;
606 push @{$self->{flags}->{WARNING_messages}}, @str;
607}
608sub get_warning_messages {
609 my $self = shift;
610 $self->{flags}->{WARNING_messages};
611}
612
613sub internal_debug_message {
614 my $self = shift;
615 my @str = @_;
616 push @{$internal_debug_messages}, @str;
617}
618sub get_internal_debug_messages {
619 my $self = shift;
620 $internal_debug_messages;
621}
622sub clear_internal_debug_messages {
623 my $self = shift;
624 $internal_debug_messages=[];
625}
626
524sub DESTROY { 627sub DESTROY {
525 # doing nothing about destruction, hope that isn't dangerous 628 # doing nothing about destruction, hope that isn't dangerous
526} 629}
527 630
528sub WARN { 631# sub WARN {
529 warn(@_); 632# warn(@_);
530} 633# }
531 634
532 635
533# This creates on the fly graphs 636# This creates on the fly graphs
534 637
535=head2 insertGraph 638=head2 insertGraph
711 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 814 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
712 #system(qq!echo "" > $path! ); 815 #system(qq!echo "" > $path! );
713 return $path; 816 return $path;
714} 817}
715 818
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 819
7301; 8201;

Legend:
Removed from v.6280  
changed lines
  Added in v.6397

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9