diff options
Diffstat (limited to 'Perl/t/TestLog.pm')
| -rw-r--r-- | Perl/t/TestLog.pm | 231 |
1 files changed, 231 insertions, 0 deletions
diff --git a/Perl/t/TestLog.pm b/Perl/t/TestLog.pm new file mode 100644 index 0000000..55f40c0 --- /dev/null +++ b/Perl/t/TestLog.pm @@ -0,0 +1,231 @@ +package TestLog; + +# $Id$ +# These test facilities has been developped by C. Mertz <mertz@cena.fr> + +use IO::Handle; # for autoflushing the logs +use Carp; + +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 + equal_flat_arrays nequal_cplx_arrays); + +use constant ERROR => '--an error--'; + +my $opt_log; +sub openLog { + my ($outfile); + ($outfile,$opt_log) = @_; + + + if ( open LOG, "$outfile.prev" ) { + close LOG; + unlink "$outfile.prev"; + } + if ( open LOG, $outfile ) { + close LOG; + link $outfile, "$outfile.prev"; + unlink "$outfile"; + } + + open LOG,">$outfile"; + autoflush LOG 1; # autoflush is important so that logs are up-to-date if Zinc crashes! +} + + + +### 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 0 means an message to be usually printed (and logged in any case) +### - a loglevel greater than 1 is for trace only + + +sub log { + my ($loglevel, @strgs) = @_; + if ($loglevel <= $opt_log) { + print "%%%% " if $loglevel == -100; + print "%% " if $loglevel == -10; + print @strgs; + } + print LOG "%%%% " if $loglevel == -100; + print LOG "%% " if $loglevel == -10; + print LOG @strgs; +} # end log + +my $zinc; +## to init the $zinc +sub setZincLog { + ($zinc)=@_; +} + + +my %method_with_tagOrId = + ("anchorxy" => 1, "bbox" => 1, "bind" => 1, "chggroup" => 1, + "clone" => 1, "contour" => 1, "coords"=> 1, "cursor" => 1, + "dchars" => 1, "dtag" => 1, "focus" => 1, "gettags" => 1, + "group" => 1, # blabla... to complete + "itemcget" => 1, "itemconfigure" => 1, # blabla... to complete + "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 +sub test_eval { + my ($loglevel, $method, @args) = @_; + + my @strs; + my $start_index = 0; + 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); + } + } + my $string2log = "\$zinc->$method (" . join (", ", @strs) . ")"; + if ($method eq 'itemcget' or $method eq 'get') { + $string2log .= " := " ; + } + else { + $string2log .= "\n"; + } + &log ($loglevel, $string2log); + + my (@res, $res); + if (wantarray()) { + @res = eval { $zinc->$method (@args) } ; + if ($method eq 'itemcget' or $method eq 'get') { + &log ($loglevel, printables(@res) . "\n" ); + } + } + else { + $res = eval { $zinc->$method (@args) } ; + if ($method eq 'itemcget' or $method eq 'get') { + &log ($loglevel, &printable($res) . "\n"); + } + } + + + if ($@) { # in case of error, logging! + &log (-100, "Error while evaluating: $string2log"); + &log (-100, $@); + my $msgl = &Carp::longmess; + my ($msg2) = $msgl =~ /.*?( at .*)/s ; + &log (-100, "\t$msg2"); + return (ERROR); + } + else { + if (wantarray()) { + return @res; + } + else { + return $res; + } + } +} # end of test_eval + + +### to print something in a readable form +sub printable { + my ($value) = @_; + my $ref = ref($value); + if ($ref eq 'ARRAY') { + return printables ( @{$value} ); + } + elsif ($ref eq 'Tk::Photo') { + return "Tk::Photo(\"". $value->cget(-file) . "\)"; + } + elsif ($ref eq '') { # scalar + if (defined $value) { + if ($value eq '') { + return "''"; + } + else { + return $value; + } + } + else { + return "undef"; + } + } + else { # some class instance + return $value; + } +} # end printable + +### to print an array of something +sub printables { + my (@values) = @_; + if (! scalar @values) { + return "[]"; + } + else { # the arry is not empty + my @res; + foreach my $value (@values) { + push @res, &printable($value); + } + return ("[ " . join (', ', @res) . " ]") ; + } +} # end printables + +## return 1 if arrays of scalars have the same length and every items are eq +sub equal_flat_arrays { + my ($refArray1, $refArray2) = @_; + my @array1 = @{$refArray1}; + my @array2 = @{$refArray2}; + + return 0 if ($#array1 != $#array2); + + for my $i (0..$#array1) { + return 0 if ($array1[$i] ne $array2[$i]); + } + return 1; +} # equal_arrays + + +## return 0 if arrays of anything are equal +## return 'length' if their length are different +## return xx if some elements are différents +## arrays may be arrays of arrays of arrays ... +sub nequal_cplx_arrays { + my ($refArray1, $refArray2) = @_; + my @array1 = @{$refArray1}; + my @array2 = @{$refArray2}; + +# print "array1=", &printables(@array1), "\narray2=",&printables(@array2),"\n"; + return 'length' if ($#array1 != $#array2); + + for my $i (0..$#array1) { + my $el1 = $array1[$i]; + my $el2 = $array2[$i]; + + if (ref($el1)) { +# print "REF el1=",ref($el1),"\n"; + if (!ref($el2)) { + return "elts at index $i are different: $el1 != $el2\n"; + } elsif (ref($el2) ne ref($el1)) { + return "elts at index $i are of different type: ". + ref($el2), " ne ", ref($el1), "\n"; + } elsif (ref($el2) eq 'ARRAY') { + if (my $res = &nequal_cplx_arrays ($el1,$el2)) { + return "elts at index $i are different: $res"; + } + } + } elsif (ref($el2) or $el1 ne $el2) { + return "elts at index $i are different $el1 != $el2\n"; + } + } + return 0; +} # nequal_cplx_arrays + + +1; |