package require Tk
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands
lappend auto_path .
package require tile
proc skip args {}
proc ok {} { return }
# 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 tile-6.1 "Self-destructing checkbutton" -body {
pack [tcheckbutton .sd -text "Self-destruction" -variable ::sd]
trace variable sd w [list selfdestruct .sd]
update
.sd invoke
} -returnCodes 1
test tile-6.2 "Checkbutton self-destructed" -body {
winfo exists .sd
} -result 0
test tile-6.3 "Test package cleanup" -body {
interp create foo
foo eval { if {[catch {package require Tk}]} { load {} Tk } }
foo eval [package ifneeded tile [package provide tile]]
foo eval { destroy . }
interp delete foo
}
test tile-6.4 "Defeat evil intentions" -body {
trace variable OUCH r { kill.b }
proc kill.b {args} { destroy .b }
pack [tcheckbutton .b]
.b configure -variable OUCH
.b invoke ;# @@@ At this point, .b might be gone.
list [set OUCH] [winfo exists .b]
# Mostly we just care that we haven't crashed the interpreter.
#
} -returnCodes error
test tile-6.5 "Clean up -textvariable traces" -body {
foreach class {tbutton tcheckbutton tradiobutton} {
$class .b1 -textvariable V
set V "asdf"
destroy .b1
set V ""
}
}
test tile-6.6 "Bad color spec in styles" -body {
pack [tbutton .b1 -text Hi!]
style default TButton -foreground badColor
event generate .b1 <Expose>
update
style default TButton -foreground black
destroy .b1
}
test tile-6.7 "Basic destruction test" -body {
foreach widget $::ttk::widgets {
ttk::$widget .w
pack .w
destroy .w
}
}
test tile-6.8 "Button command removes itself" -body {
tbutton .b -command ".b configure -command {}; set ::A {it worked}"
.b invoke
destroy .b
set ::A
} -result {it worked}
#
# Basic tests.
#
test tile-1.1 "Create button" -body {
pack [tbutton .t] -expand true -fill both
update
}
test tile-1.2 "Check style" -body {
.t cget -style
} -result {}
test tile-1.4 "Restore default style" -body {
.t cget -style
} -result ""
proc checkstate {w} {
foreach statespec {
{!active !disabled}
{!active disabled}
{active !disabled}
{active disabled}
active
disabled
} {
lappend result [$w instate $statespec]
}
set result
}
# NB: this will fail if the top-level window pops up underneath the cursor
test tile-2.0 "Check state" -body {
checkstate .t
} -result [list 1 0 0 0 0 0]
test tile-2.1 "Change state" -body {
.t state active
} -result !active
test tile-2.2 "Check state again" -body {
checkstate .t
} -result [list 0 0 1 0 1 0]
test tile-2.3 "Change state again" -body {
.t state {!active disabled}
} -result {active !disabled}
test tile-2.4 "Check state again" -body {
checkstate .t
} -result [list 0 1 0 0 0 1]
test tile-2.5 "Change state again" -body {
.t state !disabled
} -result {disabled}
test tile-2.6 "instate scripts, false" -body {
set x 0
.t instate disabled { set x 1 }
set x
} -result 0
test tile-2.7 "instate scripts, true" -body {
set x 0
.t instate !disabled { set x 1 }
set x
} -result 1
# misc. error detection
test tile-3.0 "Bad option" -body {
tbutton .bad -badoption foo
} -returnCodes 1 -result {unknown option "-badoption"} -match glob
test tile-3.1 "Make sure widget command not created" -body {
.bad state disabled
} -returnCodes 1 -result {invalid command name ".bad"} -match glob
test tile-3.2 "Propagate errors from variable traces" -body {
set A 0
trace add variable A write {error "failure" ;# }
tcheckbutton .cb -variable A
.cb invoke
} -cleanup {
unset ::A ; destroy .cb
} -returnCodes error -result {can't set "A": failure}
# 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 tile-4.0 "Setup" -body {
catch { destroy .t }
pack [tlabel .t -text "Button 1"]
testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]]
ok
}
test tile-4.1 "Change font" -constraints fontOption -body {
.t configure -font "Helvetica 18 bold"
}
test tile-4.2 "Check font" -constraints fontOption -body {
.t cget -font
} -result "Helvetica 18 bold"
test tile-4.3 "Restore font" -constraints fontOption -body {
.t configure -font $prevFont
}
test tile-4.4 "Bad resource specifications" -body {
style theme settings alt {
style default 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 [tbutton .tb1 -text "Ouch"]
style theme use alt
update;
# As long as we haven't crashed, everything's OK
style theme settings alt {
style default TButton -font TkDefaultFont
}
style theme use default
destroy .tb1
}
#
# checkbutton tests
#
test tile-5.1 "Checkbutton check" -body {
pack [tcheckbutton .cb -text "TCheckbutton" -variable cb]
}
test tile-5.2 "Checkbutton invoke" -body {
.cb invoke
list [set ::cb] [.cb instate selected]
} -result [list 1 1]
test tile-5.3 "Checkbutton reinvoke" -body {
.cb invoke
list [set ::cb] [.cb instate selected]
} -result [list 0 0]
test tile-5.4 "Checkbutton variable" -body {
set result []
set ::cb 1
lappend result [.cb instate selected]
set ::cb 0
lappend result [.cb instate selected]
} -result {1 0}
test tile-5.5 "Unset checkbutton variable" -body {
set result []
unset ::cb
lappend result [.cb instate alternate] [info exists ::cb]
set ::cb 1
lappend result [.cb instate alternate] [info exists ::cb]
} -result {1 0 0 1}
#
# radiobutton tests
#
test tile-7.1 "Radiobutton check" -body {
pack \
[tradiobutton .rb1 -text "One" -variable choice -value 1] \
[tradiobutton .rb2 -text "Two" -variable choice -value 2] \
[tradiobutton .rb3 -text "Three" -variable choice -value 3] \
;
}
test tile-7.2 "Radiobutton invoke" -body {
.rb1 invoke
set ::choice
} -result 1
test tile-7.3 "Radiobutton state" -body {
.rb1 instate selected
} -result 1
test tile-7.4 "Other radiobutton invoke" -body {
.rb2 invoke
set ::choice
} -result 2
test tile-7.5 "Other radiobutton state" -body {
.rb2 instate selected
} -result 1
test tile-7.6 "First radiobutton state" -body {
.rb1 instate selected
} -result 0
test tile-7.6 "Unset radiobutton variable" -body {
unset ::choice
list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
} -result {0 1 1}
test tile-7.6 "Reset radiobutton variable" -body {
set ::choice 2
list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
} -result {1 0 0}
#
# -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 tile-8.0 "Setup for 8.X" -body {
tbutton .ctb
image create photo icon -data $::iconData;
pack .ctb
}
tock
now
test tile-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 tile-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 tile-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 tile-8.4 "ImageChanged" -body {
tbutton .b -image icon
icon blank
} -cleanup { destroy .b }
#------------------------------------------------------------------------
test tile-9.1 "Traces on nonexistant namespaces" -body {
tcheckbutton .tcb -variable foo::bar
} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob
test tile-9.2 "Traces on nonexistant namespaces II" -body {
tcheckbutton .tcb -variable X
.tcb configure -variable foo::bar
} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob
test tile-9.3 "Restore saved options on configure error" -body {
.tcb cget -variable
} -result X
test tile-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 tile-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 tile-9.6 "Unset -textvariable" -body {
unset tcbLabel
list [info exists tcbLabel] [.tcb cget -text]
} -result [list 0 ""]
test tile-9.7 "Unset textvariable, comparison" -body {
#
# NB: the tile 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 ; tlabel .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 tile-9.8 "-textvariable overrides -text" -body {
tlabel .tl -textvariable TV
set TV Foo
.tl configure -text Bar
.tl cget -text
} -cleanup { destroy .tl } -result "Foo"
#
# Frame widget tests:
#
test tile-10.1 "tframe -class resource" -body {
tframe .f -class Foo
} -result .f
test tile-10.2 "Check widget class" -body {
winfo class .f
} -result Foo
test tile-10.3 "Check class resource" -body {
.f cget -class
} -result Foo
test tile-10.4 "Try to modify class resource" -body {
.f configure -class Bar
} -returnCodes 1 -match glob -result "*read-only option*"
test tile-10.5 "Check class resource again" -body {
.f cget -class
} -result Foo
test tile-11.1 "-state test, setup" -body {
tbutton .b
.b instate disabled
} -result 0
test tile-11.2 "-state test, disable" -body {
.b configure -state disabled
.b instate disabled
} -result 1
test tile-11.3 "-state test, reenable" -body {
.b configure -state normal
.b instate disabled
} -result 0
test tile-11.4 "-state test, unrecognized -state value" -body {
.b configure -state bogus
.b state
} -result [list]
test tile-11.5 "-state test, 'active'" -body {
.b configure -state active
.b state
} -result [list active] -cleanup { .b state !active }
test tile-11.6 "-state test, 'readonly'" -body {
.b configure -state readonly
.b state
} -result [list readonly] -cleanup { .b state !readonly }
test tile-11.7 "-state test, cleanup" -body {
destroy .b
}
test tile-12.1 "-cursor option" -body {
tbutton .b
.b cget -cursor
} -result {}
test tile-12.2 "-cursor option" -body {
.b configure -cursor arrow
.b cget -cursor
} -result arrow
test tile-12.3 "-borderwidth frame option" -body {
destroy .t
toplevel .t
raise .t
pack [set t [tframe .t.f]] -expand true -fill x ;
pack [tlabel $t.l -text "ASDF QWERTY"] -expand true -fill both
foreach theme {default alt} {
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 tile-12.4 "-borderwidth frame option" -body {
.t.f configure -relief raised
.t.f configure -borderwidth 1
style theme use alt
update
}
test tile-13.1 "Custom styles -- bad -style option" -body {
tbutton .tb1 -style badstyle
} -returnCodes 1 -result "*badstyle not found*" -match glob
test tile-13.4 "Custom styles -- bad -style option" -body {
tbutton .tb1
.tb1 configure -style badstyle
} -cleanup {
destroy .tb1
} -returnCodes 1 -result "*badstyle not found*" -match glob
test tile-13.5 "Custom layouts -- missing element definition" -body {
style layout badstyle {
NoSuchElement
}
tbutton .tb1 -style badstyle
} -cleanup {
destroy .tb1
} -result .tb1
# @@@ Should: signal an error, possibly a background error.
#
# See #793909
#
test tile-14.1 "-variable in nonexistant namespace" -body {
tcheckbutton .tw -variable ::nsn::foo
} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
-match glob -cleanup { destroy .tw }
test tile-14.2 "-textvariable in nonexistant namespace" -body {
tlabel .tw -textvariable ::nsn::foo
} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
-match glob -cleanup { destroy .tw }
test tile-14.3 "-textvariable in nonexistant namespace" -body {
tentry .tw -textvariable ::nsn::foo
} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
-match glob -cleanup { destroy .tw }
tcltest::cleanupTests
#*EOF*