package require tk
package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
proc skip args {}
proc ok {} { return }
variable widgetClasses {
button checkbutton radiobutton menubutton label entry
frame labelframe scrollbar
notebook progressbar combobox separator
panedwindow treeview sizegrip
scale
}
proc bgerror {error} {
variable bgerror $error
variable bgerrorInfo $::errorInfo
variable bgerrorCode $::errorCode
}
# Self-destruct tests.
# Do these early, so any memory corruption has a longer time to cause a crash.
#
proc selfdestruct {w args} {
destroy $w
}
test ttk-6.1 "Self-destructing checkbutton" -body {
pack [ttk::checkbutton .sd -text "Self-destruction" -variable ::sd]
trace add variable sd write [list selfdestruct .sd]
update
.sd invoke
} -returnCodes error
test ttk-6.2 "Checkbutton self-destructed" -body {
winfo exists .sd
} -result 0
# test ttk-6.3 not applicable [see #2175411]
test ttk-6.4 "Destroy widget in configure" -setup {
set OUCH ouch
trace add variable OUCH read { kill.b }
proc kill.b {args} { destroy .b }
} -cleanup {
unset OUCH
} -body {
pack [ttk::checkbutton .b]
set rc [catch { .b configure -variable OUCH } msg]
list $rc $msg [winfo exists .b] [info commands .b]
} -result [list 1 "widget has been destroyed" 0 {}]
test ttk-6.5 "Clean up -textvariable traces" -body {
foreach class {ttk::button ttk::checkbutton ttk::radiobutton} {
$class .b1 -textvariable V
set V "asdf"
destroy .b1
set V ""
}
}
test ttk-6.6 "Bad color spec in styles" -body {
pack [ttk::button .b1 -text Hi!]
ttk::style configure TButton -foreground badColor
event generate .b1 <Expose>
update
ttk::style configure TButton -foreground black
destroy .b1
set ::bgerror
} -result {unknown color name "badColor"}
test ttk-6.7 "Basic destruction test" -body {
foreach widget $widgetClasses {
ttk::$widget .w
pack .w
destroy .w
}
}
test ttk-6.8 "Button command removes itself" -body {
ttk::button .b -command ".b configure -command {}; set ::A {it worked}"
.b invoke
destroy .b
set ::A
} -result {it worked}
test ttk-6.9 "Bad font spec in styles" -setup {
ttk::style theme create badfont -settings {
ttk::style configure . -font {Helvetica 12 Bogus}
}
ttk::style theme use badfont
} -cleanup {
ttk::style theme use default
} -body {
pack [ttk::label .l -text Hi! -font {}]
event generate .l <Expose>
update
destroy .l
set ::bgerror
} -result {unknown font style "Bogus"}
test ttk-construction-failure-1 "Excercise construction failure path" -setup {
option add *TLabel.cursor badCursor 1
} -cleanup {
option add *TLabel.cursor {} 1
} -body {
catch {ttk::label .l} errmsg
list $errmsg [info commands .l] [winfo exists .l]
} -result [list {bad cursor spec "badCursor"} {} 0]
test ttk-construction-failure-2 "Destroy widget in constructor" -setup {
set OUCH ouch
trace add variable OUCH read { kill.b }
proc kill.b {args} { destroy .b }
} -cleanup {
unset OUCH
} -body {
list \
[catch { ttk::checkbutton .b -variable OUCH } msg] \
$msg \
[winfo exists .b] \
[info commands .b] \
;
} -result [list 1 "widget has been destroyed" 0 {}]
test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body {
# see #2298720
toplevel .t
ttk::button .t.b -command [list destroy .t]
.t.b invoke
list [winfo exists .t] [winfo exists .t.b]
} -result [list 0 0]
#
# Basic tests.
#
test ttk-1.1 "Create multiline button showing justified text" -body {
wm geometry . +100+100
event generate . <Motion> -warp 1 -x 600 -y 600
pack [ttk::button .t -text "Hello\nWorld!!" -justify center] -expand true -fill both
update
}
test ttk-1.2 "Check style" -body {
.t cget -style
} -result {}
test ttk-1.3 "Set bad style" -body {
.t configure -style "nosuchstyle"
} -returnCodes error -result {Layout nosuchstyle not found}
test ttk-1.4 "Original style preserved" -body {
.t cget -style
} -result ""
# Tests using this will fail if the top-level window contains the cursor
proc checkstate {w} {
foreach statespec {
{!active !disabled}
{!active disabled}
{active !disabled}
{active disabled}
active
disabled
} {
lappend result [$w instate $statespec]
}
set result
}
test ttk-2.0 "Check state" -body {
checkstate .t
} -result [list 1 0 0 0 0 0]
test ttk-2.1 "Change state" -body {
.t state active
} -result !active
test ttk-2.2 "Check state again" -body {
checkstate .t
} -result [list 0 0 1 0 1 0]
test ttk-2.3 "Change state again" -body {
.t state {!active disabled}
} -result {active !disabled}
test ttk-2.4 "Check state again" -body {
checkstate .t
} -result [list 0 1 0 0 0 1]
test ttk-2.5 "Change state again" -body {
.t state !disabled
} -result {disabled}
test ttk-2.6 "instate scripts, false" -body {
set x 0
.t instate disabled { set x 1 }
set x
} -result 0
test ttk-2.7 "instate scripts, true" -body {
set x 0
.t instate !disabled { set x 1 }
set x
} -result 1
test ttk-2.8 {Bug [3223850]: Button remains stuck when disabled as depressed on XP} -setup {
destroy .b
set ttk28 {}
pack [ttk::button .b -command {set ::ttk28 failed}]
update
} -body {
bind .b <Button-1> {after 0 {.b configure -state disabled}}
after 1 {event generate .b <Button-1>}
after 50 {event generate .b <ButtonRelease-1>}
set aid [after 100 {set ::ttk28 [.b instate {disabled !pressed}]}]
vwait ::ttk28
after cancel $aid
set ttk28
} -cleanup {
destroy .b
unset -nocomplain ttk28 aid
} -result 1
test ttk-2.9 {Bug [7231bf99]: Setting ttk state may change the variable passed by value} -body {
pack [ttk::button .b1 -text Hi!]
set state [list invalid disabled]
.b1 state $state
set state
} -cleanup {
unset state
destroy .b1
} -result [list invalid disabled]
foreach wc $widgetClasses {
test ttk-coreoptions-$wc "$wc has all core options" -body {
ttk::$wc .w
foreach option {-class -style -cursor -takefocus} {
.w cget $option
}
} -cleanup {
catch {destroy .w}
}
}
# misc. error detection
test ttk-3.0 "Bad option" -body {
ttk::button .bad -badoption foo
} -returnCodes error -result {unknown option "-badoption"} -match glob
test ttk-3.1 "Make sure widget command not created" -body {
.bad state disabled
} -returnCodes error -result {invalid command name ".bad"} -match glob
test ttk-3.2 "Propagate errors from variable traces" -body {
set A 0
trace add variable A write {error "failure" ;# }
ttk::checkbutton .cb -variable A
.cb invoke
} -cleanup {
unset ::A ; destroy .cb
} -returnCodes error -result {can't set "A": failure}
test ttk-3.3 "Constructor failure with cursor" -body {
ttk::button .b -cursor bottom_right_corner -style BadStyle
} -returnCodes error -result "Layout BadStyle not found"
test ttk-3.4 {Bug [2009213]: Segfault after setting bad -sliderrelief and packing scale} -body {
ttk::style configure TScale -sliderrelief {}
pack [ttk::scale .s]
update
} -cleanup {
ttk::style configure TScale -sliderrelief raised
destroy .s
}
# Test resource allocation
# (@@@ "-font" is a compatibility option now, so tests 4.1-4.3
# don't really test anything useful at the moment.)
#
test ttk-4.0 "Setup" -body {
catch { destroy .t }
pack [ttk::label .t -text "Button 1"]
testConstraint fontOption [expr {![catch { set prevFont [.t cget -font] }]}]
ok
}
test ttk-4.1 "Change font" -constraints fontOption -body {
.t configure -font "Helvetica 18 bold"
}
test ttk-4.2 "Check font" -constraints fontOption -body {
.t cget -font
} -result "Helvetica 18 bold"
test ttk-4.3 "Restore font" -constraints fontOption -body {
.t configure -font $prevFont
}
test ttk-4.4 "Bad resource specifications" -body {
ttk::style theme settings alt {
ttk::style configure TButton -font {Bad font}
# @@@ it would be best to raise an error at this point,
# @@@ but that's not really feasible in the current framework.
}
pack [ttk::button .tb1 -text "Ouch"]
ttk::style theme use alt
update;
# As long as we haven't crashed, everything's OK
ttk::style theme settings alt {
ttk::style configure TButton -font TkDefaultFont
}
ttk::style theme use default
destroy .tb1
}
#
# -compound tests:
#
variable iconData \
{R0lGODlhIAAgAKIAANnZ2YQAAP8AAISEhP///////////////yH5BAEAAAAALAAAAAAgACAA
AAP/CLoMGLqKoMvtGIqiqxEYCLrcioGiyxwIusyBgaLLLRiBoMsQKLrcjYGgu4Giy+2CAkFX
A0WX2wXFIOgGii7trkCEohsDCACBoktEKLpKhISiGwAIECiqSKooukiqKKoxgACBooukKiIo
SKooujGDECi6iqQqsopEV2MQAkV3kXQZRXdjEAJFl5F0FUWXY3ACRZcFSRdFlyVwJlB0WZB0
UXRZAmcCRZeRdBVFl2NwAkV3kXQZRXdjcAJFV5FURVaR6GoMDgSKLpKqiKAgqaLoxgwOBIoq
kiqKLpIqimrM4ECg6BIRiq4SIaHoxgyCBoou7a5AhKIbMzgAAIGiy+2CTWJmBhAAAkWX2wXF
zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi
6DIj6HI7jq4i6DIkADs=}
variable compoundStrings {text image center top bottom left right none}
if {0} {
proc now {} { set ::now [clock clicks -milliseconds] }
proc tick {} { puts -nonewline stderr "+" ; flush stderr }
proc tock {} {
set then $::now; set ::now [clock clicks -milliseconds]
puts stderr " [expr {$::now - $then}] ms"
}
} else {
proc now {} {} ; proc tick {} {} ; proc tock {} {}
}
now ; tick
test ttk-8.0 "Setup for 8.X" -body {
ttk::button .ctb
image create photo icon -data $::iconData;
pack .ctb
}
tock
now
test ttk-8.1 "Test -compound options" -body {
# Exhaustively test each combination.
# Main goal is to make sure no code paths crash.
foreach image {icon ""} {
foreach text {"Hi!" ""} {
foreach compound $::compoundStrings {
.ctb configure -image $image -text $text -compound $compound
update; tick
}
}
}
}
tock
test ttk-8.2 "Test -compound options with regular button" -body {
button .rtb
pack .rtb
foreach image {"" icon} {
foreach text {"Hi!" ""} {
foreach compound [lrange $::compoundStrings 2 end] {
.rtb configure -image $image -text $text -compound $compound
update; tick
}
}
}
}
tock
test ttk-8.3 "Rerun test 8.1" -body {
foreach image {icon ""} {
foreach text {"Hi!" ""} {
foreach compound $::compoundStrings {
.ctb configure -image $image -text $text -compound $compound
update; tick
}
}
}
}
tock
test ttk-8.4 "ImageChanged" -body {
ttk::button .b -image icon
icon blank
} -cleanup { destroy .b }
#------------------------------------------------------------------------
test ttk-9.1 "Traces on nonexistant namespaces" -body {
ttk::checkbutton .tcb -variable foo::bar
} -returnCodes error -result {can't trace "foo::bar": parent namespace doesn't exist}
test ttk-9.2 "Traces on nonexistant namespaces II" -body {
ttk::checkbutton .tcb -variable X
.tcb configure -variable foo::bar
} -returnCodes error -result {can't trace "foo::bar": parent namespace doesn't exist}
test ttk-9.3 "Restore saved options on configure error" -body {
.tcb cget -variable
} -result X
test ttk-9.4 "Textvariable tests" -body {
set tcbLabel "Testing..."
.tcb configure -textvariable tcbLabel
.tcb cget -text
} -result "Testing..."
# Changing -text has no effect if there is a linked -textvariable.
# Compatible with core widget.
test ttk-9.5 "Change -text" -body {
.tcb configure -text "Changed -text"
.tcb cget -text
} -result "Testing..."
# Unset -textvariable clears the text.
# NOTE: this is different from core widgets, which automagically reinitalize
# the -textvariable to the last value of -text.
#
test ttk-9.6 "Unset -textvariable" -body {
unset tcbLabel
list [info exists tcbLabel] [.tcb cget -text]
} -result [list 0 ""]
test ttk-9.7 "Unset textvariable, comparison" -body {
#
# NB: ttk::label behaves differently from the standard label here;
# NB: this is on purpose: I believe the standard behaviour is the Wrong Thing
#
unset -nocomplain V1 V2
label .l -text Foo ; ttk::label .tl -text Foo
.l configure -textvariable V1 ; .tl configure -textvariable V2
list [set V1] [info exists V2]
} -cleanup { destroy .l .tl } -result [list Foo 0]
test ttk-9.8 "-textvariable overrides -text" -body {
ttk::label .tl -textvariable TV
set TV Foo
.tl configure -text Bar
.tl cget -text
} -cleanup { destroy .tl } -result "Foo"
test ttk-9.9 "default for -justify" -body {
ttk::label .tl
.tl cget -justify
} -cleanup { destroy .tl } -result "left"
test ttk-9.10 "default for -anchor" -body {
ttk::label .tl
.tl cget -anchor
} -cleanup { destroy .tl } -result "w"
#
# Frame widget tests:
#
test ttk-10.1 "ttk::frame -class resource" -body {
ttk::frame .f -class Foo
} -result .f
test ttk-10.2 "Check widget class" -body {
winfo class .f
} -result Foo
test ttk-10.3 "Check class resource" -body {
.f cget -class
} -result Foo
test ttk-10.4 "Try to modify class resource" -body {
.f configure -class Bar
} -returnCodes error -match glob -result "*read-only option*"
test ttk-10.5 "Check class resource again" -body {
.f cget -class
} -result Foo
test ttk-11.1 "-state test, setup" -body {
ttk::button .b
.b instate disabled
} -result 0
test ttk-11.2 "-state test, disable" -body {
.b configure -state disabled
.b instate disabled
} -result 1
test ttk-11.3 "-state test, reenable" -body {
.b configure -state normal
.b instate disabled
} -result 0
test ttk-11.4 "-state test, unrecognized -state value" -body {
.b configure -state bogus
.b state
} -result [list]
test ttk-11.5 "-state test, 'active'" -body {
.b configure -state active
.b state
} -result [list active] -cleanup { .b state !active }
test ttk-11.6 "-state test, 'readonly'" -body {
.b configure -state readonly
.b state
} -result [list readonly] -cleanup { .b state !readonly }
test ttk-11.7 "-state test, cleanup" -body {
destroy .b
}
test ttk-12.1 "-cursor option" -body {
ttk::button .b
.b cget -cursor
} -result {}
test ttk-12.2 "-cursor option" -body {
.b configure -cursor arrow
.b cget -cursor
} -result arrow
test ttk-12.2.1 "-cursor option, widget doesn't overwrite it" -setup {
ttk::treeview .tr
pack .tr
update
} -body {
.tr configure -cursor X_cursor
event generate .tr <Motion>
update
.tr cget -cursor
} -cleanup {
destroy .tr
} -result {X_cursor}
test ttk-12.3 "-borderwidth frame option" -body {
destroy .t
toplevel .t
raise .t
pack [set t [ttk::frame .t.f]] -expand true -fill x ;
pack [ttk::label $t.l -text "ASDF QWERTY"] -expand true -fill both
foreach theme {default alt} {
ttk::style theme use $theme
foreach relief {flat raised sunken ridge groove solid} {
$t configure -relief $relief
for {set i 5} {$i >= 0} {incr i -1} {
$t configure -borderwidth $i
update
}
}
}
}
test ttk-12.4 "-borderwidth frame option" -body {
.t.f configure -relief raised
.t.f configure -borderwidth 1
ttk::style theme use alt
update
}
test ttk-13.1 "Custom styles -- bad -style option" -body {
ttk::button .tb1 -style badstyle
} -returnCodes error -result "*badstyle not found*" -match glob
test ttk-13.4 "Custom styles -- bad -style option" -body {
ttk::button .tb1
.tb1 configure -style badstyle
} -cleanup {
destroy .tb1
} -returnCodes error -result "*badstyle not found*" -match glob
test ttk-13.5 "Custom layouts -- missing element definition" -body {
ttk::style layout badstyle {
NoSuchElement
}
ttk::button .tb1 -style badstyle
} -cleanup {
destroy .tb1
} -result .tb1
# @@@ Should: signal an error, possibly a background error.
#
# See #793909
#
test ttk-14.1 "-variable in nonexistant namespace" -body {
ttk::checkbutton .tw -variable ::nsn::foo
} -returnCodes error -result {can't trace *: parent namespace doesn't exist} \
-match glob -cleanup { destroy .tw }
test ttk-14.2 "-textvariable in nonexistant namespace" -body {
ttk::label .tw -textvariable ::nsn::foo
} -returnCodes error -result {can't trace *: parent namespace doesn't exist} \
-match glob -cleanup { destroy .tw }
test ttk-14.3 "-textvariable in nonexistant namespace" -body {
ttk::entry .tw -textvariable ::nsn::foo
} -returnCodes error -result {can't trace *: parent namespace doesn't exist} \
-match glob -cleanup { destroy .tw }
test ttk-15.1 {Tcl bug [3062331]: segfault in variable traces with ttk::* widgets} -setup {
destroy .b
} -body {
set Y {}
ttk::button .b -textvariable Y
trace add variable Y unset "destroy .b; #"
unset Y
} -cleanup {
destroy .b
} -result {}
test ttk-15.2 {Bug [3341056]: Usage of recreated ttk::checkbutton causes crash} -setup {
proc foo {} {
destroy .lf
ttk::labelframe .lf
ttk::checkbutton .lf.cb -text xxx
}
} -body {
ttk::button .b -text xxx -command foo
.b invoke
.b invoke
.lf.cb invoke
destroy .b
} -cleanup {
rename foo {}
destroy .lf
} -result {}
## Test ensemble processing:
#
# (See also: SF#2021443)
#
proc wrong#args {args} {
return "wrong # args: should be \"$args\""
}
proc wrong#varargs {varpart args} {
set usage $args
append usage " ?$varpart ...?"
return "wrong # args: should be \"$usage\""
}
test ttk-ensemble-0 "style element create: insufficient args" -body {
ttk::style
} -returnCodes error -result \
[wrong#varargs arg ttk::style option]
test ttk-ensemble-1 "style element create: insufficient args" -body {
ttk::style element
} -returnCodes error -result \
[wrong#varargs arg ttk::style element option]
test ttk-ensemble-2 "style element create: insufficient args" -body {
ttk::style element create
} -returnCodes error -result \
[wrong#varargs {-option value} ttk::style element create name type]
test ttk-ensemble-3 "style element create: insufficient args" -body {
ttk::style element create plain.background
} -returnCodes error -result \
[wrong#varargs {-option value} ttk::style element create name type]
test ttk-ensemble-4 "style element create: insufficient args" -body {
ttk::style element create plain.background from
} -returnCodes error -result [wrong#args theme ?element?]
test ttk-ensemble-5 "style element create: valid" -body {
ttk::style element create plain.background from default
} -returnCodes 0 -result ""
test ttk-16.1 {ttk::style theme styles - no such theme} -body {
ttk::style theme styles noSuchTheme
} -returnCodes 1 -result {theme "noSuchTheme" does not exist}
test ttk-16.2 {ttk::style theme styles - theme exists} -body {
# simply check this produces a list with some style names,
# without checking exact content (not needed, and may vary
# depending on platform, versions, improvements...)
expr {[llength [ttk::style theme styles alt]] > 0}
} -result 1
destroy {*}[winfo children .]
tcltest::cleanupTests
#*EOF*
| 