summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorhobbs <hobbs>2006-10-31 01:42:25 (GMT)
committerhobbs <hobbs>2006-10-31 01:42:25 (GMT)
commit397a2c9832bf618f26be267501cf49ab06a562ec (patch)
tree61d5e957eccfcba57b0dd27ebc73db085385834e /tests
parent18d330543869e240c2bd12fc9fbb8d5027f5cad6 (diff)
downloadtk-397a2c9832bf618f26be267501cf49ab06a562ec.zip
tk-397a2c9832bf618f26be267501cf49ab06a562ec.tar.gz
tk-397a2c9832bf618f26be267501cf49ab06a562ec.tar.bz2
* doc/ttk_Geometry.3, doc/ttk_Theme.3, doc/ttk_button.n:
* doc/ttk_checkbutton.n, doc/ttk_combobox.n, doc/ttk_dialog.n: * doc/ttk_entry.n, doc/ttk_frame.n, doc/ttk_image.n: * doc/ttk_intro.n, doc/ttk_label.n, doc/ttk_labelframe.n: * doc/ttk_menubutton.n, doc/ttk_notebook.n, doc/ttk_panedwindow.n: * doc/ttk_progressbar.n, doc/ttk_radiobutton.n, doc/ttk_scrollbar.n: * doc/ttk_separator.n, doc/ttk_sizegrip.n, doc/ttk_style.n: * doc/ttk_treeview.n, doc/ttk_widget.n,: * generic/ttk/ttk.decls, generic/ttk/ttkBlink.c: * generic/ttk/ttkButton.c, generic/ttk/ttkCache.c: * generic/ttk/ttkClamTheme.c, generic/ttk/ttkClassicTheme.c: * generic/ttk/ttkDecls.h, generic/ttk/ttkDefaultTheme.c: * generic/ttk/ttkElements.c, generic/ttk/ttkEntry.c: * generic/ttk/ttkFrame.c, generic/ttk/ttkImage.c: * generic/ttk/ttkInit.c, generic/ttk/ttkLabel.c: * generic/ttk/ttkLayout.c, generic/ttk/ttkManager.c: * generic/ttk/ttkManager.h, generic/ttk/ttkNotebook.c: * generic/ttk/ttkPanedwindow.c, generic/ttk/ttkProgress.c: * generic/ttk/ttkScale.c, generic/ttk/ttkScroll.c: * generic/ttk/ttkScrollbar.c, generic/ttk/ttkSeparator.c: * generic/ttk/ttkSquare.c, generic/ttk/ttkState.c: * generic/ttk/ttkStubInit.c, generic/ttk/ttkStubLib.c: * generic/ttk/ttkTagSet.c, generic/ttk/ttkTheme.c: * generic/ttk/ttkTheme.h, generic/ttk/ttkThemeInt.h: * generic/ttk/ttkTrace.c, generic/ttk/ttkTrack.c: * generic/ttk/ttkTreeview.c, generic/ttk/ttkWidget.c: * generic/ttk/ttkWidget.h: * library/demos/ttk_demo.tcl, library/demos/ttk_iconlib.tcl: * library/demos/ttk_repeater.tcl: * library/ttk/altTheme.tcl, library/ttk/aquaTheme.tcl: * library/ttk/button.tcl, library/ttk/clamTheme.tcl: * library/ttk/classicTheme.tcl, library/ttk/combobox.tcl: * library/ttk/cursors.tcl, library/ttk/defaults.tcl: * library/ttk/dialog.tcl, library/ttk/entry.tcl: * library/ttk/fonts.tcl, library/ttk/icons.tcl: * library/ttk/keynav.tcl, library/ttk/menubutton.tcl: * library/ttk/notebook.tcl, library/ttk/panedwindow.tcl: * library/ttk/progress.tcl, library/ttk/scale.tcl: * library/ttk/scrollbar.tcl, library/ttk/sizegrip.tcl: * library/ttk/treeview.tcl, library/ttk/ttk.tcl: * library/ttk/utils.tcl, library/ttk/winTheme.tcl: * library/ttk/xpTheme.tcl: * macosx/ttkMacOSXTheme.c: * tests/ttk/all.tcl, tests/ttk/bwidget.test, tests/ttk/combobox.test: * tests/ttk/entry.test, tests/ttk/image.test: * tests/ttk/labelframe.test, tests/ttk/layout.test: * tests/ttk/misc.test, tests/ttk/notebook.test: * tests/ttk/panedwindow.test, tests/ttk/progressbar.test: * tests/ttk/scrollbar.test, tests/ttk/treetags.test: * tests/ttk/treeview.test, tests/ttk/ttk.test, tests/ttk/validate.test: * win/ttkWinMonitor.c, win/ttkWinTheme.c, win/ttkWinXPTheme.c: First import of Ttk themed Tk widgets as branched from tile 0.7.8 * generic/tkInt.h, generic/tkWindow.c: add Ttk_Init call, copy tk classic widgets to ::tk namespace. * library/tk.tcl: add source of ttk/ttk.tcl, define $::ttk::library. * unix/Makefile.in, win/Makefile.in: add Ttk build bits * win/configure, win/configure.in: check for uxtheme.h (XP theme).
Diffstat (limited to 'tests')
-rw-r--r--tests/ttk/all.tcl15
-rw-r--r--tests/ttk/bwidget.test101
-rw-r--r--tests/ttk/combobox.test48
-rw-r--r--tests/ttk/entry.test262
-rw-r--r--tests/ttk/image.test44
-rw-r--r--tests/ttk/labelframe.test134
-rw-r--r--tests/ttk/layout.test29
-rw-r--r--tests/ttk/misc.test33
-rw-r--r--tests/ttk/notebook.test387
-rw-r--r--tests/ttk/panedwindow.test201
-rw-r--r--tests/ttk/progressbar.test89
-rw-r--r--tests/ttk/scrollbar.test42
-rw-r--r--tests/ttk/treetags.test77
-rw-r--r--tests/ttk/treeview.test494
-rw-r--r--tests/ttk/ttk.test594
-rw-r--r--tests/ttk/validate.test277
16 files changed, 2827 insertions, 0 deletions
diff --git a/tests/ttk/all.tcl b/tests/ttk/all.tcl
new file mode 100644
index 0000000..75aa035
--- /dev/null
+++ b/tests/ttk/all.tcl
@@ -0,0 +1,15 @@
+#
+# source all tests.
+#
+package require tcltest 2.1
+
+package require Tk 8.5 ;# This is the Tk test suite; fail early if no Tk!
+
+tcltest::configure -testdir [file join [pwd] [file dirname [info script]]]
+
+eval tcltest::configure $::argv
+tcltest::runAllTests
+
+if {![catch { package present Tk }]} {
+ destroy .
+}
diff --git a/tests/ttk/bwidget.test b/tests/ttk/bwidget.test
new file mode 100644
index 0000000..f371daf
--- /dev/null
+++ b/tests/ttk/bwidget.test
@@ -0,0 +1,101 @@
+#
+# Test BWidget / Ttk compatibility.
+#
+# NOTE: This part of the test suite is no longer operative:
+# [namespace import -force ttk::*] is not expected or intended to work.
+#
+# Keeping the file around for now since it contains some historical
+# information about how ttk *tried* to make it work, and what
+# sort of things went wrong.
+#
+
+package require Tk 8.5
+package require tcltest
+tcltest::cleanupTests ; return
+
+loadTestedCommands
+
+set have_compat 0
+if {![catch {ttk::pkgconfig get compat} compat]} {set have_compat $compat}
+testConstraint bwidget [expr {$have_compat && ![catch {package require BWidget}]}]
+
+test bwidget-1.0 "Setup for BWidget test" -constraints bwidget -body {
+ namespace import -force ttk::*
+ puts "Loaded BWidget version [package provide BWidget]"
+}
+
+test bwidget-1.1 "Make Label widget" -constraints bwidget -body {
+ pack [Label .w]
+} -cleanup {destroy .w}
+
+test bwidget-1.2 "Make ScrolledWindow widget" -constraints bwidget -body {
+ pack [ScrolledWindow .w -auto both -scrollbar vertical]
+} -cleanup {destroy .w}
+
+test bwidget-1.3 "Make PagesManager widget" -constraints bwidget -body {
+ pack [PagesManager .w]
+} -cleanup {destroy .w}
+
+#
+# ProgressBar: this one fails with 'unknown color name "xxx"',
+# where "xxx" is the default value of some other option
+# (variously, "4m", "100", something else).
+#
+# Update: fixed now. Source of problem: widgets were using "unused"
+# as the resource database name for compatibility options;
+# BWidgets keys off the db name instead of the option name.
+#
+test bwidget-1.4 "Make ProgressBar widget" -constraints bwidget -body {
+ pack [ProgressBar .w]
+} -cleanup {destroy .w}
+
+# @@@ TODO: full BWidget coverage,
+# @@@ not just the ones people have reported problems with.
+
+
+#
+# <<NOTE-NULLOPTIONS>>:
+#
+# TK_OPTION_NULL_OK doesn't work for TK_OPTION_INT (among others);
+# see Bug #967209.
+#
+# This means that [.l configure -width [.l cget -width]] -- which is
+# essentially what BWidgets does -- will raise an error if -width has
+# a NULL default.
+#
+# Temporary workaround: declare -width, etc. as TK_OPTION_STRING instead.
+# This disables typechecking in the 'configure' method, but it seems
+# to be the best way to avoid the BWidget incompatibility for now.
+#
+test nulloptions-1.1 "Test null options" -body {
+ ttk::label .tl
+ .tl configure -width [.tl cget -width]
+} -cleanup { destroy .tl }
+
+#
+# <<NOTE-NULLOPTIONS-2>> This also means we have to (partially) disable
+# the widget option / element option consistency checks.
+#
+test nulloptions-1.2 "Ensure workaround doesn't break -width" -body {
+ ttk::label .tl -text "x" -width 0
+ set w1 [winfo reqwidth .tl]
+ .tl configure -width 10
+ set w2 [winfo reqwidth .tl]
+ expr {$w2 > $w1}
+} -result 1 -cleanup { destroy .tl }
+
+test nulloptions-1.3 "Exhaustive test" -body {
+ set readonlyOpts [list -class]
+ foreach widget $::ttk::widgets {
+ #puts "$widget"
+ ttk::$widget .w
+ foreach configspec [.w configure] {
+ set option [lindex $configspec 0]
+ if {[lsearch -exact $readonlyOpts $option] >= 0} { continue }
+ .w configure $option [.w cget $option]
+ }
+ destroy .w
+ }
+}
+
+tcltest::cleanupTests
diff --git a/tests/ttk/combobox.test b/tests/ttk/combobox.test
new file mode 100644
index 0000000..3c20bd3
--- /dev/null
+++ b/tests/ttk/combobox.test
@@ -0,0 +1,48 @@
+#
+# Tile package: 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-end "Cleanup" -body { destroy .cb }
+
+tcltest::cleanupTests
diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test
new file mode 100644
index 0000000..0e7acd2
--- /dev/null
+++ b/tests/ttk/entry.test
@@ -0,0 +1,262 @@
+#
+# 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 idletasks
+ set scrollInfo
+} -result {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 "M" 40]
+ update idletasks
+ set result [.e xview]
+} -result {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.
+
+tcltest::cleanupTests
diff --git a/tests/ttk/image.test b/tests/ttk/image.test
new file mode 100644
index 0000000..b1f66bd
--- /dev/null
+++ b/tests/ttk/image.test
@@ -0,0 +1,44 @@
+#
+# $Id: image.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+# catch background errors:
+#
+if {[info procs bgerror] == "bgerror"} { rename bgerror {} }
+array set BGerror { caught 0 message {} }
+proc bgerror {message} {
+ variable BGerror
+ set BGerror(caught) 1
+ set BGerror(message) $message
+}
+proc caughtbgerror {} {
+ variable BGerror
+ if {!$BGerror(caught)} {
+ error "No bgerror caught"
+ }
+ set BGerror(caught) 0
+ return $BGerror(message)
+}
+
+test image-1.1 "Bad image element" -body {
+ ttk::style element create BadImage image badimage
+ ttk::style layout BadImage { BadImage }
+ ttk::label .l -style BadImage
+ pack .l ; update
+ destroy .l
+ caughtbgerror
+} -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"
+
+#
+tcltest::cleanupTests
diff --git a/tests/ttk/labelframe.test b/tests/ttk/labelframe.test
new file mode 100644
index 0000000..1dd5573
--- /dev/null
+++ b/tests/ttk/labelframe.test
@@ -0,0 +1,134 @@
+#
+# $Id: labelframe.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+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..4b69b3c
--- /dev/null
+++ b/tests/ttk/layout.test
@@ -0,0 +1,29 @@
+#
+# $Id: layout.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+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/misc.test b/tests/ttk/misc.test
new file mode 100644
index 0000000..27b87d6
--- /dev/null
+++ b/tests/ttk/misc.test
@@ -0,0 +1,33 @@
+#
+# $Id: misc.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test misc-1.0 "#1551500 -parent option in ttk::dialog doesn't work" -body {
+ ttk::dialog .dialog -parent . -type ok \
+ -message "Something to say" -title "Let's see"
+ wm transient .dialog
+} -result . -cleanup { destroy .dialog }
+
+test misc-1.1 "ttk::dialog w/no -parent option" -body {
+ toplevel .t
+ ttk::dialog .t.dialog -type ok
+ wm transient .t.dialog
+} -result .t -cleanup { destroy .t }
+
+test misc-1.2 "Explicitly specify -parent" -body {
+ toplevel .t
+ ttk::dialog .t.dialog -type ok -parent .
+ wm transient .t.dialog
+} -result . -cleanup { destroy .t }
+
+test misc-1.3 "Nontransient dialog" -body {
+ toplevel .t
+ ttk::dialog .t.dialog -type ok -parent ""
+ wm transient .t.dialog
+} -result "" -cleanup { destroy .t }
+
+tcltest::cleanupTests
diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test
new file mode 100644
index 0000000..ecb614a
--- /dev/null
+++ b/tests/ttk/notebook.test
@@ -0,0 +1,387 @@
+#
+# $Id: notebook.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+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 tab $nb.f2 -state hidden
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 2 0]
+
+# 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 tab $nb.f1 -state hidden
+ 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 tab $nb.f3 -state hidden
+ 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 tab $nb.f2 -state hidden
+ 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 tab $nb.f1 -state hidden
+ 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 tab $nb.f3 -state hidden
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 1]
+
+
+#
+# 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.end "insert - cleanup" -body {
+ destroy .nb
+}
+
+tcltest::cleanupTests
diff --git a/tests/ttk/panedwindow.test b/tests/ttk/panedwindow.test
new file mode 100644
index 0000000..13a7e85
--- /dev/null
+++ b/tests/ttk/panedwindow.test
@@ -0,0 +1,201 @@
+#
+# $Id: panedwindow.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+
+# 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 "paned"
+
+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 "paned"
+
+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
+ foreach win $winlist {
+ set nextpos [winfo y $win]
+ if {$nextpos <= $pos} {
+ error "window $win out of order"
+ }
+ 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 "Propage 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
+}
+
+tcltest::cleanupTests
diff --git a/tests/ttk/progressbar.test b/tests/ttk/progressbar.test
new file mode 100644
index 0000000..ead15f6
--- /dev/null
+++ b/tests/ttk/progressbar.test
@@ -0,0 +1,89 @@
+#
+# $Id: progressbar.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+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/scrollbar.test b/tests/ttk/scrollbar.test
new file mode 100644
index 0000000..f91659a
--- /dev/null
+++ b/tests/ttk/scrollbar.test
@@ -0,0 +1,42 @@
+#
+# $Id: scrollbar.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+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/treetags.test b/tests/ttk/treetags.test
new file mode 100644
index 0000000..2161395
--- /dev/null
+++ b/tests/ttk/treetags.test
@@ -0,0 +1,77 @@
+#
+# $Id: treetags.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+testConstraint treeview [llength [info commands ttk::treeview]]
+testConstraint nyi 0
+
+test treetags-1.0 "Setup" -constraints treeview -body {
+ set tv [ttk::treeview .tv]
+ .tv insert {} end -id item1 -text "Item 1"
+ pack .tv
+}
+
+test treetags-1.1 "Bad tag list" -constraints treeview -body {
+ $tv item item1 -tags {bad {list}here bad}
+} -returnCodes error -result "list element in braces *" -match glob
+
+test treetags-1.2 "Good tag list" -constraints treeview -body {
+ $tv item item1 -tags tag1
+ $tv item item1 -tags
+} -result [list tag1]
+
+test treetags-1.3 "Bad events" -constraints treeview -body {
+ $tv tag bind bad <Enter> { puts "Entered!" }
+} -returnCodes 1 -result "unsupported event <Enter>*" -match glob
+
+test treetags-2.0 "tag bind" -constraints treeview -body {
+ $tv tag bind tag1 <KeyPress> {set ::KEY %A}
+ $tv tag bind tag1 <KeyPress>
+} -result {set ::KEY %A}
+
+test treetags-2.1 "Events delivered to tags" -constraints treeview -body {
+ focus -force $tv ; update ;# needed so [event generate] delivers KeyPress
+ $tv focus item1
+ event generate .tv <KeyPress-a>
+ set ::KEY
+} -result a
+
+test treetags-2.2 "Events delivered to correct tags" -constraints treeview -body {
+ $tv insert {} end -id item2 -tags tag2
+ $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
+} -result [list b c]
+
+test treetags-2.3 "Virtual events delivered to focus item" -constraints treeview -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
+} -result 1
+
+
+test treetags-3.0 "tag configure" -constraints treeview -body {
+ $tv tag configure tag1 -foreground blue -background red
+} -result {}
+
+test treetags-3.1 "tag configure" -constraints treeview -body {
+ $tv tag configure tag1 -foreground
+} -result [list blue]
+
+
+test treetags-end "Cleanup" -constraints treeview -body { destroy .tv }
+
+tcltest::cleanupTests
diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test
new file mode 100644
index 0000000..ac0778c
--- /dev/null
+++ b/tests/ttk/treeview.test
@@ -0,0 +1,494 @@
+#
+# $Id: treeview.test,v 1.1 2006/10/31 01:42:27 hobbs Exp $
+#
+# [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
+
+testConstraint treeview [llength [info commands ttk::treeview]]
+
+# 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 {}}} {
+ if {![llength [info commands ttk::treeview]]} { return }
+ 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" -constraints treeview -body {
+ ttk::treeview .tv -columns {a b c}
+ pack .tv -expand true -fill both
+ update
+}
+
+test treeview-1.1 "columns" -constraints treeview -body {
+ .tv configure -columns {a b c}
+}
+
+test treeview-1.2 "Bad columns" -constraints treeview -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" -constraints treeview -body {
+ .tv configure -displaycolumns {a b d}
+} -returnCodes 1 -result "Invalid column index d"
+
+test treeview-1.4 "more bad displaycolumns" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ .tv insert
+} -returnCodes 1 -result "wrong # args: *" -match glob
+
+test treeview-2.3 "insert -- bad integer index" -constraints treeview -body {
+ .tv insert {} badindex
+} -returnCodes 1 -result "expected integer *" -match glob
+
+test treeview-2.4 "insert -- bad parent node" -constraints treeview -body {
+ .tv insert badparent end
+} -returnCodes 1 -result "Item badparent not found" -match glob
+
+test treeview-2.5 "insert -- finaly insert a node" -constraints treeview -body {
+ .tv insert {} end -id newnode -text "New node"
+} -result newnode
+
+test treeview-2.6 "insert -- make sure node was inserted" -constraints treeview -body {
+ .tv children {}
+} -result [list newnode]
+
+test treeview-2.7 "insert -- prevent duplicate node names" -constraints treeview -body {
+ .tv insert {} end -id newnode
+} -returnCodes 1 -result "Item newnode already exists"
+
+test treeview-2.8 "insert -- new node at end" -constraints treeview -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" -constraints treeview -body {
+ .tv insert {} 0 -id firstnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode lastnode]
+
+test treeview-2.10 "insert -- one more node" -constraints treeview -body {
+ .tv insert {} 2 -id onemore
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode onemore lastnode]
+
+test treeview-2.11 "insert -- and another one" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ .tv insert {} end -badoption foo
+} -returnCodes 1 -result {unknown option "-badoption"}
+
+test treeview-2.15 "insert -- at position 0 w/no children" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ .tv parent newnode.n1
+} -result newnode
+test treeview-3.2 "parent - top-level node" -constraints treeview -body {
+ .tv parent newnode
+} -result {}
+test treeview-3.3 "parent - root node" -constraints treeview -body {
+ .tv parent {}
+} -result {}
+test treeview-3.4 "index" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ .tv children newnode
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-3.10 "detach is idempotent" -constraints treeview -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" -constraints treeview -body {
+ .tv detach [list {}]
+ update
+ consistencyCheck .tv
+} -returnCodes 1 -result "Cannot detach root item"
+consistencyCheck .tv
+
+test treeview-3.12 "Reattach" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ .tv move x3 newfirstone 3
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+
+test treeview-4.1 "opened - initial state" -constraints treeview -body {
+ .tv item newnode -open
+} -result 0
+test treeview-4.2 "opened - open node" -constraints treeview -body {
+ .tv item newnode -open 1
+ .tv item newnode -open
+} -result 1
+test treeview-4.3 "opened - closed node" -constraints treeview -body {
+ .tv item newnode -open 0
+ .tv item newnode -open
+} -result 0
+
+test treeview-5.1 "item -- error checks" -constraints treeview -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 " -constraints treeview -body {
+ .tv item newnode -text
+} -result "New node"
+
+test treeview-5.3 "Heading" -constraints treeview -body {
+ .tv heading #0 -text "Heading"
+}
+
+test treeview-5.4 "get cell" -constraints treeview -body {
+ set l [list a b c]
+ .tv item newnode -values $l
+ .tv set newnode 1
+} -result b
+
+test treeview-5.5 "set cell" -constraints treeview -body {
+ .tv set newnode 1 XXX
+ .tv item newnode -values
+} -result [list a XXX c]
+
+test treeview-5.6 "set illegal cell" -constraints treeview -body {
+ .tv set newnode #0 YYY
+} -returnCodes 1 -result "Display column #0 cannot be set"
+
+test treeview-5.7 "set illegal cell" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ .tv column #1 -id X
+} -returnCodes 1 -result "Attempt to change read-only option"
+
+test treeview-5.11 "get" -constraints treeview -body {
+ .tv set newnode #1
+} -result X
+
+test treeview-5.12 "get dictionary" -constraints treeview -body {
+ .tv set newnode
+} -result [list a Z b Y c X]
+
+test treeview-5.13 "get, no value" -constraints treeview -body {
+ set newitem [.tv insert {} end]
+ set result [.tv set $newitem #1]
+ .tv delete $newitem
+ set result
+} -result {}
+
+
+test treeview-6.1 "deletion - setup" -constraints treeview -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 "delete" -constraints treeview -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" -constraints treeview -body {
+ .tv delete [list a e a e]
+ consistencyCheck .tv
+ .tv children dtest
+} -result [list c d]
+
+test treeview-6.3 "delete - descendants removed" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ consistencyCheck .tv
+ .tv children dtest
+} -result [list d]
+
+test treeview-7.1 "move" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ consistencyCheck .tv
+ .tv children d
+} -result [list d3 d1 d2]
+
+test treeview-7.4 "Replace children" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -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" -constraints treeview -body {
+ .tv selection add [list newnode]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-8.2 "Selection toggle" -constraints treeview -body {
+ .tv selection toggle [list newnode.n2 d3]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n3 d3]
+
+test treeview-8.3 "Selection remove" -constraints treeview -body {
+ .tv selection remove [list newnode.n2 d3]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n3]
+
+test treeview-8.4 "Selection - clear" -constraints treeview -body {
+ .tv selection set {}
+ .tv selection
+} -result {}
+
+test treeview-8.5 "Selection - bad operation" -constraints treeview -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" -constraints treeview -body {
+ .tv configure -yscrollcommand scrollcallback
+ .tv delete [.tv children {}]
+ update
+ set ::scrolldata
+} -result [list 0 1]
+
+### 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
+} -constraints treeview
+
+tcltest::cleanupTests
diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test
new file mode 100644
index 0000000..1532a24
--- /dev/null
+++ b/tests/ttk/ttk.test
@@ -0,0 +1,594 @@
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+proc skip args {}
+proc ok {} { return }
+
+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 "Test package cleanup" -body {
+ interp create foo
+ foo eval { if {[catch {package require Tk}]} { load {} Tk } }
+ foo eval { destroy . }
+ interp delete foo
+}
+
+test ttk-6.4 "Defeat evil intentions" -body {
+ trace variable OUCH r { kill.b }
+ proc kill.b {args} { destroy .b }
+ pack [ttk::checkbutton .b]
+ .b configure -variable OUCH
+ # At this point, .b should be gone.
+ .b invoke
+ list [set OUCH] [winfo exists .b]
+ # Mostly we just care that we haven't crashed the interpreter.
+ #
+} -returnCodes error -match glob -result "*"
+
+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"}
+
+# This should move to be a standard test per widget test file
+test ttk-6.7 "Basic destruction test" -body {
+ foreach widget {
+ button checkbutton radiobutton sizegrip separator notebook
+ progressbar panedwindow scrollbar
+ } {
+ 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!]
+ event generate .l <Expose>
+ update
+ destroy .l
+ set ::bgerror
+} -result {unknown font style "Bogus"}
+
+#
+# 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.4 "Restore default style" -body {
+ .t cget -style
+} -result ""
+
+proc checkstate {w} {
+ foreach statespec {
+ {!active !disabled}
+ {!active disabled}
+ {active !disabled}
+ {active disabled}
+ active
+ disabled
+ } {
+ lappend result [$w instate $statespec]
+ }
+ set result
+}
+
+# NB: this will fail if the top-level window pops up underneath the cursor
+test 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
+
+
+# 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 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
+}
+
+#
+# checkbutton tests
+#
+test ttk-5.1 "Checkbutton check" -body {
+ pack [ttk::checkbutton .cb -text "TCheckbutton" -variable cb]
+}
+test ttk-5.2 "Checkbutton invoke" -body {
+ .cb invoke
+ list [set ::cb] [.cb instate selected]
+} -result [list 1 1]
+test ttk-5.3 "Checkbutton reinvoke" -body {
+ .cb invoke
+ list [set ::cb] [.cb instate selected]
+} -result [list 0 0]
+
+test ttk-5.4 "Checkbutton variable" -body {
+ set result []
+ set ::cb 1
+ lappend result [.cb instate selected]
+ set ::cb 0
+ lappend result [.cb instate selected]
+} -result {1 0}
+
+test ttk-5.5 "Unset checkbutton variable" -body {
+ set result []
+ unset ::cb
+ lappend result [.cb instate alternate] [info exists ::cb]
+ set ::cb 1
+ lappend result [.cb instate alternate] [info exists ::cb]
+} -result {1 0 0 1}
+
+# See #1257319
+test ttk-5.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 {}]
+
+#
+# radiobutton tests
+#
+test ttk-7.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 ttk-7.2 "Radiobutton invoke" -body {
+ .rb1 invoke
+ set ::choice
+} -result 1
+
+test ttk-7.3 "Radiobutton state" -body {
+ .rb1 instate selected
+} -result 1
+
+test ttk-7.4 "Other radiobutton invoke" -body {
+ .rb2 invoke
+ set ::choice
+} -result 2
+
+test ttk-7.5 "Other radiobutton state" -body {
+ .rb2 instate selected
+} -result 1
+
+test ttk-7.6 "First radiobutton state" -body {
+ .rb1 instate selected
+} -result 0
+
+test ttk-7.6 "Unset radiobutton variable" -body {
+ unset ::choice
+ list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
+} -result {0 1 1}
+
+test ttk-7.6 "Reset radiobutton variable" -body {
+ set ::choice 2
+ list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
+} -result {1 0 0}
+
+#
+# -compound tests:
+#
+variable iconData \
+{R0lGODlhIAAgAKIAANnZ2YQAAP8AAISEhP///////////////yH5BAEAAAAALAAAAAAgACAA
+AAP/CLoMGLqKoMvtGIqiqxEYCLrcioGiyxwIusyBgaLLLRiBoMsQKLrcjYGgu4Giy+2CAkFX
+A0WX2wXFIOgGii7trkCEohsDCACBoktEKLpKhISiGwAIECiqSKooukiqKKoxgACBooukKiIo
+SKooujGDECi6iqQqsopEV2MQAkV3kXQZRXdjEAJFl5F0FUWXY3ACRZcFSRdFlyVwJlB0WZB0
+UXRZAmcCRZeRdBVFl2NwAkV3kXQZRXdjcAJFV5FURVaR6GoMDgSKLpKqiKAgqaLoxgwOBIoq
+kiqKLpIqimrM4ECg6BIRiq4SIaHoxgyCBoou7a5AhKIbMzgAAIGiy+2CTWJmBhAAAkWX2wXF
+zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi
+6DIj6HI7jq4i6DIkADs=}
+
+variable compoundStrings {text image center top bottom left right none}
+
+if {0} {
+ proc now {} { set ::now [clock clicks -milliseconds] }
+ proc tick {} { puts -nonewline stderr "+" ; flush stderr }
+ proc tock {} {
+ set then $::now; set ::now [clock clicks -milliseconds]
+ puts stderr " [expr {$::now - $then}] ms"
+ }
+} else {
+ proc now {} {} ; proc tick {} {} ; proc tock {} {}
+}
+
+now ; tick
+test 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: the 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 }
+
+
+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
generated by cgit v0.12 at 2024-11-10 21:38:45 (GMT)