From a1dd2162211e19f74a6a67c02ac50ef5fa9dcee4 Mon Sep 17 00:00:00 2001 From: mertz Date: Wed, 19 Feb 2003 08:08:13 +0000 Subject: log files are now very similar to perl code; This should ease cut-and-paste of part of this file to perl scripts to reproduce bugs in simpler scripts --- Perl/t/TestLog.pm | 157 ++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 111 insertions(+), 46 deletions(-) (limited to 'Perl/t/TestLog.pm') diff --git a/Perl/t/TestLog.pm b/Perl/t/TestLog.pm index 55f40c0..9488dcd 100644 --- a/Perl/t/TestLog.pm +++ b/Perl/t/TestLog.pm @@ -10,7 +10,7 @@ use strict; use vars qw( $VERSION @ISA @EXPORT ); ($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); -@EXPORT = qw( openLog setZincLog log test_eval printable printables +@EXPORT = qw( openLog setZincLog log test_eval test_no_eval printableItem printableArray printableList equal_flat_arrays nequal_cplx_arrays); use constant ERROR => '--an error--'; @@ -39,8 +39,8 @@ sub openLog { ### print log information to the logfile ### if $level is <= than opt_log (def = 0) then print log on the stdout -### - a loglevel of -100 means an error to be logged with %%% prefix -### - a loglevel of -10 means an error in the test (data missing?) +### - a loglevel of -100 means an error to be logged with #### prefix +### - a loglevel of -10 means an error in the test to be logged with ## prefix ### - a loglevel of 0 means an message to be usually printed (and logged in any case) ### - a loglevel greater than 1 is for trace only @@ -48,12 +48,12 @@ sub openLog { sub log { my ($loglevel, @strgs) = @_; if ($loglevel <= $opt_log) { - print "%%%% " if $loglevel == -100; - print "%% " if $loglevel == -10; + print "#### " if $loglevel == -100; + print "## " if $loglevel == -10; print @strgs; } - print LOG "%%%% " if $loglevel == -100; - print LOG "%% " if $loglevel == -10; + print LOG "#### " if $loglevel == -100; + print LOG "## " if $loglevel == -10; print LOG @strgs; } # end log @@ -73,30 +73,34 @@ my %method_with_tagOrId = "remove" => 1, ); -### - a loglevel of -100 means an error to be loggued with %%% prefix -### - a loglevel of -10 means an error in the test (data missing?) -### - a loglevel of of 0 or greater is for trace only if an error occured +### evaluate $zinc->$method(@args); and verifies that NO ERROR occurs +### - a loglevel of -100 means an error to be logged with #### prefix +### - a loglevel of -10 means an error in the test, to be logged with ## +### - a loglevel of of 0 or greater is for trace only (usefull when an error occurs) sub test_eval { my ($loglevel, $method, @args) = @_; my @strs; my $start_index = 0; + my $string2log = "\$zinc->$method ("; if (scalar @args) { - if ($method_with_tagOrId{$method} and $args[0] =~ /\d+/) { - my $item = $args[0]; - @strs = $item . " (" . $zinc->type($item) . ")"; - $start_index = 1; - } - foreach my $arg (@args[$start_index..$#args]) { - push @strs, &printable ($arg); - } + if ($method_with_tagOrId{$method} and $args[0] =~ /^\d+$/) { + my $type = $zinc->type($args[0]); + $string2log .= &printableItem($args[0]) . " (a". ucfirst($type) . ")"; + } else { + $string2log .= &printableItem($args[0]) ; + } + $string2log .= ", " if $#args > 0 ; + my $rest = &printableList(@args[1..$#args]); + $rest =~ s/^\(//; ### suppressing the first ( char + $string2log .= $rest; + } else { + $string2log .= ")"; } - my $string2log = "\$zinc->$method (" . join (", ", @strs) . ")"; if ($method eq 'itemcget' or $method eq 'get') { - $string2log .= " := " ; - } - else { - $string2log .= "\n"; + $string2log .= "; # := " ; + } else { + $string2log .= ";\n"; } &log ($loglevel, $string2log); @@ -104,26 +108,23 @@ sub test_eval { if (wantarray()) { @res = eval { $zinc->$method (@args) } ; if ($method eq 'itemcget' or $method eq 'get') { - &log ($loglevel, printables(@res) . "\n" ); + &log ($loglevel, printableList(@res) . "\n" ); } - } - else { + } else { $res = eval { $zinc->$method (@args) } ; if ($method eq 'itemcget' or $method eq 'get') { - &log ($loglevel, &printable($res) . "\n"); + &log ($loglevel, &printableItem($res) . "\n"); } } - if ($@) { # in case of error, logging! - &log (-100, "Error while evaluating: $string2log"); + &log (-100, "Error while evaluating: $string2log;"); &log (-100, $@); my $msgl = &Carp::longmess; my ($msg2) = $msgl =~ /.*?( at .*)/s ; &log (-100, "\t$msg2"); return (ERROR); - } - else { + } else { if (wantarray()) { return @res; } @@ -133,13 +134,51 @@ sub test_eval { } } # end of test_eval +### evaluate $zinc->$method(@args); and verifies that AN ERROR occurs +### - a loglevel of -100 means an NO error to be loggued with #### prefix +### - a loglevel of -10 means NO error in the test to be loggued with ## prefix +### - a loglevel of of 0 or greater is for trace only if NO error occured +sub test_no_eval { + my ($reason, $loglevel, $method, @args) = @_; + + my @strs; + my $start_index = 0; + my $string2log = "\$zinc->$method ("; + if (scalar @args) { + if ($method_with_tagOrId{$method} and $args[0] =~ /^\d+$/) { + my $type = $zinc->type($args[0]); + $string2log .= &printableItem($args[0]) . " (a". ucfirst($type) . ")"; + } else { + $string2log .= &printableItem($args[0]) ; + } + $string2log .= ", " if $#args > 0 ; + my $rest = &printableList(@args[1..$#args]); + $rest =~ s/^\(//; ### suppressing the first ( char + $string2log .= $rest; + } else { + $string2log .= ")"; + } + + eval { $zinc->$method (@args) } ; + + # in case of NO error, logging! + if ($@) { +# print "errormsg=$@"; + my ($error_msg) = $@ =~ /(.*)\s*at \/usr\//; + $error_msg = $@ if !defined $error_msg ; + &log ($loglevel, " # When $reason : $string2log;\n # the error msg is: $error_msg\n"); + } else { + &log (-100, "An error SHOULD have occured while evaluating:\n####\t$string2log;\n####\tbecause $reason\n"); + } +} # end of test_no_eval + -### to print something in a readable form -sub printable { +### return a printable string of something in a readable form +sub printableItem { my ($value) = @_; my $ref = ref($value); if ($ref eq 'ARRAY') { - return printables ( @{$value} ); + return printableArray ( @{$value} ); } elsif ($ref eq 'Tk::Photo') { return "Tk::Photo(\"". $value->cget(-file) . "\)"; @@ -147,9 +186,12 @@ sub printable { elsif ($ref eq '') { # scalar if (defined $value) { if ($value eq '') { - return "''"; - } - else { + return "''"; + } elsif ($value =~ /\s/ + or $value =~ /^[a-zA-Z]/ + or $value =~ /^[\W]$/ ) { + return "'$value'"; + } else { return $value; } } @@ -160,22 +202,45 @@ sub printable { else { # some class instance return $value; } -} # end printable +} # end printableItem ### to print an array of something -sub printables { +sub printableArray { my (@values) = @_; if (! scalar @values) { return "[]"; } - else { # the arry is not empty - my @res; - foreach my $value (@values) { - push @res, &printable($value); + else { # the array is not empty + my $res = "[ "; + while (@values) { + my $value = shift @values; + $res .= &printableItem($value); + next unless (@values); + if ($value =~ /^-\w+/) { + $res .= " => "; + } elsif (@_) { + $res .= ", "; + } + } - return ("[ " . join (', ', @res) . " ]") ; + return ($res . " ]") ; } -} # end printables +} # end printableArray + +sub printableList { + my $res = "("; + while (@_) { + my $v = shift @_; + $res .= &printableItem($v); + if (defined $v and $v =~ /^-\w+/) { + $res .= " => "; + } elsif (@_) { + $res .= ", "; + } + } + return $res . ")"; +} # end printableList + ## return 1 if arrays of scalars have the same length and every items are eq sub equal_flat_arrays { @@ -201,7 +266,7 @@ sub nequal_cplx_arrays { my @array1 = @{$refArray1}; my @array2 = @{$refArray2}; -# print "array1=", &printables(@array1), "\narray2=",&printables(@array2),"\n"; +# print "array1=", &printableArray(@array1), "\narray2=",&printableArray(@array2),"\n"; return 'length' if ($#array1 != $#array2); for my $i (0..$#array1) { -- cgit v1.1