summaryrefslogtreecommitdiffstats
path: root/tk8.6/tests/ttk
diff options
context:
space:
mode:
Diffstat (limited to 'tk8.6/tests/ttk')
-rw-r--r--tk8.6/tests/ttk/all.tcl20
-rw-r--r--tk8.6/tests/ttk/checkbutton.test64
-rw-r--r--tk8.6/tests/ttk/combobox.test68
-rw-r--r--tk8.6/tests/ttk/entry.test283
-rw-r--r--tk8.6/tests/ttk/image.test50
-rw-r--r--tk8.6/tests/ttk/labelframe.test130
-rw-r--r--tk8.6/tests/ttk/layout.test25
-rw-r--r--tk8.6/tests/ttk/notebook.test514
-rw-r--r--tk8.6/tests/ttk/panedwindow.test291
-rw-r--r--tk8.6/tests/ttk/progressbar.test85
-rw-r--r--tk8.6/tests/ttk/radiobutton.test48
-rw-r--r--tk8.6/tests/ttk/scrollbar.test69
-rw-r--r--tk8.6/tests/ttk/spinbox.test280
-rw-r--r--tk8.6/tests/ttk/treetags.test221
-rw-r--r--tk8.6/tests/ttk/treeview.test639
-rw-r--r--tk8.6/tests/ttk/ttk.test647
-rw-r--r--tk8.6/tests/ttk/validate.test277
-rw-r--r--tk8.6/tests/ttk/vsapi.test47
18 files changed, 0 insertions, 3758 deletions
diff --git a/tk8.6/tests/ttk/all.tcl b/tk8.6/tests/ttk/all.tcl
deleted file mode 100644
index f03cd56..0000000
--- a/tk8.6/tests/ttk/all.tcl
+++ /dev/null
@@ -1,20 +0,0 @@
-# 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 Tk ;# This is the Tk test suite; fail early if no Tk!
-package require tcltest 2.2
-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/tk8.6/tests/ttk/checkbutton.test b/tk8.6/tests/ttk/checkbutton.test
deleted file mode 100644
index 6b79287..0000000
--- a/tk8.6/tests/ttk/checkbutton.test
+++ /dev/null
@@ -1,64 +0,0 @@
-#
-# 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 {}]
-
-# Bug [109865fa01]
-test checkbutton-1.7 "Button destroyed by click" -body {
- proc destroy_button {} {
- destroy .top
- }
- toplevel .top
- ttk::menubutton .top.mb -text Button -style TLabel
- bind .top.mb <ButtonRelease-1> destroy_button
- pack .top.mb
- focus -force .top.mb
- update
- event generate .top.mb <1>
- event generate .top.mb <ButtonRelease-1>
- update ; # shall not trigger error invalid command name ".top.b"
-} -result {}
-
-tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/combobox.test b/tk8.6/tests/ttk/combobox.test
deleted file mode 100644
index 43f3cf1..0000000
--- a/tk8.6/tests/ttk/combobox.test
+++ /dev/null
@@ -1,68 +0,0 @@
-#
-# 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/tk8.6/tests/ttk/entry.test b/tk8.6/tests/ttk/entry.test
deleted file mode 100644
index 0c2f0be..0000000
--- a/tk8.6/tests/ttk/entry.test
+++ /dev/null
@@ -1,283 +0,0 @@
-#
-# 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/tk8.6/tests/ttk/image.test b/tk8.6/tests/ttk/image.test
deleted file mode 100644
index a55f7f8..0000000
--- a/tk8.6/tests/ttk/image.test
+++ /dev/null
@@ -1,50 +0,0 @@
-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/tk8.6/tests/ttk/labelframe.test b/tk8.6/tests/ttk/labelframe.test
deleted file mode 100644
index 28b4d2e..0000000
--- a/tk8.6/tests/ttk/labelframe.test
+++ /dev/null
@@ -1,130 +0,0 @@
-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/tk8.6/tests/ttk/layout.test b/tk8.6/tests/ttk/layout.test
deleted file mode 100644
index 814e1d9..0000000
--- a/tk8.6/tests/ttk/layout.test
+++ /dev/null
@@ -1,25 +0,0 @@
-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/tk8.6/tests/ttk/notebook.test b/tk8.6/tests/ttk/notebook.test
deleted file mode 100644
index 3a2a6ff..0000000
--- a/tk8.6/tests/ttk/notebook.test
+++ /dev/null
@@ -1,514 +0,0 @@
-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 }
-
-test notebook-readd-1 "add same widget twice" -body {
- pack [ttk::notebook .nb]
- .nb add [ttk::button .nb.b1] -text "Button"
- .nb add .nb.b1
- .nb tabs
-} -result [list .nb.b1] -cleanup { destroy .nb }
-
-test notebook-readd-2 "add same widget twice, with options" -body {
- pack [ttk::notebook .nb]
- .nb add [ttk::button .nb.b1] -text "Tab label"
- .nb add .nb.b1 -text "Changed tab label"
- .nb tabs
-} -result [list .nb.b1] -cleanup { destroy .nb }
-
-test notebook-readd-3 "insert same widget twice, with options" -body {
- pack [ttk::notebook .nb]
- .nb insert end [ttk::button .nb.b1] -text "Tab label"
- .nb insert end .nb.b1 -text "Changed tab label"
- .nb tabs
-} -result [list .nb.b1] -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/tk8.6/tests/ttk/panedwindow.test b/tk8.6/tests/ttk/panedwindow.test
deleted file mode 100644
index 7fe5c87..0000000
--- a/tk8.6/tests/ttk/panedwindow.test
+++ /dev/null
@@ -1,291 +0,0 @@
-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/tk8.6/tests/ttk/progressbar.test b/tk8.6/tests/ttk/progressbar.test
deleted file mode 100644
index b9add86..0000000
--- a/tk8.6/tests/ttk/progressbar.test
+++ /dev/null
@@ -1,85 +0,0 @@
-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/tk8.6/tests/ttk/radiobutton.test b/tk8.6/tests/ttk/radiobutton.test
deleted file mode 100644
index ba02954..0000000
--- a/tk8.6/tests/ttk/radiobutton.test
+++ /dev/null
@@ -1,48 +0,0 @@
-#
-# 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/tk8.6/tests/ttk/scrollbar.test b/tk8.6/tests/ttk/scrollbar.test
deleted file mode 100644
index 0464273..0000000
--- a/tk8.6/tests/ttk/scrollbar.test
+++ /dev/null
@@ -1,69 +0,0 @@
-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/tk8.6/tests/ttk/spinbox.test b/tk8.6/tests/ttk/spinbox.test
deleted file mode 100644
index 32b77af..0000000
--- a/tk8.6/tests/ttk/spinbox.test
+++ /dev/null
@@ -1,280 +0,0 @@
-#
-# 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 -force .sb
- after 500 {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/tk8.6/tests/ttk/treetags.test b/tk8.6/tests/ttk/treetags.test
deleted file mode 100644
index 7f26e2f..0000000
--- a/tk8.6/tests/ttk/treetags.test
+++ /dev/null
@@ -1,221 +0,0 @@
-
-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/tk8.6/tests/ttk/treeview.test b/tk8.6/tests/ttk/treeview.test
deleted file mode 100644
index aa7e64a..0000000
--- a/tk8.6/tests/ttk/treeview.test
+++ /dev/null
@@ -1,639 +0,0 @@
-#
-# [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 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 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/tk8.6/tests/ttk/ttk.test b/tk8.6/tests/ttk/ttk.test
deleted file mode 100644
index e58b021..0000000
--- a/tk8.6/tests/ttk/ttk.test
+++ /dev/null
@@ -1,647 +0,0 @@
-
-package require Tk 8.5
-package require tcltest ; namespace import -force tcltest::*
-loadTestedCommands
-
-proc skip args {}
-proc ok {} { return }
-
-variable widgetClasses {
- button checkbutton radiobutton menubutton label entry
- frame labelframe scrollbar
- notebook progressbar combobox separator
- panedwindow treeview sizegrip
- scale
-}
-
-proc bgerror {error} {
- variable bgerror $error
- variable bgerrorInfo $::errorInfo
- variable bgerrorCode $::errorCode
-}
-
-# Self-destruct tests.
-# Do these early, so any memory corruption has a longer time to cause a crash.
-#
-proc selfdestruct {w args} {
- destroy $w
-}
-test ttk-6.1 "Self-destructing checkbutton" -body {
- pack [ttk::checkbutton .sd -text "Self-destruction" -variable ::sd]
- trace variable sd w [list selfdestruct .sd]
- update
- .sd invoke
-} -returnCodes 1
-test ttk-6.2 "Checkbutton self-destructed" -body {
- winfo exists .sd
-} -result 0
-
-# test ttk-6.3 not applicable [see #2175411]
-
-test ttk-6.4 "Destroy widget in configure" -setup {
- set OUCH ouch
- trace variable OUCH r { kill.b }
- proc kill.b {args} { destroy .b }
-} -cleanup {
- unset OUCH
-} -body {
- pack [ttk::checkbutton .b]
- set rc [catch { .b configure -variable OUCH } msg]
- list $rc $msg [winfo exists .b] [info commands .b]
-} -result [list 1 "widget has been destroyed" 0 {}]
-
-test ttk-6.5 "Clean up -textvariable traces" -body {
- foreach class {ttk::button ttk::checkbutton ttk::radiobutton} {
- $class .b1 -textvariable V
- set V "asdf"
- destroy .b1
- set V ""
- }
-}
-
-test ttk-6.6 "Bad color spec in styles" -body {
- pack [ttk::button .b1 -text Hi!]
- ttk::style configure TButton -foreground badColor
- event generate .b1 <Expose>
- update
- ttk::style configure TButton -foreground black
- destroy .b1
- set ::bgerror
-} -result {unknown color name "badColor"}
-
-test ttk-6.7 "Basic destruction test" -body {
- foreach widget $widgetClasses {
- ttk::$widget .w
- pack .w
- destroy .w
- }
-}
-
-test ttk-6.8 "Button command removes itself" -body {
- ttk::button .b -command ".b configure -command {}; set ::A {it worked}"
- .b invoke
- destroy .b
- set ::A
-} -result {it worked}
-
-test ttk-6.9 "Bad font spec in styles" -setup {
- ttk::style theme create badfont -settings {
- ttk::style configure . -font {Helvetica 12 Bogus}
- }
- ttk::style theme use badfont
-} -cleanup {
- ttk::style theme use default
-} -body {
- pack [ttk::label .l -text Hi! -font {}]
- event generate .l <Expose>
- update
- destroy .l
- set ::bgerror
-} -result {unknown font style "Bogus"}
-
-test ttk-construction-failure-1 "Excercise construction failure path" -setup {
- option add *TLabel.cursor badCursor 1
-} -cleanup {
- option add *TLabel.cursor {} 1
-} -body {
- catch {ttk::label .l} errmsg
- list $errmsg [info commands .l] [winfo exists .l]
-} -result [list {bad cursor spec "badCursor"} {} 0]
-
-test ttk-construction-failure-2 "Destroy widget in constructor" -setup {
- set OUCH ouch
- trace variable OUCH r { kill.b }
- proc kill.b {args} { destroy .b }
-} -cleanup {
- unset OUCH
-} -body {
- list \
- [catch { ttk::checkbutton .b -variable OUCH } msg] \
- $msg \
- [winfo exists .b] \
- [info commands .b] \
- ;
-} -result [list 1 "widget has been destroyed" 0 {}]
-
-test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body {
- # see #2298720
- toplevel .t
- ttk::button .t.b -command [list destroy .t]
- .t.b invoke
- list [winfo exists .t] [winfo exists .t.b]
-} -result [list 0 0]
-
-#
-# Basic tests.
-#
-test ttk-1.1 "Create button" -body {
- pack [ttk::button .t] -expand true -fill both
- update
-}
-
-test ttk-1.2 "Check style" -body {
- .t cget -style
-} -result {}
-
-test ttk-1.3 "Set bad style" -body {
- .t configure -style "nosuchstyle"
-} -returnCodes 1 -result {Layout nosuchstyle not found}
-
-test ttk-1.4 "Original style preserved" -body {
- .t cget -style
-} -result ""
-
-proc checkstate {w} {
- foreach statespec {
- {!active !disabled}
- {!active disabled}
- {active !disabled}
- {active disabled}
- active
- disabled
- } {
- lappend result [$w instate $statespec]
- }
- set result
-}
-
-# NB: this will fail if the top-level window pops up underneath the cursor
-test ttk-2.0 "Check state" -body {
- checkstate .t
-} -result [list 1 0 0 0 0 0]
-
-test ttk-2.1 "Change state" -body {
- .t state active
-} -result !active
-
-test ttk-2.2 "Check state again" -body {
- checkstate .t
-} -result [list 0 0 1 0 1 0]
-
-test ttk-2.3 "Change state again" -body {
- .t state {!active disabled}
-} -result {active !disabled}
-
-test ttk-2.4 "Check state again" -body {
- checkstate .t
-} -result [list 0 1 0 0 0 1]
-
-test ttk-2.5 "Change state again" -body {
- .t state !disabled
-} -result {disabled}
-
-test ttk-2.6 "instate scripts, false" -body {
- set x 0
- .t instate disabled { set x 1 }
- set x
-} -result 0
-
-test ttk-2.7 "instate scripts, true" -body {
- set x 0
- .t instate !disabled { set x 1 }
- set x
-} -result 1
-
-test ttk-2.8 "bug 3223850: button state disabled during click" -setup {
- destroy .b
- set ttk28 {}
- pack [ttk::button .b -command {set ::ttk28 failed}]
-} -body {
- bind .b <ButtonPress-1> {after 0 {.b configure -state disabled}}
- after 1 {event generate .b <ButtonPress-1>}
- after 20 {event generate .b <ButtonRelease-1>}
- set aid [after 100 {set ::ttk28 [.b instate {disabled !pressed}]}]
- vwait ::ttk28
- after cancel $aid
- set ttk28
-} -cleanup {
- destroy .b
- unset -nocomplain ttk28 aid
-} -result 1
-
-foreach wc $widgetClasses {
- test ttk-coreoptions-$wc "$wc has all core options" -body {
- ttk::$wc .w
- foreach option {-class -style -cursor -takefocus} {
- .w cget $option
- }
- } -cleanup {
- catch {destroy .w}
- }
-}
-
-# misc. error detection
-test ttk-3.0 "Bad option" -body {
- ttk::button .bad -badoption foo
-} -returnCodes 1 -result {unknown option "-badoption"} -match glob
-
-test ttk-3.1 "Make sure widget command not created" -body {
- .bad state disabled
-} -returnCodes 1 -result {invalid command name ".bad"} -match glob
-
-test ttk-3.2 "Propagate errors from variable traces" -body {
- set A 0
- trace add variable A write {error "failure" ;# }
- ttk::checkbutton .cb -variable A
- .cb invoke
-} -cleanup {
- unset ::A ; destroy .cb
-} -returnCodes error -result {can't set "A": failure}
-
-test ttk-3.3 "Constructor failure with cursor" -body {
- ttk::button .b -cursor bottom_right_corner -style BadStyle
-} -returnCodes 1 -result "Layout BadStyle not found"
-
-test ttk-3.4 "SF#2009213" -body {
- ttk::style configure TScale -sliderrelief {}
- pack [ttk::scale .s]
- update
-} -cleanup {
- ttk::style configure TScale -sliderrelief raised
- destroy .s
-}
-
-# Test resource allocation
-# (@@@ "-font" is a compatibility option now, so tests 4.1-4.3
-# don't really test anything useful at the moment.)
-#
-
-test ttk-4.0 "Setup" -body {
- catch { destroy .t }
- pack [ttk::label .t -text "Button 1"]
- testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]]
- ok
-}
-
-test ttk-4.1 "Change font" -constraints fontOption -body {
- .t configure -font "Helvetica 18 bold"
-}
-test ttk-4.2 "Check font" -constraints fontOption -body {
- .t cget -font
-} -result "Helvetica 18 bold"
-
-test ttk-4.3 "Restore font" -constraints fontOption -body {
- .t configure -font $prevFont
-}
-
-test ttk-4.4 "Bad resource specifications" -body {
- ttk::style theme settings alt {
- ttk::style configure TButton -font {Bad font}
- # @@@ it would be best to raise an error at this point,
- # @@@ but that's not really feasible in the current framework.
- }
- pack [ttk::button .tb1 -text "Ouch"]
- ttk::style theme use alt
- update;
- # As long as we haven't crashed, everything's OK
- ttk::style theme settings alt {
- ttk::style configure TButton -font TkDefaultFont
- }
- ttk::style theme use default
- destroy .tb1
-}
-
-#
-# -compound tests:
-#
-variable iconData \
-{R0lGODlhIAAgAKIAANnZ2YQAAP8AAISEhP///////////////yH5BAEAAAAALAAAAAAgACAA
-AAP/CLoMGLqKoMvtGIqiqxEYCLrcioGiyxwIusyBgaLLLRiBoMsQKLrcjYGgu4Giy+2CAkFX
-A0WX2wXFIOgGii7trkCEohsDCACBoktEKLpKhISiGwAIECiqSKooukiqKKoxgACBooukKiIo
-SKooujGDECi6iqQqsopEV2MQAkV3kXQZRXdjEAJFl5F0FUWXY3ACRZcFSRdFlyVwJlB0WZB0
-UXRZAmcCRZeRdBVFl2NwAkV3kXQZRXdjcAJFV5FURVaR6GoMDgSKLpKqiKAgqaLoxgwOBIoq
-kiqKLpIqimrM4ECg6BIRiq4SIaHoxgyCBoou7a5AhKIbMzgAAIGiy+2CTWJmBhAAAkWX2wXF
-zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi
-6DIj6HI7jq4i6DIkADs=}
-
-variable compoundStrings {text image center top bottom left right none}
-
-if {0} {
- proc now {} { set ::now [clock clicks -milliseconds] }
- proc tick {} { puts -nonewline stderr "+" ; flush stderr }
- proc tock {} {
- set then $::now; set ::now [clock clicks -milliseconds]
- puts stderr " [expr {$::now - $then}] ms"
- }
-} else {
- proc now {} {} ; proc tick {} {} ; proc tock {} {}
-}
-
-now ; tick
-test ttk-8.0 "Setup for 8.X" -body {
- ttk::button .ctb
- image create photo icon -data $::iconData;
- pack .ctb
-}
-tock
-
-now
-test ttk-8.1 "Test -compound options" -body {
- # Exhaustively test each combination.
- # Main goal is to make sure no code paths crash.
- foreach image {icon ""} {
- foreach text {"Hi!" ""} {
- foreach compound $::compoundStrings {
- .ctb configure -image $image -text $text -compound $compound
- update; tick
- }
- }
- }
-}
-tock
-
-test ttk-8.2 "Test -compound options with regular button" -body {
- button .rtb
- pack .rtb
-
- foreach image {"" icon} {
- foreach text {"Hi!" ""} {
- foreach compound [lrange $::compoundStrings 2 end] {
- .rtb configure -image $image -text $text -compound $compound
- update; tick
- }
- }
- }
-}
-tock
-
-test ttk-8.3 "Rerun test 8.1" -body {
- foreach image {icon ""} {
- foreach text {"Hi!" ""} {
- foreach compound $::compoundStrings {
- .ctb configure -image $image -text $text -compound $compound
- update; tick
- }
- }
- }
-}
-tock
-
-test ttk-8.4 "ImageChanged" -body {
- ttk::button .b -image icon
- icon blank
-} -cleanup { destroy .b }
-
-#------------------------------------------------------------------------
-
-test ttk-9.1 "Traces on nonexistant namespaces" -body {
- ttk::checkbutton .tcb -variable foo::bar
-} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob
-
-test ttk-9.2 "Traces on nonexistant namespaces II" -body {
- ttk::checkbutton .tcb -variable X
- .tcb configure -variable foo::bar
-} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob
-
-test ttk-9.3 "Restore saved options on configure error" -body {
- .tcb cget -variable
-} -result X
-
-test ttk-9.4 "Textvariable tests" -body {
- set tcbLabel "Testing..."
- .tcb configure -textvariable tcbLabel
- .tcb cget -text
-} -result "Testing..."
-
-# Changing -text has no effect if there is a linked -textvariable.
-# Compatible with core widget.
-test ttk-9.5 "Change -text" -body {
- .tcb configure -text "Changed -text"
- .tcb cget -text
-} -result "Testing..."
-
-# Unset -textvariable clears the text.
-# NOTE: this is different from core widgets, which automagically reinitalize
-# the -textvariable to the last value of -text.
-#
-test ttk-9.6 "Unset -textvariable" -body {
- unset tcbLabel
- list [info exists tcbLabel] [.tcb cget -text]
-} -result [list 0 ""]
-
-test ttk-9.7 "Unset textvariable, comparison" -body {
-#
-# NB: ttk::label behaves differently from the standard label here;
-# NB: this is on purpose: I believe the standard behaviour is the Wrong Thing
-#
- unset -nocomplain V1 V2
- label .l -text Foo ; ttk::label .tl -text Foo
-
- .l configure -textvariable V1 ; .tl configure -textvariable V2
- list [set V1] [info exists V2]
-} -cleanup { destroy .l .tl } -result [list Foo 0]
-
-test ttk-9.8 "-textvariable overrides -text" -body {
- ttk::label .tl -textvariable TV
- set TV Foo
- .tl configure -text Bar
- .tl cget -text
-} -cleanup { destroy .tl } -result "Foo"
-
-#
-# Frame widget tests:
-#
-
-test ttk-10.1 "ttk::frame -class resource" -body {
- ttk::frame .f -class Foo
-} -result .f
-
-test ttk-10.2 "Check widget class" -body {
- winfo class .f
-} -result Foo
-
-test ttk-10.3 "Check class resource" -body {
- .f cget -class
-} -result Foo
-
-test ttk-10.4 "Try to modify class resource" -body {
- .f configure -class Bar
-} -returnCodes 1 -match glob -result "*read-only option*"
-
-test ttk-10.5 "Check class resource again" -body {
- .f cget -class
-} -result Foo
-
-test ttk-11.1 "-state test, setup" -body {
- ttk::button .b
- .b instate disabled
-} -result 0
-
-test ttk-11.2 "-state test, disable" -body {
- .b configure -state disabled
- .b instate disabled
-} -result 1
-
-test ttk-11.3 "-state test, reenable" -body {
- .b configure -state normal
- .b instate disabled
-} -result 0
-
-test ttk-11.4 "-state test, unrecognized -state value" -body {
- .b configure -state bogus
- .b state
-} -result [list]
-
-test ttk-11.5 "-state test, 'active'" -body {
- .b configure -state active
- .b state
-} -result [list active] -cleanup { .b state !active }
-
-test ttk-11.6 "-state test, 'readonly'" -body {
- .b configure -state readonly
- .b state
-} -result [list readonly] -cleanup { .b state !readonly }
-
-test ttk-11.7 "-state test, cleanup" -body {
- destroy .b
-}
-
-test ttk-12.1 "-cursor option" -body {
- ttk::button .b
- .b cget -cursor
-} -result {}
-
-test ttk-12.2 "-cursor option" -body {
- .b configure -cursor arrow
- .b cget -cursor
-} -result arrow
-
-test ttk-12.3 "-borderwidth frame option" -body {
- destroy .t
- toplevel .t
- raise .t
- pack [set t [ttk::frame .t.f]] -expand true -fill x ;
- pack [ttk::label $t.l -text "ASDF QWERTY"] -expand true -fill both
- foreach theme {default alt} {
- ttk::style theme use $theme
- foreach relief {flat raised sunken ridge groove solid} {
- $t configure -relief $relief
- for {set i 5} {$i >= 0} {incr i -1} {
- $t configure -borderwidth $i
- update
- }
- }
- }
-}
-
-test ttk-12.4 "-borderwidth frame option" -body {
- .t.f configure -relief raised
- .t.f configure -borderwidth 1
- ttk::style theme use alt
- update
-}
-
-test ttk-13.1 "Custom styles -- bad -style option" -body {
- ttk::button .tb1 -style badstyle
-} -returnCodes 1 -result "*badstyle not found*" -match glob
-
-test ttk-13.4 "Custom styles -- bad -style option" -body {
- ttk::button .tb1
- .tb1 configure -style badstyle
-} -cleanup {
- destroy .tb1
-} -returnCodes 1 -result "*badstyle not found*" -match glob
-
-test ttk-13.5 "Custom layouts -- missing element definition" -body {
- ttk::style layout badstyle {
- NoSuchElement
- }
- ttk::button .tb1 -style badstyle
-} -cleanup {
- destroy .tb1
-} -result .tb1
-# @@@ Should: signal an error, possibly a background error.
-
-#
-# See #793909
-#
-
-test ttk-14.1 "-variable in nonexistant namespace" -body {
- ttk::checkbutton .tw -variable ::nsn::foo
-} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
- -match glob -cleanup { destroy .tw }
-
-test ttk-14.2 "-textvariable in nonexistant namespace" -body {
- ttk::label .tw -textvariable ::nsn::foo
-} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
- -match glob -cleanup { destroy .tw }
-
-test ttk-14.3 "-textvariable in nonexistant namespace" -body {
- ttk::entry .tw -textvariable ::nsn::foo
-} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
- -match glob -cleanup { destroy .tw }
-
-test ttk-15.1 {Bug 3062331} -setup {
- destroy .b
-} -body {
- set Y {}
- ttk::button .b -textvariable Y
- trace variable Y u "destroy .b; #"
- unset Y
-} -cleanup {
- destroy .b
-} -result {}
-
-test ttk-15.2 {Bug 3341056} -setup {
- proc foo {} {
- destroy .lf
- ttk::labelframe .lf
- ttk::checkbutton .lf.cb -text xxx
- }
-} -body {
- ttk::button .b -text xxx -command foo
- .b invoke
- .b invoke
- .lf.cb invoke
- destroy .b
-} -cleanup {
- rename foo {}
- destroy .lf
-} -result {}
-
-## Test ensemble processing:
-#
-# (See also: SF#2021443)
-#
-proc wrong#args {args} {
- return "wrong # args: should be \"$args\""
-}
-proc wrong#varargs {varpart args} {
- set usage $args
- append usage " ?$varpart ...?"
- return "wrong # args: should be \"$usage\""
-}
-
-test ttk-ensemble-0 "style element create: insufficient args" -body {
- ttk::style
-} -returnCodes 1 -result \
- [wrong#varargs arg ttk::style option]
-
-test ttk-ensemble-1 "style element create: insufficient args" -body {
- ttk::style element
-} -returnCodes 1 -result \
- [wrong#varargs arg ttk::style element option]
-
-test ttk-ensemble-2 "style element create: insufficient args" -body {
- ttk::style element create
-} -returnCodes 1 -result \
- [wrong#varargs {-option value} ttk::style element create name type]
-
-test ttk-ensemble-3 "style element create: insufficient args" -body {
- ttk::style element create plain.background
-} -returnCodes 1 -result \
- [wrong#varargs {-option value} ttk::style element create name type]
-
-test ttk-ensemble-4 "style element create: insufficient args" -body {
- ttk::style element create plain.background from
-} -returnCodes 1 -result [wrong#args theme ?element?]
-
-test ttk-ensemble-5 "style element create: valid" -body {
- ttk::style element create plain.background from default
-} -returnCodes 0 -result ""
-
-eval destroy [winfo children .]
-
-tcltest::cleanupTests
-
-#*EOF*
diff --git a/tk8.6/tests/ttk/validate.test b/tk8.6/tests/ttk/validate.test
deleted file mode 100644
index 417deac..0000000
--- a/tk8.6/tests/ttk/validate.test
+++ /dev/null
@@ -1,277 +0,0 @@
-##
-## 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/tk8.6/tests/ttk/vsapi.test b/tk8.6/tests/ttk/vsapi.test
deleted file mode 100644
index bb88fef..0000000
--- a/tk8.6/tests/ttk/vsapi.test
+++ /dev/null
@@ -1,47 +0,0 @@
-# -*- 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-06 13:16:49 (GMT)