Subversion Repositories or1k

# This file is a Tcl script to test labels, buttons, checkbuttons, and

# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c).  It is

# organized in the standard fashion for Tcl tests.

#

# Copyright (c) 1994 The Regents of the University of California.

# Copyright (c) 1994-1996 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: button.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\""

    puts "image, 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 .

proc bogusTrace args {

    error "trace aborted"

}

catch {unset value}

catch {unset value2}

# Create entries in the option database to be sure that geometry options

# like border width have predictable values.

option add *Button.borderWidth 2

option add *Button.highlightThickness 2

option add *Button.font {Helvetica -12 bold}

eval image delete [image names]

image create test image1

label .l -text Label

button .b -text Button

checkbutton .c -text Checkbutton

radiobutton .r -text Radiobutton

pack .l .b .c .r

update

set i 1

foreach test {

    {-activebackground #012345 #012345 non-existent

            {unknown color name "non-existent"}}

    {-activeforeground #ff0000 #ff0000 non-existent

            {unknown color name "non-existent"}}

    {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}}

    {-background #ff0000 #ff0000 non-existent

            {unknown color name "non-existent"}}

    {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}

    {-bd 4 4 badValue {bad screen distance "badValue"}}

    {-bitmap questhead questhead badValue {bitmap "badValue" not defined}}

    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}

    {-command "set x" {set x} {} {}}

    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}

    {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}}

    {-fg #110022 #110022 bogus {unknown color name "bogus"}}

    {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}}

    {-foreground #110022 #110022 bogus {unknown color name "bogus"}}

    {-height 18 18 20.0 {expected integer but got "20.0"}}

    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}

    {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}

    {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}

    {-image image1 image1 bogus {image "bogus" doesn't exist}}

    {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}}

    {-justify right right bogus {bad justification "bogus": must be left, right, or center}}

    {-offvalue lousy lousy {} {}}

    {-offvalue fantastic fantastic {} {}}

    {-padx 12 12 420x {bad screen distance "420x"}}

    {-pady 12 12 420x {bad screen distance "420x"}}

    {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}

    {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}}

    {-selectimage image1 image1 bogus {image "bogus" doesn't exist}}

    {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}}

    {-takefocus "any string" "any string" {} {}}

    {-text "Sample text" {Sample text} {} {}}

    {-textvariable i i {} {}}

    {-underline 5 5 3p {expected integer but got "3p"}}

    {-width 402 402 3p {expected integer but got "3p"}}

    {-wraplength 100 100 6x {bad screen distance "6x"}}

} {

    set name [lindex $test 0]

    test button-1.$i {configuration options} {

        .c configure $name [lindex $test 1]

        lindex [.c configure $name] 4

    } [lindex $test 2]

    incr i

    if {[lindex $test 3] != ""} {

        test button-1.$i {configuration options} {

            list [catch {.c configure $name [lindex $test 3]} msg] $msg

        } [list 1 [lindex $test 4]]

    }

    .c configure $name [lindex [.c configure $name] 3]

    incr i

}

test button-1.$i {configuration options} {

    .c configure -selectcolor {}

} {}

incr i

# the following tests only work on buttons, not checkbuttons

test button-1.$i {configuration options} {

    .b configure -default active

    lindex [.b configure -default] 4

} active

incr i

test button-1.$i {configuration options} {

    .b configure -default normal

    lindex [.b configure -default] 4

} normal

incr i

test button-1.$i {configuration options} {

    .b configure -default disabled

    lindex [.b configure -default] 4

} disabled

incr i

test button-1.$i {configuration options} {

    .b configure -default active

    lindex [.b configure -default] 3

} disabled

incr i

test button-1.$i {configuration options} {

    list [catch {.b configure -default no_way} msg] $msg

} {1 {bad -default value "no_way": must be normal, active, or disabled}}

set i 1

