diff options
Diffstat (limited to 'Perl/t/test-no-crash.pl')
| -rw-r--r-- | Perl/t/test-no-crash.pl | 70 |
1 files changed, 35 insertions, 35 deletions
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(); |