diff options
| -rw-r--r-- | Perl/t/test-no-crash.pl | 59 |
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"); |