aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Perl/t/test-no-crash.pl59
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");