diff options
Diffstat (limited to 'tests/image.test')
| -rw-r--r-- | tests/image.test | 639 |
1 files changed, 413 insertions, 226 deletions
diff --git a/tests/image.test b/tests/image.test index c6c4f8a..3134ee8 100644 --- a/tests/image.test +++ b/tests/image.test @@ -7,38 +7,56 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force ::tk::test::loadTkCommand -eval image delete [image names] +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} { - 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, inuse, 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} testImageType { - list [image create test myimage] [image names] -} {myimage myimage} -test image-1.6 {Tk_ImageCmd procedure, "create" option} testImageType { + + +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 -} {1} -test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType { - image delete myimage +} -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 @@ -46,10 +64,16 @@ test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType { 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} testImageType { + 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 @@ -58,185 +82,289 @@ test image-1.8 {Tk_ImageCmd procedure, "create" option} testImageType { 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} testImageType { + return $x +} -cleanup { .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-1.10 {Tk_ImageCmd procedure, "create" option with same name as main window} { + 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 + update + puts [list [catch {image create photo .} msg] $msg] + exit } set script [makeFile $code script] - set x [list [catch {exec [interpreter] <$script} msg] $msg] + exec [interpreter] <$script +} -cleanup { removeFile script - set x -} {0 {1 {images may not be named the same as the main window}}} -test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} { +} -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 + update + puts [list [catch {rename . foo;image create photo foo} msg] $msg] + exit } set script [makeFile $code script] - set x [list [catch {exec [interpreter] <$script} msg] $msg] + exec [interpreter] <$script +} -cleanup { removeFile script - set x -} {0 {1 {images may not be named the same as the main window}}} -test image-1.12 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { +} -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] -} -body { + image$serial } -cleanup { rename image$serial {} image delete $i $j } -result works -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} testImageType { - .c delete all - eval image delete [image names] +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 - set result {} - lappend result [lsort [image names]] + lappend result [lsort [imageNames]] image d myimage img2 - lappend result [image names] -} {{img2 myimage} {}} -test image-2.3 {Tk_ImageCmd procedure, "delete" option} testImageType { - .c delete all - eval image delete [image names] + 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 - 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} testImageType { + 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] -} {15 50} +} -cleanup { + imageCleanup +} -result {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} testImageType { - .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} testImageType { + +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 -} {test} -test image-5.5 {Tk_ImageCmd procedure, "type" option} testImageType { +} -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 - list [catch {image type myimage} msg] $msg -} {1 {image "myimage" doesn't exist}} -test image-5.6 {Tk_ImageCmd procedure, "type" option} testOldImageType { + 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 -} {oldtest} -test image-5.7 {Tk_ImageCmd procedure, "type" option} testOldImageType { +} -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 - list [catch {image type myimage} msg] $msg -} {1 {image "myimage" doesn't exist}} + 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} { - list [catch {image types x} msg] $msg -} {1 {wrong # args: should be "image types"}} -test image-6.2 {Tk_ImageCmd procedure, "types" option} testImageType { + +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] -} {bitmap oldtest 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} testImageType { +} -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] -} {30 60} +} -cleanup { + imageCleanup +} -result {30 60} -test image-8.1 {Tk_ImageCmd procedure, "inuse" option} testImageType { - catch {image delete myimage2} - image create test myimage2 + +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] - catch {destroy .b} button .b -image myimage2 lappend res [image inuse myimage2] +} -cleanup { + imageCleanup catch {destroy .b} - image delete myimage2 - set res -} [list 0 1] +} -result [list 0 1] -test image-9.1 {Tk_ImageChanged procedure} testImageType { +test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all - eval image delete [image names] + 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 - set x -} {{foo display 5 6 7 8 30 30}} -test image-9.2 {Tk_ImageChanged procedure} testImageType { + 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 - eval image delete [image names] + imageCleanup +} -body { image create test foo -variable x .c create image 50 50 -image foo .c create image 90 100 -image foo @@ -244,25 +372,38 @@ test image-9.2 {Tk_ImageChanged procedure} testImageType { 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}} + 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} { - list [catch {.c create image 100 10 -image bad_name} msg] $msg -} {1 {image "bad_name" doesn't exist}} -test image-10.2 {Tk_GetImage procedure} testImageType { +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 - catch {destroy .l} label .l -image mytest image delete mytest - set result [list [catch {label .l2 -image mytest} msg] $msg] + label .l2 -image mytest +} -cleanup { destroy .l - set result -} {1 {image "mytest" doesn't exist}} + imageCleanup +} -returnCodes error -result {image "mytest" doesn't exist} + -test image-11.1 {Tk_FreeImage procedure} testImageType { +test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup { .c delete all - eval image delete [image names] + 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 @@ -272,168 +413,214 @@ test image-11.1 {Tk_FreeImage procedure} testImageType { .c delete i1 pack .c update - list [image names] $x -} {foo {{foo free} {foo display 0 0 30 15 103 121}}} -test image-11.2 {Tk_FreeImage procedure} testImageType { + list [imageNames] $x +} -cleanup { .c delete all - eval image delete [image names] + 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 [image names] + set names [imageNames] image delete foo update - set names2 [image names] + set names2 [imageNames] set x {} .c delete i1 pack forget .c pack .c update - list $names $names2 [image names] $x -} {foo {} {} {}} + 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} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] +# 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 - set x -} {{foo display 0 0 5 5 50 50}} -test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + 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 - set x -} {{foo display 10 0 20 5 30 50}} -test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + 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 - set x -} {{foo display 10 10 20 5 30 30}} -test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + 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 - set x -} {{foo display 0 10 5 5 50 30}} -test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + 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 - set x -} {{foo display 0 0 30 15 70 70}} -test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + 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 - set x -} {{foo display 5 5 20 5 30 30}} + return $x +} -cleanup { + imageCleanup +} -result {{foo display 5 5 20 5 30 30}} -test image-13.1 {Tk_SizeOfImage procedure} testImageType { - eval image delete [image names] + +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] -} {30 15 85 60} +} -cleanup { + imageCleanup +} -result {30 15 85 60} -test image-13.2 {DeleteImage procedure} testImageType { +test image-13.2 {DeleteImage procedure} -constraints testImageType -setup { .c delete all - eval image delete [image names] + 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 | [image names] | [catch {image delete foo} msg] | $msg | [image names] | -} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} + 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} testOldImageType { - eval image delete [image names] +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] -} {30 15 85 60} +} -cleanup { + imageCleanup +} -result {30 15 85 60} -test image-13.4 {DeleteImage procedure} testOldImageType { +test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup { .c delete all - eval image delete [image names] + 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 | [image names] | [catch {image delete foo} msg] | $msg | [image names] | -} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} - - -catch {image delete hidden} -set l [image names] -set h [interp hidden] + 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} { +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 - list [image names] [interp hidden] -} [list $l $h] + set res1 [list [imageNames] [interp hidden]] + set res2 [list $l $h] + expr {$res1 eq $res2} +} -result 1 -eval image delete [image names] -test image-15.1 {deleting image does not make widgets forget about it} { +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 [image names] + lappend x [imageNames] image delete foo - lappend x [image names] + lappend x [imageNames] image create photo foo -width 20 -height 20 - lappend x [.c bbox i1] [image names] -} {10 10 20 20 foo {} {10 10 30 30} foo} + lappend x [.c bbox i1] [imageNames] +} -cleanup { + .c delete all + imageCleanup +} -result {10 10 20 20 foo {} {10 10 30 30} foo} destroy .c -eval image delete [image names] +imageFinish # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: |