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