# 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. # # RCS: @(#) $Id: image.test,v 1.8.2.1 2003/09/17 23:45:05 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands namespace import -force tcltest::interpreter namespace import -force tcltest::makeFile namespace import -force tcltest::removeFile 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, 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 { 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 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} testImageType { .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} testImageType { .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} { set script [makeFile { update puts [list [catch {image create photo .} msg] $msg] exit } script] set x [list [catch {exec [interpreter] <$script} msg] $msg] 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} { set script [makeFile { update puts [list [catch {rename . foo;image create photo foo} msg] $msg] exit } script] set x [list [catch {exec [interpreter] <$script} msg] $msg] removeFile script set x } {0 {1 {images may not be named the same as the main window}}} test image-1.11 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { 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] 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} testImageType { .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} testImageType { 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} 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 { image create test myimage image type myimage } {test} test image-5.5 {Tk_ImageCmd procedure, "type" option} testImageType { 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} testImageType { 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} testImageType { 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_ImageCmd procedure, "inuse" option} testImageType { catch {image delete myimage2} image create test myimage2 set res {} lappend res [image inuse myimage2] catch {destroy .b} button .b -image myimage2 lappend res [image inuse myimage2] catch {destroy .b} image delete myimage2 set res } [list 0 1] test image-9.1 {Tk_ImageChanged procedure} testImageType { .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-9.2 {Tk_ImageChanged procedure} testImageType { .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-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 { 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-11.1 {Tk_FreeImage procedure} testImageType { .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-11.2 {Tk_FreeImage procedure} testImageType { .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-12.1 {Tk_RedrawImage procedure, redisplay area clipping} \ {testImageType 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-12.2 {Tk_RedrawImage procedure, redisplay area clipping} \ {testImageType 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-12.3 {Tk_RedrawImage procedure, redisplay area clipping} \ {testImageType 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-12.4 {Tk_RedrawImage procedure, redisplay area clipping} \ {testImageType 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-12.5 {Tk_RedrawImage procedure, redisplay area clipping} \ {testImageType 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-12.6 {Tk_RedrawImage procedure, redisplay area clipping} \ {testImageType 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-13.1 {Tk_SizeOfImage procedure} testImageType { 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-13.2 {DeleteImage procedure} testImageType { .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-14.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] # cleanup ::tcltest::cleanupTests return