diff options
Diffstat (limited to 'Perl/t/test-methods.pl')
| -rw-r--r-- | Perl/t/test-methods.pl | 305 |
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(); |