diff options
Diffstat (limited to 'tests/image.test')
| -rw-r--r-- | tests/image.test | 357 |
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] |