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