path: root/tests/image.test

# 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