initial release

1 files changed, 305 insertions, 0 deletions

diff --git a/Perl/t/test-methods.pl b/Perl/t/test-methods.pl
new file mode 100644
index 0000000..48788fd
--- /dev/null
+++ b/Perl/t/test-methods.pl
@@ -0,0 +1,305 @@
+#!/usr/bin/perl -w
+# $Id$
+# This non-regression test has been developped by C. Mertz <mertz@cena.fr>
+
+use Tk;
+use Tk::Zinc;
+use Getopt::Long;
+use TestLog;
+
+use strict;
+
+use constant ERROR => '--an error--';
+
+
+# the following list be coherent with the treatments done in the TEST section.
+my @testsList = (
+		 1 => 'test_contour_and_coords (quick)',
+#		 2 => 'test_every_field_attributes (long)',
+#		 3 => 'test_attributes (medium)',
+#		 4 => 'test_cloning (quick)',
+#		 5 => 'test_coords (quick)',
+		 );
+my %testsHash;
+{ my @tests = @testsList;
+  while (@tests) {
+      my $num = shift (@tests);
+      my $comment = shift (@tests);
+      $testsHash{ $num } = $comment;
+  }
+}
+
+unshift (@INC, "/usr/lib/perl5/Tk");  # for getting Tk some images;
+
+# les variables positionnées en fonction des options de la ligne de commande
+my $opt_log = 0;
+my $opt_trace = "";
+my $opt_render = -1;
+my $opt_type = 0;
+my $outfile;
+my $opt_tests = "all";
+
+# on récupère les options
+Getopt::Long::Configure('pass_through');
+my $optstatus = GetOptions('log=i' => \$opt_log,
+			   'out=s' => \$outfile,
+			   'trace=s' => \$opt_trace,
+			   'render:s' => \$opt_render,
+			   'type=s' => \$opt_type,
+			   'help' => \&usage,
+			   'tests:s' => \$opt_tests,
+			   );
+
+# on teste la validité de l'option -render!
+if ($opt_render eq '') {
+    print "-render option have no value!\n";
+    &usage;
+}
+$opt_render = 1 if $opt_render == -1;
+unless ($opt_render==0 or $opt_render==1 or $opt_render==2) {
+    print "-render option value must be 0, 1 or 2!\n";
+    &usage;
+}
+
+
+$outfile = "methods-$Tk::Zinc::VERSION.log" if (!defined $outfile);
+
+&openLog($outfile, $opt_log);
+
+sub usage {
+    my ($text) = @_;
+    print $text,"\n" if (defined $text);
+    print "test-methods [options]\n";
+    print "       A non-regression test suite for zinc.\n";
+    print "       Some exhaustive test of TkZinc methods. Of course everything is not tested yet\n";
+    print " options are:\n";
+    print " -help           to print this short help\n";
+    print " -log <n>        trace level, defaulted to 0; higher level trace more infos\n";
+    print " -out filename   the log filename. defaulted to methods-<version><-rendering>.log\n";
+    print "      NB: the previous log file is always renamed with a .prev suffix\n";
+    print " -render 0|1|2   to select the render option of TkZinc (defaulted to 1)\n";
+    print " -trace <an_item_option>  to better trace usage of an option\n";
+    print " -type <a_zinc_item_type> to limits tests to this item type.\n";
+    print " -tests to get the list of available tests.\n";
+    print " -tests i,j,k... to define the list of tests to pass.\n";
+    exit;
+}
+
+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
+some sets of methods!",
+		     -justify => 'left')->pack(-padx => 10, -pady => 10);
+
+
+# Creating the zinc widget
+my $zinc = $mw->Zinc(-width => 500, -height => 500,
+		     -trackmanagedhistorysize => 10,
+		     -font => "10x20", # usually fonts are sets in resources
+		                       # but for this example it is set in the code!
+		     -borderwidth => 0, -relief => 'sunken',
+		     -render => $opt_render,
+		     )->pack;
+
+&setZincLog($zinc);
+
+sub test_contour_and_coords {
+    &log (0, "---- Start of test_contour_and_coords ----\n");
+    $zinc->add('rectangle', 1, [ [100,200], [400,300] ], -tags => ['rect1']);
+    my $contour_rect = [ [100,200], [400,200], [400,300], [100,300] ];
+    $zinc->add('rectangle', 1, [ 100,200, 400,300 ], -tags => ['rect2']);
+    &verify_coords_of_contour ('eq','rect1', 'rect2', 0);
+    &verify_coords_of_contour_points ('eq','rect1', 'rect2', 0);
+
+
+    $zinc->add('arc', 1, [ [100,200], [400,300] ], -tags => ['arc1']);
+    $zinc->add('arc', 1, [ 100,200, 400,300 ], -tags => ['arc2']);
+    &verify_coords_of_contour ('eq','arc1', 'arc2', 0);
+    &verify_coords_of_contour_points ('eq','arc1', 'arc2', 0);
+
+    my $contour1 = [ [100,200], [400,300,'c'], [500,100], [350,10, 'c'], [300,500,'c'], [50,100] ];
+    my $contour2 = [  100,200,   400,300,       500,100,   350,10,        300,500,       50,100 ];
+    my $contour3 = [ [100,200], [400,300],     [500,100], [350,10],      [300,500],     [50,100]];
+    $zinc->add('curve', 1, $contour1, -tags => ['curve1']);
+    $zinc->add('curve', 1, $contour2, -tags => ['curve2']);
+    $zinc->add('curve', 1, $contour3, -tags => ['curve3']);
+    &verify_coords_of_contour ('ne','curve1', 'curve2', 0);
+    &verify_coords_of_contour_points ('ne','curve1', 'curve2', 0);
+    
+    &verify_coords_of_contour ('eq','curve2', 'curve3', 0);
+    &verify_coords_of_contour_points ('ne','curve2', 'curve3', 0);
+
+    ## testing contours
+    $zinc->add('curve', 1, [], -tags => ['curve_contour_0']);
+    $zinc->add('curve', 1, [], -tags => ['curve_contour_plus']);
+    $zinc->add('curve', 1, [], -tags => ['curve_contour_minus']);
+    $zinc->contour('curve_contour_0','add',0, $contour1);
+    $zinc->contour('curve_contour_plus','add',+1, $contour1);
+    $zinc->contour('curve_contour_minus','add',-1, $contour1);
+    &verify_coords_of_contour ('eq','curve1', 'curve_contour_0', 0);
+    &verify_coords_of_contour ('ne','curve_contour_plus', 'curve_contour_minus', 0);
+    if (&nequal_cplx_arrays ($zinc->coords('curve_contour_0',0),
+			     $zinc->coords('curve_contour_minus',0))) {
+	&verify_coords_of_contour ('eq','curve1', 'curve_contour_plus', 0);
+    } else {
+	&verify_coords_of_contour ('eq','curve1', 'curve_contour_minus', 0);
+    }
+    $zinc->add('curve', 1, [], -tags => ['curve_contour_minus_plus']);
+    $zinc->contour('curve_contour_minus_plus','add',1,
+		   [$zinc->coords('curve_contour_minus',0)]);
+    &verify_coords_of_contour ('eq','curve1', 'curve_contour_minus_plus', 0);
+
+    ## the following curves are similar, because the first contour is
+    ## always set counterclockwise
+    $zinc->add('curve', 1, $contour_rect, -tags => ['curve_rect_coords']);
+    $zinc->add('curve', 1, (reverse($contour_rect)), -tags => ['curve_rect_coords_reversed']);
+    $zinc->add('curve', 1, [], -tags => ['curve_rect_0']);
+    $zinc->add('curve', 1, [], -tags => ['curve_rect_plus']);
+    $zinc->add('curve', 1, [], -tags => ['curve_rect_minus']);
+##    $zinc->contour('curve_rect_0','add',0, 'rect1'); ## this is an error! to be tested
+    $zinc->contour('curve_rect_plus','add',1, 'rect1');
+    $zinc->contour('curve_rect_minus','add',-1, 'rect1');
+    &verify_coords_of_contour ('ne','curve_rect_plus', 'curve_rect_minus', 0);
+    &verify_coords_of_contour ('eq','curve_rect_coords', 'curve_rect_plus', 0);
+    &verify_coords_of_contour ('eq','curve_rect_coords_reversed', 'curve_rect_minus', 0);
+    
+    &log (0, "----  End of test_contour_and_coords  ----\n");
+}
+
+
+sub verify_coords_of_contour {
+    my ($predicat, $id1, $id2, $contour) = @_;
+    my @contour1 = $zinc->coords($id1,$contour);
+    my @contour2 = $zinc->coords($id2,$contour);
+#    print "contour1: ", &printables (@contour1), "\n";
+#    print "contour2: ", &printables (@contour2), "\n";
+    my $res = &nequal_cplx_arrays (\@contour1, \@contour2);
+#    print "res=$res\n";
+    if ($predicat eq 'eq') {
+	if ($res) {
+	    &log(0, "coords of $id1($contour) and $id2($contour) are not equal:\n\t".
+		 &printables(@contour1)."\n\t".&printables(@contour2)."\n");
+	} else {
+	    &log(1, "coords of $id1($contour) and $id2($contour) are OK ($predicat)\n");
+	}
+    } elsif ($predicat eq 'ne') {
+	if (!$res)  {
+	    &log(0, "coords of $id1($contour) and $id2($contour) should not be equal\n");
+	} else {
+	    &log(1, "coords of $id1($contour) and $id2($contour) are OK ($predicat)\n");
+	}
+    } else {
+	&log(0, "unknown predicat: $predicat\n");
+    }
+} # end of verify_coords_of_contour;
+
+sub verify_coords_of_contour_points {
+    my ($predicat, $id1, $id2, $contour) = @_;
+    my @contour1 = $zinc->coords($id1,$contour);
+
+    my $nequal=0;
+    for (my $i = 0; $i < $#contour1; $i++) {
+	my @coords1 = $zinc->coords($id1,0,$i);
+	my @coords2 = $zinc->coords($id2,0,$i);
+	my $res = &equal_flat_arrays ( \@coords1, \@coords2 );
+	if ($predicat eq 'eq') {
+	    if (!$res) {
+		&log(0, "coords of $id1($contour,$i) and $id2($contour,$i) are not equal:\n\t$res");
+	    }
+	} elsif ($predicat eq 'ne') {
+	    if (!$res) {
+		$nequal=$res;
+		last;
+	    }
+	} else {
+	    &log(0, "unknown predicat: $predicat\n");
+	 }   
+    }
+    if ($predicat eq 'neq' and !$nequal)  {
+	&log(0, "coords of $id1($contour,i) and $id2($contour,i) should not be all equal\n");
+    } else {
+	&log(1, "coords of $id1($contour,i) and $id2($contour,i) are OK ($predicat)\n");
+    }
+} # end of verify_coords_of_contour_points;
+
+
+sub parseTestsOpt {
+    my ($opt) = @_;
+    my @tests;
+    if ($opt eq '') {
+	print "Availables tests are:\n";
+	while (@testsList) {
+	    my $i = shift @testsList;
+	    my $comment = shift @testsList;
+	    print "\t$i => $comment\n";
+	}
+	exit;
+    } elsif ( $opt eq 'all' ) { ## default!
+	&log (0, "all tests will be passed through\n");
+	@tests = sort keys %testsHash;
+    } elsif ( $opt =~ /^\d+(,\d+)*$/ ) {
+	@tests = split (/,/ , $opt);
+	my $testnumb = (scalar @testsList) / 2;
+	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,  "\t$test => " . $testsHash{$test} . "\n");
+	}
+    } else {
+	print "bad -tests value. Must be a list of integer separated by ,\n";
+	&usage;
+    }
+    return @tests;
+} # end of parseTestsOpt
+
+# ---------- TEST ------------------
+# the following code must be coherent with the tests list described
+# on the very beginning of this file (see @testsList definition)
+
+if ($tests{1}) {
+    &test_contour_and_coords ();
+}
+
+if ($tests{2}) {
+#    &test_every_field_attributes;
+}
+
+if ($tests{3}) {
+#    &test_attributes; # on peut configurer tous les attributs
+}
+
+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_illegal_call
+# for example:
+#  calling a methode for an non-existing item
+#  getting coords, contours, fields, etc... of non-existing index
+#
+#  cloning, deleting topgroup
+#
+
+&log (0, "---- End of test_method ----\n");
+
+#MainLoop();