foreach check {

    {-activebackground 1 0 0 0}

    {-activeforeground 1 0 0 0}

    {-anchor 0 0 0 0}

    {-background 0 0 0 0}

    {-bd 0 0 0 0}

    {-bg 0 0 0 0}

    {-bitmap 0 0 0 0}

    {-borderwidth 0 0 0 0}

    {-command 1 0 0 0}

    {-cursor 0 0 0 0}

    {-default 1 0 1 1}

    {-disabledforeground 1 0 0 0}

    {-fg 0 0 0 0}

    {-font 0 0 0 0}

    {-foreground 0 0 0 0}

    {-height 0 0 0 0}

    {-image 0 0 0 0}

    {-indicatoron 1 1 0 0}

    {-offvalue 1 1 0 1}

    {-onvalue 1 1 0 1}

    {-padx 0 0 0 0}

    {-pady 0 0 0 0}

    {-relief 0 0 0 0}

    {-selectcolor 1 1 0 0}

    {-selectimage 1 1 0 0}

    {-state 1 0 0 0}

    {-text 0 0 0 0}

    {-textvariable 0 0 0 0}

    {-value 1 1 1 0}

    {-variable 1 1 0 0}

    {-width 0 0 0 0}

} {

    test button-2.$i {label-specific options} "

        catch {.l configure [lindex $check 0]}

    " [lindex $check 1]

    incr i

    test button-2.$i {button-specific options} "

        catch {.b configure [lindex $check 0]}

    " [lindex $check 2]

    incr i

    test button-2.$i {checkbutton-specific options} "

        catch {.c configure [lindex $check 0]}

    " [lindex $check 3]

    incr i

    test button-2.$i {radiobutton-specific options} "

        catch {.r configure [lindex $check 0]}

    " [lindex $check 4]

    incr i

}

test button-3.1 {ButtonCreate procedure} {

    list [catch {button} msg] $msg

} {1 {wrong # args: should be "button pathName ?options?"}}

test button-3.2 {ButtonCreate procedure} {

    catch {destroy .x}

    label .x

    winfo class .x

} {Label}

test button-3.3 {ButtonCreate procedure} {

    catch {destroy .x}

    button .x

    winfo class .x

} {Button}

test button-3.4 {ButtonCreate procedure} {

    catch {destroy .x}

    checkbutton .x

    winfo class .x

} {Checkbutton}

test button-3.5 {ButtonCreate procedure} {

    catch {destroy .x}

    radiobutton .x

    winfo class .x

} {Radiobutton}

rename button gorp

test button-3.6 {ButtonCreate procedure} {

    catch {destroy .x}

    gorp .x

    winfo class .x

} {Button}

rename gorp button

test button-3.7 {ButtonCreate procedure} {

    list [catch {button foo} msg] $msg

} {1 {bad window path name "foo"}}

test button-3.8 {ButtonCreate procedure} {

    catch {destroy .x}

    list [catch {button .x -gorp foo} msg] $msg [winfo exists .x]

} {1 {unknown option "-gorp"} 0}

test button-4.1 {ButtonWidgetCmd procedure} {

    list [catch {.b} msg] $msg

} {1 {wrong # args: should be ".b option ?arg arg ...?"}}

test button-4.2 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.b c} msg] $msg

} {1 {bad option "c": must be cget, configure, flash, or invoke}}

test button-4.3 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.b cget a b} msg] $msg

} {1 {wrong # args: should be ".b cget option"}}

test button-4.4 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.b cget -gorp} msg] $msg

} {1 {unknown option "-gorp"}}

test button-4.5 {ButtonWidgetCmd procedure, "cget" option} {

    .b configure -highlightthickness 3

    .b cget -highlightthickness

} {3}

test button-4.6 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.l cget -disabledforeground} msg] $msg

} {1 {unknown option "-disabledforeground"}}

test button-4.7 {ButtonWidgetCmd procedure, "cget" option} {

    catch {.b cget -disabledforeground}

} {0}

