addition of some tests of error messages

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