From 54bf367c80ecd7bb2d2b2d49e51331d5c83b28b7 Mon Sep 17 00:00:00 2001 From: mertz Date: Mon, 13 May 2002 08:27:25 +0000 Subject: traitement des erreurs et poursuite des tests... test des clones... --- Perl/t/test-no-crash.pl | 395 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 298 insertions(+), 97 deletions(-) diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl index 5d92eac..561777f 100644 --- a/Perl/t/test-no-crash.pl +++ b/Perl/t/test-no-crash.pl @@ -1,14 +1,18 @@ #!/usr/bin/perl -w # $Id$ -# This simple demo has been developped by C. Mertz +# This non-regression test has been developped by C. Mertz use Tk; use Tk::Zinc; use Getopt::Long; use IO::Handle; # for autoflushing the logs +use Carp; use strict; +use constant ERROR => '--an error--'; + + unshift (@INC, "/usr/lib/perl5/Tk"); # for getting Tk some images; # les variables positionnées en fonction des options de la ligne de commande @@ -66,44 +70,65 @@ my @itemtypes = qw(arc tabular track waypoint if ($opt_type) { @itemtypes = ($opt_type); } +#### some global variables needed as attributes values +my ($text1, $text2, $text3, $text4); +my ($image1, $image2, $image3, $image4); -$zinc->add('group', 1); -$zinc->add('group', 1); -$zinc->add('icon', 1); -$zinc->add('map', 1); -$zinc->add('reticle', 1); -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]); -$zinc->add('tabular', 1, 5, -position => [100,20]); -$zinc->add('tabular', 1, 5, -position => [100,20]); -$zinc->add('group', 1); -$zinc->add('group', 1); +&creating_items ("unused"); + +sub creating_items { + # first removing all remaining items + foreach my $item (&test_eval (1, "find", 'all')) { + &test_eval (1, "remove", $item); + } + + my $labelformat = "x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1"; + # and then creating items + &test_eval (1, "add", 'group', 1); + &test_eval (1, "add", 'group', 1); + &test_eval (1, "add", 'icon', 1); + &test_eval (1, "add", 'map', 1); + &test_eval (1, "add", 'reticle', 1); + $text1 = &test_eval (1, "add", 'text', 1, -position => [300,120], -text => "hello world1"); + $text2 = &test_eval (1, "add", 'text', 1, -position => [350,170], -text => "hello world2"); + $text3 = &test_eval (1, "add", 'text', 1, -position => [400,220], -text => "hello world3"); + &test_eval (1, "add", 'window', 1); +# &test_eval (1, "add", 'track', 1, 5, -position => [100,200]); + &test_eval (1, "add", 'track', 1, 5, -position => [100,200]); + &test_eval (1, "add", 'waypoint', 1, 5, -position => [200,100]); + &test_eval (1, "add", 'tabular', 1, 5, -position => [100,20]); + &test_eval (1, "add", 'group', 1); + + &test_eval (1, "mapinfo", 'mapinfo1', 'create'); + &test_eval (1, "mapinfo", 'mapinfo2', 'create'); + &test_eval (1, "mapinfo", 'mapinfo3', 'create'); + #$zinc->itemconfigure ('tabular', -labelformat => "200x10"); #$zinc->update; -$zinc->add('arc', 1, [10,10 , 50,50]); -$zinc->add('bezier', 1, [10,10 , 50,50, 100,10, 10,200, 150,40]); -$zinc->add('curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140]); -$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"]); + &test_eval (1, "add", 'arc', 1, [10,10 , 50,50]); + &test_eval (1, "add", 'bezier', 1, [10,10 , 50,50, 100,10, 10,200, 150,40]); + &test_eval (1, "add", 'curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140]); + &test_eval (1, "add", 'rectangle', 1, [400,400 , 450,220]); + &test_eval (1, "add", 'triangles', 1, [200,200 , 300,200 , 300,300, 200,300], + -colors => ["blue:50", "red:20", "green:80"]); + + $image1 = $zinc->Photo(-file => Tk::findINC("icon.gif") ); + $image2 = $zinc->Photo(-file => Tk::findINC("Xcamel.gif") ); + $image3 = $zinc->Photo(-file => Tk::findINC("tranicon.gif") ); + $image4 = $zinc->Photo(-file => Tk::findINC("anim.gif") ); -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") ); + &creating_datas; # some of the data are using items! +} my %options; my %types; + foreach my $itemType (@itemtypes) { my $anItem = $zinc->find('withtype', $itemType); if (!defined $anItem) { &log (-10, "no item $itemType\n"); next;}; @@ -115,25 +140,51 @@ foreach my $itemType (@itemtypes) { } } +my %fieldOptions; + +{ +my $aTrack = $zinc->find('withtype', 'track'); +if (!defined $aTrack) { &log (-10, "no item track\n") } +else { + my @fieldOptions = $zinc->itemconfigure($aTrack, 0); + for my $elem (@fieldOptions) { + my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem; + $fieldOptions{$optionName} = [$optionType, $readOnly, $empty, $optionValue]; + $types{$optionType} = 1; + } +} +} + foreach my $type (sort keys %types) { # print "$type\n"; } +# a hash giving samples of valid data for attributes types +my %typesValues; -$zinc->mapinfo('mapinfo1', 'create'); -$zinc->mapinfo('mapinfo2', 'create'); -$zinc->mapinfo('mapinfo3', 'create'); +# the following hash associated to types valid value that should be all different from +# default value and from value initiated when creating items (see up...) +my %typesNonStandardValues; + +# a hash giving samples of NOT valid data for attributes types +my %typesIllegalValues; -my %typesValues = +sub creating_datas { + %typesValues = ('justify' => ['left', 'right', 'center'], 'alpha' => [0, 50, 100, 23], 'anchor' => ['n', 's', 'e', 'w', 'nw', 'ne', 'sw', 'se', 'center'], 'angle' => [0, 90, 180, 270, 360, 12, 93, 178, 272, 359], - 'autoalignment' => ['lll', 'llr', 'llc', 'lrl', 'lrr', 'lrc', 'lcl', 'lcr', 'lcc', - 'rll', 'rlr', 'rlc', 'rrl', 'rrr', 'rrc', 'rcl', 'rcr', 'rcc', - 'cll', 'clr', 'clc', 'crl', 'crr', 'crc', 'ccl', 'ccr', 'ccc', - '-',], +# 'autoalignment' => ['lll', 'llr', 'llc', 'lrl', 'lrr', 'lrc', 'lcl', 'lcr', 'lcc', +# 'rll', 'rlr', 'rlc', 'rrl', 'rrr', 'rrc', 'rcl', 'rcr', 'rcc', +# 'cll', 'clr', 'clc', 'crl', 'crr', 'crc', 'ccl', 'ccr', 'ccc', +# '-',], + 'autojustify' => ['lll', 'llr', 'llc', 'lrl', 'lrr', 'lrc', 'lcl', 'lcr', 'lcc', + 'rll', 'rlr', 'rlc', 'rrl', 'rrr', 'rrc', 'rcl', 'rcr', 'rcc', + 'cll', 'clr', 'clc', 'crl', 'crr', 'crc', 'ccl', 'ccr', 'ccc', + '-',], 'boolean' => [0..1], + 'border' => ['left', 'right', 'top', 'bottom', 'contour', 'oblique', 'counteroblique'], ## +combinations! 'pattern' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ####?! 'patterns' => [['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ['AlphaStipple0']], ##TBC 'capstyle' => ['butt', 'projecting', 'round'], @@ -144,7 +195,7 @@ my %typesValues = ['blue:0', 'green:50', 'red:90'], ], ## TBC '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! +# 'edgelist' => ['left', 'right', 'top', 'bottom', 'contour', 'oblique', 'counteroblique'], ## +combinations! 'font' => ['10x20', '6x10', '6x12', '6x13'], 'image' => [$image1, $image2, $image3], ## TBC 'integer' => [-10000, -100, -1, 0, 1, 10, 10000], ## pour quoi? @@ -154,7 +205,8 @@ my %typesValues = "200x10", ## BUG BUG # "200x100 x100x20+0+0 x100x20+0+20 x200x40+100+20" ], - 'leaderanchors' => ["%10x30", "%40x20", "%67x21" ], ## TBC! non exchaustif!! BUG non conforme à la doc + 'leaderanchors' => ["%10x30", "|0|0", "%40x20", "|1|1", "|100|100", "%67x21" ], ## TBC! non exchaustif!! BUG non conforme à la doc + # illegal et fait planter: "%50" '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'], @@ -173,7 +225,7 @@ my %typesValues = # the following valid value associated to types should be all different from # default value and from value initiated when creating items (see up...) -my %typesNonStandardValues = + %typesNonStandardValues = ('justify' => 'right', 'alpha' => 50, 'anchor' => 'w', @@ -192,7 +244,7 @@ my %typesNonStandardValues = 'item' => $text3, 'joinstyle' => 'miter', 'labelformat' => "200x30", ## BUG BUG - 'leaderanchors' => "%10x60", ## BUG BUG + 'leaderanchors' => "%10x45", ## BUG BUG 'lineend' => [13,7,20], 'lineshape' => 'rightlightning', 'linestyle' => 'dotted', @@ -207,7 +259,7 @@ my %typesNonStandardValues = 'window' => undef, ### TBC ); -my %typesFalseValues = + %typesIllegalValues = ('alpha' => [0..100], 'anchor' => ['n', 's', 'e', 'w'], ##TBC 'angle' => [0..360], @@ -215,11 +267,12 @@ my %typesFalseValues = 'capstyle' => [], 'dimension' => [0..100], 'font' => ['10x20', '6x10', '6x12', '6x13'], + 'leaderanchors' => ["%50" ], ## TBC! non exchaustif!! BUG non 'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken', 'roundraised', 'roundsunken', 'roundgroove', 'roundridge', 'sunkenrule', 'raisedrule'], ); - +} $mw->Button(-text => "Test options", -command => sub {&test_attributes}, @@ -229,21 +282,90 @@ $mw->Button(-text => "Test cloning", -command => sub {&test_cloning}, )->pack(-pady => 4); - +$mw->Button(-text => "Test fields attributes", + -command => sub {&test_every_field_attributes}, + )->pack(-pady => 4); + ### print log information to the logfile -### if $level is lower than opt_log alos print log on the stdout +### if $level is <= than opt_log (def = 0) then print log on the stdout +### - 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 0 means an message to be usually printed (aznd logged in any case) +### - a loglevel greater than 1 is for trace only + + sub log { my ($level, @strgs) = @_; - print @strgs if $level <= $opt_log ; + if ($level <= $opt_log) { + print "%%%% " if $level == -100; + print "%% " if $level == -10; + print @strgs; + } + print LOG "%%%% " if $level == -100; + print LOG "%% " if $level == -10; print LOG @strgs; } +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 (ref($arg), $arg); + } + } + my $string2log = "\$zinc->$method (" . join (", ", @strs) . ")\n"; + + &log ($loglevel, $string2log); + + my (@res, $res); + if (wantarray()) { @res = eval { $zinc->$method (@args) } ; } + else { $res = eval { $zinc->$method (@args) } ; } + + 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; + } + } +} + sub test_attributes { foreach my $type (@itemtypes) { my @items = $zinc->find('withtype', $type); - &log (0, "---------testing ", (1+$#items), " ",$type,"(s) ----------------\n"); + &log (0, "--------- Testing ", (1+$#items), " ",$type," ----------------\n"); if ($#items == -1) { - &log (-100, "*** no such item: $type\n"); + &log (-100, "No such item: $type\n"); next; } my %theoptions = %{$options{$type}}; @@ -254,7 +376,7 @@ sub test_attributes { my @boolean_attributes; my %boolean_attributes; foreach my $option (sort keys %theoptions) { - my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}}; + my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; if ($optionType eq 'boolean') { next if $option eq -composerotation; next if $option eq -composescale; @@ -266,7 +388,6 @@ sub test_attributes { $boolean_attributes{$option}=1; } } -# 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"; @@ -274,21 +395,20 @@ sub test_attributes { &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"; - &log (0, "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n"); + &test_eval (0, "itemconfigure", $item, $boolean_attributes[$j] => $binary[$j] ); +# &log (0, "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n"); } 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 next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested - my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$type}{$option}}; + my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; my $typeValues = $typesValues{$optionType}; - if (!defined $typeValues) {&log (-100, "*** 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) {&log (-100, "*** 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]); @@ -302,12 +422,9 @@ sub test_attributes { @previous_val = $zinc->itemcget($item, $option); } &log (1, "\$zinc->itemconfigure($item ($type), $option => ",&printables ($valueRef,@values),"\n"); -# if ($opt_log == 1); foreach my $value (@values) { - my $log_lev = 2; - $log_lev = 0 if ($opt_trace eq $option || $opt_trace eq $optionType ) ; + my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType ) ? 0 : 2 ; &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); @@ -321,11 +438,10 @@ sub test_attributes { } } -# print "end of sub_test_option\n"; } } } - &log (0, "End of test_option\n"); + &log (0, "End of test_attributes\n"); } @@ -338,23 +454,24 @@ sub test_attributes { # test4: tester qu'en clonant on obtient bien une copie de tous les attributs sub test_cloning { + &creating_items; foreach my $type (@itemtypes) { my $item = $zinc->find('withtype', $type); - &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); + &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\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)); - $zinc->remove($item); + &test_eval (1, "remove", $item); &test_every_attributes_once($type,$clone); - $zinc->remove($clone); + &test_eval (1, "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 @@ -384,27 +501,29 @@ sub test_cloning { 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"); + &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); + my @items = &test_eval (1, "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"); + &log(-100, "The $type ($clone_or_original) is not enclosed in its bbox!\n"); TESTOVERLAPPING: - @items = $zinc->find ('overlapping', @bbox); +# @items = $zinc->find ('overlapping', @bbox); + @items = &test_eval (1, "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"); + &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); +# my $closest = $zinc->find ('closest', $x,$y); + my $closest = &test_eval (1, "find", 'closest', $x,$y); } } @@ -414,10 +533,10 @@ sub test_a_clone { 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 ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; my $value = $typesNonStandardValues{$optionType}; if ($optionType ne 'boolean' && !defined $value) { - &log (-100, "*** no value for type $optionType (option $option)\n"); + &log (-100, "No value for type $optionType (option $option)\n"); next; } @@ -427,34 +546,32 @@ sub test_a_clone { # memoryzing previous value of the clone if ($valueRef eq '') { - $previous_val = $zinc->itemcget($clone, $option); + $previous_val = &test_eval (2, "itemcget", $clone, $option); } else { - @previous_val = $zinc->itemcget($clone, $option); + @previous_val = &test_eval (2, "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); + my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ; + &test_eval ($log_lev, "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); + 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, "*** Cloned $type gets the same $option (type $optionType) ". &printable($valueRef, \@original_value) . "\n"); + &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); + my $original_value = &test_eval (2, "itemcget", $original, $option); + my $clone_value = &test_eval (2, "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) " . + &log (-100, "Cloned $type gets the same $option (type $optionType) " . "(original=cloned: " . &printable($valueRef,$original_value) . "?=" . &printable($valueRef,$previous_val) . " :previous)\n"); @@ -463,10 +580,10 @@ sub test_a_clone { # setting back the previous value if ($valueRef eq '') { - $zinc->itemconfigure($clone, $option => $previous_val); + &test_eval (1, "itemconfigure", $clone, $option => $previous_val); } else { - $zinc->itemconfigure($clone, $option => \@previous_val); + &test_eval (1, "itemconfigure", $clone, $option => \@previous_val); } } @@ -478,27 +595,110 @@ sub test_every_attributes_once { 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 ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; my $value = $typesNonStandardValues{$optionType}; if ($optionType ne 'boolean' && !defined $value) { - &log (-100, "*** no value for type $optionType (option $option)\n"); + &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 ) ; + 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"); - $zinc->itemconfigure($item, $option => $value); + &test_eval (1, "itemconfigure", $item, $option => $value); $zinc->update; } -} +} # end test_every_attributes_once + +sub test_every_field_attributes { + foreach my $type qw(waypoint track tabular) { + my %theoptions = %fieldOptions; + my @items = $zinc->find('withtype', $type); + &log (0, "--------- Testing fields of ", (1+$#items), " ",$type,"(s) ----------------\n"); + if ($#items == -1) { + &log (-100, "No such item: $type\n"); + next; + } + foreach my $item (@items) { + ## 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) + my @boolean_attributes; + my %boolean_attributes; + foreach my $option (sort keys %theoptions) { + my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; + if ($optionType eq 'boolean') { +# next if $option =~ /-\w+sensitive/ ; # to get rid of many track options! +# next if $option =~ /-filled\w+/ ; # to get rid of many track options! +# next if $option =~ /-speed\w+/ ; # to get rid of many track options! +# next if $option =~ /-\w+history/ ; # to get rid of many track options! + push @boolean_attributes, $option; + $boolean_attributes{$option}=1; + } + } + &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"); + 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"); + foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) { + &test_eval (1, "itemconfigure", $item, $field, $boolean_attributes[$j] => $binary[$j] ); + } + } + foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) { + foreach my $option (sort keys %theoptions) { + next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested + + my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; + my $typeValues = $typesValues{$optionType}; + if (!defined $typeValues) {&log (-100, "No values for type $optionType (option $option)\n");next;} + my @values = @{$typeValues}; + + if (!@values) {&log (-100, "No values for type $optionType (option $option)\n");next;} + + + my $valueRef = ref ($values[0]); + my $previous_val; + my @previous_val; + + if ($valueRef eq '') { + $previous_val = &test_eval (1, "itemcget", $item, $field, $option); + } + else { + @previous_val = &test_eval (1, "itemcget", $item, $field, $option); + } + &log (1, "\$zinc->itemconfigure($item ($type), $field, $option => ",&printables ($valueRef,@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 '') { + &test_eval (1, "itemconfigure", $item, $field, $option => $previous_val); + } + else { + &test_eval (1, "itemconfigure", $item, $field, $option => \@previous_val); + } + + }} + } + } + } + &log (0, "End of test_every_field_attributes\n"); +} # end test_every_field_attributes + sub printable { my ($ref, $value) = @_; if ($ref eq 'ARRAY') { - return ("[ " . join ( ', ', @{$value} ) . " ]"); + return ("[" . join ( ', ', @{$value} ) . "]"); } else { # scalar or class instance if (defined $value) { @@ -508,7 +708,7 @@ sub printable { return "undef"; } } -} +} # end printable sub printables { my ($ref, @values) = @_; @@ -541,6 +741,7 @@ sub equal_arrays { # &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_every_field_attributes; +&test_attributes; # on peut configurer toutes les attributs &test_cloning; # le clonage fonctionne correctement ! MainLoop(); -- cgit v1.1