summaryrefslogtreecommitdiffstats
path: root/tests/image.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/image.test')
-rw-r--r--tests/image.test357
1 files changed, 357 insertions, 0 deletions
diff --git a/tests/image.test b/tests/image.test
new file mode 100644
index 0000000..b4e7ad7
--- /dev/null
+++ b/tests/image.test
@@ -0,0 +1,357 @@
+# This file is a Tcl script to test out the "image" command and the
+# other procedures in the file tkImage.c. It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) image.test 1.15 97/07/31 10:17:25
+
+if {[lsearch [image types] test] < 0} {
+ puts "This application hasn't been compiled with the \"test\" image"
+ puts "type, so I can't run this test. Are you sure you're using"
+ puts "tktest instead of wish?"
+ return
+}
+
+if {[info procs test] != "test"} {
+ source defs
+}
+
+foreach i [winfo children .] {
+ destroy $i
+}
+wm geometry . {}
+raise .
+
+eval image delete [image names]
+canvas .c -highlightthickness 2
+pack .c
+update
+test image-1.1 {Tk_ImageCmd procedure, "create" option} {
+ list [catch image msg] $msg
+} {1 {wrong # args: should be "image option ?args?"}}
+test image-1.2 {Tk_ImageCmd procedure, "create" option} {
+ list [catch {image gorp} msg] $msg
+} {1 {bad option "gorp": must be create, delete, height, names, type, types, or width}}
+test image-1.3 {Tk_ImageCmd procedure, "create" option} {
+ list [catch {image create} msg] $msg
+} {1 {wrong # args: should be "image create type ?name? ?options?"}}
+test image-1.4 {Tk_ImageCmd procedure, "create" option} {
+ list [catch {image c bad_type} msg] $msg
+} {1 {image type "bad_type" doesn't exist}}
+test image-1.5 {Tk_ImageCmd procedure, "create" option} {
+ list [image create test myimage] [image names]
+} {myimage myimage}
+test image-1.6 {Tk_ImageCmd procedure, "create" option} {
+ scan [image create test] image%d first
+ image create test myimage
+ scan [image create test -variable x] image%d second
+ expr $second-$first
+} {1}
+test image-1.7 {Tk_ImageCmd procedure, "create" option} {
+ image delete myimage
+ image create test myimage -variable x
+ .c create image 100 50 -image myimage
+ .c create image 100 150 -image myimage
+ update
+ set x {}
+ image create test myimage -variable x
+ update
+ set x
+} {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
+test image-1.8 {Tk_ImageCmd procedure, "create" option} {
+ .c delete all
+ image create test myimage -variable x
+ .c create image 100 50 -image myimage
+ .c create image 100 150 -image myimage
+ image delete myimage
+ update
+ set x {}
+ image create test myimage -variable x
+ update
+ set x
+} {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
+test image-1.9 {Tk_ImageCmd procedure, "create" option} {
+ .c delete all
+ eval image delete [image names]
+ list [catch {image create test -badName foo} msg] $msg [image names]
+} {1 {bad option name "-badName"} {}}
+
+test image-2.1 {Tk_ImageCmd procedure, "delete" option} {
+ list [catch {image delete} msg] $msg
+} {0 {}}
+test image-2.2 {Tk_ImageCmd procedure, "delete" option} {
+ .c delete all
+ eval image delete [image names]
+ image create test myimage
+ image create test img2
+ set result {}
+ lappend result [lsort [image names]]
+ image d myimage img2
+ lappend result [image names]
+} {{img2 myimage} {}}
+test image-2.3 {Tk_ImageCmd procedure, "delete" option} {
+ .c delete all
+ eval image delete [image names]
+ image create test myimage
+ image create test img2
+ list [catch {image delete myimage gorp img2} msg] $msg [image names]
+} {1 {image "gorp" doesn't exist} img2}
+
+test image-3.1 {Tk_ImageCmd procedure, "height" option} {
+ list [catch {image height} msg] $msg
+} {1 {wrong # args: should be "image height name"}}
+test image-3.2 {Tk_ImageCmd procedure, "height" option} {
+ list [catch {image height a b} msg] $msg
+} {1 {wrong # args: should be "image height name"}}
+test image-3.3 {Tk_ImageCmd procedure, "height" option} {
+ list [catch {image height foo} msg] $msg
+} {1 {image "foo" doesn't exist}}
+test image-3.4 {Tk_ImageCmd procedure, "height" option} {
+ image create test myimage
+ set x [image h myimage]
+ myimage changed 0 0 0 0 60 50
+ list $x [image height myimage]
+} {15 50}
+
+test image-4.1 {Tk_ImageCmd procedure, "names" option} {
+ list [catch {image names x} msg] $msg
+} {1 {wrong # args: should be "image names"}}
+test image-4.2 {Tk_ImageCmd procedure, "names" option} {
+ .c delete all
+ eval image delete [image names]
+ image create test myimage
+ image create test img2
+ image create test 24613
+ lsort [image names]
+} {24613 img2 myimage}
+test image-4.3 {Tk_ImageCmd procedure, "names" option} {
+ .c delete all
+ eval image delete [image names]
+ lsort [image names]
+} {}
+
+test image-5.1 {Tk_ImageCmd procedure, "type" option} {
+ list [catch {image type} msg] $msg
+} {1 {wrong # args: should be "image type name"}}
+test image-5.2 {Tk_ImageCmd procedure, "type" option} {
+ list [catch {image type a b} msg] $msg
+} {1 {wrong # args: should be "image type name"}}
+test image-5.3 {Tk_ImageCmd procedure, "type" option} {
+ list [catch {image type foo} msg] $msg
+} {1 {image "foo" doesn't exist}}
+test image-5.4 {Tk_ImageCmd procedure, "type" option} {
+ image create test myimage
+ image type myimage
+} {test}
+test image-5.5 {Tk_ImageCmd procedure, "type" option} {
+ image create test myimage
+ .c create image 50 50 -image myimage
+ image delete myimage
+ image type myimage
+} {}
+
+test image-6.1 {Tk_ImageCmd procedure, "types" option} {
+ list [catch {image types x} msg] $msg
+} {1 {wrong # args: should be "image types"}}
+test image-6.2 {Tk_ImageCmd procedure, "types" option} {
+ lsort [image types]
+} {bitmap photo test}
+
+test image-7.1 {Tk_ImageCmd procedure, "width" option} {
+ list [catch {image width} msg] $msg
+} {1 {wrong # args: should be "image width name"}}
+test image-7.2 {Tk_ImageCmd procedure, "width" option} {
+ list [catch {image width a b} msg] $msg
+} {1 {wrong # args: should be "image width name"}}
+test image-7.3 {Tk_ImageCmd procedure, "width" option} {
+ list [catch {image width foo} msg] $msg
+} {1 {image "foo" doesn't exist}}
+test image-7.4 {Tk_ImageCmd procedure, "width" option} {
+ image create test myimage
+ set x [image w myimage]
+ myimage changed 0 0 0 0 60 50
+ list $x [image width myimage]
+} {30 60}
+
+test image-8.1 {Tk_ImageChanged procedure} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 50 -image foo
+ update
+ set x {}
+ foo changed 5 6 7 8 30 15
+ update
+ set x
+} {{foo display 5 6 7 8 30 30}}
+test image-8.2 {Tk_ImageChanged procedure} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 50 -image foo
+ .c create image 90 100 -image foo
+ update
+ set x {}
+ foo changed 5 6 7 8 30 15
+ update
+ set x
+} {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}}
+
+test image-9.1 {Tk_GetImage procedure} {
+ list [catch {.c create image 100 10 -image bad_name} msg] $msg
+} {1 {image "bad_name" doesn't exist}}
+test image-9.2 {Tk_GetImage procedure} {
+ image create test mytest
+ catch {destroy .l}
+ label .l -image mytest
+ image delete mytest
+ set result [list [catch {label .l2 -image mytest} msg] $msg]
+ destroy .l
+ set result
+} {1 {image "mytest" doesn't exist}}
+
+test image-10.1 {Tk_FreeImage procedure} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 50 -image foo -tags i1
+ .c create image 90 100 -image foo -tags i2
+ pack forget .c
+ update
+ set x {}
+ .c delete i1
+ pack .c
+ update
+ list [image names] $x
+} {foo {{foo free} {foo display 0 0 30 15 103 121}}}
+test image-10.2 {Tk_FreeImage procedure} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 50 -image foo -tags i1
+ image delete foo
+ update
+ set names [image names]
+ set x {}
+ .c delete i1
+ pack forget .c
+ pack .c
+ update
+ list $names [image names] $x
+} {foo {} {}}
+
+# Non-portable, apparently due to differences in rounding:
+
+test image-11.1 {Tk_RedrawImage procedure, redisplay area clipping} \
+ {nonPortable} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 30 40 55 65 -width 0 -fill black -outline {}
+ set x {}
+ update
+ set x
+} {{foo display 0 0 5 5 50 50}}
+test image-11.2 {Tk_RedrawImage procedure, redisplay area clipping} \
+ {nonPortable} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 60 40 100 65 -width 0 -fill black -outline {}
+ set x {}
+ update
+ set x
+} {{foo display 10 0 20 5 30 50}}
+test image-11.3 {Tk_RedrawImage procedure, redisplay area clipping} \
+ {nonPortable} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 60 70 100 200 -width 0 -fill black -outline {}
+ set x {}
+ update
+ set x
+} {{foo display 10 10 20 5 30 30}}
+test image-11.4 {Tk_RedrawImage procedure, redisplay area clipping} \
+ {nonPortable} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 30 70 55 200 -width 0 -fill black -outline {}
+ set x {}
+ update
+ set x
+} {{foo display 0 10 5 5 50 30}}
+test image-11.5 {Tk_RedrawImage procedure, redisplay area clipping} \
+ {nonPortable} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 10 20 120 130 -width 0 -fill black -outline {}
+ set x {}
+ update
+ set x
+} {{foo display 0 0 30 15 70 70}}
+test image-11.6 {Tk_RedrawImage procedure, redisplay area clipping} \
+ {nonPortable} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 55 65 75 70 -width 0 -fill black -outline {}
+ set x {}
+ update
+ set x
+} {{foo display 5 5 20 5 30 30}}
+
+test image-12.1 {Tk_SizeOfImage procedure} {
+ eval image delete [image names]
+ image create test foo -variable x
+ set result [list [image width foo] [image height foo]]
+ foo changed 0 0 0 0 85 60
+ lappend result [image width foo] [image height foo]
+} {30 15 85 60}
+
+test image-12.2 {DeleteImage procedure} {
+ .c delete all
+ eval image delete [image names]
+ image create test foo -variable x
+ .c create image 50 50 -image foo -tags i1
+ .c create image 90 100 -image foo -tags i2
+ set x {}
+ image delete foo
+ lappend x | [image names] |
+ image delete foo
+ lappend x | [image names] |
+} {{foo free} {foo free} {foo delete} | foo | | foo |}
+
+catch {image delete hidden}
+set l [image names]
+set h [interp hidden]
+
+test image-13.1 {image command vs hidden commands} {
+ catch {image delete hidden}
+ image create photo hidden
+ interp hide {} hidden
+ image delete hidden
+ list [image names] [interp hidden]
+} [list $l $h]
+
+destroy .c
+eval image delete [image names]