test button-4.8 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.b cget -variable} msg] $msg

} {1 {unknown option "-variable"}}

test button-4.9 {ButtonWidgetCmd procedure, "cget" option} {

    catch {.c cget -variable}

} {0}

test button-4.10 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.c cget -value} msg] $msg

} {1 {unknown option "-value"}}

test button-4.11 {ButtonWidgetCmd procedure, "cget" option} {

    catch {.r cget -value}

} {0}

test button-4.12 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.r cget -onvalue} msg] $msg

} {1 {unknown option "-onvalue"}}

test button-4.13 {ButtonWidgetCmd procedure, "configure" option} {

    llength [.c configure]

} {36}

test button-4.14 {ButtonWidgetCmd procedure, "configure" option} {

    list [catch {.b configure -gorp} msg] $msg

} {1 {unknown option "-gorp"}}

test button-4.15 {ButtonWidgetCmd procedure, "configure" option} {

    list [catch {.b co -bg #ffffff -fg} msg] $msg

} {1 {value for "-fg" missing}}

test button-4.16 {ButtonWidgetCmd procedure, "configure" option} {

    .b configure -fg #123456

    .b configure -bg #654321

    lindex [.b configure -fg] 4

} {#123456}

.c configure -variable value -onvalue 1 -offvalue 0

.r configure -variable value2 -value red

test button-4.17 {ButtonWidgetCmd procedure, "deselect" option} {

    list [catch {.c deselect foo} msg] $msg

} {1 {wrong # args: should be ".c deselect"}}

test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} {

    list [catch {.l deselect} msg] $msg

} {1 {bad option "deselect": must be cget or configure}}

test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} {

    list [catch {.b deselect} msg] $msg

} {1 {bad option "deselect": must be cget, configure, flash, or invoke}}

test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} {

    set value 1

    .c d

    set value

} {0}

test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} {

    set value2 green

    .r deselect

    set value2

} {green}

test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} {

    set value2 red

    .r deselect

    set value2

} {}

test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} {

    set value 1

    trace variable value w bogusTrace

    set result [list [catch {.c deselect} msg] $msg $errorInfo $value]

    trace vdelete value w bogusTrace

    set result

} {1 {can't set "value": trace aborted} {can't set "value": trace aborted

    while executing

".c deselect"} 0}

test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} {

    set value2 red

    trace variable value2 w bogusTrace

    set result [list [catch {.r deselect} msg] $msg $errorInfo $value2]

    trace vdelete value2 w bogusTrace

    set result

} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted

    while executing

".r deselect"} {}}

test button-4.25 {ButtonWidgetCmd procedure, "flash" option} {

    list [catch {.b flash foo} msg] $msg

} {1 {wrong # args: should be ".b flash"}}

test button-4.26 {ButtonWidgetCmd procedure, "flash" option} {

    list [catch {.l flash} msg] $msg

} {1 {bad option "flash": must be cget or configure}}

test button-4.27 {ButtonWidgetCmd procedure, "flash" option} {

    list [catch {.b flash} msg] $msg

} {0 {}}

test button-4.28 {ButtonWidgetCmd procedure, "flash" option} {

    list [catch {.c flash} msg] $msg

} {0 {}}

test button-4.29 {ButtonWidgetCmd procedure, "flash" option} {

    list [catch {.r f} msg] $msg

} {0 {}}

test button-4.30 {ButtonWidgetCmd procedure, "invoke" option} {

    list [catch {.b invoke foo} msg] $msg

} {1 {wrong # args: should be ".b invoke"}}

test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} {

    list [catch {.l invoke} msg] $msg

} {1 {bad option "invoke": must be cget or configure}}

test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} {

    .b configure -command {set x invoked}

    set x "not invoked"

    .b invoke

    set x

} {invoked}

test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} {

    .b configure -command {set x invoked} -state disabled

    set x "not invoked"

    .b invoke

    set x

} {not invoked}

test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} {

    set value bogus

    .c configure -command {set x invoked} -variable value -onvalue 1 \

            -offvalue 0

    set x "not invoked"

    .c invoke

    list $x $value

} {invoked 1}

