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