[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 6292
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;
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
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});
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
515sub append_debug_message { 582sub debug_message {
516 my $self = shift; 583 my $self = shift;
517 my @str = @_; 584 my @str = @_;
518 push @{$self->{DEBUG_messages}}, @str; 585 push @{$self->{flags}->{DEBUG_messages}}, @str;
519} 586}
520sub get_debug_messages { 587sub get_debug_messages {
521 my $self = shift; 588 my $self = shift;
522 $self->{DEBUG_messages}; 589 $self->{flags}->{DEBUG_messages};
523} 590}
591
592sub internal_debug_message {
593 my $self = shift;
594 my @str = @_;
595 push @{$internal_debug_messages}, @str;
596}
597sub get_internal_debug_messages {
598 my $self = shift;
599 $internal_debug_messages;
600}
601sub clear_internal_debug_messages {
602 my $self = shift;
603 $internal_debug_messages=[];
604}
605
524sub DESTROY { 606sub DESTROY {
525 # doing nothing about destruction, hope that isn't dangerous 607 # doing nothing about destruction, hope that isn't dangerous
526} 608}
527 609
528sub WARN { 610sub WARN {
711 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 793 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
712 #system(qq!echo "" > $path! ); 794 #system(qq!echo "" > $path! );
713 return $path; 795 return $path;
714} 796}
715 797
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 798
7301; 7991;

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9