addition of error messages tests

1 files changed, 113 insertions, 24 deletions

diff --git a/Perl/t/test-methods.pl b/Perl/t/test-methods.pl
index bb13bd8..0573289 100644
--- a/Perl/t/test-methods.pl
+++ b/Perl/t/test-methods.pl
@@ -17,7 +17,7 @@ my @testsList = (
 		 1 => 'test_contour_and_coords (quick)',
 		 2 => 'test_forbidden_operations_on_root_group (quick)',
 		 3 => 'test_errors (quick)',
-#		 4 => 'test_cloning (quick)',
+		 4 => 'test_bboxes (quick)',
 #		 5 => 'test_coords (quick)',
 		 );
 my %testsHash;
@@ -103,7 +103,6 @@ some sets of methods!",
 
 # 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',
@@ -112,6 +111,63 @@ my $zinc = $mw->Zinc(-width => 500, -height => 500,
 
 &setZincLog($zinc);
 
+## TkZinc bbox method doesn't return correct values for bbox. This test
+# function tries to find out in which cases these bbox are wrong
+sub test_bboxes {
+    &log (0, "#----  Start of test_bboxes ----\n");
+    &creating_items; # to know exactly which items exists at the beginning of this test
+
+    # Rectangles
+    &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400]),
+		  [100,200,300,400], "a simple rectangle");
+    &bbox_must_be($zinc->add('rectangle', 1, [300,400,100,200]),
+		  [100,200,300,400], "a simple reversed rectangle");
+    
+    # Rectangles with linewidth = 2, 3, 4 and 5
+    &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>2),
+		  [100,200,300,400], "a simple rectangle with linewidth of 2");
+    &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>3),
+		  [100,200,300,400], "a simple rectangle with linewidth of 3");
+    &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>4),
+		  [100,200,300,400], "a simple rectangle with linewidth of 4");
+    &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>5),
+		  [100,200,300,400], "a simple rectangle with linewidth of 5");
+    
+    # Rectangular curves
+    &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ]),
+		  [100,200,300,400], "a rectangular curve");
+    &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ],
+			     -linewidth => 2),
+		  [100,200,300,400], "a rectangular curve of linewidth => 2");
+    &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ],
+			     -linewidth => 3),
+		  [100,200,300,400], "a rectangular curve of linewidth => 3");
+    &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ],
+			     -linewidth => 5),
+		  [100,200,300,400], "a rectangular curve");
+
+    # Arcs
+    &bbox_must_be($zinc->add('arc', 1, [100,200,300,400]),
+		  [100,200,300,400], "an arc");
+    &bbox_must_be($zinc->add('arc', 1, [100,200,300,400], -linewidth => 2),
+		  [100,200,300,400], "an arc of linewidth => 2");
+    &bbox_must_be($zinc->add('arc', 1, [100,200,300,400], -linewidth => 3),
+		  [100,200,300,400], "an arc of linewidth => 3");
+
+    &log (0, "#----  End of test_bboxes  -----\n");
+} # end of test_bboxes
+
+sub bbox_must_be {
+    my ($item, $bbox_ref, $explanation) = @_;
+    my @computed_bbox=$zinc->bbox($item);
+    my @theoritical_bbox = @{$bbox_ref};
+    unless (&equal_flat_arrays (\@theoritical_bbox, \@computed_bbox)) {
+	&log(-10, "bad bbox of $explanation:\n  ## computed = ", &printableArray(\@computed_bbox),
+	     " theoritical = ", &printableArray(\@theoritical_bbox), "\n");
+    }
+} # end of bbox_must_be
+
+
 sub test_contour_and_coords {
     &log (0, "#----  Start of test_contour_and_coords ----\n");
     my $log_level = 2 ;
@@ -214,7 +270,12 @@ sub test_contour_and_coords {
 		   $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] ]);
+    &test_no_eval ("adding a contour with a malformed list",
+		   $log_level, "contour", 'curve_rect_0','add',1, [1, 2, [3, 4], [5, 6] ]);
 
