diff options
Diffstat (limited to 'tk8.6/tests/image.test')
| -rw-r--r-- | tk8.6/tests/image.test | 626 |
1 files changed, 0 insertions, 626 deletions
diff --git a/tk8.6/tests/image.test b/tk8.6/tests/image.test deleted file mode 100644 index 3134ee8..0000000 --- a/tk8.6/tests/image.test +++ /dev/null @@ -1,626 +0,0 @@ -# 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. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands - -imageInit - -# Canvas used in some tests in the whole file -canvas .c -highlightthickness 2 -pack .c -update - - -test image-1.1 {Tk_ImageCmd procedure, "create" option} -body { - image -} -returnCodes error -result {wrong # args: should be "image option ?args?"} -test image-1.2 {Tk_ImageCmd procedure, "create" option} -body { - image gorp -} -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width} -test image-1.3 {Tk_ImageCmd procedure, "create" option} -body { - image create -} -returnCodes error -result {wrong # args: should be "image create type ?name? ?-option value ...?"} -test image-1.4 {Tk_ImageCmd procedure, "create" option} -body { - image c bad_type -} -returnCodes error -result {image type "bad_type" doesn't exist} -test image-1.5 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType -} -body { - list [image create test myimage] [imageNames] -} -cleanup { - imageCleanup -} -result {myimage myimage} -test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType -} -setup { - imageCleanup -} -body { - scan [image create test] image%d first - image create test myimage - scan [image create test -variable x] image%d second - expr $second-$first -} -cleanup { - imageCleanup -} -result {1} - -test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType -} -setup { - imageCleanup -} -body { - 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 - return $x -} -cleanup { - imageCleanup -} -result {{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} -constraints { - testImageType -} -setup { - .c delete all - imageCleanup -} -body { - 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 - return $x -} -cleanup { - .c delete all - imageCleanup -} -result {{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} -constraints { - testImageType -} -body { - image create test -badName foo -} -returnCodes error -result {bad option name "-badName"} -test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType -} -body { - catch {image create test -badName foo} - imageNames -} -result {} -test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window} -body { - set code [loadTkCommand] - append code { - update - puts [list [catch {image create photo .} msg] $msg] - exit - } - set script [makeFile $code script] - exec [interpreter] <$script -} -cleanup { - removeFile script -} -result {1 {images may not be named the same as the main window}} -test image-1.12 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} -body { - set code [loadTkCommand] - append code { - update - puts [list [catch {rename . foo;image create photo foo} msg] $msg] - exit - } - set script [makeFile $code script] - exec [interpreter] <$script -} -cleanup { - removeFile script -} -result {1 {images may not be named the same as the main window}} -test image-1.13 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { - .c delete all - imageCleanup -} -body { - set i [image create bitmap] - regexp {^image(\d+)$} $i -> serial - incr serial - proc image$serial {} {return works} - set j [image create bitmap] - - image$serial -} -cleanup { - rename image$serial {} - image delete $i $j -} -result works - -test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body { - image delete -} -result {} -test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints { - testImageType -} -setup { - imageCleanup - set result {} -} -body { - image create test myimage - image create test img2 - lappend result [lsort [imageNames]] - image d myimage img2 - lappend result [imageNames] -} -cleanup { - imageCleanup -} -result {{img2 myimage} {}} -test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints { - testImageType -} -setup { - imageCleanup -} -body { - image create test myimage - image create test img2 - image delete myimage gorp img2 -} -cleanup { - imageCleanup -} -returnCodes error -result {image "gorp" doesn't exist} -test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints { - testImageType -} -setup { - imageCleanup -} -body { - image create test myimage - image create test img2 - catch {image delete myimage gorp img2} - imageNames -} -cleanup { - imageCleanup -} -result {img2} - - -test image-3.1 {Tk_ImageCmd procedure, "height" option} -body { - image height -} -returnCodes error -result {wrong # args: should be "image height name"} -test image-3.2 {Tk_ImageCmd procedure, "height" option} -body { - image height a b -} -returnCodes error -result {wrong # args: should be "image height name"} -test image-3.3 {Tk_ImageCmd procedure, "height" option} -body { - image height foo -} -returnCodes error -result {image "foo" doesn't exist} -test image-3.4 {Tk_ImageCmd procedure, "height" option} -constraints { - testImageType -} -setup { - imageCleanup -} -body { - image create test myimage - set x [image h myimage] - myimage changed 0 0 0 0 60 50 - list $x [image height myimage] -} -cleanup { - imageCleanup -} -result {15 50} - - -test image-4.1 {Tk_ImageCmd procedure, "names" option} -body { - image names x -} -returnCodes error -result {wrong # args: should be "image names"} -test image-4.2 {Tk_ImageCmd procedure, "names" option} -constraints { - testImageType -} -setup { - catch {interp delete testinterp} -} -body { - interp create testinterp - load {} Tk testinterp - interp eval testinterp { - image delete {*}[image names] - image create test myimage - image create test img2 - image create test 24613 - lsort [image names] - } -} -cleanup { - interp delete testinterp -} -result {24613 img2 myimage} -test image-4.3 {Tk_ImageCmd procedure, "names" option} -setup { - catch {interp delete testinterp} -} -body { - interp create testinterp - load {} Tk testinterp - interp eval testinterp { - image delete {*}[image names] - eval image delete [image names] [image names] - lsort [image names] - } -} -cleanup { - interp delete testinterp -} -result {} - - -test image-5.1 {Tk_ImageCmd procedure, "type" option} -body { - image type -} -returnCodes error -result {wrong # args: should be "image type name"} -test image-5.2 {Tk_ImageCmd procedure, "type" option} -body { - image type a b -} -returnCodes error -result {wrong # args: should be "image type name"} -test image-5.3 {Tk_ImageCmd procedure, "type" option} -body { - image type foo -} -returnCodes error -result {image "foo" doesn't exist} - -test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints { - testImageType -} -setup { - imageCleanup -} -body { - image create test myimage - image type myimage -} -cleanup { - imageCleanup -} -result {test} -test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints { - testImageType -} -setup { - imageCleanup -} -body { - image create test myimage - .c create image 50 50 -image myimage - image delete myimage - image type myimage -} -cleanup { - imageCleanup -} -returnCodes error -result {image "myimage" doesn't exist} -test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints { - testOldImageType -} -setup { - imageCleanup -} -body { - image create oldtest myimage - image type myimage -} -cleanup { - imageCleanup -} -result {oldtest} -test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints { - testOldImageType -} -setup { - .c delete all - imageCleanup -} -body { - image create oldtest myimage - .c create image 50 50 -image myimage - image delete myimage - image type myimage -} -cleanup { - .c delete all - imageCleanup -} -returnCodes error -result {image "myimage" doesn't exist} - - -test image-6.1 {Tk_ImageCmd procedure, "types" option} -body { - image types x -} -returnCodes error -result {wrong # args: should be "image types"} -test image-6.2 {Tk_ImageCmd procedure, "types" option} -constraints { - testImageType -} -body { - lsort [image types] -} -result {bitmap oldtest photo test} - - -test image-7.1 {Tk_ImageCmd procedure, "width" option} -body { - image width -} -returnCodes error -result {wrong # args: should be "image width name"} -test image-7.2 {Tk_ImageCmd procedure, "width" option} -body { - image width a b -} -returnCodes error -result {wrong # args: should be "image width name"} -test image-7.3 {Tk_ImageCmd procedure, "width" option} -body { - image width foo -} -returnCodes error -result {image "foo" doesn't exist} -test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints { - testImageType -} -setup { - imageCleanup -} -body { - image create test myimage - set x [image w myimage] - myimage changed 0 0 0 0 60 50 - list $x [image width myimage] -} -cleanup { - imageCleanup -} -result {30 60} - - -test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints { - testImageType -} -setup { - imageCleanup - set res {} - destroy .b -} -body { - image create test myimage2 - lappend res [image inuse myimage2] - button .b -image myimage2 - lappend res [image inuse myimage2] -} -cleanup { - imageCleanup - catch {destroy .b} -} -result [list 0 1] - - -test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { - .c delete all - imageCleanup -} -body { - 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 - return $x -} -cleanup { - .c delete all - imageCleanup -} -result {{foo display 5 6 7 8 30 30}} -test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { - .c delete all - imageCleanup -} -body { - 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 - return $x -} -cleanup { - .c delete all - imageCleanup -} -result {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} - - -test image-10.1 {Tk_GetImage procedure} -setup { - imageCleanup -} -body { - .c create image 100 10 -image bad_name -} -cleanup { - imageCleanup -} -returnCodes error -result {image "bad_name" doesn't exist} -test image-10.2 {Tk_GetImage procedure} -constraints testImageType -setup { - destroy .l - imageCleanup -} -body { - image create test mytest - label .l -image mytest - image delete mytest - label .l2 -image mytest -} -cleanup { - destroy .l - imageCleanup -} -returnCodes error -result {image "mytest" doesn't exist} - - -test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup { - .c delete all - imageCleanup -} -body { - 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 [imageNames] $x -} -cleanup { - .c delete all - imageCleanup -} -result {foo {{foo free} {foo display 0 0 30 15 103 121}}} -test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup { - .c delete all - imageCleanup -} -body { - image create test foo -variable x - .c create image 50 50 -image foo -tags i1 - set names [imageNames] - image delete foo - update - set names2 [imageNames] - set x {} - .c delete i1 - pack forget .c - pack .c - update - list $names $names2 [imageNames] $x -} -cleanup { - .c delete all - imageCleanup -} -result {foo {} {} {}} - - -# Non-portable, apparently due to differences in rounding: -test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { - testImageType nonPortable -} -setup { - imageCleanup -} -body { - 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 - return $x -} -cleanup { - imageCleanup -} -result {{foo display 0 0 5 5 50 50}} -test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { - testImageType nonPortable -} -setup { - imageCleanup -} -body { - 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 - return $x -} -cleanup { - imageCleanup -} -result {{foo display 10 0 20 5 30 50}} -test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { - testImageType nonPortable -} -setup { - imageCleanup -} -body { - 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 - return $x -} -cleanup { - imageCleanup -} -result {{foo display 10 10 20 5 30 30}} -test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { - testImageType nonPortable -} -setup { - imageCleanup -} -body { - 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 - return $x -} -cleanup { - imageCleanup -} -result {{foo display 0 10 5 5 50 30}} -test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { - testImageType nonPortable -} -setup { - imageCleanup -} -body { - 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 - return $x -} -cleanup { - imageCleanup -} -result {{foo display 0 0 30 15 70 70}} -test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { - testImageType nonPortable -} -setup { - imageCleanup -} -body { - 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 - return $x -} -cleanup { - imageCleanup -} -result {{foo display 5 5 20 5 30 30}} - - -test image-13.1 {Tk_SizeOfImage procedure} -constraints testImageType -setup { - imageCleanup -} -body { - 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] -} -cleanup { - imageCleanup -} -result {30 15 85 60} - -test image-13.2 {DeleteImage procedure} -constraints testImageType -setup { - .c delete all - imageCleanup -} -body { - 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 | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] | -} -cleanup { - imageCleanup -} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} - -test image-13.3 {Tk_SizeOfImage procedure} -constraints testOldImageType -setup { - imageCleanup -} -body { - image create oldtest 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] -} -cleanup { - imageCleanup -} -result {30 15 85 60} - -test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup { - .c delete all - imageCleanup -} -body { - image create oldtest 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 | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] | -} -cleanup { - .c delete all - imageCleanup -} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} - -test image-14.1 {image command vs hidden commands} -body { - catch {image delete hidden} - set l [imageNames] - set h [interp hidden] - image create photo hidden - interp hide {} hidden - image delete hidden - set res1 [list [imageNames] [interp hidden]] - set res2 [list $l $h] - expr {$res1 eq $res2} -} -result 1 - -test image-15.1 {deleting image does not make widgets forget about it} -setup { - .c delete all - imageCleanup -} -body { - image create photo foo -width 10 -height 10 - .c create image 10 10 -image foo -tags i1 -anchor nw - update - set x [.c bbox i1] - lappend x [imageNames] - image delete foo - lappend x [imageNames] - image create photo foo -width 20 -height 20 - lappend x [.c bbox i1] [imageNames] -} -cleanup { - .c delete all - imageCleanup -} -result {10 10 20 20 foo {} {10 10 30 30} foo} - -destroy .c -imageFinish - -# cleanup -cleanupTests -return - -# Local variables: -# mode: tcl -# End: |