From 6e6a03d63e66387289d1897f807008d93b2d7530 Mon Sep 17 00:00:00 2001 From: mertz Date: Mon, 29 Apr 2002 09:39:49 +0000 Subject: une version qui teste le clonage ainsi que la suppression apres clonage --- Perl/t/test-no-crash.pl | 324 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 239 insertions(+), 85 deletions(-) (limited to 'Perl/t') 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(); -- cgit v1.1