path: root/tests/ttk/ttk.test

package require Tk 8.5
package require tcltest ; 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 variable sd w [list selfdestruct .sd]
    update
    .sd invoke
} -returnCodes 1
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 variable OUCH r { 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 variable OUCH r { 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 button" -body {
    pack [ttk::button .t] -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 1 -result {Layout nosuchstyle not found}

test ttk-1.4 "Original style preserved" -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 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 state disabled during click" -setup {
    destroy .b
    set ttk28 {}
    pack [ttk::button .b -command {set ::ttk28 failed}]
} -body { 
    bind .b <ButtonPress-1> {after 0 {.b configure -state disabled}}
    after 1 {event generate .b <ButtonPress-1>}
    after 20 {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

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 1 -result {unknown option "-badoption"} -match glob

test ttk-3.1 "Make sure widget command not created" -body {
    .bad state disabled
} -returnCodes 1 -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 1 -result "Layout BadStyle not found"

test ttk-3.4 "SF#2009213" -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 1 -result "*parent namespace doesn't exist*" -match glob

test ttk-9.2 "Traces on nonexistant namespaces II" -body {
    ttk::checkbutton .tcb -variable X
    .tcb configure -variable foo::bar
} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob

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"

#
# 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 1 -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.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 1 -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 1 -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 1 -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 1 -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 1 -result {can't trace *: parent namespace doesn't exist} \
  -match glob -cleanup { destroy .tw }

test ttk-15.1 {Bug 3062331} -setup {
    destroy .b
} -body {
    set Y {}
    ttk::button .b -textvariable Y
    trace variable Y u "destroy .b; #"
    unset Y
} -cleanup {
    destroy .b
} -result {}

test ttk-15.2 {Bug 3341056} -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 1 -result \
    [wrong#varargs arg ttk::style option]

test ttk-ensemble-1 "style element create: insufficient args" -body {
     ttk::style element
} -returnCodes 1 -result \
    [wrong#varargs arg ttk::style element option]

test ttk-ensemble-2 "style element create: insufficient args" -body {
     ttk::style element create
} -returnCodes 1 -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 1 -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 1 -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 ""

eval destroy [winfo children .]

tcltest::cleanupTests

#*EOF*