test related to the bug reported by Daniel Etienne the 30th of November 2004

1 files changed, 89 insertions, 0 deletions

diff --git a/Perl/t/Scale_clipped_group.pl b/Perl/t/Scale_clipped_group.pl
new file mode 100644
index 0000000..1facee3
--- /dev/null
+++ b/Perl/t/Scale_clipped_group.pl
@@ -0,0 +1,89 @@
+#
+# $Id$
+# Author: Christophe Mertz  mertz@intuilab.com, adapted from a script 
+# reported by Daniel Etienne for a bug report in Tk::Zinc 3.2.96
+#
+
+use strict;
+
+# testing all the import
+
+BEGIN {
+    if (!eval q{
+        use Test::More tests => 1;
+        1;
+    }) {
+        print "# tests only work properly with installed Test::More module\n";
+        print "1..1\n";
+        print "ok 1\n";
+        exit;
+    }
+    if (!eval q{
+	use Tk::Zinc;
+ 	1;
+    }) {
+        print "unable to load Tk::Zinc";
+        print "1..1\n";
+        print "ok 1\n";
+        exit;
+    }
+}
+use Tk;
+
+my $mw = MainWindow->new();
+my $zinc = $mw->Zinc(-render => 0)->pack(-expand => 1, -fill => "both");
+
+
+# creating the father group 1 and 2
+my $fatherGroup1=$zinc->add("group", 1);
+my $fatherGroup2=$zinc->add("group", 1);
+
+$zinc->coords($fatherGroup1, [50,100]);
+$zinc->coords($fatherGroup2, [200,100]);
+
+# creating subGroup 1 and 2
+my $subGroup1=$zinc->add("group", $fatherGroup1);
+my $subGroup2=$zinc->add("group", $fatherGroup2);
+
+# creating null sized rectangle 1 to clip the subgroup 1
+my $rectangle1 = $zinc->add("rectangle", $subGroup1, [ [0, 0], [0, 0] ]);
+
+$zinc->itemconfigure($subGroup1, -clip => $rectangle1);
+
+# creating an icon in the sub-group
+my $surroundimgfile = Tk->findINC("Tk.xbm");
+
+my $surroundimg = $zinc->Bitmap(-file => $surroundimgfile,
+				-foreground => 'sienna',
+				);
+my $icon1 = $zinc->add("icon", $subGroup1,
+                       -image => $surroundimg,
+                      );
+my $icon2 = $zinc->add("icon", $subGroup2,
+                       -image => $surroundimg,
+                      );
+
+
+## scaling fatherGroup1 makes an image visible on 3.2.96/3.3.2 TkZinc version
+$zinc->scale($fatherGroup1, 0.8, 0.8);
+
+
+&wait ("You should see ONLY ONE ptk ICON (a camel), please INSPECT VISUALY!"); sleep 2;
+
+
+sub wait {
+    $zinc->update;
+    ok (1, $_[0]);
+
+    my $delay = $ARGV[0];
+    if (defined $delay) {
+	$zinc->update;
+	if ($delay =~ /^\d+$/) {
+	    sleep $delay;
+	} else {
+	    sleep 1;
+	}
+    }
+}
+
+