870 lines
29 KiB
Plaintext
870 lines
29 KiB
Plaintext
# 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-1995 Sun Microsystems, Inc.
|
|
#
|
|
# See the file "license.terms" for information on usage and redistribution
|
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
#
|
|
# SCCS: @(#) button.test 1.26 96/08/21 09:56:09
|
|
|
|
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}
|
|
|
|
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 -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
|
|
-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* bogus
|
|
{font "bogus" 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, 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
|
|
}
|
|
|
|
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}
|
|
{-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.3 {ButtonWidgetCmd procedure, "cget" option} {
|
|
list [catch {.b c} msg] $msg
|
|
} {1 {bad option "c": must be cget, configure, flash, or invoke}}
|
|
test button-4.4 {ButtonWidgetCmd procedure, "cget" option} {
|
|
list [catch {.b cget a b} msg] $msg
|
|
} {1 {wrong # args: should be ".b cget option"}}
|
|
test button-4.5 {ButtonWidgetCmd procedure, "cget" option} {
|
|
list [catch {.b cget -gorp} msg] $msg
|
|
} {1 {unknown option "-gorp"}}
|
|
test button-4.6 {ButtonWidgetCmd procedure, "cget" option} {
|
|
.b configure -highlightthickness 3
|
|
.b cget -highlightthickness
|
|
} {3}
|
|
test button-4.7 {ButtonWidgetCmd procedure, "cget" option} {
|
|
list [catch {.l cget -disabledforeground} msg] $msg
|
|
} {1 {unknown option "-disabledforeground"}}
|
|
test button-4.8 {ButtonWidgetCmd procedure, "cget" option} {
|
|
catch {.b cget -disabledforeground}
|
|
} {0}
|
|
test button-4.9 {ButtonWidgetCmd procedure, "cget" option} {
|
|
list [catch {.b cget -variable} msg] $msg
|
|
} {1 {unknown option "-variable"}}
|
|
test button-4.10 {ButtonWidgetCmd procedure, "cget" option} {
|
|
catch {.c cget -variable}
|
|
} {0}
|
|
test button-4.11 {ButtonWidgetCmd procedure, "cget" option} {
|
|
list [catch {.c cget -value} msg] $msg
|
|
} {1 {unknown option "-value"}}
|
|
test button-4.12 {ButtonWidgetCmd procedure, "cget" option} {
|
|
catch {.r cget -value}
|
|
} {0}
|
|
test button-4.13 {ButtonWidgetCmd procedure, "cget" option} {
|
|
list [catch {.r cget -onvalue} msg] $msg
|
|
} {1 {unknown option "-onvalue"}}
|
|
test button-4.14 {ButtonWidgetCmd procedure, "configure" option} {
|
|
llength [.c configure]
|
|
} {36}
|
|
test button-4.15 {ButtonWidgetCmd procedure, "configure" option} {
|
|
list [catch {.b configure -gorp} msg] $msg
|
|
} {1 {unknown option "-gorp"}}
|
|
test button-4.16 {ButtonWidgetCmd procedure, "configure" option} {
|
|
list [catch {.b co -bg #ffffff -fg} msg] $msg
|
|
} {1 {value for "-fg" missing}}
|
|
test button-4.17 {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.18 {ButtonWidgetCmd procedure, "deselect" option} {
|
|
list [catch {.c deselect foo} msg] $msg
|
|
} {1 {wrong # args: should be ".c deselect"}}
|
|
test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} {
|
|
list [catch {.l deselect} msg] $msg
|
|
} {1 {bad option "deselect": must be cget or configure}}
|
|
test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} {
|
|
list [catch {.b deselect} msg] $msg
|
|
} {1 {bad option "deselect": must be cget, configure, flash, or invoke}}
|
|
test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} {
|
|
set value 1
|
|
.c d
|
|
set value
|
|
} {0}
|
|
test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} {
|
|
set value2 green
|
|
.r deselect
|
|
set value2
|
|
} {green}
|
|
test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} {
|
|
set value2 red
|
|
.r deselect
|
|
set value2
|
|
} {}
|
|
test button-4.24 {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.25 {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.26 {ButtonWidgetCmd procedure, "flash" option} {
|
|
list [catch {.b flash foo} msg] $msg
|
|
} {1 {wrong # args: should be ".b flash"}}
|
|
test button-4.27 {ButtonWidgetCmd procedure, "flash" option} {
|
|
list [catch {.l flash} msg] $msg
|
|
} {1 {bad option "flash": must be cget or configure}}
|
|
test button-4.28 {ButtonWidgetCmd procedure, "flash" option} {
|
|
list [catch {.b flash} msg] $msg
|
|
} {0 {}}
|
|
test button-4.29 {ButtonWidgetCmd procedure, "flash" option} {
|
|
list [catch {.c flash} msg] $msg
|
|
} {0 {}}
|
|
test button-4.30 {ButtonWidgetCmd procedure, "flash" option} {
|
|
list [catch {.r f} msg] $msg
|
|
} {0 {}}
|
|
test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} {
|
|
list [catch {.b invoke foo} msg] $msg
|
|
} {1 {wrong # args: should be ".b invoke"}}
|
|
test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} {
|
|
list [catch {.l invoke} msg] $msg
|
|
} {1 {bad option "invoke": must be cget or configure}}
|
|
test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} {
|
|
.b configure -command {set x invoked}
|
|
set x "not invoked"
|
|
.b invoke
|
|
set x
|
|
} {invoked}
|
|
test button-4.34 {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.35 {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.36 {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.37 {ButtonWidgetCmd procedure, "select" option} {
|
|
list [catch {.l select} msg] $msg
|
|
} {1 {bad option "select": must be cget or configure}}
|
|
test button-4.38 {ButtonWidgetCmd procedure, "select" option} {
|
|
list [catch {.b select} msg] $msg
|
|
} {1 {bad option "select": must be cget, configure, flash, or invoke}}
|
|
test button-4.39 {ButtonWidgetCmd procedure, "select" option} {
|
|
list [catch {.c select foo} msg] $msg
|
|
} {1 {wrong # args: should be ".c select"}}
|
|
test button-4.40 {ButtonWidgetCmd procedure, "select" option} {
|
|
set value bogus
|
|
.c configure -command {} -variable value -onvalue lovely -offvalue 0
|
|
.c s
|
|
set value
|
|
} {lovely}
|
|
test button-4.41 {ButtonWidgetCmd procedure, "select" option} {
|
|
set value2 green
|
|
.r configure -command {} -variable value2 -value red
|
|
.r select
|
|
set value2
|
|
} {red}
|
|
test button-4.42 {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.43 {ButtonWidgetCmd procedure, "toggle" option} {
|
|
list [catch {.l toggle} msg] $msg
|
|
} {1 {bad option "toggle": must be cget or configure}}
|
|
test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} {
|
|
list [catch {.b toggle} msg] $msg
|
|
} {1 {bad option "toggle": must be cget, configure, flash, or invoke}}
|
|
test button-4.45 {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.46 {ButtonWidgetCmd procedure, "toggle" option} {
|
|
list [catch {.c toggle foo} msg] $msg
|
|
} {1 {wrong # args: should be ".c toggle"}}
|
|
test button-4.47 {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.48 {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.49 {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.50 {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-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 {ComputeButtonGeometry procedure} {
|
|
eval destroy [winfo children .]
|
|
image create test image1
|
|
image1 changed 0 0 0 0 60 40
|
|
label .b1 -image image1 -bd 4 -padx 0 -pady 2
|
|
button .b2 -image image1 -bd 4 -padx 0 -pady 2
|
|
checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1
|
|
radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0
|
|
pack .b1 .b2 .b3 .b4
|
|
update
|
|
list [winfo reqwidth .b1] [winfo reqheight .b1] \
|
|
[winfo reqwidth .b2] [winfo reqheight .b2] \
|
|
[winfo reqwidth .b3] [winfo reqheight .b3] \
|
|
[winfo reqwidth .b4] [winfo reqheight .b4]
|
|
} {68 48 74 54 112 52 112 52}
|
|
test button-9.2 {ComputeButtonGeometry procedure} {
|
|
eval destroy [winfo children .]
|
|
label .b1 -bitmap question -bd 3 -padx 0 -pady 2
|
|
button .b2 -bitmap question -bd 3 -padx 0 -pady 2
|
|
checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1
|
|
radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0
|
|
pack .b1 .b2 .b3 .b4
|
|
update
|
|
list [winfo reqwidth .b1] [winfo reqheight .b1] \
|
|
[winfo reqwidth .b2] [winfo reqheight .b2] \
|
|
[winfo reqwidth .b3] [winfo reqheight .b3] \
|
|
[winfo reqwidth .b4] [winfo reqheight .b4]
|
|
} {23 33 29 39 54 37 54 37}
|
|
test button-9.3 {ComputeButtonGeometry procedure} {
|
|
eval destroy [winfo children .]
|
|
label .b1 -bitmap question -bd 3 -highlightthickness 4
|
|
button .b2 -bitmap question -bd 3 -highlightthickness 0
|
|
checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \
|
|
-indicatoron 0
|
|
radiobutton .b4 -bitmap question -bd 3 -indicatoron false
|
|
pack .b1 .b2 .b3 .b4
|
|
update
|
|
list [winfo reqwidth .b1] [winfo reqheight .b1] \
|
|
[winfo reqwidth .b2] [winfo reqheight .b2] \
|
|
[winfo reqwidth .b3] [winfo reqheight .b3] \
|
|
[winfo reqwidth .b4] [winfo reqheight .b4]
|
|
} {31 41 25 35 25 35 27 37}
|
|
test button-9.4 {ComputeButtonGeometry procedure} {nonPortable fonts} {
|
|
eval destroy [winfo children .]
|
|
label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2\
|
|
-font -Adobe-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
|
|
button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2\
|
|
-font -Adobe-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
|
|
checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1\
|
|
-font -Adobe-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
|
|
radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0\
|
|
-font -Adobe-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
|
|
pack .b1 .b2 .b3 .b4
|
|
update
|
|
list [winfo reqwidth .b1] [winfo reqheight .b1] \
|
|
[winfo reqwidth .b2] [winfo reqheight .b2] \
|
|
[winfo reqwidth .b3] [winfo reqheight .b3] \
|
|
[winfo reqwidth .b4] [winfo reqheight .b4]
|
|
} {82 29 88 35 114 31 121 29}
|
|
test button-9.5 {ComputeButtonGeometry procedure} {nonPortable fonts} {
|
|
eval destroy [winfo children .]
|
|
label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0
|
|
pack .l1
|
|
update
|
|
list [winfo reqwidth .l1] [winfo reqheight .l1]
|
|
} {136 88}
|
|
test button-9.6 {ComputeButtonGeometry procedure} {nonPortable fonts} {
|
|
eval destroy [winfo children .]
|
|
label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0
|
|
pack .l1
|
|
update
|
|
list [winfo reqwidth .l1] [winfo reqheight .l1]
|
|
} {231 46}
|
|
test button-9.7 {ComputeButtonGeometry procedure} {nonPortable fonts} {
|
|
eval destroy [winfo children .]
|
|
label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10
|
|
button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5
|
|
checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2
|
|
radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -width 4
|
|
pack .b1 .b2 .b3 .b4
|
|
update
|
|
list [winfo reqwidth .b1] [winfo reqheight .b1] \
|
|
[winfo reqwidth .b2] [winfo reqheight .b2] \
|
|
[winfo reqwidth .b3] [winfo reqheight .b3] \
|
|
[winfo reqwidth .b4] [winfo reqheight .b4]
|
|
} {74 22 60 84 168 38 61 22}
|
|
test button-9.8 {ComputeButtonGeometry procedure} {nonPortable fonts} {
|
|
eval destroy [winfo children .]
|
|
label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \
|
|
-highlightthickness 4
|
|
button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \
|
|
-highlightthickness 0
|
|
checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \
|
|
-highlightthickness 1 -indicatoron no
|
|
radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0
|
|
pack .b1 .b2 .b3 .b4
|
|
update
|
|
list [winfo reqwidth .b1] [winfo reqheight .b1] \
|
|
[winfo reqwidth .b2] [winfo reqheight .b2] \
|
|
[winfo reqwidth .b3] [winfo reqheight .b3] \
|
|
[winfo reqwidth .b4] [winfo reqheight .b4]
|
|
} {62 30 56 24 58 22 62 22}
|
|
|
|
test button-10.1 {InvokeButton 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-10.2 {InvokeButton 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-10.3 {InvokeButton 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-10.4 {InvokeButton 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-10.5 {InvokeButton 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-10.6 {InvokeButton 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-10.7 {InvokeButton 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-10.8 {InvokeButton 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-11.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-11.2 {ButtonVarProc procedure} {
|
|
eval destroy [winfo children .]
|
|
set x 0
|
|
checkbutton .b1 -variable x
|
|
set x 44
|
|
.b1 toggle
|
|
set x
|
|
} {1}
|
|
test button-11.3 {ButtonVarProc procedure} {
|
|
eval destroy [winfo children .]
|
|
set x 1
|
|
checkbutton .b1 -variable x
|
|
set x 44
|
|
.b1 toggle
|
|
set x
|
|
} {1}
|
|
test button-11.4 {ButtonVarProc procedure} {
|
|
eval destroy [winfo children .]
|
|
set x 0
|
|
checkbutton .b1 -variable x
|
|
set x 1
|
|
.b1 toggle
|
|
set x
|
|
} {0}
|
|
test button-11.5 {ButtonVarProc procedure} {
|
|
eval destroy [winfo children .]
|
|
set x 1
|
|
checkbutton .b1 -variable x
|
|
set x 1
|
|
.b1 toggle
|
|
set x
|
|
} {0}
|
|
test button-11.6 {ButtonVarProc procedure} {
|
|
eval destroy [winfo children .]
|
|
set x 0
|
|
checkbutton .b1 -variable x
|
|
set x 0
|
|
.b1 toggle
|
|
set x
|
|
} {1}
|
|
test button-11.7 {ButtonVarProc procedure} {
|
|
eval destroy [winfo children .]
|
|
set x 1
|
|
checkbutton .b1 -variable x
|
|
set x 0
|
|
.b1 toggle
|
|
set x
|
|
} {1}
|
|
test button-11.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-12.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-12.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-13.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 .]
|