ajout d'un test �l�mentaire de la m�thode coords

1 files changed, 44 insertions, 15 deletions

diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl
index 38716f9..45db8ec 100644
--- a/Perl/t/test-no-crash.pl
+++ b/Perl/t/test-no-crash.pl
@@ -19,6 +19,7 @@ my @testsList = (
 		 2 => 'test_every_field_attributes (long)',
 		 3 => 'test_attributes (medium)',
 		 4 => 'test_cloning (quick)',
+		 5 => 'test_coords (quick)',
 		 );
 my %testsHash;
 { my @tests = @testsList;
@@ -77,12 +78,6 @@ if ( open LOG, $outfile ) {
 open LOG,">$outfile";
 autoflush LOG 1;
 
-## must be done after the LOG file is open
-my @tests = &parseTestsOpt($opt_tests);
-my %tests;
-foreach my $t (@tests) {$tests{$t} = $t }
-
-
 sub usage {
     my ($text) = @_;
     print $text,"\n" if (defined $text);
@@ -106,6 +101,12 @@ my $mw = MainWindow->new();
 
 &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);
+my %tests;
+foreach my $t (@tests) {$tests{$t} = $t }
+
+
 # The explanation displayed when running this demo
 my $label=$mw->Label(-text => "This is a non-regression test, testing that
 zinc is not core-dumping!",
@@ -373,14 +374,14 @@ $mw->Button(-text => "Test fields attributes",
 
 
 sub log {
-    my ($level, @strgs) = @_;
-    if ($level <= $opt_log) {
-	print "%%%% " if $level == -100;
-	print "%% " if $level == -10;
+    my ($loglevel, @strgs) = @_;
+    if ($loglevel <= $opt_log) {
+	print "%%%% " if $loglevel == -100;
+	print "%% " if $loglevel == -10;
 	print @strgs;
     }
-    print LOG "%%%% " if $level == -100;
-    print LOG "%% " if $level == -10;
+    print LOG "%%%% " if $loglevel == -100;
+    print LOG "%% " if $loglevel == -10;
     print LOG @strgs;
 } # end log
 
@@ -882,7 +883,30 @@ sub test_mapitems {
     &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");
+    foreach my $it ($zinc->find('withtag','*')) {
+	$zinc->remove($it);
+    }
+    ## creationg again items
+    &creating_items;
+    foreach my $type ($zinc->add()) {
+	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);
+	&log (1, "=> $coordsAll\n");
+	my @coordsContour= &test_eval (1, "coords", $it,0); # all items have 1 contour
+	my $coordsContour = &printables(@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);
+	&log (1,"=> $coordsPoint\n");
+    }
+    &log (0, "---- End of test_coords ----\n");
+}
+    
 sub parseTestsOpt {
     my ($opt) = @_;
     my @tests;
@@ -903,8 +927,9 @@ sub parseTestsOpt {
 	foreach my $test (@tests) {
 	    die "tests num must not exceed $testnumb" if $test > $testnumb;
 	}
+	&log(0,  "Test to be done:\n");
 	foreach my $test (@tests) {
-	    &log(0,  "Test to be done:$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";
@@ -941,11 +966,15 @@ if ($tests{4}) {
     &test_cloning; # we test that cloning items and modifiyng/removing them does not core dump
 }
 
+### we should also test multicontour curves
+if ($tests{5}) {
+    &test_coords;
+}
+
 # #### &test_fonts;  ## and specially big fonts with render = 1;
 # #### &test_path_tags;
 # #### &test_illegal_tags;
 
-# #### &test_contours and coords
 
 &log (0, "---- End of test_no_crash ----\n");