summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/ttk/checkbutton.test49
-rw-r--r--tests/ttk/combobox.test4
-rw-r--r--tests/ttk/radiobutton.test49
-rw-r--r--tests/ttk/spinbox.test280
-rw-r--r--tests/ttk/treetags.test190
-rw-r--r--tests/ttk/treeview.test135
-rw-r--r--tests/ttk/ttk.test199
-rw-r--r--tests/ttk/vsapi.test2
8 files changed, 761 insertions, 147 deletions
diff --git a/tests/ttk/checkbutton.test b/tests/ttk/checkbutton.test
new file mode 100644
index 0000000..49c62dd
--- /dev/null
+++ b/tests/ttk/checkbutton.test
@@ -0,0 +1,49 @@
+# $Id: checkbutton.test,v 1.1.2.2 2010/08/26 02:06:10 hobbs Exp $
+#
+# 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
index 8f25a81..43f3cf1 100644
--- a/tests/ttk/combobox.test
+++ b/tests/ttk/combobox.test
@@ -56,8 +56,8 @@ test combobox-1890211 "ComboboxSelected event after listbox unposted" -body {
lappend result Start 0 [.cb get]
ttk::combobox::Post .cb
lappend result Post [winfo ismapped .cb.popdown] [.cb get]
- .cb.popdown.l selection clear 0 end; .cb.popdown.l selection set 1
- ttk::combobox::LBSelected .cb.popdown.l
+ .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
diff --git a/tests/ttk/radiobutton.test b/tests/ttk/radiobutton.test
new file mode 100644
index 0000000..6858659
--- /dev/null
+++ b/tests/ttk/radiobutton.test
@@ -0,0 +1,49 @@
+# $Id: radiobutton.test,v 1.1.2.2 2010/08/26 02:06:10 hobbs Exp $
+#
+# 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/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
index fe4dbcd..5f1287d 100644
--- a/tests/ttk/treetags.test
+++ b/tests/ttk/treetags.test
@@ -1,48 +1,147 @@
#
-# $Id: treetags.test,v 1.2 2007/05/18 16:53:18 dgp Exp $
+# $Id: treetags.test,v 1.2.4.1 2010/08/26 02:06:10 hobbs Exp $
#
-package require Tk 8.5
+package require Tk
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands
-tk useinputmethods 0
-testConstraint treeview [llength [info commands ttk::treeview]]
-testConstraint nyi 0
+### 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]]}
+ }
+ }
-test treetags-1.0 "Setup" -constraints treeview -body {
+ itemConstraints $tv {}
+}
+#
+###
+
+test treetags-1.0 "Setup" -body {
set tv [ttk::treeview .tv]
.tv insert {} end -id item1 -text "Item 1"
- pack .tv
+ pack .tv
+} -cleanup {
+ treeConstraints $tv
}
-test treetags-1.1 "Bad tag list" -constraints treeview -body {
+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" -constraints treeview -body {
+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 "Bad events" -constraints treeview -body {
- $tv tag bind bad <Enter> { puts "Entered!" }
-} -returnCodes 1 -result "unsupported event <Enter>*" -match glob
+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" -constraints treeview -body {
+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" -constraints treeview -body {
+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>
+ event generate $tv <KeyPress-a>
set ::KEY
+} -cleanup {
+ treeConstraints $tv
} -result a
-test treetags-2.2 "Events delivered to correct tags" -constraints treeview -body {
- $tv insert {} end -id item2 -tags tag2
+test treetags-2.2 "Events delivered to correct tags" -body {
$tv tag bind tag2 <KeyPress> [list set ::KEY2 %A]
$tv focus item1
@@ -51,9 +150,11 @@ test treetags-2.2 "Events delivered to correct tags" -constraints treeview -body
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" -constraints treeview -body {
+test treetags-2.3 "Virtual events delivered to focus item" -body {
set ::bong 0
$tv tag bind tag2 <<Bing>> { incr bong }
$tv focus item2
@@ -61,18 +162,63 @@ test treetags-2.3 "Virtual events delivered to focus item" -constraints treeview
$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" -constraints treeview -body {
+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" -constraints treeview -body {
+test treetags-3.1 "tag configure - get" -body {
$tv tag configure tag1 -foreground
-} -result [list blue]
+} -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" -constraints treeview -body { destroy .tv }
+test treetags-end "Cleanup" -body { destroy $tv }
tcltest::cleanupTests
diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test
index c97b27a..5bc7a80 100644
--- a/tests/ttk/treeview.test
+++ b/tests/ttk/treeview.test
@@ -1,5 +1,5 @@
#
-# $Id: treeview.test,v 1.3.2.2 2010/05/31 17:22:49 jenglish Exp $
+# $Id: treeview.test,v 1.3.2.3 2010/08/26 02:06:10 hobbs Exp $
#
# [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do
# what it currently does)
@@ -245,7 +245,7 @@ test treeview-3.15 "Consecutive duplicate entries in children list" -body {
} -result [list x1 x2 x3]
test treeview-3.16 "Insert child after self" -body {
- .tv move x2 newfirstone 1
+ .tv move x2 newfirstone 1
consistencyCheck .tv
.tv children newfirstone
} -result [list x1 x2 x3]
@@ -262,7 +262,6 @@ test treeview-3.18 "Insert last child after end" -body {
.tv children newfirstone
} -result [list x1 x2 x3]
-
test treeview-4.1 "opened - initial state" -body {
.tv item newnode -open
} -result 0
@@ -290,12 +289,12 @@ test treeview-5.3 "Heading" -body {
test treeview-5.4 "get cell" -body {
set l [list a b c]
.tv item newnode -values $l
- .tv set newnode 1
+ .tv set newnode 1
} -result b
test treeview-5.5 "set cell" -body {
.tv set newnode 1 XXX
- .tv item newnode -values
+ .tv item newnode -values
} -result [list a XXX c]
test treeview-5.6 "set illegal cell" -body {
@@ -408,11 +407,11 @@ test treeview-7.1 "move" -body {
test treeview-7.2 "illegal move" -body {
.tv move d d2 end
-} -returnCodes 1 -result "Cannot insert d as a descendant of d2"
+} -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
+ .tv children d
} -result [list d3 d1 d2]
test treeview-7.4 "Replace children" -body {
@@ -474,8 +473,128 @@ test treeview-9.0 "scroll callback - empty tree" -body {
set ::scrolldata
} -result [list 0.0 1.0]
-### NEED: tests for focus item, selection
+### 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:
diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test
index a1430ff..9732f46 100644
--- a/tests/ttk/ttk.test
+++ b/tests/ttk/ttk.test
@@ -28,24 +28,19 @@ test ttk-6.2 "Checkbutton self-destructed" -body {
winfo exists .sd
} -result 0
-test ttk-6.3 "Test package cleanup" -body {
- interp create foo
- foo eval { if {[catch {package require Tk}]} { load {} Tk } }
- foo eval { destroy . }
- interp delete foo
-}
+# test ttk-6.3 not applicable [see #2175411]
-test ttk-6.4 "Defeat evil intentions" -body {
+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]
- .b configure -variable OUCH
- # At this point, .b should be gone.
- .b invoke
- list [set OUCH] [winfo exists .b]
- # Mostly we just care that we haven't crashed the interpreter.
- #
-} -returnCodes error -match glob -result "*"
+ 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} {
@@ -66,7 +61,6 @@ test ttk-6.6 "Bad color spec in styles" -body {
set ::bgerror
} -result {unknown color name "badColor"}
-# This should move to be a standard test per widget test file
test ttk-6.7 "Basic destruction test" -body {
foreach widget {
button checkbutton radiobutton sizegrip separator notebook
@@ -85,9 +79,6 @@ test ttk-6.8 "Button command removes itself" -body {
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}
@@ -103,10 +94,41 @@ test ttk-6.9 "Bad font spec in styles" -setup {
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
@@ -116,8 +138,11 @@ 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 "Restore default style" -body {
+test ttk-1.4 "Original style preserved" -body {
.t cget -style
} -result ""
@@ -172,7 +197,6 @@ test ttk-2.7 "instate scripts, true" -body {
set x
} -result 1
-
# misc. error detection
test ttk-3.0 "Bad option" -body {
ttk::button .bad -badoption foo
@@ -191,6 +215,10 @@ test ttk-3.2 "Propagate errors from variable traces" -body {
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]
@@ -241,90 +269,6 @@ test ttk-4.4 "Bad resource specifications" -body {
}
#
-# checkbutton tests
-#
-test ttk-5.1 "Checkbutton check" -body {
- pack [ttk::checkbutton .cb -text "TCheckbutton" -variable cb]
-}
-test ttk-5.2 "Checkbutton invoke" -body {
- .cb invoke
- list [set ::cb] [.cb instate selected]
-} -result [list 1 1]
-test ttk-5.3 "Checkbutton reinvoke" -body {
- .cb invoke
- list [set ::cb] [.cb instate selected]
-} -result [list 0 0]
-
-test ttk-5.4 "Checkbutton variable" -body {
- set result []
- set ::cb 1
- lappend result [.cb instate selected]
- set ::cb 0
- lappend result [.cb instate selected]
-} -result {1 0}
-
-test ttk-5.5 "Unset checkbutton variable" -body {
- set result []
- unset ::cb
- lappend result [.cb instate alternate] [info exists ::cb]
- set ::cb 1
- lappend result [.cb instate alternate] [info exists ::cb]
-} -result {1 0 0 1}
-
-# See #1257319
-test ttk-5.6 "Checkbutton default variable" -body {
- destroy .cb ; unset -nocomplain {} ; set result [list]
- ttk::checkbutton .cb -onvalue on -offvalue off
- lappend result [.cb cget -variable] [info exists .cb] [.cb state]
- .cb invoke
- lappend result [info exists .cb] [set .cb] [.cb state]
- .cb invoke
- lappend result [info exists .cb] [set .cb] [.cb state]
-} -result [list .cb 0 alternate 1 on selected 1 off {}]
-
-#
-# radiobutton tests
-#
-test ttk-7.1 "Radiobutton check" -body {
- pack \
- [ttk::radiobutton .rb1 -text "One" -variable choice -value 1] \
- [ttk::radiobutton .rb2 -text "Two" -variable choice -value 2] \
- [ttk::radiobutton .rb3 -text "Three" -variable choice -value 3] \
- ;
-}
-test ttk-7.2 "Radiobutton invoke" -body {
- .rb1 invoke
- set ::choice
-} -result 1
-
-test ttk-7.3 "Radiobutton state" -body {
- .rb1 instate selected
-} -result 1
-
-test ttk-7.4 "Other radiobutton invoke" -body {
- .rb2 invoke
- set ::choice
-} -result 2
-
-test ttk-7.5 "Other radiobutton state" -body {
- .rb2 instate selected
-} -result 1
-
-test ttk-7.6 "First radiobutton state" -body {
- .rb1 instate selected
-} -result 0
-
-test ttk-7.7 "Unset radiobutton variable" -body {
- unset ::choice
- list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
-} -result {0 1 1}
-
-test ttk-7.8 "Reset radiobutton variable" -body {
- set ::choice 2
- list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
-} -result {1 0 0}
-
-#
# -compound tests:
#
variable iconData \
@@ -444,7 +388,7 @@ test ttk-9.6 "Unset -textvariable" -body {
test ttk-9.7 "Unset textvariable, comparison" -body {
#
-# NB: the ttk label behaves differently from the standard label here;
+# 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
@@ -554,7 +498,6 @@ test ttk-12.4 "-borderwidth frame option" -body {
update
}
-
test ttk-13.1 "Custom styles -- bad -style option" -body {
ttk::button .tb1 -style badstyle
} -returnCodes 1 -result "*badstyle not found*" -match glob
@@ -596,16 +539,44 @@ test ttk-14.3 "-textvariable in nonexistant namespace" -body {
-match glob -cleanup { destroy .tw }
-test ttk-15.1 "style element create: insufficient args" -body {
+## 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 # args: should be \"ttk::style element create name type ?options...?\""
-test ttk-15.2 "style element create: insufficient args" -body {
+} -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 # args: should be \"ttk::style element create name type ?options...?\""
-test ttk-15.3 "style element create: insufficient args" -body {
+} -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: should be \"theme ?element?\""
-test ttk-15.4 "style element create: valid" -body {
+} -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 ""
diff --git a/tests/ttk/vsapi.test b/tests/ttk/vsapi.test
index 7000e3e..21898bb 100644
--- a/tests/ttk/vsapi.test
+++ b/tests/ttk/vsapi.test
@@ -1,5 +1,5 @@
# -*- tcl -*-
-# $Id: vsapi.test,v 1.1.2.2 2009/05/14 00:53:04 patthoyts Exp $
+# $Id: vsapi.test,v 1.1.2.3 2010/08/26 02:06:10 hobbs Exp $
#
package require Tk 8.5
generated by cgit v0.12 at 2024-11-10 03:51:54 (GMT)