Subversion Repositories or1k

# 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.

#

# RCS: @(#) $Id: image.test,v 1.1.1.1 2002-01-16 10:25:58 markom Exp $

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]