aboutsummaryrefslogtreecommitdiff
path: root/Perl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl')
-rw-r--r--Perl/t/test-methods.pl244
1 files changed, 219 insertions, 25 deletions
diff --git a/Perl/t/test-methods.pl b/Perl/t/test-methods.pl
index 48788fd..bb13bd8 100644
--- a/Perl/t/test-methods.pl
+++ b/Perl/t/test-methods.pl
@@ -15,8 +15,8 @@ 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)',
+ 2 => 'test_forbidden_operations_on_root_group (quick)',
+ 3 => 'test_errors (quick)',
# 4 => 'test_cloning (quick)',
# 5 => 'test_coords (quick)',
);
@@ -113,9 +113,13 @@ my $zinc = $mw->Zinc(-width => 500, -height => 500,
&setZincLog($zinc);
sub test_contour_and_coords {
- &log (0, "---- Start of test_contour_and_coords ----\n");
+ &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], [400,200], [400,300], [100,300] ];
+ 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);
@@ -161,47 +165,237 @@ sub test_contour_and_coords {
## 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, $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']);
-## $zinc->contour('curve_rect_0','add',0, 'rect1'); ## this is an error! to be tested
+
+ ## 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");
-}
+ &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: ", &printables (@contour1), "\n";
-# print "contour2: ", &printables (@contour2), "\n";
+# 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(0, "coords of $id1($contour) and $id2($contour) are not equal:\n\t".
- &printables(@contour1)."\n\t".&printables(@contour2)."\n");
+ &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");
+ &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");
+ &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");
+ &log(1, " # coords of $id1($contour) and $id2($contour) are OK ($predicat)\n");
}
} else {
- &log(0, "unknown predicat: $predicat\n");
+ &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);
@@ -213,7 +407,7 @@ sub verify_coords_of_contour_points {
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");
+ &log(-100, "coords of $id1($contour,$i) and $id2($contour,$i) are not equal:\n\t$res");
}
} elsif ($predicat eq 'ne') {
if (!$res) {
@@ -221,13 +415,13 @@ sub verify_coords_of_contour_points {
last;
}
} else {
- &log(0, "unknown predicat: $predicat\n");
+ &log(-100, "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");
+ &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");
+ &log(1, " # coords of $id1($contour,i) and $id2($contour,i) are OK ($predicat)\n");
}
} # end of verify_coords_of_contour_points;
@@ -244,7 +438,7 @@ sub parseTestsOpt {
}
exit;
} elsif ( $opt eq 'all' ) { ## default!
- &log (0, "all tests will be passed through\n");
+ &log (0, " # all tests will be passed through\n");
@tests = sort keys %testsHash;
} elsif ( $opt =~ /^\d+(,\d+)*$/ ) {
@tests = split (/,/ , $opt);
@@ -254,7 +448,7 @@ sub parseTestsOpt {
}
&log(0, "Test to be done:\n");
foreach my $test (@tests) {
- &log(0, "\t$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";
@@ -272,11 +466,11 @@ if ($tests{1}) {
}
if ($tests{2}) {
-# &test_every_field_attributes;
+ &test_forbidden_operations_on_root_group ();
}
if ($tests{3}) {
-# &test_attributes; # on peut configurer tous les attributs
+ &test_errors;
}
if ($tests{4}) {
@@ -300,6 +494,6 @@ if ($tests{5}) {
# cloning, deleting topgroup
#
-&log (0, "---- End of test_method ----\n");
+&log (0, "#---- End of test_method ----\n");
#MainLoop();
generated by cgit v1.1 at 2024-11-08 02:27:40 +0000