summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/all.tcl3
-rw-r--r--tests/bevel.tcl2
-rw-r--r--tests/bind.test21
-rw-r--r--tests/button.test34
-rw-r--r--tests/constraints.tcl2
-rw-r--r--tests/entry.test4
-rw-r--r--tests/listbox.test71
-rwxr-xr-xtests/option.file32
-rw-r--r--tests/panedwindow.test32
-rw-r--r--tests/safe.test2
-rw-r--r--tests/scale.test108
-rw-r--r--tests/scrollbar.test37
-rw-r--r--tests/text.test139
-rw-r--r--tests/textDisp.test27
-rw-r--r--tests/textTag.test154
-rw-r--r--tests/ttk/all.tcl3
-rw-r--r--tests/ttk/checkbutton.test16
-rw-r--r--tests/ttk/notebook.test21
-rw-r--r--tests/wm.test26
19 files changed, 653 insertions, 51 deletions
diff --git a/tests/all.tcl b/tests/all.tcl
index 7f57dc2..d15e5ca 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -9,9 +9,8 @@
# 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!
+package require tcltest 2.2
tcltest::configure {*}$argv
tcltest::configure -testdir [file normalize [file dirname [info script]]]
tcltest::configure -loadfile \
diff --git a/tests/bevel.tcl b/tests/bevel.tcl
index 531def0..4af60f3 100644
--- a/tests/bevel.tcl
+++ b/tests/bevel.tcl
@@ -147,14 +147,12 @@ set ind [.t.t index end]
xxxx} {} SSSSS sol100 {xxxx
x} {} SSSSSSSSSSSSSSSSSS sol100 {x
xxx} {} SSSSSSSSS sol100 xxxx {}
-}
.t.t insert end "\n\nA thinner border is continuous"
.t.t insert end {
xxxx} {} SSSSS sol12 {xxxx
x} {} SSSSSSSSSSSSSSSSSS sol12 {x
xxx} {} SSSSSSSSS sol12 xxxx {}
-}
.t.t tag add big $ind end
diff --git a/tests/bind.test b/tests/bind.test
index 474771d..892ba36 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -34,6 +34,14 @@ proc unsetBindings {} {
bind .t <Enter> {}
}
+# move the mouse pointer away of the testing area
+# otherwise some spurious events may pollute the tests
+toplevel .top
+wm geometry .top 50x50-50-50
+update
+event generate .top <Button-1> -warp 1
+update
+destroy .top
test bind-1.1 {bind command} -body {
bind
@@ -6093,6 +6101,19 @@ test bind-31.7 {virtual event user_data field - unshared, asynch} -setup {
destroy .t.f
} -result {{} {} {TestUserData >b<}}
+test bind-32 {-warp, window was destroyed before the idle callback DoWarp} -setup {
+ frame .t.f
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ event generate .t.f <Button-1> -warp 1
+ event generate .t.f <ButtonRelease-1>
+ destroy .t.f
+ update ; # shall simply not crash
+} -cleanup {
+} -result {}
+
# cleanup
cleanupTests
diff --git a/tests/button.test b/tests/button.test
index 984fd43..708fc30 100644
--- a/tests/button.test
+++ b/tests/button.test
@@ -3750,7 +3750,7 @@ test button-12.1 {button widget vs hidden commands} -body {
destroy .b
} -result {1}
-test button-13.1 {size behaviouor: label} -setup {
+test button-13.1 {size behavior: label} -setup {
label .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
label .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
label .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
@@ -3769,7 +3769,7 @@ test button-13.1 {size behaviouor: label} -setup {
} -cleanup {
destroy .a .b .c
} -result {1 1 1}
-test button-13.2 {size behaviouor: label} -setup {
+test button-13.2 {size behavior: label} -setup {
label .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
label .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
label .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
@@ -3789,7 +3789,7 @@ test button-13.2 {size behaviouor: label} -setup {
destroy .a .b .c
} -result {1 1 1}
-test button-13.3 {size behaviouor: button} -setup {
+test button-13.3 {size behavior: button} -setup {
button .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
button .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
@@ -3808,7 +3808,7 @@ test button-13.3 {size behaviouor: button} -setup {
} -cleanup {
destroy .a .b .c
} -result {1 1 1}
-test button-13.4 {size behaviouor: button} -setup {
+test button-13.4 {size behavior: button} -setup {
button .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
button .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
button .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
@@ -3828,7 +3828,7 @@ test button-13.4 {size behaviouor: button} -setup {
destroy .a .b .c
} -result {1 1 1}
-test button-13.5 {size behaviouor: radiobutton} -setup {
+test button-13.5 {size behavior: radiobutton} -setup {
radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
radiobutton .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
@@ -3848,7 +3848,7 @@ test button-13.5 {size behaviouor: radiobutton} -setup {
destroy .a .b .c
} -result {1 1 1}
-test button-13.6 {size behaviouor: radiobutton} -setup {
+test button-13.6 {size behavior: radiobutton} -setup {
radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
radiobutton .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
@@ -3868,7 +3868,7 @@ test button-13.6 {size behaviouor: radiobutton} -setup {
destroy .a .b .c
} -result {1 1 1}
-test button-13.7 {size behaviouor: checkbutton} -setup {
+test button-13.7 {size behavior: checkbutton} -setup {
checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
checkbutton .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
@@ -3888,7 +3888,7 @@ test button-13.7 {size behaviouor: checkbutton} -setup {
destroy .a .b .c
} -result {1 1 1}
-test button-13.8 {size behaviouor: checkbutton} -setup {
+test button-13.8 {size behavior: checkbutton} -setup {
checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
checkbutton .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
@@ -3908,6 +3908,24 @@ test button-13.8 {size behaviouor: checkbutton} -setup {
destroy .a .b .c
} -result {1 1 1}
+test button-14.1 {bug fix: [011706ec42] tk::ButtonInvoke unsafe wrt widget destruction} -body {
+ proc destroy_button {} {
+ if {[winfo exists .top.b]} {
+ destroy .top.b
+ }
+ }
+ toplevel .top
+ button .top.b -text Foo -command destroy_button
+ bind .top.b <space> destroy_button
+ pack .top.b
+ focus -force .top.b
+ update
+ event generate .top.b <space>
+ update ; # shall not trigger error invalid command name ".top.b"
+} -cleanup {
+ destroy .top.b .top
+} -result {}
+
imageFinish
cleanupTests
return
diff --git a/tests/constraints.tcl b/tests/constraints.tcl
index 6402753..e0486ff 100644
--- a/tests/constraints.tcl
+++ b/tests/constraints.tcl
@@ -5,8 +5,6 @@ if {[namespace exists tk::test]} {
return
}
-package require Tcl 8.4
-
package require Tk 8.4
tk appname tktest
wm title . tktest
diff --git a/tests/entry.test b/tests/entry.test
index 9c30b00..d27ffb5 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -1896,12 +1896,12 @@ test entry-6.12 {EntryComputeGeometry procedure} -constraints {
fonts
} -setup {
catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief raised -width 20
+ entry .e -font {Courier -12} -bd 2 -relief raised -width 20
pack .e
} -body {
.e insert end "012\t456\t"
update
- list [.e index @81] [.e index @82] [.e index @116] [.e index @117]
+ list [.e index @80] [.e index @81] [.e index @115] [.e index @116]
} -cleanup {
destroy .e
} -result {6 7 7 8}
diff --git a/tests/listbox.test b/tests/listbox.test
index f50267e..407420c 100644
--- a/tests/listbox.test
+++ b/tests/listbox.test
@@ -57,6 +57,7 @@ proc mkPartial {{w .partial}} {
# like border width have predictable values.
option add *Listbox.borderWidth 2
+option add *Listbox.selectBorderWidth 1
option add *Listbox.highlightThickness 2
option add *Listbox.font {Helvetica -12 bold}
@@ -203,6 +204,21 @@ test listbox-1.31 {configuration options} -body {
} -cleanup {
.l configure -highlightthickness [lindex [.l configure -highlightthickness] 3]
} -result {0 0}
+test listbox-1.32.1 {configuration options} -setup {
+ set res {}
+} -body {
+ .l configure -justify left
+ set res [list [lindex [.l configure -justify] 4] [.l cget -justify]]
+ .l configure -justify center
+ lappend res [lindex [.l configure -justify] 4] [.l cget -justify]
+ .l configure -justify right
+ lappend res [lindex [.l configure -justify] 4] [.l cget -justify]
+} -cleanup {
+ .l configure -justify [lindex [.l configure -justify] 3]
+} -result {left left center center right right}
+test listbox-1.32.2 {configuration options} -body {
+ .l configure -justify bogus
+} -returnCodes error -result {bad justification "bogus": must be left, right, or center}
test listbox-1.33 {configuration options} -body {
.l configure -relief groove
list [lindex [.l configure -relief] 4] [.l cget -relief]
@@ -441,6 +457,58 @@ test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line}
mkPartial
list [.partial.l bbox 3] [.partial.l bbox 4]
} -result {{5 56 24 14} {5 73 23 14}}
+test listbox-3.18a {ListboxWidgetCmd procedure, "bbox" option, justified} -constraints {
+ fonts
+} -setup {
+ destroy .top.l .top
+ unset -nocomplain res
+} -body {
+ toplevel .top
+ listbox .top.l -justify left
+ .top.l insert end Item1 LongerItem2 MuchLongerItem3
+ pack .top.l
+ update
+ lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ .top.l configure -justify center
+ lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ .top.l configure -justify right
+ lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+} -cleanup {
+ destroy .top.l .top
+ unset -nocomplain res
+} -result [list \
+ {5 5 34 14} {5 22 74 14} {5 39 106 14} \
+ {58 5 34 14} {38 22 74 14} {22 39 106 14} \
+ {111 5 34 14} {71 22 74 14} {39 39 106 14} \
+]
+test listbox-3.18b {ListboxWidgetCmd procedure, "bbox" option, justified, non-default borderwidth} -setup {
+ destroy .top.l .top
+ unset -nocomplain lres res
+} -body {
+ # This test checks whether all "x" values from bbox for different size
+ # items with different justification settings are all positive or zero
+ # This checks a bit the calculation of this x value with non-default
+ # borders widths of the listbox
+ toplevel .top
+ listbox .top.l -justify left -borderwidth 17 -highlightthickness 19 -selectborderwidth 22
+ .top.l insert end Item1 LongerItem2 MuchLongerItem3
+ .top.l selection set 1
+ pack .top.l
+ update
+ lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ .top.l configure -justify center
+ lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ .top.l configure -justify right
+ lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ set res 1
+ for {set i 0} {$i < [llength $lres]} {incr i 4} {
+ set res [expr {$res * [expr {[lindex $lres $i] >= 0}] }]
+ }
+ set res
+} -cleanup {
+ destroy .top.l .top
+ unset -nocomplain lres res
+} -result {1}
test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} -body {
.l cget
} -returnCodes error -result {wrong # args: should be ".l cget option"}
@@ -455,7 +523,7 @@ test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} -body {
} -result {0}
test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} -body {
llength [.l configure]
-} -result {27}
+} -result {28}
test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} -body {
.l configure -gorp
} -returnCodes error -result {unknown option "-gorp"}
@@ -3102,6 +3170,7 @@ test listbox-31.2 {<<ListboxSelect>> event on lost selection} -setup {
focus -force .l
event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires
selection clear ; # <<ListboxSelect>> fires again
+ update
set res
} -cleanup {
destroy .l
diff --git a/tests/option.file3 b/tests/option.file3
index 87f41ae..146cfd9 100755
--- a/tests/option.file3
+++ b/tests/option.file3
@@ -1,4 +1,4 @@
-! This file is a sample option (resource) database used to test
+! This file is a sample option (resource) database used to test
! Tk's option-handling capabilities.
! Comment line \
diff --git a/tests/panedwindow.test b/tests/panedwindow.test
index 666ed9c..ee184ce 100644
--- a/tests/panedwindow.test
+++ b/tests/panedwindow.test
@@ -4955,6 +4955,38 @@ test panedwindow-23.30 {ConfigurePanes, -hide works} -setup {
} -cleanup {
deleteWindows
} -result {1 1 1 0 39 40 40 1 130 1 0 1 1 40 40 40 42 130}
+test panedwindow-23.30a {ConfigurePanes, hidden panes are unmapped} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p1 -sashrelief raised
+ panedwindow .p2 -sashrelief raised
+ label .l1 -text Label1
+ label .l2 -text Label2
+ label .l3 -text Label3
+ .p2 add .l2 -sticky nsew
+ .p2 add .l3 -sticky nsew
+ .p1 add .p2 -sticky nsew
+ .p1 add .l1 -sticky nsew
+ pack .p1 -side top -expand 1 -fill both
+ update
+ set result [list]
+ lappend result [list [winfo ismapped .p1] [winfo ismapped .p2] \
+ [winfo ismapped .l1] [winfo ismapped .l2] [winfo ismapped .l3]]
+ .p2 paneconfigure .l1 -hide 1
+ update
+ lappend result [list [winfo ismapped .p1] [winfo ismapped .p2] \
+ [winfo ismapped .l1] [winfo ismapped .l2] [winfo ismapped .l3]]
+ .p1 paneconfigure .p2 -hide 1
+ update
+ lappend result [list [winfo ismapped .p1] [winfo ismapped .p2] \
+ [winfo ismapped .l1] [winfo ismapped .l2] [winfo ismapped .l3]]
+ .p1 paneconfigure .p2 -hide 0
+ update
+ lappend result [list [winfo ismapped .p1] [winfo ismapped .p2] \
+ [winfo ismapped .l1] [winfo ismapped .l2] [winfo ismapped .l3]]
+} -cleanup {
+ deleteWindows
+} -result {{1 1 1 1 1} {1 1 0 1 1} {1 0 0 0 0} {1 1 0 1 1}}
test panedwindow-23.31 {ConfigurePanes, -hide works, last pane stretches} -setup {
deleteWindows
} -body {
diff --git a/tests/safe.test b/tests/safe.test
index e7ed6c7..69a67ba 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -187,7 +187,7 @@ test safe-5.1 {loading Tk in safe interps without master's clearance} -body {
interp eval $i {load {} Tk}
} -cleanup {
safe::interpDelete $i
-} -returnCodes error -result {not allowed to start Tk by master's safe::TkInit}
+} -returnCodes error -result {not allowed}
test safe-5.2 {multi-level Tk loading with clearance} -setup {
set safeParent [safe::interpCreate]
} -body {
diff --git a/tests/scale.test b/tests/scale.test
index a8d08a8..8c14ed4 100644
--- a/tests/scale.test
+++ b/tests/scale.test
@@ -1396,6 +1396,114 @@ test scale-19 {Bug [3529885fff] - Click in through goes in wrong direction} \
} \
-result {1.0 1.0 1.0 1.0}
+test scale-20.1 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 1} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50 -command {set commandedVar}
+ pack .s
+ update ; # -command callback shall NOT fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {1 -1}
+test scale-20.2 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 2} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+ set scaleVar 7
+} -body {
+ scale .s -from 1 -to 50 -variable scaleVar -command {set commandedVar}
+ pack .s
+ update ; # -command callback shall NOT fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {7 -1}
+test scale-20.3 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 3} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50
+ .s set 10
+ .s configure -command {set commandedVar}
+ pack .s
+ update ; # -command callback shall NOT fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 -1}
+test scale-20.4 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 4} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50 -command {set commandedVar}
+ .s set 10
+ pack .s
+ update ; # -command callback shall fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 10}
+test scale-20.5 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 5} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50
+ pack .s
+ .s set 10
+ .s configure -command {set commandedVar}
+ update ; # -command callback shall NOT fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 -1}
+test scale-20.6 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 6} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50
+ pack .s
+ .s configure -command {set commandedVar}
+ .s set 10
+ update ; # -command callback shall fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 10}
+test scale-20.7 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 7} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50 -command {set commandedVar}
+ pack .s
+ .s set 10
+ update ; # -command callback shall fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 10}
+test scale-20.8 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 8} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+ set scaleVar 7
+} -body {
+ scale .s -from 1 -to 50 -variable scaleVar -command {set commandedVar}
+ pack .s
+ .s set 10
+ update ; # -command callback shall fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 10}
+
option clear
# cleanup
diff --git a/tests/scrollbar.test b/tests/scrollbar.test
index 3b16821..bd14067 100644
--- a/tests/scrollbar.test
+++ b/tests/scrollbar.test
@@ -662,6 +662,43 @@ test scrollbar-10.2 {<MouseWheel> event on scrollbar} -constraints {win|unix} -s
destroy .t .s
} -result {1.4}
+test scrollbar-11.1 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body {
+ proc destroy_scrollbar {} {
+ if {[winfo exists .top.s]} {
+ destroy .top.s
+ }
+ }
+ toplevel .top
+ scrollbar .top.s
+ bind .top.s <2> {destroy_scrollbar}
+ pack .top.s
+ focus -force .top.s
+ update
+ event generate .top.s <2>
+ update ; # shall not trigger error invalid command name ".top.s"
+} -cleanup {
+ destroy .top.s .top
+} -result {}
+test scrollbar-11.2 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body {
+ proc destroy_scrollbar {{y 0}} {
+ if {[winfo exists .top.s]} {
+ destroy .top.s
+ }
+ }
+ toplevel .top
+ wm minsize .top 50 400
+ update
+ scrollbar .top.s
+ bind .top.s <2> {after idle destroy_scrollbar}
+ pack .top.s -expand true -fill y
+ focus -force .top.s
+ update
+ event generate .top.s <2> -x 2 -y [expr {[winfo height .top.s] / 2}]
+ update ; # shall not trigger error invalid command name ".top.s"
+} -cleanup {
+ destroy .top.s .top
+} -result {}
+
catch {destroy .s}
catch {destroy .t}
diff --git a/tests/text.test b/tests/text.test
index 52a21af..720afbe 100644
--- a/tests/text.test
+++ b/tests/text.test
@@ -3053,6 +3053,25 @@ test text-11a.41 {"sync" "pendingsync" and <<WidgetViewSync>>} -setup {
destroy .top.yt .top
} -result {Sync:0 Pending:1 Sync:1 Pending:0}
+test text-11a.51 {<<WidgetViewSync>> calls TkSendVirtualEvent(),
+ NOT Tk_HandleEvent().
+ Bug [b362182e45704dd7bbd6aed91e48122035ea3d16]} -setup {
+ destroy .top.t .top
+} -body {
+ set res {}
+ toplevel .top
+ pack [text .top.t]
+ for {set i 1} {$i < 10000} {incr i} {
+ .top.t insert end "Hello world!\n"
+ }
+ bind .top.t <<WidgetViewSync>> {destroy .top.t}
+ .top.t tag add mytag 1.5 8000.8 ; # shall not crash
+ update
+ set res "Still doing fine!"
+} -cleanup {
+ destroy .top.t .top
+} -result {Still doing fine!}
+
test text-12.1 {TextWidgetCmd procedure, "index" option} -setup {
text .t
} -body {
@@ -3673,10 +3692,9 @@ Line 4"
list [.t tag ranges sel] [.t get 1.0 end]
} -cleanup {
destroy .t
-} -result {{1.0 4.0} {Line 1
+} -result {{1.0 3.5} {Line 1
abcde
12345
-
}}
test text-19.9 {DeleteChars procedure} -body {
text .t
@@ -6189,7 +6207,7 @@ test text-27.2 {TextEditCmd procedure, argument parsing} -body {
.t edit gorp
} -cleanup {
destroy .t
-} -returnCodes {error} -result {bad edit option "gorp": must be modified, redo, reset, separator, or undo}
+} -returnCodes {error} -result {bad edit option "gorp": must be canundo, canredo, modified, redo, reset, separator, or undo}
test text-27.3 {TextEditUndo procedure, undoing changes} -body {
text .t -undo 1
pack .t
@@ -6281,7 +6299,7 @@ test text-27.11 {TextEditCmd procedure, set modified flag repeat} -setup {
# Shouldn't require [update idle] to trigger event [Bug 1809538]
lappend ::retval [.t edit modified]
.t edit modified 1
- update idletasks
+ update
lappend ::retval [.t edit modified]
.t edit modified 1 ; # binding should only fire once [Bug 1799782]
update idletasks
@@ -6296,6 +6314,7 @@ test text-27.12 {<<Modified>> virtual event} -body {
bind .t <<Modified>> "set ::retval modified"
update idletasks
.t insert end "nothing special\n"
+ update
return $::retval
} -cleanup {
destroy .t
@@ -6306,6 +6325,7 @@ test text-27.13 {<<Modified>> virtual event - insert before Modified} -body {
bind .t <<Modified>> { set ::retval [.t get 1.0 end-1c] }
update idletasks
.t insert end "nothing special"
+ update
return $::retval
} -cleanup {
destroy .t
@@ -6318,10 +6338,26 @@ test text-27.14 {<<Modified>> virtual event - delete before Modified} -body {
.t insert end "nothing special"
.t edit modified 0
.t delete 1.0 1.2
+ update
set ::retval
} -cleanup {
destroy .t
} -result {thing special}
+test text-27.14a {<<Modified>> virtual event - propagation to peers} -body {
+# Bug [fd3a4dc111], <<Modified>> event is not always sent to peers
+ set ::retval 0
+ text .t -undo 1
+ .t peer create .tt
+ pack .t .tt
+ bind .t <<Modified>> {incr ::retval}
+ bind .tt <<Modified>> {incr ::retval}
+ .t insert end "This increments ::retval once for each peer, i.e. twice."
+ .t edit modified 0 ; # shall increment twice as well, not just once
+ update
+ set ::retval
+} -cleanup {
+ destroy .t .tt
+} -result {4}
test text-27.15 {<<Selection>> virtual event} -body {
set ::retval no_selection
pack [text .t -undo 1]
@@ -6329,6 +6365,7 @@ test text-27.15 {<<Selection>> virtual event} -body {
update idletasks
.t insert end "nothing special\n"
.t tag add sel 1.0 1.1
+ update
set ::retval
} -cleanup {
destroy .t
@@ -6346,6 +6383,21 @@ test text-27.16 {-maxundo configuration option} -body {
} -cleanup {
destroy .t
} -result "line 1\n\n"
+test text-27.16a {undo configuration options with peers} -body {
+ text .t -undo 1 -autoseparators 0 -maxundo 100
+ .t peer create .tt
+ set res [.t cget -undo]
+ lappend res [.tt cget -undo]
+ lappend res [.t cget -autoseparators]
+ lappend res [.tt cget -autoseparators]
+ lappend res [.t cget -maxundo]
+ lappend res [.tt cget -maxundo]
+ .t insert end "The undo stack is common between peers"
+ lappend res [.t edit canundo]
+ lappend res [.tt edit canundo]
+} -cleanup {
+ destroy .t
+} -result {1 1 0 0 100 100 1 1}
test text-27.17 {bug fix 1536735 - undo with empty text} -body {
text .t -undo 1
set r [.t edit modified]
@@ -6368,7 +6420,7 @@ test text-27.18 {patch 1469210 - inserting after undo} -setup {
} -cleanup {
destroy .t
} -result 1
-test text-25.19 {patch 1669632 (i) - undo after <Control-1>} -setup {
+test text-27.19 {patch 1669632 (i) - undo after <Control-1>} -setup {
destroy .t
} -body {
text .t -undo 1
@@ -6382,7 +6434,7 @@ test text-25.19 {patch 1669632 (i) - undo after <Control-1>} -setup {
} -cleanup {
destroy .t
} -result WORLD
-test text-25.20 {patch 1669632 (iv) - undo after <<SelectNone>>} -setup {
+test text-27.20 {patch 1669632 (iv) - undo after <<SelectNone>>} -setup {
destroy .top .top.t
} -body {
toplevel .top
@@ -6401,7 +6453,7 @@ test text-25.20 {patch 1669632 (iv) - undo after <<SelectNone>>} -setup {
} -cleanup {
destroy .top.t .top
} -result HELLO
-test text-25.21 {patch 1669632 (vii) - <<Undo>> shall not remove separators} -setup {
+test text-27.21 {patch 1669632 (vii) - <<Undo>> shall not remove separators} -setup {
destroy .t
} -body {
text .t -undo 1
@@ -6417,7 +6469,7 @@ test text-25.21 {patch 1669632 (vii) - <<Undo>> shall not remove separators} -se
} -cleanup {
destroy .t
} -result "This WORLD is an example text"
-test text-25.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup {
+test text-27.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup {
destroy .t
} -body {
toplevel .top
@@ -6437,7 +6489,7 @@ test text-25.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup {
} -cleanup {
destroy .top.t .top
} -result "This A an example text"
- test text-25.23 {patch 1669632 (v) - <<Cut>> is atomic} -setup {
+ test text-27.23 {patch 1669632 (v) - <<Cut>> is atomic} -setup {
destroy .t
} -body {
toplevel .top
@@ -6457,6 +6509,75 @@ test text-25.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup {
} -cleanup {
destroy .top.t .top
} -result "This A an example text"
+test text-27.24 {TextEditCmd procedure, canundo and canredo} -setup {
+ destroy .t
+ set res {}
+} -body {
+ text .t -undo false -autoseparators false
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t configure -undo true
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t insert end "DO\n"
+ .t edit separator
+ .t insert end "IT\n"
+ .t insert end "YOURSELF\n"
+ .t edit separator
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t edit undo
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t configure -undo false
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t configure -undo true
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t edit redo
+ lappend res [.t edit canundo] [.t edit canredo]
+} -cleanup {
+ destroy .t
+} -result {0 0 0 0 1 0 1 1 0 0 1 1 1 0}
+test text-27.25 {<<UndoStack>> virtual event} -setup {
+ destroy .t
+ set res {}
+ set nbUS 0
+} -body {
+ text .t -undo false -autoseparators false
+ bind .t <<UndoStack>> {incr nbUS}
+ update ; lappend res $nbUS
+ .t configure -undo true
+ update ; lappend res $nbUS
+ .t insert end "DO\n"
+ .t edit separator
+ .t insert end "IT\n"
+ .t insert end "YOURSELF\n"
+ .t edit separator
+ .t insert end "MAN\n"
+ .t edit separator
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit redo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit redo
+ update ; lappend res $nbUS
+ .t edit redo
+ update ; lappend res $nbUS
+ .t edit redo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit reset
+ update ; lappend res $nbUS
+} -cleanup {
+ destroy .t
+} -result {0 0 1 2 3 4 4 5 6 6 7 8 8 9}
+
test text-28.1 {bug fix - 624372, ControlUtfProc long lines} -body {
pack [text .t -wrap none]
diff --git a/tests/textDisp.test b/tests/textDisp.test
index caba769..99401c2 100644
--- a/tests/textDisp.test
+++ b/tests/textDisp.test
@@ -657,7 +657,7 @@ test textDisp-4.9 {UpdateDisplayInfo, filling in extra vertical space} {textfont
update
.t delete 15.0 end
list [.t bbox 7.0] [.t bbox 12.0]
-} [list [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + $fixedHeight}] $fixedWidth $fixedHeight] [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 6 * $fixedHeight}] $fixedWidth $fixedHeight]]
+} [list [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 2 * $fixedHeight}] $fixedWidth $fixedHeight] [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 7 * $fixedHeight}] $fixedWidth $fixedHeight]]
test textDisp-4.10 {UpdateDisplayInfo, filling in extra vertical space} {
.t delete 1.0 end
.t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17"
@@ -666,7 +666,7 @@ test textDisp-4.10 {UpdateDisplayInfo, filling in extra vertical space} {
.t delete 13.0 end
update
list [.t index @0,0] $tk_textRelayout $tk_textRedraw
-} {6.0 {13.0 7.0 6.40 6.20 6.0} {6.0 6.20 6.40 7.0 13.0}}
+} {5.0 {12.0 7.0 6.40 6.20 6.0 5.0} {5.0 6.0 6.20 6.40 7.0 12.0}}
test textDisp-4.11 {UpdateDisplayInfo, filling in extra vertical space} {
.t delete 1.0 end
.t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around, not once but really quite a few times.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17"
@@ -675,7 +675,7 @@ test textDisp-4.11 {UpdateDisplayInfo, filling in extra vertical space} {
.t delete 14.0 end
update
list [.t index @0,0] $tk_textRelayout $tk_textRedraw
-} {6.60 {14.0 7.0 6.80 6.60} {6.60 6.80 7.0 14.0}}
+} {6.40 {13.0 7.0 6.80 6.60 6.40} {6.40 6.60 6.80 7.0 13.0}}
test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} {
.t delete 1.0 end
.t insert end "1\n2\n3\n4\n5\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16"
@@ -1181,16 +1181,15 @@ test textDisp-8.12 {TkTextChanged, moving the insert cursor redraws only past an
.t mark set insert 3.8 ; # within the same line
update
lappend res $tk_textRedraw
- # This last one is tricky: correct result really is {2.0 3.0} when
- # calling .t mark set insert, two calls to TkTextChanged are done:
- # (a) to redraw the line of the past position of the cursor
- # (b) to redraw the line of the new position of the cursor
- # During (a) the display line showing the cursor gets unlinked,
- # which leads TkTextChanged in (b) to schedule a redraw starting
- # one line _before_ the line containing the insert cursor. This is
- # because during (b) findDLine cannot return the display line the
- # cursor is in since this display line was just unlinked in (a).
-} {{8.0 9.0} {8.0 12.0} {8.0 12.0} {3.0 8.0} {2.0 3.0}}
+} {{8.0 9.0} {8.0 12.0} {8.0 12.0} {3.0 8.0} {3.0 4.0}}
+test textDisp-8.13 {TkTextChanged, used to crash, see [06c1433906]} {
+ .t delete 1.0 end
+ .t insert 1.0 \nLine2\nLine3\n
+ update
+ .t insert 3.0 ""
+ .t delete 1.0 2.0
+ update idletasks
+} {}
test textDisp-9.1 {TkTextRedrawTag} {
.t configure -wrap char
@@ -3698,7 +3697,7 @@ test textDisp-28.1 {"yview" option with bizarre scroll command} {
set result [.t2.t index @0,0]
update
lappend result [.t2.t index @0,0]
-} {6.0 2.0}
+} {6.0 1.0}
test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {textfonts} {
catch {destroy .t2}
diff --git a/tests/textTag.test b/tests/textTag.test
index fed073a..88081d0 100644
--- a/tests/textTag.test
+++ b/tests/textTag.test
@@ -168,6 +168,17 @@ test textTag-1.17 {configuration options} -constraints {
} -cleanup {
.t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3]
} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.17a {tag configuration options} -body {
+ .t tag configure x -lmargincolor lightgreen
+ .t tag cget x -lmargincolor
+} -cleanup {
+ .t tag configure x -lmargincolor [lindex [.t tag configure x -lmargincolor] 3]
+} -result {lightgreen}
+test textTag-1.17b {configuration options} -body {
+ .t tag configure x -lmargincolor non-existent
+} -cleanup {
+ .t tag configure x -lmargincolor [lindex [.t tag configure x -lmargincolor] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
test textTag-1.18 {tag configuration options} -constraints {
haveCourier12
} -body {
@@ -198,6 +209,17 @@ test textTag-1.21 {configuration options} -constraints {
} -cleanup {
.t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3]
} -returnCodes error -result {expected boolean value but got "stupid"}
+test textTag-1.21a {tag configuration options} -body {
+ .t tag configure x -overstrikefg red
+ .t tag cget x -overstrikefg
+} -cleanup {
+ .t tag configure x -overstrikefg [lindex [.t tag configure x -overstrikefg] 3]
+} -result {red}
+test textTag-1.21b {configuration options} -body {
+ .t tag configure x -overstrikefg stupid
+} -cleanup {
+ .t tag configure x -overstrikefg [lindex [.t tag configure x -overstrikefg] 3]
+} -returnCodes error -result {unknown color name "stupid"}
test textTag-1.22 {tag configuration options} -constraints {
haveCourier12
} -body {
@@ -228,6 +250,39 @@ test textTag-1.25 {configuration options} -constraints {
} -cleanup {
.t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3]
} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.25a {tag configuration options} -body {
+ .t tag configure x -rmargincolor darkblue
+ .t tag cget x -rmargincolor
+} -cleanup {
+ .t tag configure x -rmargincolor [lindex [.t tag configure x -rmargincolor] 3]
+} -result {darkblue}
+test textTag-1.25b {configuration options} -body {
+ .t tag configure x -rmargincolor non-existent
+} -cleanup {
+ .t tag configure x -rmargincolor [lindex [.t tag configure x -rmargincolor] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
+test textTag-1.25c {tag configuration options} -body {
+ .t tag configure x -selectbackground #012345
+ .t tag cget x -selectbackground
+} -cleanup {
+ .t tag configure x -selectbackground [lindex [.t tag configure x -selectbackground] 3]
+} -result {#012345}
+test textTag-1.25d {configuration options} -body {
+ .t tag configure x -selectbackground non-existent
+} -cleanup {
+ .t tag configure x -selectbackground [lindex [.t tag configure x -selectbackground] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
+test textTag-1.25e {tag configuration options} -body {
+ .t tag configure x -selectforeground #012345
+ .t tag cget x -selectforeground
+} -cleanup {
+ .t tag configure x -selectforeground [lindex [.t tag configure x -selectforeground] 3]
+} -result {#012345}
+test textTag-1.25f {configuration options} -body {
+ .t tag configure x -selectforeground non-existent
+} -cleanup {
+ .t tag configure x -selectforeground [lindex [.t tag configure x -selectforeground] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
test textTag-1.26 {tag configuration options} -constraints {
haveCourier12
} -body {
@@ -303,6 +358,17 @@ test textTag-1.35 {configuration options} -constraints {
} -cleanup {
.t tag configure x -underline [lindex [.t tag configure x -underline] 3]
} -returnCodes error -result {expected boolean value but got "stupid"}
+test textTag-1.36 {tag configuration options} -body {
+ .t tag configure x -underlinefg red
+ .t tag cget x -underlinefg
+} -cleanup {
+ .t tag configure x -underlinefg [lindex [.t tag configure x -underlinefg] 3]
+} -result {red}
+test textTag-1.37 {configuration options} -body {
+ .t tag configure x -underlinefg stupid
+} -cleanup {
+ .t tag configure x -underlinefg [lindex [.t tag configure x -underlinefg] 3]
+} -returnCodes error -result {unknown color name "stupid"}
test textTag-2.1 {TkTextTagCmd - "add" option} -constraints {
@@ -559,6 +625,13 @@ test textTag-5.4 {TkTextTagCmd - "configure" option} -constraints {
} -cleanup {
.t tag delete x
} -result {-underline {} {} {} yes}
+test textTag-5.4a {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -underlinefg lightgreen
+ .t tag configure x -underlinefg
+} -cleanup {
+ .t tag delete x
+} -result {-underlinefg {} {} {} lightgreen}
test textTag-5.5 {TkTextTagCmd - "configure" option} -constraints {
haveCourier12
} -body {
@@ -568,6 +641,13 @@ test textTag-5.5 {TkTextTagCmd - "configure" option} -constraints {
} -cleanup {
.t tag delete x
} -result {on}
+test textTag-5.5a {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -overstrikefg lightgreen
+ .t tag configure x -overstrikefg
+} -cleanup {
+ .t tag delete x
+} -result {-overstrikefg {} {} {} lightgreen}
test textTag-5.6 {TkTextTagCmd - "configure" option} -constraints {
haveCourier12
} -body {
@@ -625,16 +705,19 @@ test textTag-5.12 {TkTextTagCmd - "configure" option} -constraints {
} -cleanup {
.t tag delete x
} -returnCodes error -result {bad screen distance "1.0q"}
-test textTag-5.13 {TkTextTagCmd - "configure" option} -constraints {
- haveCourier12
-} -body {
+test textTag-5.13 {TkTextTagCmd - "configure" option} -body {
.t tag delete x
- .t tag configure x -lmargin1 2 -lmargin2 4 -rmargin 5
+ .t tag configure x -lmargin1 2 -lmargin2 4 -rmargin 5 \
+ -lmargincolor darkblue -rmargincolor lightgreen
list [.t tag configure x -lmargin1] [.t tag configure x -lmargin2] \
- [.t tag configure x -rmargin]
+ [.t tag configure x -rmargin] [.t tag configure x -lmargincolor] \
+ [.t tag configure x -rmargincolor]
} -cleanup {
.t tag delete x
-} -result {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}}
+} -result [list {-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} \
+ {-rmargin {} {} {} 5} \
+ {-lmargincolor {} {} {} darkblue} {-rmargincolor {} {} {} lightgreen} \
+ ]
test textTag-5.14 {TkTextTagCmd - "configure" option} -constraints {
haveCourier12
} -body {
@@ -651,6 +734,12 @@ test textTag-5.15 {TkTextTagCmd - "configure" option} -constraints {
} -cleanup {
.t tag delete x
} -returnCodes error -result {bad screen distance "gorp"}
+test textTag-5.15a {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -lmargincolor rainbow
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {unknown color name "rainbow"}
test textTag-5.16 {TkTextTagCmd - "configure" option} -constraints {
haveCourier12
} -body {
@@ -659,6 +748,12 @@ test textTag-5.16 {TkTextTagCmd - "configure" option} -constraints {
} -cleanup {
.t tag delete x
} -returnCodes error -result {bad screen distance "140.1.1"}
+test textTag-5.16a {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -rmargincolor rainbow
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {unknown color name "rainbow"}
.t tag delete x
test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints {
haveCourier12
@@ -713,7 +808,52 @@ test textTag-5.22 {TkTextTagCmd - "configure" option} -constraints {
.t tag configure sel -borderwidth {}
.t cget -selectborderwidth
} -result {}
-
+test textTag-5.23 {TkTextTagCmd - "configure" option} -body {
+ set x {}
+ # when [.t tag cget sel -selectbackground] == "", mirroring happens between
+ # the text widget option -selectbackground
+ # and the tag option -background
+ .t tag configure sel -selectbackground {}
+ .t configure -selectbackground black
+ .t tag configure sel -background yellow
+ lappend x [.t cget -selectbackground]
+ .t tag configure sel -background orange
+ .t configure -selectbackground blue
+ lappend x [.t tag cget sel -background]
+ # when [.t tag cget sel -selectbackground] != "", mirroring happens between
+ # the text widget option -selectbackground
+ # and the tag option -selectbackground
+ .t tag configure sel -selectbackground green
+ .t configure -selectbackground red
+ lappend x [.t tag cget sel -selectbackground]
+ .t configure -selectbackground black
+ .t tag configure sel -selectbackground white
+ lappend x [.t cget -selectbackground]
+ return $x
+} -result {yellow blue red white}
+test textTag-5.24 {TkTextTagCmd - "configure" option} -body {
+ set x {}
+ # when [.t tag cget sel -selectforeground] == "", mirroring happens between
+ # the text widget option -selectforeground
+ # and the tag option -foreground
+ .t tag configure sel -selectforeground {}
+ .t configure -selectforeground black
+ .t tag configure sel -foreground yellow
+ lappend x [.t cget -selectforeground]
+ .t tag configure sel -foreground orange
+ .t configure -selectforeground blue
+ lappend x [.t tag cget sel -foreground]
+ # when [.t tag cget sel -selectforeground] != "", mirroring happens between
+ # the text widget option -selectforeground
+ # and the tag option -selectforeground
+ .t tag configure sel -selectforeground green
+ .t configure -selectforeground red
+ lappend x [.t tag cget sel -selectforeground]
+ .t configure -selectforeground black
+ .t tag configure sel -selectforeground white
+ lappend x [.t cget -selectforeground]
+ return $x
+} -result {yellow blue red white}
test textTag-6.1 {TkTextTagCmd - "delete" option} -constraints {
haveCourier12
diff --git a/tests/ttk/all.tcl b/tests/ttk/all.tcl
index da2e316..f03cd56 100644
--- a/tests/ttk/all.tcl
+++ b/tests/ttk/all.tcl
@@ -9,9 +9,8 @@
# 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!
+package require tcltest 2.2
tcltest::configure {*}$argv
tcltest::configure -testdir [file normalize [file dirname [info script]]]
tcltest::configure -loadfile \
diff --git a/tests/ttk/checkbutton.test b/tests/ttk/checkbutton.test
index e18ff32..6b79287 100644
--- a/tests/ttk/checkbutton.test
+++ b/tests/ttk/checkbutton.test
@@ -45,4 +45,20 @@ test checkbutton-1.6 "Checkbutton default variable" -body {
lappend result [info exists .cb] [set .cb] [.cb state]
} -result [list .cb 0 alternate 1 on selected 1 off {}]
+# Bug [109865fa01]
+test checkbutton-1.7 "Button destroyed by click" -body {
+ proc destroy_button {} {
+ destroy .top
+ }
+ toplevel .top
+ ttk::menubutton .top.mb -text Button -style TLabel
+ bind .top.mb <ButtonRelease-1> destroy_button
+ pack .top.mb
+ focus -force .top.mb
+ update
+ event generate .top.mb <1>
+ event generate .top.mb <ButtonRelease-1>
+ update ; # shall not trigger error invalid command name ".top.b"
+} -result {}
+
tcltest::cleanupTests
diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test
index cdce020..3a2a6ff 100644
--- a/tests/ttk/notebook.test
+++ b/tests/ttk/notebook.test
@@ -468,6 +468,27 @@ test notebook-1817596-3 "insert/configure" -body {
} -result [list [list .nb.l2 .nb.l0 .nb.l1] L2 L0 L1] -cleanup { destroy .nb }
+test notebook-readd-1 "add same widget twice" -body {
+ pack [ttk::notebook .nb]
+ .nb add [ttk::button .nb.b1] -text "Button"
+ .nb add .nb.b1
+ .nb tabs
+} -result [list .nb.b1] -cleanup { destroy .nb }
+
+test notebook-readd-2 "add same widget twice, with options" -body {
+ pack [ttk::notebook .nb]
+ .nb add [ttk::button .nb.b1] -text "Tab label"
+ .nb add .nb.b1 -text "Changed tab label"
+ .nb tabs
+} -result [list .nb.b1] -cleanup { destroy .nb }
+
+test notebook-readd-3 "insert same widget twice, with options" -body {
+ pack [ttk::notebook .nb]
+ .nb insert end [ttk::button .nb.b1] -text "Tab label"
+ .nb insert end .nb.b1 -text "Changed tab label"
+ .nb tabs
+} -result [list .nb.b1] -cleanup { destroy .nb }
+
# See #1343984
test notebook-1343984-1 "don't autoselect on destroy - setup" -body {
diff --git a/tests/wm.test b/tests/wm.test
index 1aa0779..afcc2cd 100644
--- a/tests/wm.test
+++ b/tests/wm.test
@@ -2276,6 +2276,32 @@ test wm-forget-1.4 "pack into unmapped toplevel causes crash" -body {
deleteWindows
} -result {}
+test wm-forget-2 {bug [e9112ef96e] - [wm forget] doesn't completely} -setup {
+ catch {destroy .l .f.b .f}
+ set res {}
+} -body {
+ label .l -text "Top Dot"
+ frame .f
+ button .f.b -text Hello -command "puts Hello!"
+ pack .l -side top
+ pack .f.b
+ pack .f -side bottom
+ update
+ set res [winfo manager .f]
+ pack forget .f
+ update
+ lappend res [winfo manager .f]
+ wm manage .f
+ update
+ lappend res [winfo manager .f]
+ wm forget .f
+ update
+ lappend res [winfo manager .f]
+} -cleanup {
+ destroy .l .f.b .f
+ unset res
+} -result {pack {} wm {}}
+
# FIXME:
# Test delivery of virtual events to the WM. We could check to see if the
generated by cgit v0.12 at 2025-12-29 07:55:26 (GMT)