path: root/Perl/t/test-methods.pl

#!/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_forbidden_operations_on_root_group (quick)',
		 3 => 'test_errors (quick)',
#		 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");
    my $log_level = 2 ;

    $zinc->add('rectangle', 1, [ [100,200], [400,300] ], -tags => ['rect1']);
    my $contour_rect = [ [100,200], [100,300], [400,300], [400,200] ];
    my $rev_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, $rev_contour_rect, -tags => ['curve_rect_coords_reversed']);
    &verify_coords_of_contour ('ne','curve_rect_coords', 'curve_rect_coords_reversed', 0); # we should test they are 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']);

    ## the following lines are errors: we cannot add an item as contour with flag 0
    &test_no_eval ("adding a contour from a rectangle with flag=0",
		   $log_level, "contour", 'curve_rect_0','add',0, 'rect1');
    &test_no_eval ("adding a contour from an arc with flag=0",
		   $log_level, "contour", 'curve_rect_0','add',0, 'arc1');
    
    $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);

    $zinc->add('tabular',1, 2, -tags => ['tabular1']);
    $zinc->add('track',1, 2, -tags => ['track1']);
    $zinc->add('waypoint',1, 2, -tags => ['waypoint1']);
    $zinc->add('reticle',1, -tags => ['reticle1']);

    ## we test now the following errors: we cannot use a track, waypoint, reticle, map as a contour
    &test_eval ($log_level, "contour", 'curve_rect_0','add',1, 'tabular1');
    &test_no_eval ("using the contour of a track",
		   $log_level, "contour", 'curve_rect_0','add',1, 'track1');
    &test_no_eval ("using the contour of a waypoint",
		   $log_level, "contour", 'curve_rect_0','add',1, 'waypoint1');
    &test_no_eval ("using the contour of a reticle",
		   $log_level, "contour", 'curve_rect_0','add',1, 'reticle1');

    ## we test now the following errors: we cannot add a contour to track, waypoint, rectangle...
    &test_no_eval ("adding a contour to a track",
		   $log_level, "contour", 'track1','add',1, 'rect1');
    &test_no_eval ("adding a contour to a waypoint",
		   $log_level, "contour", 'waypoint1','add',1, 'rect1');
    &test_no_eval ("adding a contour to a rectangle",
		   $log_level, "contour", 'rect1','add',1, 'rect2');

    &test_no_eval ("adding a contour with a malformed list",
		   $log_level, "contour", 'curve_rect_0','add',1, [1]);
    &test_no_eval ("adding a contour with a malformed list",
		   $log_level, "contour", 'curve_rect_0','add',1, [1, 2, 3]);
    &test_no_eval ("adding a contour with a malformed list",
		   $log_level, "contour", 'curve_rect_0','add',1, [1, 2, 'c']);
    &test_no_eval ("adding a contour with a malformed list",
		   $log_level, "contour", 'curve_rect_0','add',1, [1, 2, [3, 4] ]);

    
    &log (0, "#----  End of test_contour_and_coords  -----\n");
} # end of test_contour_and_coords



sub test_forbidden_operations_on_root_group {
    &log (0, "#----  Start of test_forbidden_operations_on_root_group ----\n");
    my $log_level = 2 ;

    my @all_items =  $zinc->find('withtag',".1*");
    print "Items before deleting 1: @all_items\n";
    &test_no_eval ("removing the root group",
		   $log_level, "remove", 1); ## cannot delete root group
    @all_items =  $zinc->find('withtag',".1*");
    print "Items after deleting 1: @all_items\n";
    $zinc->add('group', 1, -tags => "g2");
    # cannot chggroup root group:    
    &test_no_eval ("changing the group of the root group",
		   $log_level, "chggroup", 1,"g2");
    # cannot clone root group
    &test_no_eval ("cloning the root group",
		   $log_level, "clone", 1);
    
    &log (0, "#----  End of test_forbidden_operations_on_root_group  -----\n");
} # end of test_forbidden_operations_on_root_group