+    # we should test here what happens when successive points are identical in a curve
+
+    # we should test here what happens when the last point is identical to the first point in a curve
     
     &log (0, "#----  End of test_contour_and_coords  -----\n");
 } # end of test_contour_and_coords
@@ -250,15 +311,18 @@ sub test_errors {
 
     &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.
+    # 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.
+    # 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.
+    # 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');
 
@@ -270,12 +334,14 @@ sub test_errors {
     &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.
+#    If the command parameter is omitted, bind returns 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.
+    # 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.
@@ -290,17 +356,20 @@ sub test_errors {
     &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.
+    # 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.
+    # 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.
+    # 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:
@@ -309,32 +378,52 @@ sub test_errors {
     &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.
+    &test_no_eval ("lowering  a non-existing item with lower",
+		   $log_level, "lower", 'badtag', 'track');
 #    If belowThis doesn t name an item, an error is raised.
+    &test_no_eval ("lowering  an existing below an non-existing item with lower",
+		   $log_level, "lower", 'track', 'badtag');
 
-#    $num = $zinc->numparts(tagOrId);
 #    If no items are named by tagOrId, an error is raised.
+    &test_no_eval ("refering a non-existing item with numparts",
+		   $log_level, "numparts", 'badtag');
 
-#    $zinc->rotate(tagOrId, angle, centerX, centerY);  scale; translate
 #    If tagOrId describes neither a named transform nor an item, an error is raised.
+    &test_no_eval ("refering a non-existing item with rotate",
+		   $log_level, "rotate", 'badtag', 180);
+#    If tagOrId describes neither a named transform nor an item, an error is raised.
+    &test_no_eval ("refering a non-existing item with scale",
+		   $log_level, "scale", 'badtag', 2,2);
+#    If tagOrId describes neither a named transform nor an item, an error is raised.
+    &test_no_eval ("refering a non-existing item with translate",
+		   $log_level, "translate", 'badtag', 200,200);
 
-    # $zinc->tdelete(tName);
     # If the given name is not found among the named transforms, an error is raised.
+    &test_no_eval ("refering a non-existing named transform item with tdelete",
+		   $log_level, "tdelete", 'badNamedTransform');
 
 # ->transform ??
 
-#    $zinc->treset(tagOrdId);
-#    If tagOrId describes neither a named transform nor an item, an error is raised.
+    # If tagOrId describes neither a named transform nor an item, an error is raised.
+    &test_no_eval ("refering a non-existing named transform or item with treset",
+		   $log_level, "treset", 'badNamedTransform');
 
-#    $zinc->trestore(tagOrdId, tName);
-#    If tagOrId doesn t describe any item or if the transform named tName doesn t exist, an error is raised.
+    # If tagOrId doesn t describe any item or if the transform named tName
+    # doesn't exist, an error is raised.
+    &test_eval ($log_level, "tsave", "text", "namedTransfrom");
+    &test_no_eval ("refering a non-existing item with trestore",
+		   $log_level, "trestore", 'badTag', 'namedTransform');
+    &test_no_eval ("refering a non-existing named transform with trestore",
+		   $log_level, "trestore", 'track', 'badNamedTransform');
 
-#    $zinc->tsave(tName); $zinc->tsave(tagOrdId, tName); $zinc->tsave(tagOrdId, tName, invert);
-#    If tagOrId doesn t describe any item, an error is raised.
+    # If tagOrId doesn t describe any item, an error is raised.
+    &test_no_eval ("refering a non-existing item with tsave",
+		   $log_level, "tsave", 'badTag', 'otherNamedTransform');
 
-#    $name = $zinc->type(tagOrdId);
-#    If no items are named by tagOrId, an error is raised.
+    # If no items are named by tagOrId, an error is raised.
+    &test_no_eval ("refering a non-existing item with type",
+		   $log_level, "type", 'badTag');
     
     &log (0, "#----  End of test_errors  -----\n");
 } # end of test_errors
@@ -474,7 +563,7 @@ if ($tests{3}) {
 }
 
 if ($tests{4}) {
-#    &test_cloning; # we test that cloning items and modifiyng/removing them does not core dump
+    &test_bboxes;
 }
 
 ### we should also test multicontour curves