utilisation de TestLog.pm

fonctionnalit� identique

1 files changed, 12 insertions, 164 deletions

diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl
index 45db8ec..d74c86f 100644
--- a/Perl/t/test-no-crash.pl
+++ b/Perl/t/test-no-crash.pl
@@ -5,8 +5,7 @@
 use Tk;
 use Tk::Zinc;
 use Getopt::Long;
-use IO::Handle;    # for autoflushing the logs
-use Carp;
+use TestLog;
 
 use strict;
 
@@ -65,18 +64,7 @@ unless ($opt_render==0 or $opt_render==1 or $opt_render==2) {
 
 $outfile = "no-crash-$Tk::Zinc::VERSION.log" if (!defined $outfile);
 
-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;
+&openLog($outfile, $opt_log);
 
 sub usage {
     my ($text) = @_;
@@ -122,6 +110,8 @@ my $zinc = $mw->Zinc(-width => 500, -height => 500,
 		     -render => $opt_render,
 		     )->pack;
 
+&setZincLog($zinc);
+
 
 my %itemtypes;
 my @itemtypes = qw(arc tabular track waypoint
@@ -365,96 +355,6 @@ $mw->Button(-text => "Test fields attributes",
 	    -command => sub {&test_every_field_attributes},
 	    )->pack(-pady => 4);   
 
-### 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 %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
-
 sub test_attributes {
     &log (0, "---- Start of test_attributes ----\n");
     foreach my $type (@itemtypes) {
@@ -660,7 +560,7 @@ sub test_a_clone {
 	if ($valueRef eq 'ARRAY') {  # the value is a list
 	    my @original_value = &test_eval (2, "itemcget", $original, $option);
 	    my @clone_value = &test_eval (1, "itemcget", $clone, $option);
-	    if ( &equal_arrays (\@original_value, \@clone_value) ) {
+	    if ( &equal_flat_arrays (\@original_value, \@clone_value) ) {
 		&log (-100, "Modified cloned $type gets the same value for $option (type $optionType) ". &printables(@original_value) . "\n");
 	    }
 	}
@@ -795,65 +695,6 @@ sub test_every_field_attributes {
 } # end test_every_field_attributes
 
 
-
-### to print something
-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 have the same length and every items are eq 
-sub equal_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
-
-
 sub createMapInfo {
     my ($name, $N,$deltaN, $radius, $centerX,$centerY) = @_;
     &test_eval (1, "mapinfo", $name, 'create'); 
@@ -975,6 +816,13 @@ if ($tests{5}) {
 # #### &test_path_tags;
 # #### &test_illegal_tags;
 
+# #### &test_illegal_call
+# for example:
+#  calling a methode for an non-existing item
+#  getting coords, contours, fields, etc... of non-existing index
+#
+#  cloning, deleting topgroup
+#
 
 &log (0, "---- End of test_no_crash ----\n");