test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} {

    set value2 green

    .r configure -command {set x invoked} -variable value2 -value red

    set x "not invoked"

    .r i

    list $x $value2

} {invoked red}

test button-4.36 {ButtonWidgetCmd procedure, "select" option} {

    list [catch {.l select} msg] $msg

} {1 {bad option "select": must be cget or configure}}

test button-4.37 {ButtonWidgetCmd procedure, "select" option} {

    list [catch {.b select} msg] $msg

} {1 {bad option "select": must be cget, configure, flash, or invoke}}

test button-4.38 {ButtonWidgetCmd procedure, "select" option} {

    list [catch {.c select foo} msg] $msg

} {1 {wrong # args: should be ".c select"}}

test button-4.39 {ButtonWidgetCmd procedure, "select" option} {

    set value bogus

    .c configure -command {} -variable value -onvalue lovely -offvalue 0

    .c s

    set value

} {lovely}

test button-4.40 {ButtonWidgetCmd procedure, "select" option} {

    set value2 green

    .r configure -command {} -variable value2 -value red

    .r select

    set value2

} {red}

test button-4.41 {ButtonWidgetCmd procedure, "select" option} {

    set value2 yellow

    trace variable value2 w bogusTrace

    set result [list [catch {.r select} msg] $msg $errorInfo $value2]

    trace vdelete value2 w bogusTrace

    set result

} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted

    while executing

".r select"} red}

test button-4.42 {ButtonWidgetCmd procedure, "toggle" option} {

    list [catch {.l toggle} msg] $msg

} {1 {bad option "toggle": must be cget or configure}}

test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} {

    list [catch {.b toggle} msg] $msg

} {1 {bad option "toggle": must be cget, configure, flash, or invoke}}

test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} {

    list [catch {.r toggle} msg] $msg

} {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}}

test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} {

    list [catch {.c toggle foo} msg] $msg

} {1 {wrong # args: should be ".c toggle"}}

test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} {

    set value bogus

    .c configure -command {} -variable value -onvalue sunshine -offvalue rain

    .c toggle

    set result $value

    .c toggle

    lappend result $value

    .c toggle

    lappend result $value

} {sunshine rain sunshine}

test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} {

    .c configure -onvalue xyz -offvalue abc

    set value xyz

    trace variable value w bogusTrace

    set result [list [catch {.c toggle} msg] $msg $errorInfo $value]

    trace vdelete value w bogusTrace

    set result

} {1 {can't set "value": trace aborted} {can't set "value": trace aborted

    while executing

".c toggle"} abc}

test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} {

    .c configure -onvalue xyz -offvalue abc

    set value abc

    trace variable value w bogusTrace

    set result [list [catch {.c toggle} msg] $msg $errorInfo $value]

    trace vdelete value w bogusTrace

    set result

} {1 {can't set "value": trace aborted} {can't set "value": trace aborted

    while executing

".c toggle"} xyz}

test button-4.49 {ButtonWidgetCmd procedure} {

    list [catch {.c bad_option} msg] $msg

} {1 {bad option "bad_option": must be cget, configure, deselect, flash, invoke, select, or toggle}}

test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} {

    catch {unset value}; set value(1) 1;

    set result [list [catch {.c toggle} msg] $msg $errorInfo]

    unset value;

    set result

} {1 {can't set "value": variable is array} {can't set "value": variable is array

    while executing

".c toggle"}}

test button-5.1 {DestroyButton procedure} {

    image create test image1

    button .b1 -image image1

    button .b2 -fg #ff0000 -text "Button 2"

    button .b3 -state active -text "Button 3"

    button .b4 -disabledforeground #0000ff -state disabled -text "Button 4"

    checkbutton .b5 -variable x -text "Checkbutton 5"

    set x 1

    pack .b1 .b2 .b3 .b4 .b5

    update

    eval destroy [winfo children .]

} {}

