summaryrefslogtreecommitdiffstats
path: root/tests/ttk
diff options
context:
space:
mode:
Diffstat (limited to 'tests/ttk')
-rw-r--r--tests/ttk/all.tcl21
-rw-r--r--tests/ttk/checkbutton.test48
-rw-r--r--tests/ttk/combobox.test68
-rw-r--r--tests/ttk/entry.test283
-rw-r--r--tests/ttk/image.test50
-rw-r--r--tests/ttk/labelframe.test130
-rw-r--r--tests/ttk/layout.test25
-rw-r--r--tests/ttk/notebook.test493
-rw-r--r--tests/ttk/panedwindow.test291
-rw-r--r--tests/ttk/progressbar.test85
-rw-r--r--tests/ttk/radiobutton.test48
-rw-r--r--tests/ttk/scrollbar.test69
-rw-r--r--tests/ttk/spinbox.test280
-rw-r--r--tests/ttk/treetags.test221
-rw-r--r--tests/ttk/treeview.test639
-rw-r--r--tests/ttk/ttk.test651
-rw-r--r--tests/ttk/validate.test277
-rw-r--r--tests/ttk/vsapi.test47
18 files changed, 3726 insertions, 0 deletions
diff --git a/tests/ttk/all.tcl b/tests/ttk/all.tcl
new file mode 100644
index 0000000..da2e316
--- /dev/null
+++ b/tests/ttk/all.tcl
@@ -0,0 +1,21 @@
+# all.tcl --
+#
+# This file contains a top-level script to run all of the ttk
+# tests. Execute it by invoking "source all.tcl" when running tktest
+# in this directory.
+#
+# Copyright (c) 2007 by the Tk developers.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.5
+package require tcltest 2.2
+package require Tk ;# This is the Tk test suite; fail early if no Tk!
+tcltest::configure {*}$argv
+tcltest::configure -testdir [file normalize [file dirname [info script]]]
+tcltest::configure -loadfile \
+ [file join [file dirname [tcltest::testsDirectory]] constraints.tcl]
+tcltest::configure -singleproc 1
+tcltest::runAllTests
+
diff --git a/tests/ttk/checkbutton.test b/tests/ttk/checkbutton.test
new file mode 100644
index 0000000..e18ff32
--- /dev/null
+++ b/tests/ttk/checkbutton.test
@@ -0,0 +1,48 @@
+#
+# ttk::checkbutton widget tests.
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test checkbutton-1.1 "Checkbutton check" -body {
+ pack [ttk::checkbutton .cb -text "TCheckbutton" -variable cb]
+}
+test checkbutton-1.2 "Checkbutton invoke" -body {
+ .cb invoke
+ list [set ::cb] [.cb instate selected]
+} -result [list 1 1]
+test checkbutton-1.3 "Checkbutton reinvoke" -body {
+ .cb invoke
+ list [set ::cb] [.cb instate selected]
+} -result [list 0 0]
+
+test checkbutton-1.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 checkbutton-1.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}
+
+# See #1257319
+test checkbutton-1.6 "Checkbutton default variable" -body {
+ destroy .cb ; unset -nocomplain {} ; set result [list]
+ ttk::checkbutton .cb -onvalue on -offvalue off
+ lappend result [.cb cget -variable] [info exists .cb] [.cb state]
+ .cb invoke
+ lappend result [info exists .cb] [set .cb] [.cb state]
+ .cb invoke
+ lappend result [info exists .cb] [set .cb] [.cb state]
+} -result [list .cb 0 alternate 1 on selected 1 off {}]
+
+tcltest::cleanupTests
diff --git a/tests/ttk/combobox.test b/tests/ttk/combobox.test
new file mode 100644
index 0000000..43f3cf1
--- /dev/null
+++ b/tests/ttk/combobox.test
@@ -0,0 +1,68 @@
+#
+# ttk::combobox widget tests
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test combobox-1.0 "Combobox tests -- setup" -body {
+ ttk::combobox .cb
+} -result .cb
+
+test combobox-1.1 "Bad -values list" -body {
+ .cb configure -values "bad \{list"
+} -result "unmatched open brace in list" -returnCodes 1
+
+test combobox-1.end "Combobox tests -- cleanup" -body {
+ destroy .cb
+}
+
+test combobox-2.0 "current command" -body {
+ ttk::combobox .cb -values [list a b c d e a]
+ .cb current
+} -result -1
+
+test combobox-2.1 "current -- set index" -body {
+ .cb current 5
+ .cb get
+} -result a
+
+test combobox-2.2 "current -- change -values" -body {
+ .cb configure -values [list c b a d e]
+ .cb current
+} -result 2
+
+test combobox-2.3 "current -- change value" -body {
+ .cb set "b"
+ .cb current
+} -result 1
+
+test combobox-2.4 "current -- value not in list" -body {
+ .cb set "z"
+ .cb current
+} -result -1
+
+test combobox-2.end "Cleanup" -body { destroy .cb }
+
+
+test combobox-1890211 "ComboboxSelected event after listbox unposted" -body {
+ # whitebox test...
+ pack [ttk::combobox .cb -values [list a b c]]
+ set result [list]
+ bind .cb <<ComboboxSelected>> {
+ lappend result Event [winfo ismapped .cb.popdown] [.cb get]
+ }
+ lappend result Start 0 [.cb get]
+ ttk::combobox::Post .cb
+ lappend result Post [winfo ismapped .cb.popdown] [.cb get]
+ .cb.popdown.f.l selection clear 0 end; .cb.popdown.f.l selection set 1
+ ttk::combobox::LBSelected .cb.popdown.f.l
+ lappend result Select [winfo ismapped .cb.popdown] [.cb get]
+ update
+ set result
+} -result [list Start 0 {} Post 1 {} Select 0 b Event 0 b] -cleanup {
+ destroy .cb
+}
+
+tcltest::cleanupTests
diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test
new file mode 100644
index 0000000..0c2f0be
--- /dev/null
+++ b/tests/ttk/entry.test
@@ -0,0 +1,283 @@
+#
+# Tile package: entry widget tests
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+variable scrollInfo
+proc scroll args {
+ global scrollInfo
+ set scrollInfo $args
+}
+
+# Some of the tests raise background errors;
+# override default bgerror to catch them.
+#
+variable bgerror ""
+proc bgerror {error} {
+ variable bgerror $error
+ variable bgerrorInfo $::errorInfo
+ variable bgerrorCode $::errorCode
+}
+
+#
+test entry-1.1 "Create entry widget" -body {
+ ttk::entry .e
+} -result .e
+
+test entry-1.2 "Insert" -body {
+ .e insert end abcde
+ .e get
+} -result abcde
+
+test entry-1.3 "Selection" -body {
+ .e selection range 1 3
+ selection get
+} -result bc
+
+test entry-1.4 "Delete" -body {
+ .e delete 1 3
+ .e get
+} -result ade
+
+test entry-1.5 "Deletion - insert cursor" -body {
+ .e insert end abcde
+ .e icursor 0
+ .e delete 0 end
+ .e index insert
+} -result 0
+
+test entry-1.6 "Deletion - insert cursor at end" -body {
+ .e insert end abcde
+ .e icursor end
+ .e delete 0 end
+ .e index insert
+} -result 0
+
+test entry-1.7 "Deletion - insert cursor in the middle " -body {
+ .e insert end abcde
+ .e icursor 3
+ .e delete 0 end
+ .e index insert
+} -result 0
+
+test entry-1.done "Cleanup" -body { destroy .e }
+
+# Scrollbar tests.
+
+test entry-2.1 "Create entry before scrollbar" -body {
+ pack [ttk::entry .te -xscrollcommand [list .tsb set]] \
+ -expand true -fill both
+ pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
+ -expand false -fill x
+} -cleanup {destroy .te .tsb}
+
+test entry-2.2 "Initial scroll position" -body {
+ ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
+ .e insert end "0123456789"
+ pack .e; update
+ set scrollInfo
+} -result {0.0 0.5} -cleanup { destroy .e }
+# NOTE: result can vary depending on font.
+
+# Bounding box / scrolling tests.
+test entry-3.0 "Series 3 setup" -body {
+ ttk::style theme use default
+ variable fixed fixed
+ variable cw [font measure $fixed a]
+ variable ch [font metrics $fixed -linespace]
+ variable bd 2 ;# border + padding
+ variable ux [font measure $fixed \u4e4e]
+
+ pack [ttk::entry .e -font $fixed -width 20]
+ update
+}
+
+test entry-3.1 "bbox widget command" -body {
+ .e delete 0 end
+ .e bbox 0
+} -result [list $bd $bd 0 $ch]
+
+test entry-3.2 "xview" -body {
+ .e delete 0 end;
+ .e insert end [string repeat "0" 40]
+ update idletasks
+ set result [.e xview]
+} -result {0.0 0.5}
+
+test entry-3.last "Series 3 cleanup" -body {
+ destroy .e
+}
+
+# Selection tests:
+
+test entry-4.0 "Selection test - setup" -body {
+ ttk::entry .e
+ .e insert end asdfasdf
+ .e selection range 0 end
+}
+
+test entry-4.1 "Selection test" -body {
+ selection get
+} -result asdfasdf
+
+test entry-4.2 "Disable -exportselection" -body {
+ .e configure -exportselection false
+ selection get
+} -returnCodes error -result "PRIMARY selection doesn't exist*" -match glob
+
+test entry-4.3 "Reenable -exportselection" -body {
+ .e configure -exportselection true
+ selection get
+} -result asdfasdf
+
+test entry-4.4 "Force selection loss" -body {
+ selection own .
+ .e index sel.first
+} -returnCodes error -result "selection isn't in widget .e"
+
+test entry-4.5 "Allow selection changes if readonly" -body {
+ .e delete 0 end
+ .e insert end 0123456789
+ .e selection range 0 end
+ .e configure -state readonly
+ .e selection range 2 4
+ .e configure -state normal
+ list [.e index sel.first] [.e index sel.last]
+} -result {2 4}
+
+test entry-4.6 "Disallow selection changes if disabled" -body {
+ .e delete 0 end
+ .e insert end 0123456789
+ .e selection range 0 end
+ .e configure -state disabled
+ .e selection range 2 4
+ .e configure -state normal
+ list [.e index sel.first] [.e index sel.last]
+} -result {0 10}
+
+test entry-4.7 {sel.first and sel.last gravity} -body {
+ set result [list]
+ .e delete 0 end
+ .e insert 0 0123456789
+ .e select range 2 6
+ .e insert 2 XXX
+ lappend result [.e index sel.first] [.e index sel.last]
+ .e insert 6 YYY
+ lappend result [.e index sel.first] [.e index sel.last] [.e get]
+} -result {5 9 5 12 01XXX2YYY3456789}
+
+# Self-destruct tests.
+
+test entry-5.1 {widget deletion while active} -body {
+ destroy .e
+ pack [ttk::entry .e]
+ update
+ .e config -xscrollcommand { destroy .e }
+ update idletasks
+ winfo exists .e
+} -result 0
+
+# TODO: test killing .e in -validatecommand, -invalidcommand, variable trace;
+
+
+# -textvariable tests.
+
+test entry-6.1 {Update linked variable in write trace} -body {
+ proc override args {
+ global x
+ set x "Overridden!"
+ }
+ catch {destroy .e}
+ set x ""
+ trace variable x w override
+ ttk::entry .e -textvariable x
+ .e insert 0 "Some text"
+ set result [list $x [.e get]]
+ set result
+} -result {Overridden! Overridden!} -cleanup {
+ unset x
+ rename override {}
+ destroy .e
+}
+
+test entry-6.2 {-textvariable tests} -body {
+ set result [list]
+ ttk::entry .e -textvariable x
+ set x "text"
+ lappend result [.e get]
+ unset x
+ lappend result [.e get]
+ .e insert end "newtext"
+ lappend result [.e get] [set x]
+} -result [list "text" "" "newtext" "newtext"] -cleanup {
+ destroy .e
+ unset -nocomplain x
+}
+
+test entry-7.1 {Bad style options} -body {
+ ttk::style theme create entry-7.1 -settings {
+ ttk::style configure TEntry -foreground BadColor
+ ttk::style map TEntry -foreground {readonly AnotherBadColor}
+ ttk::style map TEntry -font {readonly ABadFont}
+ ttk::style map TEntry \
+ -selectbackground {{} BadColor} \
+ -selectforeground {{} BadColor} \
+ -insertcolor {{} BadColor}
+ }
+ pack [ttk::entry .e -text "Don't crash"]
+ ttk::style theme use entry-7.1
+ update
+ .e selection range 0 end
+ update
+ .e state readonly;
+ update
+} -cleanup { destroy .e ; ttk::style theme use default }
+
+test entry-8.1 "Unset linked variable" -body {
+ variable foo "bar"
+ pack [ttk::entry .e -textvariable foo]
+ unset foo
+ .e insert end "baz"
+ list [.e cget -textvariable] [.e get] [set foo]
+} -result [list foo "baz" "baz"] -cleanup { destroy .e }
+
+test entry-8.2 "Unset linked variable by deleting namespace" -body {
+ namespace eval ::test { variable foo "bar" }
+ pack [ttk::entry .e -textvariable ::test::foo]
+ namespace delete ::test
+ .e insert end "baz" ;# <== error here
+ list [.e cget -textvariable] [.e get] [set foo]
+} -returnCodes error -result "*parent namespace doesn't exist*" -match glob
+# '-result [list ::test::foo "baz" "baz"]' would also be sensible,
+# but Tcl namespaces don't work that way.
+
+test entry-8.2a "Followup to test 8.2" -body {
+ .e cget -textvariable
+} -result ::test::foo -cleanup { destroy .e }
+# For 8.2a, -result {} would also be sensible.
+
+test entry-9.1 "Index range invariants" -setup {
+ # See bug#1721532 for discussion
+ proc entry-9.1-trace {n1 n2 op} {
+ set ::V NO!
+ }
+ variable V
+ trace add variable V write entry-9.1-trace
+ ttk::entry .e -textvariable V
+} -body {
+ set result [list]
+ .e insert insert a ; lappend result [.e index insert] [.e index end]
+ .e insert insert b ; lappend result [.e index insert] [.e index end]
+ .e insert insert c ; lappend result [.e index insert] [.e index end]
+ .e insert insert d ; lappend result [.e index insert] [.e index end]
+ .e insert insert e ; lappend result [.e index insert] [.e index end]
+ set result
+} -result [list 1 3 2 3 3 3 3 3 3 3] -cleanup {
+ unset V
+ destroy .e
+}
+
+tcltest::cleanupTests
diff --git a/tests/ttk/image.test b/tests/ttk/image.test
new file mode 100644
index 0000000..a55f7f8
--- /dev/null
+++ b/tests/ttk/image.test
@@ -0,0 +1,50 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test image-1.1 "Bad image element" -body {
+ ttk::style element create BadImage image badimage
+} -returnCodes error -result {image "badimage" doesn't exist}
+
+test image-1.2 "Duplicate element" -setup {
+ image create photo test.element -width 10 -height 10
+ ttk::style element create testElement image test.element
+} -body {
+ ttk::style element create testElement image test.element
+} -returnCodes 1 -result "Duplicate element testElement"
+
+test image-2.0 "Deletion of displayed image (label)" -setup {
+ image create photo test.image -width 10 -height 10
+} -body {
+ pack [set w [ttk::label .ttk_image20 -image test.image]]
+ tkwait visibility $w
+ image delete test.image
+ update
+} -cleanup {
+ destroy .ttk_image20
+} -result {}
+
+test image-2.1 "Deletion of displayed image (checkbutton)" -setup {
+ image create photo test.image -width 10 -height 10
+} -body {
+ pack [set w [ttk::checkbutton .ttk_image21 -image test.image]]
+ tkwait visibility $w
+ image delete test.image
+ update
+} -cleanup {
+ destroy .ttk_image21
+} -result {}
+
+test image-2.2 "Deletion of displayed image (radiobutton)" -setup {
+ image create photo test.image -width 10 -height 10
+} -body {
+ pack [set w [ttk::radiobutton .ttk_image22 -image test.image]]
+ tkwait visibility $w
+ image delete test.image
+ update
+} -cleanup {
+ destroy .ttk_image22
+} -result {}
+
+#
+tcltest::cleanupTests
diff --git a/tests/ttk/labelframe.test b/tests/ttk/labelframe.test
new file mode 100644
index 0000000..28b4d2e
--- /dev/null
+++ b/tests/ttk/labelframe.test
@@ -0,0 +1,130 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test labelframe-1.0 "Setup" -body {
+ pack [ttk::labelframe .lf] -expand true -fill both
+}
+
+test labelframe-2.1 "Can't use indirect descendant as labelwidget" -body {
+ ttk::frame .lf.t
+ ttk::checkbutton .lf.t.cb
+ .lf configure -labelwidget .lf.t.cb
+} -returnCodes 1 -result "can't *" -match glob \
+ -cleanup { destroy .lf.t } ;
+
+test labelframe-2.2 "Can't use toplevel as labelwidget" -body {
+ toplevel .lf.t
+ .lf configure -labelwidget .lf.t
+} -returnCodes 1 -result "can't *" -match glob \
+ -cleanup { destroy .lf.t } ;
+
+test labelframe-2.3 "Can't use non-windows as -labelwidget" -body {
+ .lf configure -labelwidget BogusWindowName
+} -returnCodes 1 -result {bad window path name "BogusWindowName"}
+
+test labelframe-2.4 "Can't use nonexistent-windows as -labelwidget" -body {
+ .lf configure -labelwidget .nosuchwindow
+} -returnCodes 1 -result {bad window path name ".nosuchwindow"}
+
+
+###
+# See also series labelframe-4.x
+#
+test labelframe-3.1 "Add child slave" -body {
+ checkbutton .lf.cb -text "abcde"
+ .lf configure -labelwidget .lf.cb
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
+} -result [list 1 labelframe]
+
+test labelframe-3.2 "Remove child slave" -body {
+ .lf configure -labelwidget {}
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
+} -result [list 0 {}]
+
+test labelframe-3.3 "Re-add child slave" -body {
+ .lf configure -labelwidget .lf.cb
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
+} -result [list 1 labelframe]
+
+test labelframe-3.4 "Re-manage child slave" -body {
+ pack .lf.cb -side right
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb] [.lf cget -labelwidget]
+} -result [list 1 pack {}]
+
+test labelframe-3.5 "Re-add child slave" -body {
+ .lf configure -labelwidget .lf.cb
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
+} -result [list 1 labelframe]
+
+test labelframe-3.6 "Destroy child slave" -body {
+ destroy .lf.cb
+ .lf cget -labelwidget
+} -result {}
+
+###
+# Re-run series labelframe-3.x with nonchild slaves.
+#
+# @@@ ODDITY, 14 Nov 2005:
+# @@@ labelframe-4.1 fails if .cb is a [checkbutton],
+# @@@ but seems to succeed if it's some other widget class.
+# @@@ I suspect a race condition; unable to track it down ATM.
+#
+# @@@ FOLLOWUP: This *may* have been caused by a bug in ManagerIdleProc
+# @@@ (see manager.c r1.11). There's still probably a race condition in here.
+#
+test labelframe-4.1 "Add nonchild slave" -body {
+ checkbutton .cb -text "abcde"
+ .lf configure -labelwidget .cb
+ update
+ list [winfo ismapped .cb] [winfo viewable .cb] [winfo manager .cb]
+
+} -result [list 1 1 labelframe]
+
+test labelframe-4.2 "Remove nonchild slave" -body {
+ .lf configure -labelwidget {}
+ update;
+ list [winfo ismapped .cb] [winfo viewable .cb] [winfo manager .cb]
+} -result [list 0 0 {}]
+
+test labelframe-4.3 "Re-add nonchild slave" -body {
+ .lf configure -labelwidget .cb
+ list [update; winfo viewable .cb] [winfo manager .cb]
+} -result [list 1 labelframe]
+
+test labelframe-4.4 "Re-manage nonchild slave" -body {
+ pack .cb -side right
+ list [update; winfo viewable .cb] \
+ [winfo manager .cb] \
+ [.lf cget -labelwidget]
+} -result [list 1 pack {}]
+
+test labelframe-4.5 "Re-add nonchild slave" -body {
+ .lf configure -labelwidget .cb
+ list [update; winfo viewable .cb] \
+ [winfo manager .cb] \
+ [.lf cget -labelwidget]
+} -result [list 1 labelframe .cb]
+
+test labelframe-4.6 "Destroy nonchild slave" -body {
+ destroy .cb
+ .lf cget -labelwidget
+} -result {}
+
+test labelframe-5.0 "Cleanup" -body {
+ destroy .lf
+}
+
+# 1342876 -- labelframe should raise sibling -labelwidget above self.
+#
+test labelframe-6.1 "Stacking order" -body {
+ toplevel .t
+ pack [ttk::checkbutton .t.x1]
+ pack [ttk::labelframe .t.lf -labelwidget [ttk::label .t.lb]]
+ pack [ttk::checkbutton .t.x2]
+ winfo children .t
+} -cleanup {
+ destroy .t
+} -result [list .t.x1 .t.lf .t.lb .t.x2]
+
+tcltest::cleanupTests
diff --git a/tests/ttk/layout.test b/tests/ttk/layout.test
new file mode 100644
index 0000000..814e1d9
--- /dev/null
+++ b/tests/ttk/layout.test
@@ -0,0 +1,25 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test layout-1.1 "Size computations for mixed-orientation layouts" -body {
+ ttk::style theme use default
+
+ set block [image create photo -width 10 -height 10]
+ ttk::style element create block image $block
+ ttk::style layout Blocks {
+ border -children { block } -side left
+ border -children { block } -side top
+ border -children { block } -side bottom
+ }
+ ttk::style configure Blocks -borderwidth 1 -relief raised
+ ttk::button .b -style Blocks
+
+ pack .b -expand true -fill both
+
+ list [winfo reqwidth .b] [winfo reqheight .b]
+
+} -cleanup { destroy .b } -result [list 24 24]
+
+
+tcltest::cleanupTests
diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test
new file mode 100644
index 0000000..cdce020
--- /dev/null
+++ b/tests/ttk/notebook.test
@@ -0,0 +1,493 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test notebook-1.0 "Setup" -body {
+ ttk::notebook .nb
+} -result .nb
+
+#
+# Error handling tests:
+#
+test notebook-1.1 "Cannot add ancestor" -body {
+ .nb add .
+} -returnCodes error -result "*" -match glob
+
+proc inoperative {args} {}
+
+inoperative test notebook-1.2 "Cannot add siblings" -body {
+ # This is legal now
+ .nb add [frame .sibling]
+} -returnCodes error -result "*" -match glob
+
+test notebook-1.3 "Cannot add toplevel" -body {
+ .nb add [toplevel .nb.t]
+} -cleanup {
+ destroy .t.nb
+} -returnCodes 1 -match glob -result "can't add .nb.t*"
+
+test notebook-1.4 "Try to select bad tab" -body {
+ .nb select @6000,6000
+} -returnCodes 1 -match glob -result "* not found"
+
+#
+# Now add stuff:
+#
+test notebook-2.0 "Add children" -body {
+ pack .nb -expand true -fill both
+ .nb add [frame .nb.foo] -text "Foo"
+ pack [label .nb.foo.l -text "Foo"]
+
+ .nb add [frame .nb.bar -relief raised -borderwidth 2] -text "Bar"
+ pack [label .nb.bar.l -text "Bar"]
+
+ .nb tabs
+} -result [list .nb.foo .nb.bar]
+
+test notebook-2.1 "select pane" -body {
+ .nb select .nb.foo
+ update
+ list [winfo viewable .nb.foo] [winfo viewable .nb.bar] [.nb index current]
+} -result [list 1 0 0]
+
+test notebook-2.2 "select another pane" -body {
+ .nb select 1
+ update
+ list [winfo viewable .nb.foo] [winfo viewable .nb.bar] [.nb index current]
+} -result [list 0 1 1]
+
+test notebook-2.3 "tab - get value" -body {
+ .nb tab .nb.foo -text
+} -result "Foo"
+
+test notebook-2.4 "tab - set value" -body {
+ .nb tab .nb.foo -text "Changed Foo"
+ .nb tab .nb.foo -text
+} -result "Changed Foo"
+
+test notebook-2.5 "tab - get all options" -body {
+ .nb tab .nb.foo
+} -result [list \
+ -padding 0 -sticky nsew \
+ -state normal -text "Changed Foo" -image "" -compound none -underline -1]
+
+test notebook-4.1 "Test .nb index end" -body {
+ .nb index end
+} -result 2
+
+test notebook-4.2 "'end' is not a selectable index" -body {
+ .nb select end
+} -returnCodes error -result "*" -match glob
+
+test notebook-4.3 "Select index out of range" -body {
+ .nb select 2
+} -returnCodes error -result "*" -match glob
+
+test notebook-4.4 "-padding option" -body {
+ .nb configure -padding "5 5 5 5"
+}
+
+test notebook-4.end "Cleanup test suite 1-4.*" -body { destroy .nb }
+
+test notebook-5.1 "Virtual events" -body {
+ toplevel .t
+ set ::events [list]
+ bind .t <<NotebookTabChanged>> { lappend events changed %W }
+
+ pack [set nb [ttk::notebook .t.nb]] -expand true -fill both; update
+ $nb add [frame $nb.f1]
+ $nb add [frame $nb.f2]
+ $nb add [frame $nb.f3]
+
+ $nb select $nb.f1
+ update; set events
+} -result [list changed .t.nb]
+
+test notebook-5.2 "Virtual events, continued" -body {
+ set events [list]
+ $nb select $nb.f3
+ update ; set events
+} -result [list changed .t.nb]
+# OR: [list deselected .t.nb.f1 selected .t.nb.f3 changed .t.nb]
+
+test notebook-5.3 "Disabled tabs" -body {
+ set events [list]
+ $nb tab $nb.f2 -state disabled
+ $nb select $nb.f2
+ update
+ list $events [$nb index current]
+} -result [list [list] 2]
+
+test notebook-5.4 "Reenable tab" -body {
+ set events [list]
+ $nb tab $nb.f2 -state normal
+ $nb select $nb.f2
+ update
+ list $events [$nb index current]
+} -result [list [list changed .t.nb] 1]
+
+test notebook-5.end "Virtual events, cleanup" -body { destroy .t }
+
+test notebook-6.0 "Select hidden tab" -setup {
+ set nb [ttk::notebook .nb]
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ $nb tab $nb.f1 -state hidden
+ lappend result [$nb tab $nb.f1 -state]
+ $nb select $nb.f1
+ lappend result [$nb tab $nb.f1 -state]
+} -result [list hidden normal]
+
+test notebook-6.1 "Hide selected tab" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb hide $nb.f2
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ update idletasks; lappend result [winfo ismapped $nb.f3]
+} -result [list 1 1 2 0 1]
+
+# See 1370833
+test notebook-6.2 "Forget selected tab" -setup {
+ ttk::notebook .n
+ pack .n
+ label .n.l -text abc
+ .n add .n.l
+} -body {
+ update
+ after 100
+ .n forget .n.l
+ update ;# Yowch!
+} -cleanup {
+ destroy .n
+} -result {}
+
+test notebook-6.3 "Hide first tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f1
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f1]
+ $nb hide $nb.f1
+ lappend result [$nb index current] [winfo ismapped $nb.f1]
+} -result [list 0 1 1 0]
+
+test notebook-6.4 "Forget first tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f1
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f1]
+ $nb forget $nb.f1
+ lappend result [$nb index current] [winfo ismapped $nb.f1]
+} -result [list 0 1 0 0]
+
+test notebook-6.5 "Hide last tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f3
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f3]
+ $nb hide $nb.f3
+ lappend result [$nb index current] [winfo ismapped $nb.f3]
+} -result [list 2 1 1 0]
+
+test notebook-6.6 "Forget a middle tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb forget $nb.f2
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 0]
+
+test notebook-6.7 "Hide a middle tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]]; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb hide $nb.f2
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 2 0]
+
+test notebook-6.8 "Forget a non-current tab < current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb forget $nb.f1
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 0 1]
+
+test notebook-6.9 "Hide a non-current tab < current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb hide $nb.f1
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 1]
+
+test notebook-6.10 "Forget a non-current tab > current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb forget $nb.f3
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 1]
+
+test notebook-6.11 "Hide a non-current tab > current" -setup {
+ pack [set nb [ttk::notebook .nb]]; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb hide $nb.f3
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 1]
+
+test notebook-6.12 "Hide and re-add a tab" -setup {
+ pack [set nb [ttk::notebook .nb]]; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [$nb tab $nb.f2 -state]
+ $nb hide $nb.f2
+ lappend result [$nb index current] [$nb tab $nb.f2 -state]
+ $nb add $nb.f2
+ lappend result [$nb index current] [$nb tab $nb.f2 -state]
+} -result [list 1 normal 2 hidden 2 normal]
+
+#
+# Insert:
+#
+unset nb
+test notebook-7.0 "insert - setup" -body {
+ pack [ttk::notebook .nb]
+ for {set i 0} {$i < 5} {incr i} {
+ .nb add [ttk::frame .nb.f$i] -text "$i"
+ }
+ .nb select .nb.f1
+ list [.nb index current] [.nb tabs]
+} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]]
+
+test notebook-7.1 "insert - move backwards" -body {
+ .nb insert 1 3
+ list [.nb index current] [.nb tabs]
+} -result [list 2 [list .nb.f0 .nb.f3 .nb.f1 .nb.f2 .nb.f4]]
+
+test notebook-7.2 "insert - move backwards again" -body {
+ .nb insert 1 3
+ list [.nb index current] [.nb tabs]
+} -result [list 3 [list .nb.f0 .nb.f2 .nb.f3 .nb.f1 .nb.f4]]
+
+test notebook-7.3 "insert - move backwards again" -body {
+ .nb insert 1 3
+ list [.nb index current] [.nb tabs]
+} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]]
+
+test notebook-7.4 "insert - move forwards" -body {
+ .nb insert 3 1
+ list [.nb index current] [.nb tabs]
+} -result [list 3 [list .nb.f0 .nb.f2 .nb.f3 .nb.f1 .nb.f4]]
+
+test notebook-7.5 "insert - move forwards again" -body {
+ .nb insert 3 1
+ list [.nb index current] [.nb tabs]
+} -result [list 2 [list .nb.f0 .nb.f3 .nb.f1 .nb.f2 .nb.f4]]
+
+test notebook-7.6 "insert - move forwards again" -body {
+ .nb insert 3 1
+ list [.nb index current] [.nb tabs]
+} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]]
+
+test notebook-7.7a "insert - current tab undisturbed" -body {
+ .nb select 0
+ .nb insert 3 1
+ .nb index current
+} -result 0
+
+test notebook-7.7b "insert - current tab undisturbed" -body {
+ .nb select 0
+ .nb insert 1 3
+ .nb index current
+} -result 0
+
+test notebook-7.7c "insert - current tab undisturbed" -body {
+ .nb select 4
+ .nb insert 3 1
+ .nb index current
+} -result 4
+
+test notebook-7.7d "insert - current tab undisturbed" -body {
+ .nb select 4
+ .nb insert 1 3
+ .nb index current
+} -result 4
+
+test notebook-7.8a "move tabs - current tab undisturbed - exhaustive" -body {
+ .nb select .nb.f0
+ foreach i {0 1 2 3 4} {
+ .nb insert $i .nb.f$i
+ }
+
+ foreach i {0 1 2 3 4} {
+ .nb select .nb.f$i
+ foreach j {0 1 2 3 4} {
+ foreach k {0 1 2 3 4} {
+ .nb insert $j $k
+ set current [lindex [.nb tabs] [.nb index current]]
+ if {$current != ".nb.f$i"} {
+ error "($i,$j,$k) current = $current"
+ }
+ .nb insert $k $j
+ if {[.nb tabs] ne [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]} {
+ error "swap $j $k; swap $k $j => [.nb tabs]"
+ }
+ }
+ }
+ }
+ .nb tabs
+} -result [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]
+
+test notebook-7.8b "insert new - current tab undisturbed - exhaustive" -body {
+ foreach i {0 1 2 3 4} {
+ .nb select .nb.f$i
+ foreach j {0 1 2 3 4} {
+.nb select .nb.f$i
+ .nb insert $j [frame .nb.newf]
+ set current [lindex [.nb tabs] [.nb index current]]
+ if {$current != ".nb.f$i"} {
+ puts stderr "new tab at $j, current = $current, expect .nb.f$i"
+ }
+ destroy .nb.newf
+ if {[.nb tabs] ne [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]} {
+ error "tabs disturbed"
+ }
+ }
+ }
+}
+
+test notebook-7.end "insert - cleanup" -body {
+ destroy .nb
+}
+
+test notebook-1817596-1 "insert should autoselect first tab" -body {
+ pack [ttk::notebook .nb]
+ list \
+ [.nb insert end [ttk::label .nb.l1 -text One] -text One] \
+ [.nb select] \
+ ;
+} -result [list "" .nb.l1] -cleanup { destroy .nb }
+
+test notebook-1817596-2 "error in insert should have no effect" -body {
+ pack [ttk::notebook .nb]
+ .nb insert end [ttk::label .nb.l1]
+ .nb insert end [ttk::label .nb.l2]
+ list \
+ [catch { .nb insert .l2 0 -badoption badvalue } err] \
+ [.nb tabs] \
+} -result [list 1 [list .nb.l1 .nb.l2]] -cleanup { destroy .nb }
+
+test notebook-1817596-3 "insert/configure" -body {
+ pack [ttk::notebook .nb]
+ .nb insert end [ttk::label .nb.l0] -text "L0"
+ .nb insert end [ttk::label .nb.l1] -text "L1"
+ .nb insert end [ttk::label .nb.l2] -text "XX"
+ .nb insert 0 2 -text "L2"
+
+ list [.nb tabs] [.nb tab 0 -text] [.nb tab 1 -text] [.nb tab 2 -text]
+
+} -result [list [list .nb.l2 .nb.l0 .nb.l1] L2 L0 L1] -cleanup { destroy .nb }
+
+
+# See #1343984
+test notebook-1343984-1 "don't autoselect on destroy - setup" -body {
+ ttk::notebook .nb
+ set ::history [list]
+ bind TestFrame <Map> { lappend history MAP %W }
+ bind TestFrame <Destroy> { lappend history DESTROY %W }
+ .nb add [ttk::frame .nb.frame1 -class TestFrame] -text "Frame 1"
+ .nb add [ttk::frame .nb.frame2 -class TestFrame] -text "Frame 2"
+ .nb add [ttk::frame .nb.frame3 -class TestFrame] -text "Frame 3"
+ pack .nb -fill both -expand 1
+ update
+ set ::history
+} -result [list MAP .nb.frame1]
+
+test notebook-1343984-2 "don't autoselect on destroy" -body {
+ set ::history [list]
+ destroy .nb
+ update
+ set ::history
+} -result [list DESTROY .nb.frame1 DESTROY .nb.frame2 DESTROY .nb.frame3]
+
+tcltest::cleanupTests
diff --git a/tests/ttk/panedwindow.test b/tests/ttk/panedwindow.test
new file mode 100644
index 0000000..7fe5c87
--- /dev/null
+++ b/tests/ttk/panedwindow.test
@@ -0,0 +1,291 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+proc propagate-geometry {} { update idletasks }
+
+# Basic sanity checks:
+#
+test panedwindow-1.0 "Setup" -body {
+ ttk::panedwindow .pw
+} -result .pw
+
+test panedwindow-1.1 "Make sure empty panedwindow doesn't crash" -body {
+ pack .pw -expand true -fill both
+ update
+}
+
+test panedwindow-1.2 "Add a pane" -body {
+ .pw add [ttk::frame .pw.f1]
+ winfo manager .pw.f1
+} -result "panedwindow"
+
+test panedwindow-1.3 "Steal pane" -body {
+ pack .pw.f1 -side bottom
+ winfo manager .pw.f1
+} -result "pack"
+
+test panedwindow-1.4 "Make sure empty panedwindow still doesn't crash" -body {
+ update
+}
+
+test panedwindow-1.5 "Remanage pane" -body {
+ #XXX .pw insert 0 .pw.f1
+ .pw add .pw.f1
+ winfo manager .pw.f1
+} -result "panedwindow"
+
+test panedwindow-1.6 "Forget pane" -body {
+ .pw forget .pw.f1
+ winfo manager .pw.f1
+} -result ""
+
+test panedwindow-1.7 "Make sure empty panedwindow still still doesn't crash" -body {
+ update
+}
+
+test panedwindow-1.8 "Re-forget pane" -body {
+ .pw forget .pw.f1
+} -returnCodes 1 -result ".pw.f1 is not managed by .pw"
+
+test panedwindow-1.end "Cleanup" -body {
+ destroy .pw
+}
+
+# Resize behavior:
+#
+test panedwindow-2.1 "..." -body {
+ ttk::panedwindow .pw -orient horizontal
+
+ .pw add [listbox .pw.l1]
+ .pw add [listbox .pw.l2]
+ .pw add [listbox .pw.l3]
+ .pw add [listbox .pw.l4]
+
+ pack .pw -expand true -fill both
+ update
+ set w1 [winfo width .]
+
+ # This should make the window shrink:
+ destroy .pw.l2
+
+ update
+ set w2 [winfo width .]
+
+ expr {$w2 < $w1}
+} -result 1
+
+test panedwindow-2.2 "..., cont'd" -body {
+
+ # This should keep the window from shrinking:
+ wm geometry . [wm geometry .]
+
+ set rw2 [winfo reqwidth .pw]
+
+ destroy .pw.l1
+ update
+
+ set w3 [winfo width .]
+ set rw3 [winfo reqwidth .pw]
+
+ expr {$w3 == $w2 && $rw3 < $rw2}
+ # problem: [winfo reqwidth] shrinks, but sashes haven't moved
+ # since we haven't gotten a ConfigureNotify.
+ # How to (a) check for this, and (b) fix it?
+} -result 1
+
+test panedwindow-2.3 "..., cont'd" -body {
+
+ .pw add [listbox .pw.l5]
+ update
+ set rw4 [winfo reqwidth .pw]
+
+ expr {$rw4 > $rw3}
+} -result 1
+
+test panedwindow-2.end "Cleanup" -body { destroy .pw }
+
+#
+# ...
+#
+test panedwindow-3.0 "configure pane" -body {
+ ttk::panedwindow .pw
+ .pw add [listbox .pw.lb1]
+ .pw add [listbox .pw.lb2]
+ .pw pane 1 -weight 2
+ .pw pane 1 -weight
+} -result 2
+
+test panedwindow-3.1 "configure pane -- errors" -body {
+ .pw pane 1 -weight -4
+} -returnCodes 1 -match glob -result "-weight must be nonnegative"
+
+test panedwindow-3.2 "add pane -- errors" -body {
+ .pw add [ttk::label .pw.l] -weight -1
+} -returnCodes 1 -match glob -result "-weight must be nonnegative"
+
+
+test panedwindow-3.end "cleanup" -body { destroy .pw }
+
+
+test panedwindow-4.1 "forget" -body {
+ pack [ttk::panedwindow .pw -orient vertical] -expand true -fill both
+ .pw add [label .pw.l1 -text "L1"]
+ .pw add [label .pw.l2 -text "L2"]
+ .pw add [label .pw.l3 -text "L3"]
+ .pw add [label .pw.l4 -text "L4"]
+
+ update
+
+ .pw forget .pw.l1
+ .pw forget .pw.l2
+ .pw forget .pw.l3
+ .pw forget .pw.l4
+ update
+}
+
+test panedwindow-4.2 "forget forgotten" -body {
+ .pw forget .pw.l1
+} -returnCodes 1 -result ".pw.l1 is not managed by .pw"
+
+# checkorder $winlist --
+# Ensure that Y coordinates windows in $winlist are strictly increasing.
+#
+proc checkorder {winlist} {
+ set pos -1
+ set positions [list]
+ foreach win $winlist {
+ lappend positions [set nextpos [winfo y $win]]
+ if {$nextpos <= $pos} {
+ error "window $win out of order ($positions)"
+ }
+ set pos $nextpos
+ }
+}
+
+test panedwindow-4.3 "insert command" -body {
+ .pw insert end .pw.l1
+ .pw insert end .pw.l3
+ .pw insert 1 .pw.l2
+ .pw insert end .pw.l4
+
+ update;
+ checkorder {.pw.l1 .pw.l2 .pw.l3 .pw.l4}
+}
+
+test panedwindow-4.END "cleanup" -body {
+ destroy .pw
+}
+
+# See #1292219
+
+test panedwindow-5.1 "Propagate Map/Unmap state to children" -body {
+ set result [list]
+ pack [ttk::panedwindow .pw]
+ .pw add [ttk::button .pw.b]
+ update
+
+ lappend result [winfo ismapped .pw] [winfo ismapped .pw.b]
+
+ pack forget .pw
+ update
+ lappend result [winfo ismapped .pw] [winfo ismapped .pw.b]
+
+ set result
+} -result [list 1 1 0 0] -cleanup {
+ destroy .pw
+}
+
+### sashpos tests.
+#
+proc sashpositions {pw} {
+ set positions [list]
+ set npanes [llength [winfo children $pw]]
+ for {set i 0} {$i < $npanes - 1} {incr i} {
+ lappend positions [$pw sashpos $i]
+ }
+ return $positions
+}
+
+test paned-sashpos-setup "Setup for sash position test" -body {
+ ttk::style theme use default
+ ttk::style configure -sashthickness 5
+
+ ttk::panedwindow .pw
+ .pw add [frame .pw.f1 -width 20 -height 20]
+ .pw add [frame .pw.f2 -width 20 -height 20]
+ .pw add [frame .pw.f3 -width 20 -height 20]
+ .pw add [frame .pw.f4 -width 20 -height 20]
+
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw]
+} -result [list 20 [expr {20*4 + 5*3}]]
+
+test paned-sashpos-attempt-restore "Attempt to set sash positions" -body {
+ # This is not expected to succeed, since .pw isn't large enough yet.
+ #
+ .pw sashpos 0 30
+ .pw sashpos 1 60
+ .pw sashpos 2 90
+
+ list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw]
+} -result [list 20 95 [list 0 5 10]]
+
+test paned-sashpos-restore "Set height then sash positions" -body {
+ # Setting sash positions after setting -height _should_ succeed.
+ #
+ .pw configure -height 120
+ .pw sashpos 0 30
+ .pw sashpos 1 60
+ .pw sashpos 2 90
+ list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw]
+} -result [list 20 120 [list 30 60 90]]
+
+test paned-sashpos-cleanup "Clean up" -body { destroy .pw }
+
+test paned-propagation-setup "Setup." -body {
+ ttk::style theme use default
+ ttk::style configure -sashthickness 5
+ wm geometry . {}
+ ttk::panedwindow .pw -orient vertical
+
+ frame .pw.f1 -width 100 -height 50
+ frame .pw.f2 -width 100 -height 50
+
+ list [winfo reqwidth .pw.f1] [winfo reqheight .pw.f1]
+} -result [list 100 50]
+
+test paned-propagation-1 "Initial request size" -body {
+ .pw add .pw.f1
+ .pw add .pw.f2
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw]
+} -result [list 100 105]
+
+test paned-propagation-2 "Slave change before map" -body {
+ .pw.f1 configure -width 200 -height 100
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw]
+} -result [list 200 155]
+
+test paned-propagation-3 "Map window" -body {
+ pack .pw -expand true -fill both
+ update
+ list [winfo width .pw] [winfo height .pw] [.pw sashpos 0]
+} -result [list 200 155 100]
+
+test paned-propagation-4 "Slave change after map, off-axis" -body {
+ .pw.f1 configure -width 100 ;# should be granted
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0]
+} -result [list 100 155 100]
+
+test paned-propagation-5 "Slave change after map, on-axis" -body {
+ .pw.f1 configure -height 50 ;# should be denied
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0]
+} -result [list 100 155 100]
+
+test paned-propagation-cleanup "Clean up." -body { destroy .pw }
+
+tcltest::cleanupTests
diff --git a/tests/ttk/progressbar.test b/tests/ttk/progressbar.test
new file mode 100644
index 0000000..b9add86
--- /dev/null
+++ b/tests/ttk/progressbar.test
@@ -0,0 +1,85 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+
+test progressbar-1.1 "Setup" -body {
+ ttk::progressbar .pb
+} -result .pb
+
+test progressbar-1.2 "Linked variable" -body {
+ set PB 50
+ .pb configure -variable PB
+ .pb cget -value
+} -result 50
+
+test progressbar-1.3 "Change linked variable" -body {
+ set PB 80
+ .pb cget -value
+} -result 80
+
+test progressbar-1.4 "Set linked variable to bad value" -body {
+ set PB "bogus"
+ .pb instate invalid
+} -result 1
+
+test progressbar-1.4.1 "Set linked variable back to a good value" -body {
+ set PB 80
+ .pb instate invalid
+} -result 0
+
+test progressbar-1.5 "Set -variable to illegal variable" -body {
+ set BAD "bogus"
+ .pb configure -variable BAD
+ .pb instate invalid
+} -result 1
+
+test progressbar-1.6 "Unset -variable" -body {
+ unset -nocomplain UNSET
+ .pb configure -variable UNSET
+ .pb instate disabled
+} -result 1
+
+test progressbar-2.0 "step command" -body {
+ .pb configure -variable {} ;# @@@
+ .pb configure -value 5 -maximum 10 -mode determinate
+ .pb step
+ .pb cget -value
+} -result 6.0
+
+test progressbar-2.1 "step command, with stepamount" -body {
+ .pb step 3
+ .pb cget -value
+} -result 9.0
+
+test progressbar-2.2 "step wraps at -maximum in determinate mode" -body {
+ .pb step
+ .pb cget -value
+} -result 0.0
+
+test progressbar-2.3 "step doesn't wrap in indeterminate mode" -body {
+ .pb configure -value 8 -maximum 10 -mode indeterminate
+ .pb step
+ .pb step
+ .pb step
+ .pb cget -value
+} -result 11.0
+
+test progressbar-2.4 "step with linked variable" -body {
+ .pb configure -variable PB ;# @@@
+ set PB 5
+ .pb step
+ set PB
+} -result 6.0
+
+test progressbar-2.5 "error in write trace" -body {
+ trace variable PB w { error "YIPES!" ;# }
+ .pb step
+ set PB ;# NOTREACHED
+} -cleanup { unset PB } -returnCodes 1 -match glob -result "*YIPES!"
+
+test progressbar-end "Cleanup" -body {
+ destroy .pb
+}
+
+tcltest::cleanupTests
diff --git a/tests/ttk/radiobutton.test b/tests/ttk/radiobutton.test
new file mode 100644
index 0000000..ba02954
--- /dev/null
+++ b/tests/ttk/radiobutton.test
@@ -0,0 +1,48 @@
+#
+# ttk::radiobutton widget tests.
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test radiobutton-1.1 "Radiobutton check" -body {
+ pack \
+ [ttk::radiobutton .rb1 -text "One" -variable choice -value 1] \
+ [ttk::radiobutton .rb2 -text "Two" -variable choice -value 2] \
+ [ttk::radiobutton .rb3 -text "Three" -variable choice -value 3] \
+ ;
+}
+test radiobutton-1.2 "Radiobutton invoke" -body {
+ .rb1 invoke
+ set ::choice
+} -result 1
+
+test radiobutton-1.3 "Radiobutton state" -body {
+ .rb1 instate selected
+} -result 1
+
+test radiobutton-1.4 "Other radiobutton invoke" -body {
+ .rb2 invoke
+ set ::choice
+} -result 2
+
+test radiobutton-1.5 "Other radiobutton state" -body {
+ .rb2 instate selected
+} -result 1
+
+test radiobutton-1.6 "First radiobutton state" -body {
+ .rb1 instate selected
+} -result 0
+
+test radiobutton-1.7 "Unset radiobutton variable" -body {
+ unset ::choice
+ list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
+} -result {0 1 1}
+
+test radiobutton-1.8 "Reset radiobutton variable" -body {
+ set ::choice 2
+ list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
+} -result {1 0 0}
+
+tcltest::cleanupTests
diff --git a/tests/ttk/scrollbar.test b/tests/ttk/scrollbar.test
new file mode 100644
index 0000000..0464273
--- /dev/null
+++ b/tests/ttk/scrollbar.test
@@ -0,0 +1,69 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+testConstraint coreScrollbar [expr {[tk windowingsystem] eq "aqua"}]
+
+test scrollbar-swapout-1 "Use core scrollbars on OSX..." -constraints {
+ coreScrollbar
+} -body {
+ ttk::scrollbar .sb -command "yadda"
+ list [winfo class .sb] [.sb cget -command]
+} -result [list Scrollbar yadda] -cleanup {
+ destroy .sb
+}
+
+test scrollbar-swapout-2 "... unless -style is specified ..." -constraints {
+ coreScrollbar
+} -body {
+ ttk::style layout Vertical.Custom.TScrollbar \
+ [ttk::style layout Vertical.TScrollbar] ; # See #1833339
+ ttk::scrollbar .sb -command "yadda" -style Custom.TScrollbar
+ list [winfo class .sb] [.sb cget -command] [.sb cget -style]
+} -result [list TScrollbar yadda Custom.TScrollbar] -cleanup {
+ destroy .sb
+}
+
+test scrollbar-swapout-3 "... or -class." -constraints {
+ coreScrollbar
+} -body {
+ ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar
+ list [winfo class .sb] [.sb cget -command]
+} -result [list Custom.TScrollbar yadda] -cleanup {
+ destroy .sb
+}
+
+test scrollbar-1.0 "Setup" -body {
+ ttk::scrollbar .tsb
+} -result .tsb
+
+test scrollbar-1.1 "Set method" -body {
+ .tsb set 0.2 0.4
+ .tsb get
+} -result [list 0.2 0.4]
+
+test scrollbar-1.2 "Set orientation" -body {
+ .tsb configure -orient vertical
+ set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb]
+ expr {$h > $w}
+} -result 1
+
+test scrollbar-1.3 "Change orientation" -body {
+ .tsb configure -orient horizontal
+ set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb]
+ expr {$h < $w}
+} -result 1
+
+#
+# Scale tests:
+#
+
+test scale-1.0 "Self-destruction" -body {
+ trace variable v w { destroy .s ;# }
+ ttk::scale .s -variable v
+ pack .s ; update
+ .s set 1 ; update
+} -returnCodes 1 -match glob -result "*"
+
+tcltest::cleanupTests
+
diff --git a/tests/ttk/spinbox.test b/tests/ttk/spinbox.test
new file mode 100644
index 0000000..3397e37
--- /dev/null
+++ b/tests/ttk/spinbox.test
@@ -0,0 +1,280 @@
+#
+# ttk::spinbox widget tests
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test spinbox-1.0 "Spinbox tests -- setup" -body {
+ ttk::spinbox .sb
+} -cleanup { destroy .sb } -result .sb
+
+test spinbox-1.1 "Bad -values list" -setup {
+ ttk::spinbox .sb
+} -body {
+ .sb configure -values "bad \{list"
+} -cleanup {
+ destroy .sb
+} -returnCodes error -result "unmatched open brace in list"
+
+test spinbox-1.3.1 "get retrieves value" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 50
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 50
+
+test spinbox-1.3.2 "get retrieves value" -setup {
+ ttk::spinbox .sb -from 0 -to 100 -values 55
+} -body {
+ .sb set 55
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 55
+
+test spinbox-1.4.1 "set changes value" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 33
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 33
+
+test spinbox-1.4.2 "set changes value" -setup {
+ ttk::spinbox .sb -from 0 -to 100 -values 55
+} -body {
+ .sb set 33
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 33
+
+
+test spinbox-1.6.1 "insert start" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 5
+ .sb insert 0 4
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 45
+
+test spinbox-1.6.2 "insert end" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 5
+ .sb insert end 4
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 54
+
+test spinbox-1.6.3 "insert invalid index" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 5
+ .sb insert 100 4
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 54
+
+test spinbox-1.7.1 "-command option: set doesnt fire" -setup {
+ ttk::spinbox .sb -from 0 -to 100 -command {set ::spinbox_test 1}
+} -body {
+ set ::spinbox_test 0
+ .sb set 50
+ set ::spinbox_test
+} -cleanup {
+ destroy .sb
+} -result 0
+
+test spinbox-1.7.2 "-command option: button handler will fire" -setup {
+ ttk::spinbox .sb -from 0 -to 100 -command {set ::spinbox_test 1}
+} -body {
+ set ::spinbox_test 0
+ .sb set 50
+ event generate .sb <<Increment>>
+ set ::spinbox_test
+} -cleanup {
+ destroy .sb
+} -result 1
+
+test spinbox-1.8.1 "option -validate" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb configure -validate all
+ .sb cget -validate
+} -cleanup {
+ destroy .sb
+} -result {all}
+
+test spinbox-1.8.2 "option -validate" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb configure -validate key
+ .sb configure -validate focus
+ .sb configure -validate focusin
+ .sb configure -validate focusout
+ .sb configure -validate none
+ .sb cget -validate
+} -cleanup {
+ destroy .sb
+} -result {none}
+
+test spinbox-1.8.3 "option -validate" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb configure -validate bogus
+} -cleanup {
+ destroy .sb
+} -returnCodes error -result {bad validate "bogus": must be all, key, focus, focusin, focusout, or none}
+
+test spinbox-1.8.4 "-validate option: " -setup {
+ set ::spinbox_test {}
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb configure -validate all -validatecommand {lappend ::spinbox_test %P}
+ pack .sb
+ .sb set 50
+ focus .sb
+ after 100 {set ::spinbox_wait 1} ; vwait ::spinbox_wait
+ set ::spinbox_test
+} -cleanup {
+ destroy .sb
+} -result {50}
+
+
+test spinbox-2.0 "current command -- unset should be 0" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list a b c d e a]
+} -body {
+ .sb current
+} -cleanup {
+ destroy .sb
+} -result 0
+# @@@ for combobox, this is -1.
+
+test spinbox-2.1 "current command -- set index" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list a b c d e a]
+} -body {
+ .sb current 5
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result a
+
+test spinbox-2.2 "current command -- change -values" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list a b c d e a]
+} -body {
+ .sb current 5
+ .sb configure -values [list c b a d e]
+ .sb current
+} -cleanup {
+ destroy .sb
+} -result 2
+
+test spinbox-2.3 "current command -- change value" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list c b a d e]
+} -body {
+ .sb current 2
+ .sb set "b"
+ .sb current
+} -cleanup {
+ destroy .sb
+} -result 1
+
+test spinbox-2.4 "current command -- value not in list" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list c b a d e]
+} -body {
+ .sb current 2
+ .sb set "z"
+ .sb current
+} -cleanup {
+ destroy .sb
+} -result -1
+
+# nostomp: NB intentional difference between ttk::spinbox and tk::spinbox;
+# see also #1439266
+#
+test spinbox-nostomp-1 "don't stomp on -variable (init; -from/to)" -body {
+ set SBV 55
+ ttk::spinbox .sb -textvariable SBV -from 0 -to 100 -increment 5
+ list $SBV [.sb get]
+} -cleanup {
+ unset SBV
+ destroy .sb
+} -result [list 55 55]
+
+test spinbox-nostomp-2 "don't stomp on -variable (init; -values)" -body {
+ set SBV Apr
+ ttk::spinbox .sb -textvariable SBV -values {Jan Feb Mar Apr May Jun Jul Aug}
+ list $SBV [.sb get]
+} -cleanup {
+ unset SBV
+ destroy .sb
+} -result [list Apr Apr]
+
+test spinbox-nostomp-3 "don't stomp on -variable (configure; -from/to)" -body {
+ set SBV 55
+ ttk::spinbox .sb
+ .sb configure -textvariable SBV -from 0 -to 100 -increment 5
+ list $SBV [.sb get]
+} -cleanup {
+ unset SBV
+ destroy .sb
+} -result [list 55 55]
+
+test spinbox-nostomp-4 "don't stomp on -variable (configure; -values)" -body {
+ set SBV Apr
+ ttk::spinbox .sb
+ .sb configure -textvariable SBV -values {Jan Feb Mar Apr May Jun Jul Aug}
+ list $SBV [.sb get]
+} -cleanup {
+ unset SBV
+ destroy .sb
+} -result [list Apr Apr]
+
+test spinbox-dieoctaldie-1 "Cope with leading zeros" -body {
+ # See SF#2358545 -- ttk::spinbox also affected
+ set secs 07
+ ttk::spinbox .sb -from 0 -to 59 -format %02.0f -textvariable secs
+
+ set result [list $secs]
+ event generate .sb <<Increment>>; lappend result $secs
+ event generate .sb <<Increment>>; lappend result $secs
+ event generate .sb <<Increment>>; lappend result $secs
+ event generate .sb <<Increment>>; lappend result $secs
+
+ event generate .sb <<Decrement>>; lappend result $secs
+ event generate .sb <<Decrement>>; lappend result $secs
+ event generate .sb <<Decrement>>; lappend result $secs
+ event generate .sb <<Decrement>>; lappend result $secs
+
+ set result
+} -result [list 07 08 09 10 11 10 09 08 07] -cleanup {
+ destroy .sb
+ unset secs
+}
+
+test spinbox-dieoctaldie-2 "Cope with general bad input" -body {
+ set result [list]
+ ttk::spinbox .sb -from 0 -to 100 -format %03.0f
+ .sb set asdfasdf ; lappend result [.sb get]
+ event generate .sb <<Increment>> ; lappend result [.sb get]
+ .sb set asdfasdf ; lappend result [.sb get]
+ event generate .sb <<Decrement>> ; lappend result [.sb get]
+} -result [list asdfasdf 000 asdfasdf 000] -cleanup {
+ destroy .sb
+}
+
+tcltest::cleanupTests
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/ttk/treetags.test b/tests/ttk/treetags.test
new file mode 100644
index 0000000..7f26e2f
--- /dev/null
+++ b/tests/ttk/treetags.test
@@ -0,0 +1,221 @@
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+### treeview tag invariants:
+#
+
+proc assert {expr {message ""}} {
+ if {![uplevel 1 [list expr $expr]]} {
+ error "PANIC: $message ($expr failed)"
+ }
+}
+proc in {e l} { expr {[lsearch -exact $l $e] >= 0} }
+
+proc itemConstraints {tv item} {
+ # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item]
+ foreach tag [$tv item $item -tags] {
+ assert {[in $item [$tv tag has $tag]]}
+ }
+ foreach child [$tv children $item] {
+ itemConstraints $tv $child
+ }
+}
+
+proc treeConstraints {tv} {
+ # $item in [$tv tag has $tag] <==> [$tv tag has $tag $item]
+ #
+ foreach tag [$tv tag names] {
+ foreach item [$tv tag has $tag] {
+ assert {[in $tag [$tv item $item -tags]]}
+ }
+ }
+
+ itemConstraints $tv {}
+}
+#
+###
+
+test treetags-1.0 "Setup" -body {
+ set tv [ttk::treeview .tv]
+ .tv insert {} end -id item1 -text "Item 1"
+ pack .tv
+} -cleanup {
+ treeConstraints $tv
+}
+
+test treetags-1.1 "Bad tag list" -body {
+ $tv item item1 -tags {bad {list}here bad}
+ $tv item item1 -tags
+} -returnCodes error -result "list element in braces *" -match glob
+
+test treetags-1.2 "Good tag list" -body {
+ $tv item item1 -tags tag1
+ $tv item item1 -tags
+} -cleanup {
+ assert {[$tv tag has tag1 item1]}
+ treeConstraints $tv
+} -result [list tag1]
+
+test treetags-1.3 "tag has - test" -body {
+ $tv insert {} end -id item2 -text "Item 2" -tags tag2
+ set result [list]
+ foreach item {item1 item2} {
+ foreach tag {tag1 tag2 tag3} {
+ lappend result $item $tag [$tv tag has $tag $item]
+ }
+ }
+ set result
+} -cleanup {
+ treeConstraints $tv
+} -result [list \
+ item1 tag1 1 item1 tag2 0 item1 tag3 0 \
+ item2 tag1 0 item2 tag2 1 item2 tag3 0 ]
+
+test treetags-1.4 "tag has - query" -body {
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list item1] [list item2] [list]]
+
+test treetags-1.5 "tag add" -body {
+ $tv tag add tag3 {item1 item2}
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list item1] [list item2] [list item1 item2]]
+
+test treetags-1.6 "tag remove - list" -body {
+ $tv tag remove tag3 {item1 item2}
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list item1] [list item2] [list]]
+
+test treetags-1.7 "tag remove - all items" -body {
+ $tv tag remove tag1
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list] [list item2] [list]]
+
+test treetags-1.8 "tag names" -body {
+ lsort [$tv tag names]
+} -result [list tag1 tag2 tag3]
+
+test treetags-1.9 "tag names - tag added to item" -body {
+ $tv item item1 -tags tag4
+ lsort [$tv tag names]
+} -result [list tag1 tag2 tag3 tag4]
+
+test treetags-1.10 "tag names - tag configured" -body {
+ $tv tag configure tag5
+ lsort [$tv tag names]
+} -result [list tag1 tag2 tag3 tag4 tag5]
+
+test treetags-1.end "cleanup" -body {
+ $tv item item1 -tags tag1
+ $tv item item2 -tags tag2
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list item1] [list item2] [list]]
+
+test treetags-2.0 "tag bind" -body {
+ $tv tag bind tag1 <KeyPress> {set ::KEY %A}
+ $tv tag bind tag1 <KeyPress>
+} -cleanup {
+ treeConstraints $tv
+} -result {set ::KEY %A}
+
+test treetags-2.1 "Events delivered to tags" -body {
+ focus -force $tv ; update ;# needed so [event generate] delivers KeyPress
+ $tv focus item1
+ event generate $tv <KeyPress-a>
+ set ::KEY
+} -cleanup {
+ treeConstraints $tv
+} -result a
+
+test treetags-2.2 "Events delivered to correct tags" -body {
+ $tv tag bind tag2 <KeyPress> [list set ::KEY2 %A]
+
+ $tv focus item1
+ event generate $tv <KeyPress-b>
+ $tv focus item2
+ event generate $tv <KeyPress-c>
+
+ list $::KEY $::KEY2
+} -cleanup {
+ treeConstraints $tv
+} -result [list b c]
+
+test treetags-2.3 "Virtual events delivered to focus item" -body {
+ set ::bong 0
+ $tv tag bind tag2 <<Bing>> { incr bong }
+ $tv focus item2
+ event generate $tv <<Bing>>
+ $tv focus item1
+ event generate $tv <<Bing>>
+ set bong
+} -cleanup {
+ treeConstraints $tv
+} -result 1
+
+test treetags-2.4 "Bad events" -body {
+ $tv tag bind bad <Enter> { puts "Entered!" }
+} -returnCodes 1 -result "unsupported event <Enter>*" -match glob
+
+test treetags-3.0 "tag configure - set" -body {
+ $tv tag configure tag1 -foreground blue -background red
+} -cleanup {
+ treeConstraints $tv
+} -result {}
+
+test treetags-3.1 "tag configure - get" -body {
+ $tv tag configure tag1 -foreground
+} -cleanup {
+ treeConstraints $tv
+} -result blue
+
+# @@@ fragile test
+test treetags-3.2 "tag configure - enumerate" -body {
+ $tv tag configure tag1
+} -cleanup {
+ treeConstraints $tv
+} -result [list \
+ -text {} -image {} -anchor {} -background red -foreground blue -font {} \
+]
+
+# The next test exercises tag resource management.
+# If options are not properly freed, the message:
+# Test file error: "Font times 20 still in cache."
+# will show up on stderr at program exit.
+#
+test treetags-3.3 "tag configure - set font" -body {
+ $tv tag configure tag2 -font {times 20}
+}
+
+test treetags-3.4 "stomp tags in tag binding procedure" -body {
+ set result [list]
+ $tv tag bind rm1 <<Remove>> { lappend ::result rm1 [%W focus] <<Remove>> }
+ $tv tag bind rm2 <<Remove>> {
+ lappend ::result rm2 [%W focus] <<Remove>>
+ %W item [%W focus] -tags {tag1}
+ }
+ $tv tag bind rm3 <<Remove>> { lappend ::result rm3 [%W focus] <<Remove>> }
+
+ $tv item item1 -tags {rm1 rm2 rm3}
+ $tv focus item1
+ event generate $tv <<Remove>>
+ set result
+} -cleanup {
+ treeConstraints $tv
+} -result [list rm1 item1 <<Remove>> rm2 item1 <<Remove>> rm3 item1 <<Remove>>]
+
+#
+
+test treetags-end "Cleanup" -body { destroy $tv }
+
+tcltest::cleanupTests
diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test
new file mode 100644
index 0000000..d8bc65d
--- /dev/null
+++ b/tests/ttk/treeview.test
@@ -0,0 +1,639 @@
+#
+# [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do
+# what it currently does)
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+# consistencyCheck --
+# Traverse the tree to make sure the item data structures
+# are properly linked.
+#
+# Since [$tv children] follows ->next links and [$tv index]
+# follows ->prev links, this should cover all invariants.
+#
+proc consistencyCheck {tv {item {}}} {
+ set i 0;
+ foreach child [$tv children $item] {
+ assert {[$tv parent $child] == $item} "parent $child = $item"
+ assert {[$tv index $child] == $i} "index $child [$tv index $child]=$i"
+ incr i
+ consistencyCheck $tv $child
+ }
+}
+
+proc assert {expr {message ""}} {
+ if {![uplevel 1 [list expr $expr]]} {
+ set error "PANIC! PANIC! PANIC: $message ($expr failed)"
+ puts stderr $error
+ error $error
+ }
+}
+
+test treeview-0 "treeview test - setup" -body {
+ ttk::treeview .tv -columns {a b c}
+ pack .tv -expand true -fill both
+ update
+}
+
+test treeview-1.1 "columns" -body {
+ .tv configure -columns {a b c}
+}
+
+test treeview-1.2 "Bad columns" -body {
+ #.tv configure -columns {illegal "list"value}
+ ttk::treeview .badtv -columns {illegal "list"value}
+} -returnCodes 1 -result "list element in quotes followed by*" -match glob
+
+test treeview-1.3 "bad displaycolumns" -body {
+ .tv configure -displaycolumns {a b d}
+} -returnCodes 1 -result "Invalid column index d"
+
+test treeview-1.4 "more bad displaycolumns" -body {
+ .tv configure -displaycolumns {1 2 3}
+} -returnCodes 1 -result "Column index 3 out of bounds"
+
+test treeview-1.5 "Don't forget to check negative numbers" -body {
+ .tv configure -displaycolumns {1 -2 3}
+} -returnCodes 1 -result "Column index -2 out of bounds"
+
+# Item creation.
+#
+test treeview-2.1 "insert -- not enough args" -body {
+ .tv insert
+} -returnCodes 1 -result "wrong # args: *" -match glob
+
+test treeview-2.3 "insert -- bad integer index" -body {
+ .tv insert {} badindex
+} -returnCodes 1 -result "expected integer *" -match glob
+
+test treeview-2.4 "insert -- bad parent node" -body {
+ .tv insert badparent end
+} -returnCodes 1 -result "Item badparent not found" -match glob
+
+test treeview-2.5 "insert -- finaly insert a node" -body {
+ .tv insert {} end -id newnode -text "New node"
+} -result newnode
+
+test treeview-2.6 "insert -- make sure node was inserted" -body {
+ .tv children {}
+} -result [list newnode]
+
+test treeview-2.7 "insert -- prevent duplicate node names" -body {
+ .tv insert {} end -id newnode
+} -returnCodes 1 -result "Item newnode already exists"
+
+test treeview-2.8 "insert -- new node at end" -body {
+ .tv insert {} end -id lastnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newnode lastnode]
+
+consistencyCheck .tv
+
+test treeview-2.9 "insert -- new node at beginning" -body {
+ .tv insert {} 0 -id firstnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode lastnode]
+
+test treeview-2.10 "insert -- one more node" -body {
+ .tv insert {} 2 -id onemore
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode onemore lastnode]
+
+test treeview-2.11 "insert -- and another one" -body {
+ .tv insert {} 2 -id anotherone
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode anotherone onemore lastnode]
+
+test treeview-2.12 "insert -- one more at end" -body {
+ .tv insert {} end -id newlastone
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode anotherone onemore lastnode newlastone]
+
+test treeview-2.13 "insert -- one more at beginning" -body {
+ .tv insert {} 0 -id newfirstone
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode newnode anotherone onemore lastnode newlastone]
+
+test treeview-2.14 "insert -- bad options" -body {
+ .tv insert {} end -badoption foo
+} -returnCodes 1 -result {unknown option "-badoption"}
+
+test treeview-2.15 "insert -- at position 0 w/no children" -body {
+ .tv insert newnode 0 -id newnode.n2 -text "Foo"
+ .tv children newnode
+} -result newnode.n2 ;# don't crash
+
+test treeview-2.16 "insert -- insert way past end" -body {
+ .tv insert newnode 99 -id newnode.n3 -text "Foo"
+ consistencyCheck .tv
+ .tv children newnode
+} -result [list newnode.n2 newnode.n3]
+
+test treeview-2.17 "insert -- insert before beginning" -body {
+ .tv insert newnode -1 -id newnode.n1 -text "Foo"
+ consistencyCheck .tv
+ .tv children newnode
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+###
+#
+test treeview-3.1 "parent" -body {
+ .tv parent newnode.n1
+} -result newnode
+test treeview-3.2 "parent - top-level node" -body {
+ .tv parent newnode
+} -result {}
+test treeview-3.3 "parent - root node" -body {
+ .tv parent {}
+} -result {}
+test treeview-3.4 "index" -body {
+ list [.tv index newnode.n3] [.tv index newnode.n2] [.tv index newnode.n1]
+} -result [list 2 1 0]
+test treeview-3.5 "index - exhaustive test" -body {
+ set result [list]
+ foreach item [.tv children {}] {
+ lappend result [.tv index $item]
+ }
+ set result
+} -result [list 0 1 2 3 4 5 6]
+
+test treeview-3.6 "detach" -body {
+ .tv detach newnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone]
+# XREF: treeview-2.13
+
+test treeview-3.7 "detach didn't screw up internal links" -body {
+ consistencyCheck .tv
+ set result [list]
+ foreach item [.tv children {}] {
+ lappend result [.tv index $item]
+ }
+ set result
+} -result [list 0 1 2 3 4 5]
+
+test treeview-3.8 "detached node has no parent, index 0" -body {
+ list [.tv parent newnode] [.tv index newnode]
+} -result [list {} 0]
+# @@@ Can't distinguish detached nodes from first root node
+
+test treeview-3.9 "detached node's children undisturbed" -body {
+ .tv children newnode
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-3.10 "detach is idempotent" -body {
+ .tv detach newnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone]
+
+test treeview-3.11 "Can't detach root item" -body {
+ .tv detach [list {}]
+ update
+ consistencyCheck .tv
+} -returnCodes 1 -result "Cannot detach root item"
+consistencyCheck .tv
+
+test treeview-3.12 "Reattach" -body {
+ .tv move newnode {} end
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone newnode]
+
+# Bug # ?????
+test treeview-3.13 "Re-reattach" -body {
+ .tv move newnode {} end
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone newnode]
+
+catch {
+ .tv insert newfirstone end -id x1
+ .tv insert newfirstone end -id x2
+ .tv insert newfirstone end -id x3
+}
+
+test treeview-3.14 "Duplicated entry in children list" -body {
+ .tv children newfirstone [list x3 x1 x2 x3]
+ # ??? Maybe this should raise an error?
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x3 x1 x2]
+
+test treeview-3.14.1 "Duplicated entry in children list" -body {
+ .tv children newfirstone [list x1 x2 x3 x3 x2 x1]
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.15 "Consecutive duplicate entries in children list" -body {
+ .tv children newfirstone [list x1 x2 x2 x3]
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.16 "Insert child after self" -body {
+ .tv move x2 newfirstone 1
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.17 "Insert last child after self" -body {
+ .tv move x3 newfirstone 2
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.18 "Insert last child after end" -body {
+ .tv move x3 newfirstone 3
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-4.1 "opened - initial state" -body {
+ .tv item newnode -open
+} -result 0
+test treeview-4.2 "opened - open node" -body {
+ .tv item newnode -open 1
+ .tv item newnode -open
+} -result 1
+test treeview-4.3 "opened - closed node" -body {
+ .tv item newnode -open 0
+ .tv item newnode -open
+} -result 0
+
+test treeview-5.1 "item -- error checks" -body {
+ .tv item newnode -text "Bad values" -values "{bad}list"
+} -returnCodes 1 -result "list element in braces followed by*" -match glob
+
+test treeview-5.2 "item -- error leaves options unchanged " -body {
+ .tv item newnode -text
+} -result "New node"
+
+test treeview-5.3 "Heading" -body {
+ .tv heading #0 -text "Heading"
+}
+
+test treeview-5.4 "get cell" -body {
+ set l [list a b c]
+ .tv item newnode -values $l
+ .tv set newnode 1
+} -result b
+
+test treeview-5.5 "set cell" -body {
+ .tv set newnode 1 XXX
+ .tv item newnode -values
+} -result [list a XXX c]
+
+test treeview-5.6 "set illegal cell" -body {
+ .tv set newnode #0 YYY
+} -returnCodes 1 -result "Display column #0 cannot be set"
+
+test treeview-5.7 "set illegal cell" -body {
+ .tv set newnode 3 YY ;# 3 == current #columns
+} -returnCodes 1 -result "Column index 3 out of bounds"
+
+test treeview-5.8 "set display columns" -body {
+ .tv configure -displaycolumns [list 2 1 0]
+ .tv set newnode #1 X
+ .tv set newnode #2 Y
+ .tv set newnode #3 Z
+ .tv item newnode -values
+} -result [list Z Y X]
+
+test treeview-5.9 "display columns part 2" -body {
+ list [.tv column #1 -id] [.tv column #2 -id] [.tv column #3 -id]
+} -result [list c b a]
+
+test treeview-5.10 "cannot set column -id" -body {
+ .tv column #1 -id X
+} -returnCodes 1 -result "Attempt to change read-only option"
+
+test treeview-5.11 "get" -body {
+ .tv set newnode #1
+} -result X
+
+test treeview-5.12 "get dictionary" -body {
+ .tv set newnode
+} -result [list a Z b Y c X]
+
+test treeview-5.13 "get, no value" -body {
+ set newitem [.tv insert {} end]
+ set result [.tv set $newitem #1]
+ .tv delete $newitem
+ set result
+} -result {}
+
+
+test treeview-6.1 "deletion - setup" -body {
+ .tv insert {} end -id dtest
+ foreach id [list a b c d e] {
+ .tv insert dtest end -id $id
+ }
+ .tv children dtest
+} -result [list a b c d e]
+
+test treeview-6.1.1 "delete" -body {
+ .tv delete b
+ consistencyCheck .tv
+ list [.tv exists b] [.tv children dtest]
+} -result [list 0 [list a c d e]]
+
+consistencyCheck .tv
+
+test treeview-6.2 "delete - duplicate items in list" -body {
+ .tv delete [list a e a e]
+ consistencyCheck .tv
+ .tv children dtest
+} -result [list c d]
+
+test treeview-6.3 "delete - descendants removed" -body {
+ .tv insert c end -id c1
+ .tv insert c end -id c2
+ .tv insert c1 end -id c11
+ consistencyCheck .tv
+ .tv delete c
+ consistencyCheck .tv
+ list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.4 "delete - delete parent and descendants" -body {
+ .tv insert dtest end -id c
+ .tv insert c end -id c1
+ .tv insert c end -id c2
+ .tv insert c1 end -id c11
+ consistencyCheck .tv
+ .tv delete [list c c1 c2 c11]
+ consistencyCheck .tv
+ list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.5 "delete - delete descendants and parent" -body {
+ .tv insert dtest end -id c
+ .tv insert c end -id c1
+ .tv insert c end -id c2
+ .tv insert c1 end -id c11
+ consistencyCheck .tv
+ .tv delete [list c11 c1 c2 c]
+ consistencyCheck .tv
+ list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.6 "delete - end" -body {
+ consistencyCheck .tv
+ .tv children dtest
+} -result [list d]
+
+test treeview-7.1 "move" -body {
+ .tv insert d end -id d1
+ .tv insert d end -id d2
+ .tv insert d end -id d3
+ .tv move d3 d 0
+ consistencyCheck .tv
+ .tv children d
+} -result [list d3 d1 d2]
+
+test treeview-7.2 "illegal move" -body {
+ .tv move d d2 end
+} -returnCodes 1 -result "Cannot insert d as a descendant of d2"
+
+test treeview-7.3 "illegal move has no effect" -body {
+ consistencyCheck .tv
+ .tv children d
+} -result [list d3 d1 d2]
+
+test treeview-7.4 "Replace children" -body {
+ .tv children d [list d3 d2 d1]
+ consistencyCheck .tv
+ .tv children d
+} -result [list d3 d2 d1]
+
+test treeview-7.5 "replace children - precondition" -body {
+ # Just check to make sure the test suite so far has left
+ # us in the state we expect to be in:
+ list [.tv parent newnode] [.tv children newnode]
+} -result [list {} [list newnode.n1 newnode.n2 newnode.n3]]
+
+test treeview-7.6 "Replace children - illegal move" -body {
+ .tv children newnode.n1 [list newnode.n1 newnode.n2 newnode.n3]
+} -returnCodes 1 -result "Cannot insert newnode.n1 as a descendant of newnode.n1"
+
+consistencyCheck .tv
+
+test treeview-8.0 "Selection set" -body {
+ .tv selection set [list newnode.n1 newnode.n3 newnode.n2]
+ .tv selection
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-8.1 "Selection add" -body {
+ .tv selection add [list newnode]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-8.2 "Selection toggle" -body {
+ .tv selection toggle [list newnode.n2 d3]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n3 d3]
+
+test treeview-8.3 "Selection remove" -body {
+ .tv selection remove [list newnode.n2 d3]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n3]
+
+test treeview-8.4 "Selection - clear" -body {
+ .tv selection set {}
+ .tv selection
+} -result {}
+
+test treeview-8.5 "Selection - bad operation" -body {
+ .tv selection badop foo
+} -returnCodes 1 -match glob -result {bad selection operation "badop": must be *}
+
+### NEED: more tests for see/yview/scrolling
+
+proc scrollcallback {args} {
+ set ::scrolldata $args
+}
+test treeview-9.0 "scroll callback - empty tree" -body {
+ .tv configure -yscrollcommand scrollcallback
+ .tv delete [.tv children {}]
+ update
+ set ::scrolldata
+} -result [list 0.0 1.0]
+
+### identify tests:
+#
+proc identify* {tv comps args} {
+ foreach {x y} $args {
+ foreach comp $comps {
+ lappend result [$tv identify $comp $x $y]
+ }
+ }
+ return $result
+}
+
+# get list of column IDs from list of display column ids.
+#
+proc columnids {tv dcols} {
+ set result [list]
+ foreach dcol $dcols {
+ if {[catch {
+ lappend result [$tv column $dcol -id]
+ }]} {
+ lappend result ERROR
+ }
+ }
+ return $result
+}
+
+test treeview-identify-setup "identify series - setup" -body {
+ destroy .tv
+ ttk::setTheme default
+ ttk::treeview .tv -columns [list A B C]
+ .tv insert {} end -id branch -text branch -open true
+ .tv insert branch end -id item1 -text item1
+ .tv insert branch end -id item2 -text item2
+ .tv insert branch end -id item3 -text item3
+
+ .tv column #0 -width 50 ;# 0-50
+ .tv column A -width 50 ;# 50-100
+ .tv column B -width 50 ;# 100-150
+ .tv column C -width 50 ;# 150-200 (plus slop for margins)
+
+ wm geometry . {} ; pack .tv ; update
+}
+
+test treeview-identify-1 "identify heading" -body {
+ .tv configure -show {headings tree}
+ update idletasks
+ identify* .tv {region column} 10 10
+} -result [list heading #0]
+
+test treeview-identify-2 "identify columns" -body {
+ .tv configure -displaycolumns #all
+ update idletasks
+ columnids .tv [identify* .tv column 25 10 75 10 125 10 175 10]
+} -result [list {} A B C]
+
+test treeview-identify-3 "reordered columns" -body {
+ .tv configure -displaycolumns {B A C}
+ update idletasks
+ columnids .tv [identify* .tv column 25 10 75 10 125 10 175 10]
+} -result [list {} B A C]
+
+test treeview-identify-4 "no tree column" -body {
+ .tv configure -displaycolumns #all -show {headings}
+ update idletasks
+ identify* .tv {region column} 25 10 75 10 125 10 175 10
+} -result [list heading #1 heading #2 heading #3 nothing {}]
+
+# Item height in default theme is 20px
+test treeview-identify-5 "vertical scan - no headings" -body {
+ .tv configure -displaycolumns #all -show {tree}
+ update idletasks
+ identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90
+} -result [list tree branch tree item1 tree item2 tree item3 nothing {}]
+
+test treeview-identify-6 "vertical scan - with headings" -body {
+ .tv configure -displaycolumns #all -show {tree headings}
+ update idletasks
+ identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90
+} -result [list heading {} tree branch tree item1 tree item2 tree item3]
+
+test treeview-identify-7 "vertical scan - headings, no tree" -body {
+ .tv configure -displaycolumns #all -show {headings}
+ update idletasks
+ identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90
+} -result [list heading {} cell branch cell item1 cell item2 cell item3]
+
+# In default theme, -indent and -itemheight both 20px
+# Disclosure element name is "Treeitem.indicator"
+set disclosure "*.indicator"
+test treeview-identify-8 "identify element" -body {
+ .tv configure -show {tree}
+ .tv insert branch 0 -id branch2 -open true
+ .tv insert branch2 0 -id branch3 -open true
+ .tv insert branch3 0 -id leaf3
+ update idletasks;
+ identify* .tv {item element} 10 10 30 30 50 50
+} -match glob -result [list \
+ branch $disclosure branch2 $disclosure branch3 $disclosure]
+
+# See #2381555
+test treeview-identify-9 "identify works when horizontally scrolled" -setup {
+ .tv configure -show {tree headings}
+ foreach column {#0 A B C} {
+ .tv column $column -stretch 0 -width 50
+ }
+ place .tv -x 0 -y 0 -width 100
+} -body {
+ set result [list]
+ foreach xoffs {0 50 100} {
+ .tv xview $xoffs ; update
+ lappend result [identify* .tv {region column} 10 10 60 10]
+ }
+ set result
+} -result [list \
+ [list heading #0 heading #1] \
+ [list heading #1 heading #2] \
+ [list heading #2 heading #3] ]
+
+test treeview-identify-cleanup "identify - cleanup" -body {
+ destroy .tv
+}
+
+### NEED: tests for focus item, selection
+
+### Misc. tests:
+
+destroy .tv
+test treeview-10.1 "Root node properly initialized (#1541739)" -setup {
+ ttk::treeview .tv
+ .tv insert {} end -id a
+ .tv see a
+} -cleanup {
+ destroy .tv
+}
+
+test treeview-3006842 "Null bindings" -setup {
+ ttk::treeview .tv -show tree
+} -body {
+ .tv tag bind empty <ButtonPress-1> {}
+ .tv insert {} end -text "Click me" -tags empty
+ event generate .tv <ButtonPress-1> -x 10 -y 10
+ .tv tag bind empty
+} -result {} -cleanup {
+ destroy .tv
+}
+
+test treeview-3085489-1 "tag add, no -tags" -setup {
+ ttk::treeview .tv
+} -body {
+ set item [.tv insert {} end]
+ .tv tag add foo $item
+ .tv item $item -tags
+} -cleanup {
+ destroy .tv
+} -result [list foo]
+
+test treeview-3085489-2 "tag remove, no -tags" -setup {
+ ttk::treeview .tv
+} -body {
+ set item [.tv insert {} end]
+ .tv tag remove foo $item
+ .tv item $item -tags
+} -cleanup {
+ destroy .tv
+} -result [list]
+
+tcltest::cleanupTests
diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test
new file mode 100644
index 0000000..def709e
--- /dev/null
+++ b/tests/ttk/ttk.test
@@ -0,0 +1,651 @@
+
+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
+ }
+ 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*
diff --git a/tests/ttk/validate.test b/tests/ttk/validate.test
new file mode 100644
index 0000000..417deac
--- /dev/null
+++ b/tests/ttk/validate.test
@@ -0,0 +1,277 @@
+##
+## Entry widget validation tests
+## Derived from core test suite entry-19.1 through entry-19.20
+##
+
+package require Tk 8.5
+package require tcltest 2.1
+namespace import -force tcltest::*
+
+loadTestedCommands
+
+testConstraint ttkEntry 1
+testConstraint coreEntry [expr {![testConstraint ttkEntry]}]
+
+eval tcltest::configure $argv
+
+test validate-0.0 "Setup" -constraints ttkEntry -body {
+ rename entry {}
+ interp alias {} entry {} ttk::entry
+ return;
+}
+
+test validate-0.1 "More setup" -body {
+ destroy .e
+ catch {unset ::e}
+ catch {unset ::vVals}
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ ;
+ pack .e
+ proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 1
+ }
+}
+
+# The validation tests build each one upon the previous, so cascading
+# failures aren't good
+#
+test validate-1.1 {entry widget validation - insert} -body {
+ .e insert 0 a
+ set ::vVals
+} -result {.e 1 0 a {} a all key}
+
+test validate-1.2 {entry widget validation - insert} -body {
+ .e insert 1 b
+ set ::vVals
+} -result {.e 1 1 ab a b all key}
+
+test validate-1.3 {entry widget validation - insert} -body {
+ .e insert end c
+ set ::vVals
+} -result {.e 1 2 abc ab c all key}
+
+test validate-1.4 {entry widget validation - insert} -body {
+ .e insert 1 123
+ list $::vVals $::e
+} -result {{.e 1 1 a123bc abc 123 all key} a123bc}
+
+test validate-1.5 {entry widget validation - delete} -body {
+ .e delete 2
+ set ::vVals
+} -result {.e 0 2 a13bc a123bc 2 all key}
+
+test validate-1.6 {entry widget validation - delete} -body {
+ .e configure -validate key
+ .e delete 1 3
+ set ::vVals
+} -result {.e 0 1 abc a13bc 13 key key}
+
+test validate-1.7 {entry widget validation - vmode focus} -body {
+ set ::vVals {}
+ .e configure -validate focus
+ .e insert end d
+ set ::vVals
+} -result {}
+
+test validate-1.8 {entry widget validation - vmode focus} -body {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} focus focusin}
+
+test validate-1.9 {entry widget validation - vmode focus} -body {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} focus focusout}
+
+.e configure -validate all
+test validate-1.10 {entry widget validation - vmode all} -body {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} all focusin}
+
+test validate-1.11 {entry widget validation} -body {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} all focusout}
+.e configure -validate focusin
+
+test validate-1.12 {entry widget validation} -body {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} focusin focusin}
+
+test validate-1.13 {entry widget validation} -body {
+ set ::vVals {}
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} -result {}
+.e configure -validate focuso
+
+test validate-1.14 {entry widget validation} -body {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} -result {}
+
+test validate-1.15 {entry widget validation} -body {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} focusout focusout}
+
+# DIFFERENCE: core entry temporarily sets "-validate all", ttk::entry doesn't.
+test validate-1.16 {entry widget validation} -body {
+ .e configure -validate all
+ list [.e validate] $::vVals
+} -result {1 {.e -1 -1 abcd abcd {} all forced}}
+
+# DIFFERENCE: ttk::entry does not perform validation when setting the -variable
+test validate-1.17 {entry widget validation} -constraints coreEntry -body {
+ .e configure -validate all
+ set ::e newdata
+ list [.e cget -validate] $::vVals
+} -result {all {.e -1 -1 newdata abcd {} all forced}}
+
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 0
+}
+
+test validate-1.18 {entry widget validation} -constraints coreEntry -body {
+ .e configure -validate all
+ set ::e nextdata
+ list [.e cget -validate] $::vVals
+} -result {none {.e -1 -1 nextdata newdata {} all forced}}
+# DIFFERENCE: ttk::entry doesn't validate when setting linked -variable
+# DIFFERENCE: ttk::entry doesn't disable validation
+
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ set ::e mydata
+ return 1
+}
+
+## This sets validate to none because it shows that we prevent a possible
+## loop condition in the validation, when the entry textvar is also set
+test validate-1.19 {entry widget validation} -constraints coreEntry -body {
+ .e configure -validate all
+ .e validate
+ list [.e cget -validate] [.e get] $::vVals
+} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
+
+## This leaves validate alone because we trigger validation through the
+## textvar (a write trace), and the write during validation triggers
+## nothing (by definition of avoiding loops on var traces). This is
+## one of those "dangerous" conditions where the user will have a
+## different value in the entry widget shown as is in the textvar.
+
+# DIFFERENCE: ttk entry doesn't get out of sync w/textvar
+test validate-1.20 {entry widget validation} -constraints coreEntry -body {
+ .e configure -validate all
+ set ::e testdata
+ list [.e cget -validate] [.e get] $::e $::vVals
+} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
+
+#
+# New tests, -JE:
+#
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ .e delete 0 end;
+ .e insert end dovaldata
+ return 0
+}
+test validate-2.1 "Validation script changes value" -body {
+ .e configure -validate none
+ set ::e testdata
+ .e configure -validate all
+ .e validate
+ list [.e get] $::e $::vVals
+} -result {dovaldata dovaldata {.e -1 -1 testdata testdata {} all forced}}
+# DIFFERENCE: core entry disables validation, ttk entry does not.
+
+destroy .e
+catch {unset ::e ::vVals}
+
+# See bug #1236979
+
+test validate-2.2 "configure in -validatecommand" -body {
+ proc validate-2.2 {win str} {
+ $win configure -foreground black
+ return 1
+ }
+ ttk::entry .e -textvariable var -validatecommand {validate-2.2 %W %P}
+ .e validate
+} -result 1 -cleanup { destroy .e }
+
+
+### invalid state behavior
+#
+
+test validate-3.0 "Setup" -body {
+ set ::E "123"
+ ttk::entry .e \
+ -validatecommand {string is integer -strict %P} \
+ -validate all \
+ -textvariable ::E \
+ ;
+ return [list [.e get] [.e state]]
+} -result [list 123 {}]
+
+test validate-3.1 "insert - valid" -body {
+ .e insert end "4"
+ return [list [.e get] [.e state]]
+} -result [list 1234 {}]
+
+test validate-3.2 "insert - invalid" -body {
+ .e insert end "X"
+ return [list [.e get] [.e state]]
+} -result [list 1234 {}]
+
+test validate-3.3 "force invalid value" -body {
+ append ::E "XY"
+ return [list [.e get] [.e state]]
+} -result [list 1234XY {}]
+
+test validate-3.4 "revalidate" -body {
+ return [list [.e validate] [.e get] [.e state]]
+} -result [list 0 1234XY {invalid}]
+
+testConstraint NA 0
+# the next two tests (used to) exercise validation lockout protection --
+# if the widget is currently invalid, all edits are allowed.
+# This behavior is currently disabled.
+#
+test validate-3.5 "all edits allowed while invalid" -constraints NA -body {
+ .e delete 4
+ return [list [.e get] [.e state]]
+} -result [list 1234Y {invalid}]
+
+test validate-3.6 "...until the value becomes valid" -constraints NA -body {
+ .e delete 4
+ return [list [.e get] [.e state]]
+} -result [list 1234 {}]
+
+test validate-3.last "Cleanup" -body { destroy .e }
+
+
+###
+tcltest::cleanupTests
diff --git a/tests/ttk/vsapi.test b/tests/ttk/vsapi.test
new file mode 100644
index 0000000..bb88fef
--- /dev/null
+++ b/tests/ttk/vsapi.test
@@ -0,0 +1,47 @@
+# -*- tcl -*-
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+testConstraint xpnative \
+ [expr {[lsearch -exact [ttk::style theme names] xpnative] != -1}]
+
+test vsapi-1.1 "WINDOW WP_SMALLCLOSEBUTTON" -constraints {xpnative} -body {
+ ttk::style element create smallclose vsapi \
+ WINDOW 19 {disabled 4 pressed 3 active 2 {} 1}
+ ttk::style layout CloseButton {CloseButton.smallclose -sticky news}
+ ttk::button .b -style CloseButton
+ pack .b -expand true -fill both
+ list [winfo reqwidth .b] [winfo reqheight .b]
+} -cleanup { destroy .b } -result [list 13 13]
+
+test vsapi-1.2 "EXPLORERBAR EBP_HEADERPIN" -constraints {xpnative} -body {
+ ttk::style element create pin vsapi \
+ EXPLORERBAR 3 {
+ {pressed !selected} 3
+ {active !selected} 2
+ {pressed selected} 6
+ {active selected} 5
+ {selected} 4
+ {} 1
+ }
+ ttk::style layout Explorer.Pin {Explorer.Pin.pin -sticky news}
+ ttk::checkbutton .pin -style Explorer.Pin
+ pack .pin -expand true -fill both
+ list [winfo reqwidth .pin] [winfo reqheight .pin]
+} -cleanup { destroy .pin } -result [list 16 16]
+
+test vsapi-1.3 "EXPLORERBAR EBP_HEADERCLOSE" -constraints {xpnative} -body {
+ ttk::style element create headerclose vsapi \
+ EXPLORERBAR 2 {pressed 3 active 2 {} 1}
+ ttk::style layout Explorer.CloseButton {
+ Explorer.CloseButton.headerclose -sticky news
+ }
+ ttk::button .b -style Explorer.CloseButton
+ pack .b -expand true -fill both
+ list [winfo reqwidth .b] [winfo reqheight .b]
+} -cleanup { destroy .b } -result [list 16 16]
+
+tcltest::cleanupTests
generated by cgit v0.12 at 2024-11-18 09:34:01 (GMT)