initial release of -tile, -image, -mask, -fillpattern,

-linepattern widget and items options  tests

1 files changed, 187 insertions, 0 deletions

diff --git a/Perl/t/Images.t b/Perl/t/Images.t
new file mode 100644
index 0000000..1b3df46
--- /dev/null
+++ b/Perl/t/Images.t
@@ -0,0 +1,187 @@
+#!/usr/bin/perl -w
+
+#
+# $Id: Images.t,v 1.1 2003-10-07 11:25:48 mertz Exp $
+# Author: Christophe Mertz
+#
+
+# testing all the -tile, -image, -mask, -fillpattern, -linepattern widget and items options 
+
+# this script can be used with an optionnal argument, an integer giving
+# the delay in seconds during which the graphic updates will be displayed
+# this is usefull for visual inspection!
+
+BEGIN {
+    if (!eval q{
+#        use Test::More qw(no_plan);
+        use Test::More tests => 31;
+        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;
+    }
+    if (!eval q{
+ 	$mw = MainWindow->new();
+ 	1;
+    }) {
+        print "# tests only work properly when it is possible to create a mainwindow in your env\n";
+        print "1..1\n";
+        print "ok 1\n";
+        exit;
+    }
+}
+
+
+$zinc = $mw->Zinc(-width => 400, -height => 400)->pack;
+
+like  ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created");
+
+#### creating different images, bitmaps and pixmaps...
+my $photoMickey = $zinc->Photo('mickey.gif', -file => Tk->findINC("demos/images/mickey.gif"));
+like ($photoMickey, qr/^Tk::Photo=HASH/ , "creating a Tk::Photo with a .gif");
+
+my $bitmap = $zinc->Bitmap('file.xbm', -file => Tk->findINC("file.xbm"));
+like ($bitmap, qr/^Tk::Bitmap=HASH/ , "creating a Tk::Bitmap with a .xbm");
+
+#### tiling Tk::Zinc
+$zinc->configure(-tile => $photoMickey);
+is ($zinc->cget(-tile), "mickey.gif", "verifying Tk::Zinc -tile option value");
+&wait ("-tile of Tk::Zinc with mickey");
+
+# modifying the Tk::Photo to see if the Tk::Zinc -tile changes
+$photoMickey->read( Tk->findINC("demos/images/earth.gif") );
+&wait ("-tile of Tk::Zinc should display the earth VISUAL INSPECTION!"); sleep 1;
+# going back to the "real" mickey
+$photoMickey->read( Tk->findINC("demos/images/mickey.gif") );
+&wait ("-tile of Tk::Zinc should display mickey again VISUAL INSPECTION!"); sleep 1;
+
+$zinc->configure(-tile => "");
+is ($zinc->cget(-tile), "", "removing Tk::Zinc -tile");
+&wait ("-tile of Tk::Zinc with nothing");
+
+
+
+#### rectangle item
+my $rect1 = $zinc->add('rectangle', 1, [10,10,190,190], -filled => 1);
+
+
+$zinc->itemconfigure($rect1, -tile => $photoMickey);
+is ($zinc->itemcget($rect1, -tile), "mickey.gif", "verifying rectangle -tile option value");
+&wait ("-tile of rectangle with mickey");
+
+# modifying the Tk::Photo to see if the rectangle -tile changes
+$photoMickey->read( Tk->findINC("demos/images/earth.gif") );
+&wait ("-tile of rectangle should display the earth VISUAL INSPECTION!"); sleep 1;
+# going back to the "real" mickey
+$photoMickey->read( Tk->findINC("demos/images/mickey.gif") );
+&wait ("-tile of rectangle should display mickey again VISUAL INSPECTION!"); sleep 1;
+
+
+$zinc->itemconfigure($rect1, -tile => "");
+is ($zinc->itemcget($rect1, -tile), "", "removing rectangle -tile");
+&wait ("-tile of rectangle with nothing");
+
+TODO: {
+    local $TODO = "because it makes Tk::Zinc dying" if 1;
+
+    # the next line makes Tk::Zinc (v3.29x) dying... so I comment it out the 3 next lines 
+    # $zinc->itemconfigure($rect1, -fillpattern => $bitmap)
+    # is ($zinc->itemcget($rect1, -fillpattern), $bitmap, "verifying rectangle -fillpattern option value as a Tk::Bitmap");
+    # &wait ("displaying a rectangle with -fillpattern as a Tk::Bitmap");
+}
+
+$zinc->itemconfigure($rect1, -fillpattern => 'AlphaStipple3');
+is ($zinc->itemcget($rect1, -fillpattern), 'AlphaStipple3', "verifying rectangle -fillpattern option value");
+&wait ("-fillpattern of rectangle with 'AlphaStipple3'");
+
+$zinc->itemconfigure($rect1, -fillpattern => "");
+is ($zinc->itemcget($rect1, -fillpattern), "", "removing rectangle -fillpattern");
+&wait ("-fillpattern of rectangle with nothing");
+
+
+$zinc->itemconfigure($rect1, -filled => 0,-linepattern => 'AlphaStipple3', -linecolor => "red");
+is ($zinc->itemcget($rect1, -linepattern), 'AlphaStipple3', "verifying rectangle -linepattern option value");
+&wait ("-linepattern of rectangle with 'AlphaStipple3'");
+
+$zinc->itemconfigure($rect1, -linepattern => "");
+is ($zinc->itemcget($rect1, -linepattern), "", "removing rectangle -linepattern");
+&wait ("-linepattern of rectangle with nothing");
+
+$zinc->remove($rect1);
+
+#####  icon item
+my $icon1 = $zinc->add('icon', 1, -position => [20,100], -image => $photoMickey);
+&wait ("displaying an icon");
+
+$zinc->remove($icon1);
+
+my $icon2 = $zinc->add('icon', 1, -position => [40,100]);
+
+SKIP: {
+    skip "with Tk::Zinc < 3.295", 4 if ($Tk::Zinc::VERSION < 3.295);
+
+    $zinc->itemconfigure($icon2, -image => $bitmap);
+
+    &wait ("displaying an icon with -image as a Tk::Bitmap");
+    is ($zinc->itemcget($icon2, -image), 'file.xbm', "verifying icon -image option value as file.xbm");
+    $zinc->itemconfigure($icon2, -image => "");
+
+    $zinc->itemconfigure($icon2, -image => '@'.Tk->findINC("openfile.xbm"));
+    is ($zinc->itemcget($icon2, -image), '@'.Tk->findINC("openfile.xbm"),"verifying icon -image option value as @/path/openfile.xbm");
+    &wait ("displaying an icon with -image as a \@filename.xbm");
+}
+$zinc->remove($icon2);
+
+my $icon3 = $zinc->add('icon', 1, -position => [60,100], -mask => '@'.Tk->findINC("openfolder.xbm"),
+		       -color => "red");
+is ($zinc->itemcget($icon3, -mask), '@'.Tk->findINC("openfolder.xbm"),"verifying icon -mask option value as \@/path/openfolder.xbm");
+&wait ("displaying an icon with -mask as a \@filename.xbm");
+
+$zinc->itemconfigure($icon3, -image => "");
+is ($zinc->itemcget($icon3, -image), "", "removing icon -image");
+
+TODO: {
+    local $TODO = "because it makes Tk::Zinc dying" if 1;
+
+    # the next line makes Tk::Zinc (v3.29x) dying... so I comment it out the 3 next lines 
+    # $zinc->itemconfigure($icon3, -mask => $bitmap);
+    # is ($zinc->itemcget($icon3, -mask), $bitmap, "verifying icon -mask option value as a Tk::Bitmap");
+    # &wait ("displaying an icon with -mask as a Tk::Bitmap");
+}
+
+$zinc->remove($icon3);
+
+# We should also test that changing the content of a Tk::Photo should change the display of an icon
+
+
+
+sub wait {
+    $zinc->update;
+    ok (1, $_[0]);
+
+    my $delay = $ARGV[0];
+    if (defined $delay) {
+	$zinc->update;
+	if ($delay =~ /^\d+$/) {
+	    sleep $delay;
+	} else {
+	    sleep 1;
+	}
+    }
+    
+}
+
+
+
+diag("############## Images test");