test button-6.1 {ConfigureButton procedure} {

    catch {destroy .b1}

    set x From-x

    set y From-y

    button .b1 -textvariable x

    .b1 configure -textvariable y

    set x New

    lindex [.b1 configure -text] 4

} {From-y}

test button-6.2 {ConfigureButton procedure} {

    catch {destroy .b1}

    catch {unset x}

    checkbutton .b1 -variable x

    set x 1

    set y 1

    .b1 configure -textvariable y

    set x 0

    .b1 toggle

    set y

} {1}

test button-6.3 {ConfigureButton procedure} {

    catch {destroy .b1}

    eval image delete [image names]

    image create test image1

    image create test image2

    button .b1 -image image1

    image delete image1

    .b1 configure -image image2

    image names

} {image2}

test button-6.4 {ConfigureButton procedure} {

    catch {destroy .b1}

    button .b1 -text "Test" -state disabled

    list [catch {.b1 configure -state bogus} msg] $msg \

            [lindex [.b1 configure -state] 4]

} {1 {bad state value "bogus": must be normal, active, or disabled} normal}

test button-6.5 {ConfigureButton procedure} {

    catch {destroy .b1}

    checkbutton .b1

    .b1 cget -variable

} {b1}

test button-6.6 {ConfigureButton procedure} {

    catch {destroy .b1}

    set x 0

    set y Shiny

    checkbutton .b1 -variable x

    .b1 configure -variable y -onvalue Shiny

    .b1 toggle

    set y

} 0

test button-6.7 {ConfigureButton procedure} {

    catch {destroy .b1}

    catch {unset x}

    checkbutton .b1 -variable x -offvalue Bogus

    set x

} Bogus

test button-6.8 {ConfigureButton procedure} {

    catch {destroy .b1}

    catch {unset x}

    radiobutton .b1 -variable x

    set x

} {}