### tests all errors as defined in the refman
sub test_errors {
    &log (0, "#----  Start of test_errors ----\n");
    my $log_level = 2 ;

    &creating_items;

#    Text indices
#    sel.first Refers to the first character of the selection in the item. If the selection is not in the item, this form returns an error.
     &test_no_eval ("refering to sel.first in a text item without selection",
		   $log_level, "insert", 'text', 'sel.first', "string");
#    sel.last Refers to the last character of the selection in the item. If the selection is not in the item, this form returns an error.
     &test_no_eval ("refering to sel.last in a text item without selection",
		   $log_level, "insert", 'text', 'sel.last', "string");
 
    # If no item is named by tagOrId or if the item doesn t support anchors, an error is raised.
    &test_no_eval ("refering no item by tagOrId with anchorxy",
		   $log_level, "anchorxy", 'bad_tag', 'rectangle');

    # If the item doesn't support anchors, an error is raised.
    &test_no_eval ("refering item that does not support anchors",
		   $log_level, "anchorxy", 'rectangle', 'ne');

    # If the item doesn't support anchors, an error is raised.
    &test_no_eval ("refering a bad anchor name",
		   $log_level, "anchorxy", 'text', 'not_an_anchor');

#    If the command parameter is omitted, the command return the command associated with tagOrId and sequence or an error is raised if there is no such binding.
    &test_no_eval ("refering a non-existing bindind with bind",
		   $log_level, "bind", 'text', 'badseq');

#    $zinc->contour(tagOrId, operatorAndFlag, coordListOrTagOrId);
    # An error is generated if items are not of a correct type or if the coordinate list is malformed.
    # tested in &test_contour_and_coords
    
#    If no items are named by tagOrId, an error is raised.
    &test_no_eval ("refering a non-existing item with hasanchors",
		   $log_level, "hasanchors", 'badtag');

#    If no items are named by tagOrId, an error is raised.
    &test_no_eval ("refering a non-existing item with hasfields",
		   $log_level, "hasfields", 'badtag');

    # If no items are named by tagOrId, an error is raised.
    &test_no_eval ("refering a non-existing item with hastag",
		   $log_level, "hastag", 'badtag', 'atag');

    # If field is given, it must be a valid field index for the item or an error will be reported.
    &test_no_eval ("accessing a non existing track field",
		   $log_level, "itemcget", 'track', 111, -text);

    # If the attribute is not available for the field or item type, an error is reported.
    &test_no_eval ("accessing a non existing curve attribute",
		   $log_level, "itemcget", 'curve', -bad_attribute);
    &test_no_eval ("accessing a non existing attribute of a track field",
		   $log_level, "itemcget", 'track', 1, -bad_attribute);

    # If field is given, it must be a valid field index for the item or an error will be reported.
    &test_no_eval ("modifying a non existing track field",
		   $log_level, "itemconfigure", 'track', 111, -text => "foo");
    # If an attribute does not belong to the item or field, an error is reported:
    &test_no_eval ("modifying a non existing curve attribute",
		   $log_level, "itemconfigure", 'curve', -bad_attribute => "foo");
    &test_no_eval ("modifying a non existing attribute of a track field",
		   $log_level, "itemconfigure", 'track', 1, -bad_attribute => "foo");

#    $zinc->lower(tagOrId, belowThis); #raise!!
#    If tagOrId doesn t name an item, an error is raised.
#    If belowThis doesn t name an item, an error is raised.

#    $num = $zinc->numparts(tagOrId);
#    If no items are named by tagOrId, an error is raised.

#    $zinc->rotate(tagOrId, angle, centerX, centerY);  scale; translate
#    If tagOrId describes neither a named transform nor an item, an error is raised.

    # $zinc->tdelete(tName);
    # If the given name is not found among the named transforms, an error is raised.

# ->transform ??

#    $zinc->treset(tagOrdId);
#    If tagOrId describes neither a named transform nor an item, an error is raised.

#    $zinc->trestore(tagOrdId, tName);
#    If tagOrId doesn t describe any item or if the transform named tName doesn t exist, an error is raised.

#    $zinc->tsave(tName); $zinc->tsave(tagOrdId, tName); $zinc->tsave(tagOrdId, tName, invert);
#    If tagOrId doesn t describe any item, an error is raised.

#    $name = $zinc->type(tagOrdId);
#    If no items are named by tagOrId, an error is raised.
    
    &log (0, "#----  End of test_errors  -----\n");
} # end of test_errors

sub creating_items {
    # first removing all remaining items
    foreach my $tag qw(group track waypoint tabular text icon reticle map
			rectangle arc curve triangles window) {
	$zinc->remove($tag);
    }
    # and then creating items
    $zinc->add('group', 1, -tags => ['group']);
    $zinc->add('track', 1, 5, -position => [100,200], -tags => ['track']);
    $zinc->add('waypoint', 1, 5, -position => [200,100], -tags => ['waypoint']);
    $zinc->add('tabular', 1, 5, -position => [100,20], -tags => ['tabular']);
    $zinc->add('text',1, -tags => ['text']);
    $zinc->add('icon', 1, -tags => ['icon']);
    $zinc->add('reticle', 1, -tags => ['reticle']);
    $zinc->add('map', 1, -tags => ['map']);
    $zinc->add('rectangle', 1, [400,400 , 450,220], -tags => ['rectangle']);
    $zinc->add('arc', 1, [10,10 , 50,50], -tags => ['arc']);
    $zinc->add('curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140], -tags => ['curve']);
    $zinc->add('triangles', 1, [200,200 , 300,200 , 300,300, 200,300],
		-colors => ["blue:50", "red:20", "green:80"], -tags => ['triangles']);
    $zinc->add('window', 1, -tags => ['window']);
    foreach my $tag qw(group track waypoint tabular text icon reticle map
			rectangle arc curve triangles window) {
#	my $contour = $zinc->contour($tag);
#	print "$tag := $contour\n";
    }
    
} # end creating_items


sub verify_coords_of_contour {
    my ($predicat, $id1, $id2, $contour) = @_;
    my @contour1 = $zinc->coords($id1,$contour);
    my @contour2 = $zinc->coords($id2,$contour);
#    print "contour1: ", &printableArray (@contour1), "\n";
#    print "contour2: ", &printableArray (@contour2), "\n";
    my $res = &nequal_cplx_arrays (\@contour1, \@contour2);
#    print "res=$res\n";
    if ($predicat eq 'eq') {
	if ($res) {
	    &log(-100, "coords of $id1($contour) and $id2($contour) are not equal:\n\t".
		 &printableArray(@contour1)."\n\t".&printableArray(@contour2)."\n");
	} else {
	    &log(1, "  # coords of $id1($contour) and $id2($contour) are OK ($predicat)\n");
	}
    } elsif ($predicat eq 'ne') {
	if (!$res)  {
	    &log(-10, "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(-100, "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(-100, "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(-100, "unknown predicat: $predicat\n");
	 }   
    }
    if ($predicat eq 'neq' and !$nequal)  {
	&log(-100, "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_forbidden_operations_on_root_group ();
}

if ($tests{3}) {
    &test_errors; 
}

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();