From 4fe604aaab62880f20df435c3dc079752a5004c5 Mon Sep 17 00:00:00 2001
From: mertz
Date: Tue, 10 Sep 2002 09:44:31 +0000
Subject: correction de quelques logs erronn�s (End => Start) ajout de logs
 manquants :re-initialisation d'attribut, remove de clone et des originaux
 affichage corrects de tous les ARRAY (et des Tk::Photo) dans les logs

---
 Perl/t/test-no-crash.pl | 87 +++++++++++++++++++++++++++++--------------------
 1 file changed, 52 insertions(+), 35 deletions(-)

(limited to 'Perl/t')

diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl
index 91845a9..cdc5821 100644
--- a/Perl/t/test-no-crash.pl
+++ b/Perl/t/test-no-crash.pl
@@ -372,7 +372,7 @@ sub test_eval {
 	    $start_index = 1;
 	}
 	foreach my $arg (@args[$start_index..$#args]) {
-	    push @strs, &printable (ref($arg), $arg);
+	    push @strs, &printable ($arg);
 	}
     }
     my $string2log = "\$zinc->$method (" . join (", ", @strs) . ")";
@@ -388,13 +388,13 @@ sub test_eval {
     if (wantarray()) {
 	@res = eval { $zinc->$method (@args) } ;
 	if ($method eq 'itemcget' or $method eq 'get') {
-	    &log ($loglevel, "[" . join (", ", @res) . "]\n" );
+	    &log ($loglevel, printables(@res) . "\n" );
 	}
     }
     else {
 	$res = eval { $zinc->$method (@args) } ;
 	if ($method eq 'itemcget' or $method eq 'get') {
-	    &log ($loglevel, (defined $res)? "$res\n" : "undef\n");
+	    &log ($loglevel, &printable($res) . "\n");
 	}
     }
     
@@ -418,10 +418,10 @@ sub test_eval {
 } # end of test_eval
 
 sub test_attributes {
-    &log (0, "---- End 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," ----------------\n");
+	&log (0, "--------- Testing ", (1+$#items), " ",$type," attributes ----------------\n");
 	if ($#items == -1) {
 	    &log (-100, "No such item: $type\n");
 	    next;
@@ -479,20 +479,19 @@ sub test_attributes {
 		    else {
 			@previous_val = $zinc->itemcget($item, $option);
 		    }
-		    &log (1, "\$zinc->itemconfigure($item ($type), $option => ",&printables ($valueRef,@values),"\n");
+		    &log (1, "**  itemconfigure of $item ($type), $option => ",&printables (@values),"\n");
+		    my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType ) ? 0 : 2 ;
 		    foreach my $value (@values) {
-			my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType ) ? 0 : 2 ;
-			&log ( $log_lev, "\$zinc->itemconfigure($item ($type), $option => $value)\n");
-			$zinc->itemconfigure($item, $option => $value);
+			&test_eval ($log_lev, "itemconfigure", $item, $option => $value);
 			$zinc->update;
 			$zinc->after(10);
 		    }
 		    
 		    if ($valueRef eq '') {
-			$zinc->itemconfigure($item, $option => $previous_val);
+			&test_eval ($log_lev, "itemconfigure", $item, $option => $previous_val);
 		    }
 		    else {
-			$zinc->itemconfigure($item, $option => \@previous_val);
+			&test_eval ($log_lev, "itemconfigure", $item, $option => \@previous_val);
 		    }
 		    
 		}
@@ -512,7 +511,7 @@ sub test_attributes {
 # test4: tester qu'en clonant on obtient bien une copie de tous les attributs
 
 sub test_cloning {
-    &log (0, "---- End of test_cloning ----\n");
+    &log (0, "---- Start of test_cloning ----\n");
     &creating_items;
     foreach my $type (@itemtypes) {
 	my $item = $zinc->find('withtype', $type);
@@ -528,8 +527,10 @@ sub test_cloning {
 	&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");
 	&test_eval (1, "remove", $item);
 	&test_every_attributes_once($type,$clone);
+	&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
@@ -622,7 +623,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_arrays (\@original_value, \@clone_value) ) {
-		&log (-100, "Modified cloned $type gets the same value for $option (type $optionType) ". &printable($valueRef, \@original_value) . "\n");
+		&log (-100, "Modified cloned $type gets the same value for $option (type $optionType) ". &printables(@original_value) . "\n");
 	    }
 	}
 	else {  # the value is either a scalar or a class instance
@@ -631,8 +632,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($valueRef,$original_value) .
-		      "?=" . &printable($valueRef,$previous_val) .
+		      "(original=cloned: " . &printable($original_value) .
+		      "?=" . &printable($previous_val) .
 		      " :previous)\n");
 	    }
 	}
@@ -664,8 +665,7 @@ sub test_every_attributes_once {
 	if ($optionType eq 'boolean') { $value = !$zinc->itemcget($item, $option) }
 	
 	my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ;
-	&log ($log_lev, "\$zinc->itemconfigure($item ($type), $option => ". &printable (ref($value), $value) . "\n");
-	&test_eval (1, "itemconfigure", $item, $option => $value);
+	&test_eval ($log_lev, "itemconfigure", $item, $option => $value);
 	$zinc->update;
     }
 } # end test_every_attributes_once
@@ -677,7 +677,7 @@ sub test_every_field_attributes {
 	next unless $itemtypes{$type};
 	my %theoptions = %fieldOptions;
 	my @items = $zinc->find('withtype', $type);
-	&log (0, "--------- Testing fields 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;
@@ -734,16 +734,15 @@ sub test_every_field_attributes {
 			else {
 			    @previous_val = &test_eval (1, "itemcget", $item, $field, $option);
 			}
-			&log (1, "\$zinc->itemconfigure ($item ($type), $field, $option => ",&printables ($valueRef,@values),"\n");
+			&log (1, "**  itemconfigure ($item ($type), $field, $option => ",&printables (@values),"\n");
 			foreach my $value (@values) {
 			    my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ;
-#			&log ( $log_lev, "\$zinc->itemconfigure($item ($type), $field, $option => $value)\n");
 			    &test_eval ($log_lev, "itemconfigure", $item, $field, $option => $value);
 			    $zinc->update;
 			    $zinc->after(10);
 			}
 			
-			if ($valueRef eq '') {
+			if ($valueRef ne 'ARRAY') {
 			    &test_eval (1, "itemconfigure", $item, $field, $option => $previous_val);
 			}
 			else {
@@ -756,37 +755,52 @@ sub test_every_field_attributes {
     }
     &log (0, "---- End of test_every_field_attributes ----\n");
 } # end test_every_field_attributes
-    
+
+
+
+### to print something
 sub printable {
-    my ($ref, $value) = @_;
+    my ($value) = @_;
+    my $ref = ref($value);
     if ($ref eq 'ARRAY') {
-	return ("[" . join ( ', ', @{$value} ) . "]");
+	return printables ( @{$value} );
     }
-    else {  # scalar or class instance
+    elsif ($ref eq 'Tk::Photo') {
+	return "Tk::Photo(\"". $value->cget(-file) . "\)";
+    }
+    elsif ($ref eq '') {  # scalar 
 	if (defined $value) {
-	    return $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 ($ref, @values) = @_;
-    if ($ref eq '') {
-	return ("[ " . join (', ', @values) . " ]") ;
+    my (@values) = @_;
+    if (! scalar @values) {
+	return "[]";
     }
-    elsif ($ref eq 'ARRAY') {
-	my @array;
+    else {  # the arry is not empty
+	my @res;
 	foreach my $value (@values) {
-	    push @array, &printable ($ref, $value);
+	    push @res, &printable($value);
 	}
-	return ("[ " . join ( ', ', @array) . " ]" );
+	return ("[ " . join (', ', @res) . " ]") ;
     }
 } # end printables
 
-
 ## return 1 if arrays have the same length and every items are eq 
 sub equal_arrays {
     my ($refArray1, $refArray2) = @_;
@@ -839,7 +853,10 @@ sub test_mapitems {
 
 &test_every_field_attributes;
 &test_attributes; # on peut configurer tous les attributs
-&test_cloning; # le clonage fonctionne correctement !
+
+### we SHOULD test that setting a bad type value ofr an option does not core dump zinc!
+
+&test_cloning; # we test that cloning items and modifiyng/removing them does not core dump
 
 # #### &test_path_tags;
 # #### &test_illegal_tags;
-- 
cgit v1.1