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 ++++++++++++++++++++++++++++++++++--------------
 Perl/t/test-no-crash.pl |  70 ++++++++++-----------
 2 files changed, 146 insertions(+), 81 deletions(-)

(limited to 'Perl/t')

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) {
diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl
index d74c86f..dda953b 100644
--- a/Perl/t/test-no-crash.pl
+++ b/Perl/t/test-no-crash.pl
@@ -87,7 +87,7 @@ sub usage {
 
 my $mw = MainWindow->new();
 
-&log (0, "testing Zinc-perl Version=" . $Tk::Zinc::VERSION . " - ", $mw->zinc(), "\n");
+&log (0, "#testing Zinc-perl Version=" . $Tk::Zinc::VERSION . " - ", $mw->zinc(), "\n");
 
 ## must be done after the LOG file is open
 my @tests = &parseTestsOpt($opt_tests);
@@ -356,10 +356,10 @@ $mw->Button(-text => "Test fields attributes",
 	    )->pack(-pady => 4);   
 
 sub test_attributes {
-    &log (0, "---- Start of test_attributes ----\n");
+    &log (0, "#---- Start of test_attributes ----\n");
     foreach my $type (@itemtypes) {
 	my @items = $zinc->find('withtype', $type);
-	&log (0, "--------- Testing ", (1+$#items), " ",$type," attributes ----------------\n");
+	&log (0, "#--------- Testing ", (1+$#items), " ",$type," attributes ----------------\n");
 	if ($#items == -1) {
 	    &log (-100, "No such item: $type\n");
 	    next;
@@ -384,11 +384,11 @@ sub test_attributes {
 		    $boolean_attributes{$option}=1;
 		}
 	    }
-	    &log (0, $type, "(id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n"));
+	    &log (0, "# $type (id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n"));
 	    foreach my $i (0 .. (2**(1+$#boolean_attributes) -1) ) {
 		my $format = "%0" . ($#{boolean_attributes} +1) . "b";
 		my $binary = sprintf ($format,$i);
-		&log (0, $i, "/", (2**(1+$#boolean_attributes)), "  $binary\n");
+		&log (0, "# $i/", (2**(1+$#boolean_attributes)), "  $binary\n");
 		my @binary = split (//,$binary);
 		foreach my $j (0 .. $#boolean_attributes) {
 		    &test_eval (0, "itemconfigure", $item, $boolean_attributes[$j] => $binary[$j] );
@@ -417,7 +417,7 @@ sub test_attributes {
 		    else {
 			@previous_val = $zinc->itemcget($item, $option);
 		    }
-		    &log (1, "**  itemconfigure of $item ($type), $option => ",&printables (@values),"\n");
+		    &log (1, "#**  itemconfigure of $item ($type), $option => ",&printableList (@values),"\n");
 		    my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType ) ? 0 : 2 ;
 		    foreach my $value (@values) {
 			&test_eval ($log_lev, "itemconfigure", $item, $option => $value);
@@ -436,7 +436,7 @@ sub test_attributes {
 	    }
 	}
     }
-    &log (0, "---- End of test_attributes ----\n");
+    &log (0, "#---- End of test_attributes ----\n");
 } # end test_attributes
 
 
@@ -449,26 +449,26 @@ sub test_attributes {
 # test4: tester qu'en clonant on obtient bien une copie de tous les attributs
 
 sub test_cloning {
-    &log (0, "---- Start of test_cloning ----\n");
+    &log (0, "#---- Start of test_cloning ----\n");
     &creating_items;
     foreach my $type (@itemtypes) {
 	my $item = $zinc->find('withtype', $type);
-	&log (0, "--------- Cloning and testing item ",$type," ----------------\n");
+	&log (0, "#--------- Cloning and testing item ",$type," ----------------\n");
 	if (!defined $item) { &log (-10, "No such item: $type\n"); next;};
 	my $clone = &test_eval(1, "clone", $item);
 
-	&log (0, "---- Modifying the clone $clone\n");
+	&log (0, "#---- Modifying the clone $clone\n");
 	&test_a_clone ($type, $item, $clone);
 	&test_enclosed_overlapping_closest($type, 'original', $item, $zinc->bbox ($item));
 	&test_enclosed_overlapping_closest($type, 'clone', $clone, $zinc->bbox ($clone));
-	&log (0, "---- Modifying the original\n");
+	&log (0, "#---- Modifying the original\n");
 	&test_a_clone ($type, $clone, $item);
 	&test_enclosed_overlapping_closest($type, 'original', $item, $zinc->bbox ($item));
 	&test_enclosed_overlapping_closest($type, 'clone', $clone, $zinc->bbox ($clone));
-	&log (0, "---- Deleting the original\n");
+	&log (0, "#---- Deleting the original\n");
 	&test_eval (1, "remove", $item);
 	&test_every_attributes_once($type,$clone);
-	&log (0, "---- Deleting the clone\n");
+	&log (0, "#---- Deleting the clone\n");
 	&test_eval (1, "remove", $clone);
     }
     # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
@@ -489,7 +489,7 @@ sub test_cloning {
     # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
     # tester le closest avec le centre de la bbox
      
-    &log (0, "---- End of test_cloning ----\n");
+    &log (0, "#---- End of test_cloning ----\n");
 } # end test_cloning
 
 ## teste le find enclosed / overlapping avec un rectangle un peu plus grand
@@ -561,7 +561,7 @@ sub test_a_clone {
 	    my @original_value = &test_eval (2, "itemcget", $original, $option);
 	    my @clone_value = &test_eval (1, "itemcget", $clone, $option);
 	    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");
+		&log (-100, "Modified cloned $type gets the same value for $option (type $optionType) ". &printableArray(@original_value) . "\n");
 	    }
 	}
 	else {  # the value is either a scalar or a class instance
@@ -570,8 +570,8 @@ sub test_a_clone {
 	    if (defined $original_value && $original_value eq $clone_value) {
 #		print "ORIGIN = ",$original_value, " $original_value CLONE = ",$clone_value,"\n";
 		&log (-100, "Modified cloned $type gets the same value for $option (type $optionType) " .
-		      "(original=cloned: " . &printable($original_value) .
-		      "?=" . &printable($previous_val) .
+		      "(original=cloned: " . &printableItem($original_value) .
+		      "?=" . &printableItem($previous_val) .
 		      " :previous)\n");
 	    }
 	}
@@ -610,12 +610,12 @@ sub test_every_attributes_once {
 
 
 sub test_every_field_attributes {
-    &log (0, "---- Start of test_every_field_attributes ----\n");
+    &log (0, "#---- Start of test_every_field_attributes ----\n");
     foreach my $type qw(waypoint track tabular) {
 	next unless $itemtypes{$type};
 	my %theoptions = %fieldOptions;
 	my @items = $zinc->find('withtype', $type);
-	&log (0, "--------- Testing field attributes of ", (1+$#items), " ",$type,"(s) ----------------\n");
+	&log (0, "#--------- Testing field attributes of ", (1+$#items), " ",$type,"(s) ----------------\n");
 	if ($#items == -1) {
 	    &log (-100, "No such item: $type\n");
 	    next;
@@ -637,14 +637,14 @@ sub test_every_field_attributes {
 		    $boolean_attributes{$option}=1;
 		}
 	    }
-	    &log (0, $type, "(id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n"));
+	    &log (0, "# $type (id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n"));
 	    foreach my $i (0 .. (2**(1+$#boolean_attributes) -1) ) {
 		my $format = "%0" . ($#{boolean_attributes} +1) . "b";
 		my $binary = sprintf ($format,$i);
-		&log (0, $i, "/", (2**(1+$#boolean_attributes)), "  $binary\n");
+		&log (0, "# $i/", (2**(1+$#boolean_attributes)), "  $binary\n");
 		my @binary = split (//,$binary);
 		foreach my $j (0 .. $#boolean_attributes) {
-		    &log (0, "setting $type ($item) field 0..",$zinc->itemcget($item, -numfields)-1,  " ", $boolean_attributes[$j], " to ", $binary[$j], "\n");
+		    &log (0, "# setting $type ($item) field 0..",$zinc->itemcget($item, -numfields)-1,  " ", $boolean_attributes[$j], " to ", $binary[$j], "\n");
 		    foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) {
 			&test_eval (1, "itemconfigure", $item, $field, $boolean_attributes[$j] => $binary[$j] );
 		    }
@@ -672,7 +672,7 @@ sub test_every_field_attributes {
 			else {
 			    @previous_val = &test_eval (1, "itemcget", $item, $field, $option);
 			}
-			&log (1, "**  itemconfigure ($item ($type), $field, $option => ",&printables (@values),"\n");
+			&log (1, "#**  itemconfigure ($item ($type), $field, $option => ",&printableList (@values),"\n");
 			foreach my $value (@values) {
 			    my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ;
 			    &test_eval ($log_lev, "itemconfigure", $item, $field, $option => $value);
@@ -691,7 +691,7 @@ sub test_every_field_attributes {
 	    }
 	}
     }
-    &log (0, "---- End of test_every_field_attributes ----\n");
+    &log (0, "#---- End of test_every_field_attributes ----\n");
 } # end test_every_field_attributes
 
 
@@ -713,7 +713,7 @@ sub createMapInfo {
 
 sub test_mapitems {
     my @mapinfoNames = @_;
-    &log (0, "---- Start of test_mapitems ----\n");
+    &log (0, "#---- Start of test_mapitems ----\n");
     my @maps = $zinc->find('withtype', 'map');
     my $counter=0;
     foreach my $map (@maps) {
@@ -721,12 +721,12 @@ sub test_mapitems {
 	if ($counter == $#maps) { $counter=0 }
 	$counter++;
     }
-    &log (0, "---- End of test_mapitems ----\n");
+    &log (0, "#---- End of test_mapitems ----\n");
 } # end test_mapitems
 
 ## testing the returned value of coords
 sub test_coords {
-    &log (0, "---- Start of test_coords ----\n");
+    &log (0, "#---- Start of test_coords ----\n");
     foreach my $it ($zinc->find('withtag','*')) {
 	$zinc->remove($it);
     }
@@ -736,16 +736,16 @@ sub test_coords {
 	next if $type eq 'map'; ## map item does not support coords method
 	my $it = $zinc->find('withtype',$type);
 	my @coordsAll= &test_eval (1, "coords", $it);
-	my $coordsAll = &printables(@coordsAll);
+	my $coordsAll = &printableArray(@coordsAll);
 	&log (1, "=> $coordsAll\n");
 	my @coordsContour= &test_eval (1, "coords", $it,0); # all items have 1 contour
-	my $coordsContour = &printables(@coordsContour);
+	my $coordsContour = &printableArray(@coordsContour);
 	&log (1,"=> $coordsContour\n");
 	my @coordsPoint= &test_eval (1, "coords", $it,0,0); # all items have 1 contour with at least one point
-	my $coordsPoint = &printables(@coordsPoint);
+	my $coordsPoint = &printableArray(@coordsPoint);
 	&log (1,"=> $coordsPoint\n");
     }
-    &log (0, "---- End of test_coords ----\n");
+    &log (0, "#---- End of test_coords ----\n");
 }
     
 sub parseTestsOpt {
@@ -760,7 +760,7 @@ sub parseTestsOpt {
 	}
 	exit;
     } elsif ( $opt eq 'all' ) { ## default!
-	&log (0, "all tests will be passed through\n");
+	&log (0, "# all tests will be passed through\n");
 	@tests = sort keys %testsHash;
     } elsif ( $opt =~ /^\d+(,\d+)*$/ ) {
 	@tests = split (/,/ , $opt);
@@ -768,9 +768,9 @@ sub parseTestsOpt {
 	foreach my $test (@tests) {
 	    die "tests num must not exceed $testnumb" if $test > $testnumb;
 	}
-	&log(0,  "Test to be done:\n");
+	&log(0,  "# Tests to be done:\n");
 	foreach my $test (@tests) {
-	    &log(0,  "\t$test => " . $testsHash{$test} . "\n");
+	    &log(0,  "\t# $test => " . $testsHash{$test} . "\n");
 	}
     } else {
 	print "bad -tests value. Must be a list of integer separated by ,\n";
@@ -824,6 +824,6 @@ if ($tests{5}) {
 #  cloning, deleting topgroup
 #
 
-&log (0, "---- End of test_no_crash ----\n");
+&log (0, "#---- End of test_no_crash ----\n");
 
 MainLoop();
-- 
cgit v1.1