test button-6.9 {ConfigureButton procedure} {

    catch {destroy .b1}

    catch {unset x}

    trace variable x w bogusTrace

    set result [list [catch {radiobutton .b1 -variable x} msg] $msg]

    trace vdelete x w bogusTrace

    set result

} {1 {can't set "x": trace aborted}}

test button-6.10 {ConfigureButton procedure} {

    catch {destroy .b1}

    list [catch {button .b1 -image bogus} msg] $msg

} {1 {image "bogus" doesn't exist}}

test button-6.11 {ConfigureButton procedure} {

    catch {destroy .b1}

    catch {unset x}

    button .b1 -textvariable x -text "Button 1"

    set x

} {Button 1}

test button-6.12 {ConfigureButton procedure} {

    catch {destroy .b1}

    set x Override

    button .b1 -textvariable x -text "Button 1"

    set x

} {Override}

test button-6.13 {ConfigureButton procedure} {

    catch {destroy .b1}

    catch {unset x}

    trace variable x w bogusTrace

    set result [list [catch {radiobutton .b1 -text foo -textvariable x} msg] \

            $msg $x]

    trace vdelete x w bogusTrace

    set result

} {1 {can't set "x": trace aborted} foo}

test button-6.14 {ConfigureButton procedure} {

    catch {destroy .b1}

    button .b1 -text "Button 1"

    list [catch {.b1 configure -width 1i} msg] $msg $errorInfo

} {1 {expected integer but got "1i"} {expected integer but got "1i"

    (processing -width option)

    invoked from within

".b1 configure -width 1i"}}

test button-6.15 {ConfigureButton procedure} {

    catch {destroy .b1}

    button .b1 -text "Button 1"

    list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo

} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c"

    (processing -height option)

    invoked from within

".b1 configure -height 0.5c"}}

test button-6.16 {ConfigureButton procedure} {

    catch {destroy .b1}

    button .b1 -bitmap questhead

    list [catch {.b1 configure -width abc} msg] $msg $errorInfo

} {1 {bad screen distance "abc"} {bad screen distance "abc"

    (processing -width option)

    invoked from within

".b1 configure -width abc"}}

test button-6.17 {ConfigureButton procedure} {

    catch {destroy .b1}

    eval image delete [image names]

    image create test image1

    button .b1 -image image1

    list [catch {.b1 configure -height 0.5x} msg] $msg $errorInfo

} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x"

    (processing -height option)

    invoked from within

".b1 configure -height 0.5x"}}

test button-6.18 {ConfigureButton procedure} {nonPortable fonts} {

    catch {destroy .b1}

    button .b1 -text "Sample text" -width 10 -height 2

    pack .b1

    set result "[winfo reqwidth .b1] [winfo reqheight .b1]"

    .b1 configure -bitmap questhead

    lappend result [winfo reqwidth .b1] [winfo reqheight .b1]

} {102 46 20 12}

test button-6.19 {ConfigureButton procedure} {

    catch {destroy .b1}

    button .b1 -text "Button 1"

    set old [winfo reqwidth .b1]

    .b1 configure -text "Much longer text"

    set new [winfo reqwidth .b1]

    expr $old == $new

} {0}

test button-7.1 {ButtonEventProc procedure} {

    catch {destroy .b1}

    button .b1 -text "Test Button" -command {

        destroy .b1

        set x [list [winfo exists .b1] [info commands .b1]]

    }

    .b1 invoke

    set x

} {0 {}}

test button-7.2 {ButtonEventProc procedure} {

    eval destroy [winfo children .]

    button .b1 -bg #543210

    rename .b1 .b2

    set x {}

    lappend x [winfo children .]

    lappend x [.b2 cget -bg]

    destroy .b1

    lappend x [info command .b*] [winfo children .]

} {.b1 #543210 {} {}}

test button-8.1 {ButtonCmdDeletedProc procedure} {

    eval destroy [winfo children .]

    button .b1

    rename .b1 {}

    list [info command .b*] [winfo children .]

} {{} {}}

test button-9.1 {TkInvokeButton procedure} {

    catch {destroy .b1}

    set x 0

    checkbutton .b1 -variable x

    set result $x

    .b1 invoke

    lappend result $x

    .b1 invoke

    lappend result $x

} {0 1 0}

test button-9.2 {TkInvokeButton procedure} {

    catch {destroy .b1}

    set x 0

    checkbutton .b1 -variable x

    trace variable x w bogusTrace

    set result [list [catch {.b1 invoke} msg] $msg $x]

    trace vdelete x w bogusTrace

    set result

} {1 {can't set "x": trace aborted} 1}

test button-9.3 {TkInvokeButton procedure} {

    catch {destroy .b1}

    set x 1

    checkbutton .b1 -variable x

    trace variable x w bogusTrace

    set result [list [catch {.b1 invoke} msg] $msg $x]

    trace vdelete x w bogusTrace

    set result

} {1 {can't set "x": trace aborted} 0}

test button-9.4 {TkInvokeButton procedure} {

    catch {destroy .b1}

    set x 0

    radiobutton .b1 -variable x -value red

    set result $x

    .b1 invoke

    lappend result $x

    .b1 invoke

    lappend result $x

} {0 red red}

test button-9.5 {TkInvokeButton procedure} {

    catch {destroy .b1}

    radiobutton .b1 -variable x -value red

    set x green

    trace variable x w bogusTrace

    set result [list [catch {.b1 invoke} msg] $msg $errorInfo $x]

    trace vdelete x w bogusTrace

    set result

} {1 {can't set "x": trace aborted} {can't set "x": trace aborted

    while executing

".b1 invoke"} red}

test button-9.6 {TkInvokeButton procedure} {

    eval destroy [winfo children .]

    set result untouched

    button .b1 -command {set result invoked}

    list [catch {.b1 invoke} msg] $msg $result

} {0 invoked invoked}

test button-9.7 {TkInvokeButton procedure} {

    eval destroy [winfo children .]

    set result untouched

    set x 0

    checkbutton .b1 -variable x -command {set result "invoked $x"}

    list [catch {.b1 invoke} msg] $msg $result

} {0 {invoked 1} {invoked 1}}

test button-9.8 {TkInvokeButton procedure} {

    eval destroy [winfo children .]

    set result untouched

    set x 0

    radiobutton .b1 -variable x -value red -command {set result "invoked $x"}

    list [catch {.b1 invoke} msg] $msg $result

} {0 {invoked red} {invoked red}}

test button-10.1 {ButtonVarProc procedure} {

    eval destroy [winfo children .]

    set x 1

    checkbutton .b1 -variable x

    unset x

    set result [info exists x]

    .b1 toggle

    lappend result $x

    set x 0

    .b1 toggle

    lappend result $x

} {0 1 1}

test button-10.2 {ButtonVarProc procedure} {

    eval destroy [winfo children .]

    set x 0

    checkbutton .b1 -variable x

    set x 44

    .b1 toggle

    set x

} {1}

test button-10.3 {ButtonVarProc procedure} {

    eval destroy [winfo children .]

    set x 1

    checkbutton .b1 -variable x

    set x 44

    .b1 toggle

    set x

} {1}

test button-10.4 {ButtonVarProc procedure} {

    eval destroy [winfo children .]

    set x 0

    checkbutton .b1 -variable x

    set x 1

    .b1 toggle

    set x

} {0}

test button-10.5 {ButtonVarProc procedure} {

    eval destroy [winfo children .]

    set x 1

    checkbutton .b1 -variable x

    set x 1

    .b1 toggle

    set x

} {0}

test button-10.6 {ButtonVarProc procedure} {

    eval destroy [winfo children .]

    set x 0

    checkbutton .b1 -variable x

    set x 0

    .b1 toggle

    set x

} {1}

test button-10.7 {ButtonVarProc procedure} {

    eval destroy [winfo children .]

    set x 1

    checkbutton .b1 -variable x

    set x 0

    .b1 toggle

    set x

} {1}

test button-10.8 {ButtonVarProc procedure, can't read variable} {

    # This test does nothing but produce a core dump if there's a prbblem.

    eval destroy [winfo children .]

    catch {unset a}

    checkbutton .b1 -variable a

    unset a

    set a(32) 0

    unset a

} {}

test button-11.1 {ButtonTextVarProc procedure} {

    eval destroy [winfo children .]

    set x Label

    button .b1 -textvariable x

    unset x

    set result [list $x [lindex [.b1 configure -text] 4]]

    set x New

    lappend result [lindex [.b1 configure -text] 4]

} {Label Label New}

test button-11.2 {ButtonTextVarProc procedure} {

    eval destroy [winfo children .]

    set x Label

    button .b1 -textvariable x

    set old [winfo reqwidth .b1]

    set x New

    set new [winfo reqwidth .b1]

    list [lindex [.b1 configure -text] 4] [expr $old == $new]

} {New 0}

test button-12.1 {ButtonImageProc procedure} {

    eval destroy [winfo children .]

    eval image delete [image names]

    image create test image1

    label .b1 -image image1 -padx 0 -pady 0 -bd 0

    pack .b1

    set result "[winfo reqwidth .b1] [winfo reqheight .b1]"

    image1 changed 0 0 0 0 80 100

    lappend result [winfo reqwidth .b1] [winfo reqheight .b1]

} {30 15 80 100}

eval destroy [winfo children .]

set l [interp hidden]

test button-13.1 {button widget vs hidden commands} {

    catch {destroy .b}

    button .b -text hello

    interp hide {} .b

    destroy .b

    list [winfo children .] [interp hidden]

} [list {} $l]

eval destroy [winfo children .]

option clear