une version qui teste le clonage ainsi que la suppression apres clonage

1 files changed, 239 insertions, 85 deletions

diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl
index 3dde2ee..5d92eac 100644
--- a/Perl/t/test-no-crash.pl
+++ b/Perl/t/test-no-crash.pl
@@ -5,9 +5,12 @@
 use Tk;
 use Tk::Zinc;
 use Getopt::Long;
+use IO::Handle;    # for autoflushing the logs
 
 use strict;
 
+unshift (@INC, "/usr/lib/perl5/Tk");  # for getting Tk some images;
+
 # les variables positionnées en fonction des options de la ligne de commande
 my $opt_log = 0;
 my $opt_trace = "";
@@ -22,6 +25,19 @@ my $optstatus = GetOptions('log=i' => \$opt_log,
 			   'type=s' => \$opt_type,
 			   );
 
+if ( open LOG, "no-crash.log.prev" ) {
+    close LOG;
+    unlink "no-crash.log.prev";
+}
+if ( open LOG, "no-crash.log" ) {
+    close LOG;
+    link "no-crash.log", "no-crash.log.prev";
+    unlink "no-crash.log";
+}
+
+open LOG,">no-crash.log";
+
+autoflush LOG 1;
 
 my $mw = MainWindow->new();
 
@@ -33,6 +49,7 @@ zinc is not core-dumping!",
 
 # Creating the zinc widget
 my $zinc = $mw->Zinc(-width => 500, -height => 500,
+		     -trackmanagedhistorysize => 10,
 		     -font => "10x20", # usually fonts are sets in resources
 		                       # but for this example it is set in the code!
 		     -borderwidth => 0, -relief => 'sunken',
@@ -55,9 +72,9 @@ $zinc->add('group', 1);
 $zinc->add('icon', 1);
 $zinc->add('map', 1);
 $zinc->add('reticle', 1);
-$zinc->add('text', 1,  -position => [300,120], -text => "hello world1");
-$zinc->add('text', 1,  -position => [400,220], -text => "hello world2");
-$zinc->add('text', 1,  -position => [400,220], -text => "hello world3");
+my $text1 = $zinc->add('text', 1,  -position => [300,120], -text => "hello world1");
+my $text2 = $zinc->add('text', 1,  -position => [350,170], -text => "hello world2");
+my $text3 = $zinc->add('text', 1,  -position => [400,220], -text => "hello world3");
 $zinc->add('window', 1);
 $zinc->add('track', 1, 5, -position => [100,20]);
 $zinc->add('waypoint', 1, 5, -position => [100,20]);
@@ -78,13 +95,18 @@ $zinc->add('rectangle', 1, [400,400 , 450,220]);
 $zinc->add('triangles', 1, [200,200 , 300,200 , 300,300, 200,300],
  	   -colors => ["blue:50", "red:20", "green:80"]);
 
+my $image1 = $zinc->Photo(-file => Tk::findINC("icon.gif") );
+my $image2 = $zinc->Photo(-file => Tk::findINC("Xcamel.gif") );
+my $image3 = $zinc->Photo(-file => Tk::findINC("tranicon.gif") );
+my $image4 = $zinc->Photo(-file => Tk::findINC("anim.gif") );
+
 
 my %options;
 my %types;
 
 foreach my $itemType (@itemtypes) {
     my $anItem = $zinc->find('withtype', $itemType);
-    if (!defined $anItem) { print "no item $itemType\n"; next;};
+    if (!defined $anItem) { &log (-10, "no item $itemType\n"); next;};
     my @options = $zinc->itemconfigure($anItem);
     for my $elem (@options) {
 	my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem;
@@ -112,11 +134,9 @@ my %typesValues =
 			 'cll', 'clr', 'clc', 'crl', 'crr', 'crc', 'ccl', 'ccr', 'ccc',
 			 '-',],
      'boolean' => [0..1],
-#     'bitmap' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple7', 'AlphaStipple11', 'AlphaStipple14'], ####?!
      'pattern' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ####?!
      'patterns' => [['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ['AlphaStipple0']], ##TBC
      'capstyle' => ['butt', 'projecting', 'round'],
-#     'color' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444', 'red'], #TBC
      'gradient' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444', 'red'], ## TBC
      'gradients' => [['green'], ['LemonChiffon'], ['#c84'], ['#4488cc'], ['#888ccc444'],
 		     ['red', 'green'], ['red', 'green', 'blue'],
@@ -126,16 +146,15 @@ my %typesValues =
      'dimension' => [0..5, 10, 50, 100, 0.0, 5.5, 100.5, 4.5],  ## and floats ?!
      'edgelist' => ['left', 'right', 'top', 'bottom', 'contour', 'oblique', 'counteroblique'], ## +combinations!
      'font' => ['10x20', '6x10', '6x12', '6x13'],
-#     'gradientcolor' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444'], ## TBC
-     'image' => [], ## TBC
+     'image' => [$image1, $image2, $image3], ## TBC
      'integer' => [-10000, -100, -1, 0, 1, 10, 10000], ## pour quoi?
-     'item' => [],
+     'item' => [$text1, $text2],
      'joinstyle' => ['bevel', 'miter', 'round'],
      'labelformat' => [
 		       "200x10", ## BUG BUG
 #		       "200x100 x100x20+0+0 x100x20+0+20 x200x40+100+20"
 		       ],
-     'leaderanchors' => [], # [ "%10%30", "% 40 % 20", "% 67 % 21" ], ## TBC
+     'leaderanchors' => ["%10x30", "%40x20", "%67x21" ], ## TBC! non exchaustif!! BUG non conforme à la doc
      'lineend' => [ [10,10,10], [10,100,10], [100,10,10], [10,10,100], [100,10,100] ],
      'lineshape' => ['straight', 'rightlightning', 'leftlightning', 'rightcorner', 'leftcorner', 'doublerightcorner', 'doubleleftcorner'],
      'linestyle' => ['dotted', 'simple', 'dashed', 'mixed', 'dotted'],
@@ -147,7 +166,6 @@ my %typesValues =
 		  'roundraised', 'roundsunken', 'roundgroove',
 		  'roundridge', 'sunkenrule', 'raisedrule'],
      'text' => ['teststring', 'short', 'veryverylongstring'],
-#     'taglist' => [], ## TBC
      'tags' => [ [1], [1..2], ['a','b'], ['tag1','tag2','tag3']],
      'unsignedint' => [ 0..5 , 10, 20, 30, 100 ],
      'window' => [], ## TBC
@@ -169,9 +187,9 @@ my %typesNonStandardValues =
      'dimension' => 45,
      'edgelist' => 'contour',
      'font' => '6x10',
-     'image' => [], ## TBC
+     'image' => $image4,
      'integer' => 7,
-     'item' => [],
+     'item' => $text3,
      'joinstyle' => 'miter',
      'labelformat' => "200x30", ## BUG BUG
      'leaderanchors' => "%10x60", ## BUG BUG
@@ -185,8 +203,8 @@ my %typesNonStandardValues =
      'relief' => 'groove',
      'text' => 'notsoshort',
      'tags' => ['tag1','tag11','tag111'],
-     'unsignedint' => 22,
-     'window' => undef, ## TBC
+     'unsignedint' => 7, # 22,    # 22 is to high for -visiblehistorysize and 5 is, the default value for reticle -period
+     'window' => undef, ### TBC
  );
     
 my %typesFalseValues =
@@ -204,7 +222,7 @@ my %typesFalseValues =
 
 
 $mw->Button(-text => "Test options",
-	    -command => sub {&test_options},
+	    -command => sub {&test_attributes},
 	    )->pack(-pady => 4);   
 
 $mw->Button(-text => "Test cloning",
@@ -212,14 +230,22 @@ $mw->Button(-text => "Test cloning",
 	    )->pack(-pady => 4);   
 
     
-
-
+### print log information to the logfile
+### if $level is lower than opt_log alos print log on the stdout
+sub log {
+    my ($level, @strgs) = @_;
+    print @strgs if $level <= $opt_log ;
+    print LOG @strgs;
+}
 
 sub test_attributes {
     foreach my $type (@itemtypes) {
 	my @items = $zinc->find('withtype', $type);
-	print "---------testing ", (1+$#items), " ",$type,"(s) ----------------\n";
-	if ($#items == -1) { print "*** no such item: $type\n"; next;};
+	&log (0, "---------testing ", (1+$#items), " ",$type,"(s) ----------------\n");
+	if ($#items == -1) {
+	    &log (-100, "*** no such item: $type\n");
+	    next;
+	}
 	my %theoptions = %{$options{$type}};
 	foreach my $item (@items) {
 	    ## il faudrait tester les options selon un ordre défini à l'avance
@@ -240,26 +266,29 @@ sub test_attributes {
 		    $boolean_attributes{$option}=1;
 		}
 	    }
-	    print $type, "(id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n");
+#	    print $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);
-		print $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) {
 		    $zinc->itemconfigure( $item, $boolean_attributes[$j] => $binary[$j] );
-		    print "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n";
+#		    print "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n";
+		    &log (0, "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n");
 		}
 		foreach my $option (sort keys %theoptions) {
-		    next if ($option eq -numfields);
+		    next if ($option eq -numfields); # BUG? makes the appli stop
+		    next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random clipping item must belong to the group
 		    next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested
 
 		    my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
 		    my $typeValues = $typesValues{$optionType};
-		    if (!defined $typeValues) {print "*** no values for type $optionType (option $option)\n";next;}
+		    if (!defined $typeValues) {&log (-100, "*** no values for type $optionType (option $option)\n");next;}
 		    my @values = @{$typeValues};
 
-		    if (!@values) {print "*** no values for type $optionType (option $option)\n";next;}
+		    if (!@values) {&log (-100, "*** no values for type $optionType (option $option)\n");next;}
 			
 
 		    my $valueRef = ref ($values[0]);
@@ -272,12 +301,13 @@ sub test_attributes {
 		    else {
 			@previous_val = $zinc->itemcget($item, $option);
 		    }
-		    print "\$zinc->itemconfigure($item ($type), $option => ",join (", ",@values),"\n"
-			if ($opt_log == 1);
+		    &log (1, "\$zinc->itemconfigure($item ($type), $option => ",&printables ($valueRef,@values),"\n");
+#			if ($opt_log == 1);
 		    foreach my $value (@values) {
-#			next unless $optionType eq "gradient";
-			print "\$zinc->itemconfigure($item ($type), $option => $value)\n"
-			    if ($opt_log > 1 || $opt_trace eq $option || $opt_trace eq $optionType );
+			my $log_lev = 2;
+			$log_lev = 0 if ($opt_trace eq $option || $opt_trace eq $optionType ) ;
+			&log ( $log_lev, "\$zinc->itemconfigure($item ($type), $option => $value)\n");
+#			    if ($opt_log > 1 || $opt_trace eq $option || $opt_trace eq $optionType );
 			$zinc->itemconfigure($item, $option => $value);
 			$zinc->update;
 			$zinc->after(10);
@@ -295,7 +325,7 @@ sub test_attributes {
 	    }
 	}
     }
-    print "End of test_option\n";
+    &log (0, "End of test_option\n");
 }
 
 
@@ -305,62 +335,26 @@ sub test_attributes {
 # test3: tester toutes les fonctions aléatoirement selon les signatures
 
 
-# test4: tester qu'ne clonant ont obtient bien une copie de tous les attributs
+# test4: tester qu'en clonant on obtient bien une copie de tous les attributs
 
 sub test_cloning {
     foreach my $type (@itemtypes) {
 	my $item = $zinc->find('withtype', $type);
-	print "---------cloning and testing item ",$type,"(s) ----------------\n";
-	if (!defined $item) { print "*** no such item: $type\n"; next;};
+	&log (0, "---------cloning and testing item ",$type,"(s) ----------------\n");
+	if (!defined $item) { &log (-100, "*** no such item: $type\n"); next;};
 	my $clone = $zinc->clone($item);
-	my %theoptions = %{$options{$type}};
-	## il faudrait tester les options selon un ordre défini à l'avance
-	## en passant par plusieurs occurences pour les options et en forçant
-	## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled)
-	foreach my $option (sort keys %theoptions) {
-	    next if ($option eq -numfields);
-	    my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
-	    my $value = $typesNonStandardValues{$optionType};
-#	    if ($optionType ne 'boolean' && !defined $value) {print "*** no values for type $optionType (option $option)\n";next;}
-
-	    my $valueRef = ref ($value);
-	    my $previous_val;
-	    my @previous_val;
-
-	    # memoryzing previous value of the clone 
-	    if ($valueRef eq '') {
-		$previous_val = $zinc->itemcget($clone, $option);
-	    }
-	    else {
-		@previous_val = $zinc->itemcget($clone, $option);
-	    }
 
-	    # in the case of boolean, we must always take the not value:
-	    if ($optionType eq 'boolean') { $value = !$previous_val }
-
-	    print "\$zinc->itemconfigure(clone $clone of $item ($type), $option => $value)\n"
-		if ($opt_log > 1 || $opt_trace eq $option || $opt_trace eq $optionType );
-	    $zinc->itemconfigure($clone, $option => $value);
-	    $zinc->update;
-#	    $zinc->after(10);
-	    if ($valueRef eq '') {
-		my $original_value = $zinc->itemcget($item, $option);
-		my $clone_value = $zinc->itemcget($clone, $option);
-#		print "original = $original_value\n";
-#		print "clone    = $clone_value\n";
-		if (defined $original_value && $original_value eq $clone_value) {
-		    print "*** Cloned $type gets the same $option (type $optionType) ($original_value ?= $previous_val)\n";
-		}
-	    }
-	    else {  # the value is a list
-	    print "option $option is waiting a list $valueRef\n";		
-	    }
-
-	    # setting back the previous value
-	    if ($valueRef eq '') { $zinc->itemconfigure($clone, $option => $previous_val) }
-	    else { $zinc->itemconfigure($clone, $option => \@previous_val) }
-	    
-	}
+	&log (0, "---- modifying the 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");
+	&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));
+	$zinc->remove($item);
+	&test_every_attributes_once($type,$clone);
+	$zinc->remove($clone);
     }
     # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox
     # tester le closest avec le centre de la bbox
@@ -380,13 +374,173 @@ 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
      
-    print "End of test_cloning\n";
+    &log (0, "End of test_cloning\n");
 }
-    
 
+## teste le find enclosed / overlapping avec un rectangle un peu plus grand
+#  que la bbox donnée en paramètre.
+#  si $item est différent de '', vérifie que l'item est enclosed/overlapping 
+## Vérifie aussi le fonctionnement ud closest pour le centre de la bbox
+sub test_enclosed_overlapping_closest {
+    my ($type, $clone_or_original, $item, @bbox) = @_;
+    if ($#bbox == -1) {
+	&log(-100, "*** undef bbox of a $type ($clone_or_original)\n");
+    }
+    else {
+	@bbox = ( $bbox[0]-10, $bbox[1]-10, $bbox[2]+10, $bbox[3]+10 );
+	my @items = $zinc->find ('enclosed', @bbox);
+	goto TESTOVERLAPPING if ($item eq '');
+	foreach my $i (@items) {
+	    goto TESTOVERLAPPING if ($i eq $item); # the item is included!
+	}
+	&log(-100, "*** the $type ($clone_or_original) is not enclosed in its bbox!\n");
+  TESTOVERLAPPING:
+	@items = $zinc->find ('overlapping', @bbox);
+	goto TESTCLOSEST if ($item eq '');
+	foreach my $i (@items) {
+	    goto TESTCLOSEST if ($i eq $item);
+	}
+	&log(-100, "*** the $type ($clone_or_original) is not overlapping its bbox!\n");
+  TESTCLOSEST:
+	my $x = ($bbox[0] + $bbox[2] )/2;
+	my $y = ($bbox[1] + $bbox[3] )/2;
+	my $closest = $zinc->find ('closest', $x,$y);
+    }
+}
+
+sub test_a_clone {
+    my ($type, $original, $clone) = @_;
+    my %theoptions = %{$options{$type}};
+    foreach my $option (sort keys %theoptions) {
+	next if ($option eq -numfields); # BUG? makes the appli stop
+	next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random. Clipping item must belong to the group
+	my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
+	my $value = $typesNonStandardValues{$optionType};
+	if ($optionType ne 'boolean' && !defined $value) {
+	    &log (-100, "*** no value for type $optionType (option $option)\n");
+	    next;
+	}
+	
+	my $valueRef = ref ($value);
+	my $previous_val;
+	my @previous_val;
+	
+	# memoryzing previous value of the clone 
+	if ($valueRef eq '') {
+	    $previous_val = $zinc->itemcget($clone, $option);
+	}
+	else {
+	    @previous_val = $zinc->itemcget($clone, $option);
+	}
+
+	# in the case of boolean, we must always take the not value:
+	if ($optionType eq 'boolean') { $value = !$previous_val }
+	
+	my $log_lev = 2;
+	$log_lev = 0 if ($opt_trace eq $option || $opt_trace eq $optionType ) ;
+	&log ($log_lev, "\$zinc->itemconfigure(clone $clone of $original ($type), $option => ". &printable ($valueRef, $value) . "\n");
+	$zinc->itemconfigure($clone, $option => $value);
+	$zinc->update;
+
+	if ($valueRef eq 'ARRAY') {  # the value is a list
+	    my @original_value = $zinc->itemcget($original, $option);
+	    my @clone_value = $zinc->itemcget($clone, $option);
+	    if ( &equal_arrays (\@original_value, \@clone_value) ) {
+		&log (-100, "*** Cloned $type gets the same $option (type $optionType) ". &printable($valueRef, \@original_value) . "\n");
+	    }
+	}
+	else {  # the value is either a scalar or a class instance
+	    my $original_value = $zinc->itemcget($original, $option);
+	    my $clone_value = $zinc->itemcget($clone, $option);
+	    if (defined $original_value && $original_value eq $clone_value) {
+#		print "ORIGIN = ",$original_value, " $original_value CLONE = ",$clone_value,"\n";
+		&log (-100, "*** Cloned $type gets the same $option (type $optionType) " .
+		      "(original=cloned: " . &printable($valueRef,$original_value) .
+		      "?=" . &printable($valueRef,$previous_val) .
+		      " :previous)\n");
+	    }
+	}
+	
+	# setting back the previous value
+	if ($valueRef eq '') {
+	    $zinc->itemconfigure($clone, $option => $previous_val);
+	}
+	else {
+	    $zinc->itemconfigure($clone, $option => \@previous_val);
+	}
+	
+    }
+}
+
+sub test_every_attributes_once {
+    my ($type, $item) = @_;
+    my %theoptions = %{$options{$type}};
+    foreach my $option (sort keys %theoptions) {
+	next if ($option eq -numfields); # BUG? makes the appli stop
+	next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random. Clipping item must belong to the group
+	my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}};
+	my $value = $typesNonStandardValues{$optionType};
+	if ($optionType ne 'boolean' && !defined $value) {
+	    &log (-100, "*** no value for type $optionType (option $option)\n");
+	    next;
+	}
+	# in the case of boolean, we must always take the not value:
+	if ($optionType eq 'boolean') { $value = !$zinc->itemcget($item, $option) }
+	
+	my $log_lev = 2;
+	$log_lev = 0 if ($opt_trace eq $option || $opt_trace eq $optionType ) ;
+	&log ($log_lev, "\$zinc->itemconfigure($item ($type), $option => ". &printable (ref($value), $value) . "\n");
+	$zinc->itemconfigure($item, $option => $value);
+	$zinc->update;
+    }
+}
+
+sub printable {
+    my ($ref, $value) = @_;
+    if ($ref eq 'ARRAY') {
+	return ("[ " . join ( ', ', @{$value} ) . " ]");
+    }
+    else {  # scalar or class instance
+	if (defined $value) {
+	    return $value;
+	}
+	else {
+	    return "undef";
+	}
+    }
+}
+
+sub printables {
+    my ($ref, @values) = @_;
+    if ($ref eq '') {
+	return ("[ " . join (', ', @values) . " ]") ;
+    }
+    elsif ($ref eq 'ARRAY') {
+	my @array;
+	foreach my $value (@values) {
+	    push @array, &printable ($ref, $value);
+	}
+	return ("[ " . join ( ', ', @array) . " ]" );
+    }
+}
+
+
+## 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;
+}
 # &test_mapitems; # should be done before really testing map items attributes
 # &test_labelcontent; # should be done before really testing track/waypoint/tabular items attributes
 
-&test_attributes; # on peut configurer toutes les attributs
+#&test_attributes; # on peut configurer toutes les attributs
 &test_cloning; # le clonage fonctionne correctement !
 MainLoop();