aboutsummaryrefslogtreecommitdiff
path: root/Perl/t/TestLog.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Perl/t/TestLog.pm')
-rw-r--r--Perl/t/TestLog.pm231
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;