summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/bevel.tcl41
-rw-r--r--tests/entry.test51
-rw-r--r--tests/event.test6
-rw-r--r--tests/font.test4
-rw-r--r--tests/listbox.test109
-rw-r--r--tests/menu.test12
-rwxr-xr-xtests/option.file318
-rw-r--r--tests/option.test12
-rw-r--r--tests/scrollbar.test30
-rw-r--r--tests/spinbox.test26
-rw-r--r--tests/text.test184
-rw-r--r--tests/textDisp.test115
-rw-r--r--tests/ttk/notebook.test21
-rw-r--r--tests/ttk/spinbox.test2
-rw-r--r--tests/winButton.test10
-rw-r--r--tests/winDialog.test6
16 files changed, 576 insertions, 71 deletions
diff --git a/tests/bevel.tcl b/tests/bevel.tcl
index 950b714..4af60f3 100644
--- a/tests/bevel.tcl
+++ b/tests/bevel.tcl
@@ -42,6 +42,7 @@ significance:
r - should appear raised
u - should appear raised and also slightly offset vertically
s - should appear sunken
+S - should appear solid
n - preceding relief should extend right to end of line.
* - should appear "normal"
x - extra long lines to allow horizontal scrolling.
@@ -125,15 +126,33 @@ foreach i {1 2 3} {
.t.t insert end *****
.t.t insert end rrr r1
-
-
-
-
-
-
-
-
-
-
-
+font configure TkFixedFont -size 20
+.t.t tag configure sol100 -relief solid -borderwidth 100 \
+ -foreground red -font TkFixedFont
+.t.t tag configure sol12 -relief solid -borderwidth 12 \
+ -foreground red -font TkFixedFont
+.t.t tag configure big -font TkFixedFont
+set ind [.t.t index end]
+
+.t.t insert end "\n\nBorders do not leak on the neighbour chars"
+.t.t insert end "\nOnly \"S\" is on dark background"
+.t.t insert end {
+ xxx
+ x} {} S sol100 {x
+ xxx}
+
+.t.t insert end "\n\nA very thick border grows toward the inside of the tagged area only"
+.t.t insert end "\nOnly \"S\" is on dark background"
+.t.t insert 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/entry.test b/tests/entry.test
index 11408ac..d27ffb5 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -1892,6 +1892,19 @@ test entry-6.11 {EntryComputeGeometry procedure} -constraints {
} -cleanup {
destroy .e
} -result {1 1 1}
+test entry-6.12 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ catch {destroy .e}
+ entry .e -font {Courier -12} -bd 2 -relief raised -width 20
+ pack .e
+} -body {
+ .e insert end "012\t456\t"
+ update
+ list [.e index @80] [.e index @81] [.e index @115] [.e index @116]
+} -cleanup {
+ destroy .e
+} -result {6 7 7 8}
test entry-7.1 {InsertChars procedure} -setup {
@@ -3447,8 +3460,6 @@ test entry-22.1 {lost namespaced textvar} -body {
namespace eval test { variable foo {a b} }
entry .e -textvariable ::test::foo
namespace delete test
- .e insert end "more stuff"
- .e delete 5 end
set ::test::foo
} -cleanup {
destroy .e
@@ -3457,13 +3468,39 @@ test entry-22.2 {lost namespaced textvar} -body {
namespace eval test { variable foo {a b} }
entry .e -textvariable ::test::foo
namespace delete test
- .e insert end "more stuff"
- .e delete 5 end
- catch {set ::test::foo}
- list [.e get] [.e cget -textvar]
+ catch {.e insert end "more stuff"} result1
+ catch {.e delete 5 end } result2
+ catch {set ::test::foo} result3
+ list [.e get] [.e cget -textvar] $result1 $result2 $result3
+} -cleanup {
+ destroy .e
+} -result [list "a bmo" ::test::foo \
+ {can't set "::test::foo": parent namespace doesn't exist} \
+ {can't set "::test::foo": parent namespace doesn't exist} \
+ {can't read "::test::foo": no such variable}]
+
+test entry-23.1 {error in trace proc attached to the textvariable} -setup {
+ destroy .e
+} -body {
+ trace variable myvar w traceit
+ proc traceit args {error "Intentional error here!"}
+ entry .e -textvariable myvar
+ catch {.e insert end mystring} result1
+ catch {.e delete 0} result2
+ list $result1 $result2
} -cleanup {
destroy .e
-} -result [list "a bmo" ::test::foo]
+} -result [list {can't set "myvar": Intentional error here!} \
+ {can't set "myvar": Intentional error here!}]
+
+test entry-24.1 {textvariable lives in a non-existing namespace} -setup {
+ destroy .e
+} -body {
+ catch {entry .e -textvariable thisnsdoesntexist::myvar} result1
+ set result1
+} -cleanup {
+ destroy .e
+} -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist}
# Gathered comments about lacks
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
diff --git a/tests/event.test b/tests/event.test
index 1548467..756dbe5 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -756,9 +756,7 @@ test event-7.1(double-click) {A double click on a lone character
deleteWindows
} -result {1.3 A 1.3 A}
test event-7.2(double-click) {A double click on a lone character
- in an entry widget should select that character} -constraints {
- knownBug
-} -setup {
+ in an entry widget should select that character} -setup {
deleteWindows
} -body {
set t [toplevel .t]
@@ -822,7 +820,7 @@ test event-7.2(double-click) {A double click on a lone character
return $result
} -cleanup {
deleteWindows
-} -result {3 A 4 A}
+} -result {4 A 4 A}
# cleanup
unset -nocomplain keypress_lookup
diff --git a/tests/font.test b/tests/font.test
index abe6ebf..9e44a93 100644
--- a/tests/font.test
+++ b/tests/font.test
@@ -1526,11 +1526,11 @@ test font-24.10 {Tk_ComputeTextLayout: tab caused break} -body {
set x {}
.t.l config -text "000\t"
update
- lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}]
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}]
lappend x [expr {[winfo reqheight .t.l] eq $ay}]
.t.l config -text "000\t00" -wrap [expr $ax * 6]
update
- lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}]
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}]
lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
return $x
} -cleanup {
diff --git a/tests/listbox.test b/tests/listbox.test
index e05d574..76a4349 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"}
@@ -3068,6 +3136,45 @@ test listbox-30.1 {Bug 3607326} -setup {
unset -nocomplain a
} -result * -match glob -returnCodes error
+test listbox-31.1 {<<ListboxSelect>> event} -setup {
+ destroy .l
+ unset -nocomplain res
+} -body {
+ pack [listbox .l -state normal]
+ update
+ bind .l <<ListboxSelect>> {lappend res [%W curselection]}
+ .l insert end a b c
+ focus -force .l
+ event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires
+ .l configure -state disabled
+ focus -force .l
+ event generate .l <Control-Home> ; # <<ListboxSelect>> does NOT fire
+ .l configure -state normal
+ focus -force .l
+ event generate .l <Control-End> ; # <<ListboxSelect>> fires
+ .l selection clear 0 end ; # <<ListboxSelect>> does NOT fire
+ .l selection set 1 1 ; # <<ListboxSelect>> does NOT fire
+ lappend res [.l curselection]
+} -cleanup {
+ destroy .l
+ unset -nocomplain res
+} -result {0 2 1}
+
+test listbox-31.2 {<<ListboxSelect>> event on lost selection} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l -exportselection true]
+ update
+ bind .l <<ListboxSelect>> {lappend res [list [selection own] [%W curselection]]}
+ .l insert end a b c
+ focus -force .l
+ event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires
+ selection clear ; # <<ListboxSelect>> fires again
+ set res
+} -cleanup {
+ destroy .l
+} -result {{.l 0} {{} {}}}
+
resetGridInfo
deleteWindows
option clear
diff --git a/tests/menu.test b/tests/menu.test
index 59239d7..aaadc86 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -3867,6 +3867,18 @@ test menu-35.1 {menu -underline string overruns Bug 1599877} -setup {
deleteWindows
} -result {}
+test menu-37.1 {menubar menues cannot be posted - bug 2160206} -setup {
+ catch {destroy .m}
+} -body {
+ # On Linux the following used to panic
+ # It now returns an error (on all platforms)
+ menu .m -type menubar
+ list [catch ".m post 1 1" msg] $msg
+} -cleanup {
+ destroy .m
+} -result {1 {a menubar menu cannot be posted}}
+
+
# cleanup
imageFinish
deleteWindows
diff --git a/tests/option.file3 b/tests/option.file3
new file mode 100755
index 0000000..146cfd9
--- /dev/null
+++ b/tests/option.file3
@@ -0,0 +1,18 @@
+! This file is a sample option (resource) database used to test
+! Tk's option-handling capabilities.
+
+! Comment line \
+ with a backslash-newline sequence embedded in it.
+
+*x1: blue
+ tktest.x2 : green
+*\
+x3 \
+ : pur\
+ple
+*x 4: brówn
+# More comments, this time delimited by hash-marks.
+ # Comment-line with space.
+*x6:
+*x9: \ \ \\\101\n
+# comment line as last line of file.
diff --git a/tests/option.test b/tests/option.test
index 23866d7..ea5b5d1 100644
--- a/tests/option.test
+++ b/tests/option.test
@@ -399,18 +399,20 @@ test option-15.10 {database files} -body {
set option2 [file join [testsDirectory] option.file2]
option read $option2
} -returnCodes error -result {missing colon on line 2}
-
+set option3 [file join [testsDirectory] option.file3]
+option read $option3
+test option-15.11 {database files} {option get . {x 4} color} br\xf3wn
test option-16.1 {ReadOptionFile} -body {
- set option3 [makeFile {} option.file3]
- set file [open $option3 w]
+ set option4 [makeFile {} option.file3]
+ set file [open $option4 w]
fconfigure $file -translation crlf
puts $file "*x7: true\n*x8: false"
close $file
- option read $option3 userDefault
+ option read $option4 userDefault
list [option get . x7 color] [option get . x8 color]
} -cleanup {
- removeFile $option3
+ removeFile $option4
} -result {true false}
deleteWindows
diff --git a/tests/scrollbar.test b/tests/scrollbar.test
index c6a5a90..3b16821 100644
--- a/tests/scrollbar.test
+++ b/tests/scrollbar.test
@@ -632,6 +632,36 @@ test scrollbar-9.1 {scrollbar widget vs hidden commands} {
list [winfo children .] [interp hidden]
} [list {} $l]
+test scrollbar-10.1 {<MouseWheel> event on scrollbar} -constraints {win|unix} -setup {
+ destroy .t .s
+} -body {
+ pack [text .t -yscrollcommand {.s set}] -side left
+ for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"}
+ pack [scrollbar .s -command {.t yview}] -fill y -expand 1 -side left
+ update
+ focus -force .s
+ event generate .s <MouseWheel> -delta -120
+ after 200 {set eventprocessed 1} ; vwait eventprocessed
+ .t index @0,0
+} -cleanup {
+ destroy .t .s
+} -result {5.0}
+
+test scrollbar-10.2 {<MouseWheel> event on scrollbar} -constraints {win|unix} -setup {
+ destroy .t .s
+} -body {
+ pack [text .t -xscrollcommand {.s set} -wrap none] -side top
+ for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "}
+ pack [scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top
+ update
+ focus -force .s
+ event generate .s <Shift-MouseWheel> -delta -120
+ after 200 {set eventprocessed 1} ; vwait eventprocessed
+ .t index @0,0
+} -cleanup {
+ destroy .t .s
+} -result {1.4}
+
catch {destroy .s}
catch {destroy .t}
diff --git a/tests/spinbox.test b/tests/spinbox.test
index b8170c5..594cc90 100644
--- a/tests/spinbox.test
+++ b/tests/spinbox.test
@@ -3790,6 +3790,32 @@ test spinbox-23.1 {selection present while disabled, bug 637828} -body {
destroy .e
} -result {1 1 345}
+test spinbox-24.1 {error in trace proc attached to the textvariable} -setup {
+ destroy .s
+} -body {
+ trace variable myvar w traceit
+ proc traceit args {error "Intentional error here!"}
+ spinbox .s -textvariable myvar -from 1 -to 10
+ catch {.s set mystring} result1
+ catch {.s insert 0 mystring} result2
+ catch {.s delete 0} result3
+ catch {.s invoke buttonup} result4
+ list $result1 $result2 $result3 $result4
+} -cleanup {
+ destroy .s
+} -result [list {can't set "myvar": Intentional error here!} \
+ {can't set "myvar": Intentional error here!} \
+ {can't set "myvar": Intentional error here!} \
+ {can't set "myvar": Intentional error here!}]
+
+test spinbox-25.1 {textvariable lives in a non-existing namespace} -setup {
+ destroy .s
+} -body {
+ catch {spinbox .s -textvariable thisnsdoesntexist::myvar} result1
+ set result1
+} -cleanup {
+ destroy .s
+} -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist}
# Collected comments about lacks from the test
# XXX Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc,
diff --git a/tests/text.test b/tests/text.test
index 746e998..52a21af 100644
--- a/tests/text.test
+++ b/tests/text.test
@@ -925,7 +925,7 @@ test text-3.2 {TextWidgetCmd procedure} -setup {
.t gorp 1.0 z 1.2
} -cleanup {
destroy .t
-} -returnCodes {error} -result {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}
+} -returnCodes {error} -result {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}
test text-4.1 {TextWidgetCmd procedure, "bbox" option} -setup {
text .t
@@ -1147,7 +1147,7 @@ Line 7"
.t co 1.0 z 1.2
} -cleanup {
destroy .t
-} -returnCodes {error} -result {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}
+} -returnCodes {error} -result {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}
# "configure" option is already covered above
test text-7.1 {TextWidgetCmd procedure, "debug" option} -setup {
@@ -1163,7 +1163,7 @@ test text-7.2 {TextWidgetCmd procedure, "debug" option} -setup {
.t de 0 1
} -cleanup {
destroy .t
-} -returnCodes {error} -result {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}
+} -returnCodes {error} -result {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}
test text-7.3 {TextWidgetCmd procedure, "debug" option} -setup {
text .t
} -body {
@@ -2683,6 +2683,10 @@ test text-9.2.47 {TextWidgetCmd procedure, "count" option} -setup {
.t tag configure hidden -elide true
.t tag add hidden 5.7 11.0
update
+ # next line to be fully sure that asynchronous line heights calculation is
+ # up-to-date otherwise this test may fail (depending on the computer
+ # performance), especially when the . toplevel has small height
+ .t sync
set y1 [lindex [.t yview] 1]
.t count -displaylines 5.0 11.0
set y2 [lindex [.t yview] 1]
@@ -2878,6 +2882,176 @@ test text-11.9 {counting with tag priority eliding} -setup {
destroy .t
} -result {1 0 0 1 0 2.0 4.0 4.0 4.0 3.0 3.0 3.0 2.0 1.0 1.0}
+test text-11a.1 {TextWidgetCmd procedure, "pendingsync" option} -setup {
+ destroy .yt
+} -body {
+ text .yt
+ list [catch {.yt pendingsync mytext} msg] $msg
+} -cleanup {
+ destroy .yt
+} -result {1 {wrong # args: should be ".yt pendingsync"}}
+test text-11a.2 {TextWidgetCmd procedure, "pendingsync" option} -setup {
+ destroy .top.yt .top
+} -body {
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 300} {incr i} {
+ append content [string repeat "$i " 15] \n
+ }
+ .top.yt insert 1.0 $content
+ # wait for end of line metrics calculation to get correct $fraction1
+ # as a reference
+ while {[.top.yt pendingsync]} {update}
+ .top.yt yview moveto 1
+ set fraction1 [lindex [.top.yt yview] 0]
+ set res [expr {$fraction1 > 0}]
+ .top.yt delete 1.0 end
+ .top.yt insert 1.0 $content
+ # ensure the test is relevant
+ lappend res [.top.yt pendingsync]
+ # asynchronously wait for completion of line metrics calculation
+ while {[.top.yt pendingsync]} {update}
+ .top.yt yview moveto $fraction1
+ set fraction2 [lindex [.top.yt yview] 0]
+ lappend res [expr {$fraction1 == $fraction2}]
+} -cleanup {
+ destroy .top.yt .top
+} -result {1 1 1}
+
+test text-11a.11 {TextWidgetCmd procedure, "sync" option} -setup {
+ destroy .yt
+} -body {
+ text .yt
+ list [catch {.yt sync mytext} msg] $msg
+} -cleanup {
+ destroy .yt
+} -result {1 {wrong # args: should be ".yt sync ?-command command?"}}
+test text-11a.12 {TextWidgetCmd procedure, "sync" option} -setup {
+ destroy .top.yt .top
+} -body {
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 30} {incr i} {
+ append content [string repeat "$i " 15] \n
+ }
+ .top.yt insert 1.0 $content
+ # wait for end of line metrics calculation to get correct $fraction1
+ # as a reference
+ .top.yt sync
+ .top.yt yview moveto 1
+ set fraction1 [lindex [.top.yt yview] 0]
+ set res [expr {$fraction1 > 0}]
+ # first case: do not wait for completion of line metrics calculation
+ .top.yt delete 1.0 end
+ .top.yt insert 1.0 $content
+ .top.yt yview moveto $fraction1
+ set fraction2 [lindex [.top.yt yview] 0]
+ lappend res [expr {$fraction1 == $fraction2}]
+ # second case: wait for completion of line metrics calculation
+ .top.yt delete 1.0 end
+ .top.yt insert 1.0 $content
+ .top.yt sync
+ .top.yt yview moveto $fraction1
+ set fraction2 [lindex [.top.yt yview] 0]
+ lappend res [expr {$fraction1 == $fraction2}]
+} -cleanup {
+ destroy .top.yt .top
+} -result {1 0 1}
+
+test text-11a.21 {TextWidgetCmd procedure, "sync" option with -command} -setup {
+ destroy .yt
+} -body {
+ text .yt
+ list [catch {.yt sync -comx foo} msg] $msg
+} -cleanup {
+ destroy .yt
+} -result {1 {wrong option "-comx": should be "-command"}}
+test text-11a.22 {TextWidgetCmd procedure, "sync" option with -command} -setup {
+ destroy .top.yt .top
+} -body {
+ set res {}
+ set ::x 0
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 30} {incr i} {
+ append content [string repeat "$i " 15] \n
+ }
+ .top.yt insert 1.0 $content
+ # first case: line metrics calculation still running when launching 'sync -command'
+ lappend res [.top.yt pendingsync]
+ .top.yt sync -command [list set ::x 1]
+ lappend res $::x
+ # now finish line metrics calculations
+ while {[.top.yt pendingsync]} {update}
+ lappend res [.top.yt pendingsync] $::x
+ # second case: line metrics calculation completed when launching 'sync -command'
+ .top.yt sync -command [list set ::x 2]
+ lappend res $::x
+ vwait ::x
+ lappend res $::x
+} -cleanup {
+ destroy .top.yt .top
+} -result {1 0 0 1 1 2}
+
+test text-11a.31 {"<<WidgetViewSync>>" event} -setup {
+ destroy .top.yt .top
+} -body {
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 300} {incr i} {
+ append content [string repeat "$i " 15] \n
+ }
+ .top.yt insert 1.0 $content
+ update
+ bind .top.yt <<WidgetViewSync>> { if {%d} {set yud(%W) 1} }
+ # wait for end of line metrics calculation to get correct $fraction1
+ # as a reference
+ if {[.top.yt pendingsync]} {vwait yud(.top.yt)}
+ .top.yt yview moveto 1
+ set fraction1 [lindex [.top.yt yview] 0]
+ set res [expr {$fraction1 > 0}]
+ .top.yt delete 1.0 end
+ .top.yt insert 1.0 $content
+ # synchronously wait for completion of line metrics calculation
+ # and ensure the test is relevant
+ set waited 0
+ if {[.top.yt pendingsync]} {set waited 1 ; vwait yud(.top.yt)}
+ lappend res $waited
+ .top.yt yview moveto $fraction1
+ set fraction2 [lindex [.top.yt yview] 0]
+ lappend res [expr {$fraction1 == $fraction2}]
+} -cleanup {
+ destroy .top.yt .top
+} -result {1 1 1}
+
+test text-11a.41 {"sync" "pendingsync" and <<WidgetViewSync>>} -setup {
+ destroy .top.yt .top
+} -body {
+ set res {}
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 300} {incr i} {
+ append content [string repeat "$i " 50] \n
+ }
+ bind .top.yt <<WidgetViewSync>> {lappend res Sync:%d}
+ .top.yt insert 1.0 $content
+ vwait res ; # event dealt with by the event loop, with %d==0 i.e. we're out of sync
+ # ensure the test is relevant
+ lappend res "Pending:[.top.yt pendingsync]"
+ # - <<WidgetViewSync>> fires when sync returns if there was pending syncs
+ # - there is no more any pending sync after running 'sync'
+ .top.yt sync
+ vwait res ; # event dealt with by the event loop, with %d==1 i.e. we're in sync again
+ lappend res "Pending:[.top.yt pendingsync]"
+ set res
+} -cleanup {
+ destroy .top.yt .top
+} -result {Sync:0 Pending:1 Sync:1 Pending:0}
test text-12.1 {TextWidgetCmd procedure, "index" option} -setup {
text .t
@@ -2899,7 +3073,7 @@ test text-12.3 {TextWidgetCmd procedure, "index" option} -setup {
.t in a b
} -cleanup {
destroy .t
-} -returnCodes {error} -result {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}
+} -returnCodes {error} -result {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}
test text-12.4 {TextWidgetCmd procedure, "index" option} -setup {
text .t
} -body {
@@ -6706,7 +6880,7 @@ test text-33.2 {TextWidgetCmd procedure, "peer" option} -setup {
test text-33.3 {TextWidgetCmd procedure, "peer" option} -setup {
text .t
} -body {
- .t p names
+ .t pee names
} -cleanup {
destroy .t
} -returnCodes {ok} -result {}
diff --git a/tests/textDisp.test b/tests/textDisp.test
index a6bbfd7..353999f 100644
--- a/tests/textDisp.test
+++ b/tests/textDisp.test
@@ -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
@@ -1333,6 +1332,30 @@ test textDisp-9.13 {TkTextRedrawTag} {
update
list $tk_textRelayout $tk_textRedraw
} {{2.0 6.0 7.0} {2.0 6.0 7.0}}
+test textDisp-9.14 {TkTextRedrawTag} {
+ pack [text .tnocrash]
+ for {set i 1} {$i < 6} {incr i} {
+ .tnocrash insert end \nfoo$i
+ }
+ .tnocrash tag configure mytag1 -relief raised
+ .tnocrash tag configure mytag2 -relief solid
+ update
+ proc doit {} {
+ .tnocrash tag add mytag1 4.0 5.0
+ .tnocrash tag add mytag2 4.0 5.0
+ after idle {
+ .tnocrash tag remove mytag1 1.0 end
+ .tnocrash tag remove mytag2 1.0 end
+ }
+ .tnocrash delete 1.0 2.0
+ }
+ doit ; # must not crash
+ after 500 {
+ destroy .tnocrash
+ set done 1
+ }
+ vwait done
+} {}
test textDisp-10.1 {TkTextRelayoutWindow} {
.t configure -wrap char
@@ -1574,6 +1597,17 @@ test textDisp-11.20 {TkTextSetYView, see in elided lines} {
# this shall not crash (null chunkPtr in TkTextSeeCmd is tested)
.top.t see 3.0
} {}
+test textDisp-11.21 {TkTextSetYView, window height smaller than the line height} {
+ .top.t delete 1.0 end
+ for {set i 1} {$i <= 10} {incr i} {
+ .top.t insert end "Line $i\n"
+ }
+ set lineheight [font metrics [.top.t cget -font] -linespace]
+ wm geometry .top 200x[expr {$lineheight / 2}]
+ update
+ .top.t see 1.0
+ .top.t index @0,[expr {$lineheight - 2}]
+} {1.0}
.t configure -wrap word
.t delete 50.0 51.0
@@ -2010,9 +2044,9 @@ test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {textfonts} {
wm geometry .top1 +0+0
text .top1.t -height 3 -width 4 -wrap none -setgrid 1 -padx 6 \
-spacing3 6
- .top1.t insert end "1\n2\n3\n4\n5\n6"
pack .top1.t
update
+ .top1.t insert end "1\n2\n3\n4\n5\n6"
.top1.t yview moveto 0.3333
set result [.top1.t yview]
destroy .top1
@@ -4104,7 +4138,7 @@ test textDisp-33.2 {one line longer than fits in the widget} {
.tt debug 1
set tk_textHeightCalc ""
.tt insert 1.0 [string repeat "more wrap + " 1]
- after 100 ; update
+ after 100 ; update idletasks
# Nothing should have been recalculated.
set tk_textHeightCalc
} {}
@@ -4162,29 +4196,50 @@ test textDisp-33.5 {bold or italic fonts} win {
} {italic font measurement ok}
destroy .tt
-test textDisp-34.1 {Text widgets multi-scrolling problem: Bug 2677890} -setup {
- pack [text .t1 -width 10 -yscrollcommand {.sy set}] \
- [ttk::scrollbar .sy -orient vertical -command {.t1 yview}] \
- -side left -fill both
- bindtags .sy {}; # No clicky!
+test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup {
+ pack [text .t1] -expand 1 -fill both
set txt ""
- for {set i 0} {$i < 99} {incr i} {
- lappend txt "$i" [list pc $i] "\n" ""
+ for {set i 1} {$i < 100} {incr i} {
+ append txt "Line $i\n"
}
set result {}
} -body {
- .t1 insert end {*}$txt
- update
- lappend result [.sy get]
- .t1 replace 6.0 6.0+1c "*"
- lappend result [.sy get]
- after 0 {lappend result [.sy get]}
- after 1000 {lappend result [.sy get]}
- vwait result;vwait result
- return $result
+ .t1 insert end $txt
+ .t1 debug 1
+ set ge [winfo geometry .]
+ scan $ge "%dx%d+%d+%d" width height left top
+ update
+ .t1 sync
+ set negative 0
+ bind .t1 <<WidgetViewSync>> { if {%d < 0} {set negative 1} }
+ # Without the fix for bug 2677890, changing the width of the toplevel
+ # will launch recomputation of the line heights, but will produce negative
+ # number of still remaining outdated lines, which is obviously wrong.
+ # Thus we use this way to check for regression regarding bug 2677890,
+ # i.e. to check that the fix for this bug really is still in.
+ wm geometry . "[expr {$width * 2}]x$height+$left+$top"
+ update
+ .t1 sync
+ set negative
+} -cleanup {
+ destroy .t1
+} -result {0}
+
+test textDisp-35.1 {Init value of charHeight - Dancing scrollbar bug 1499165} -setup {
+ pack [text .t1] -fill both -expand y -side left
+ .t insert end "[string repeat a\nb\nc\n 500000]THE END\n"
+ set res {}
+} -body {
+ .t see 10000.0
+ after 300 {set fr1 [.t yview] ; set done 1}
+ vwait done
+ after 300 {set fr2 [.t yview] ; set done 1}
+ vwait done
+ lappend res [expr {[lindex $fr1 0] == [lindex $fr2 0]}]
+ lappend res [expr {[lindex $fr1 1] == [lindex $fr2 1]}]
} -cleanup {
- destroy .t1 .sy
-} -result {{0.0 1.0} {0.0 1.0} {0.0 1.0} {0.0 0.24}}
+ destroy .t1
+} -result {1 1}
deleteWindows
option clear
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/ttk/spinbox.test b/tests/ttk/spinbox.test
index f7741c6..32b77af 100644
--- a/tests/ttk/spinbox.test
+++ b/tests/ttk/spinbox.test
@@ -143,7 +143,7 @@ test spinbox-1.8.4 "-validate option: " -setup {
.sb configure -validate all -validatecommand {lappend ::spinbox_test %P}
pack .sb
.sb set 50
- focus .sb
+ focus -force .sb
after 500 {set ::spinbox_wait 1} ; vwait ::spinbox_wait
set ::spinbox_test
} -cleanup {
diff --git a/tests/winButton.test b/tests/winButton.test
index 8bf1d01..88b4345 100644
--- a/tests/winButton.test
+++ b/tests/winButton.test
@@ -22,8 +22,10 @@ option clear
# ----------------------------------------------------------------------
test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints {
- testImageType win
+ testImageType win nonPortable
} -setup {
+ # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen
+ # the smallest size (i.e. 8) is not available for "MS Sans Serif" font
deleteWindows
} -body {
image create test image1
@@ -47,7 +49,11 @@ test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints {
image delete image1
} -result {68 48 70 50 90 52 90 52}
-test winbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints win -setup {
+test winbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints {
+ win nonPortable
+} -setup {
+ # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen
+ # the smallest size (i.e. 8) is not available for "MS Sans Serif" font
deleteWindows
} -body {
label .b1 -bitmap question -bd 3 -padx 0 -pady 2
diff --git a/tests/winDialog.test b/tests/winDialog.test
index 481ab42..c8c36bf 100644
--- a/tests/winDialog.test
+++ b/tests/winDialog.test
@@ -512,13 +512,13 @@ test winDialog-5.12.2 {tk_getSaveFile: initial directory: ~user} -constraints {
unset -nocomplain x
start {set x [tk_getSaveFile \
- -initialdir ~$::env(USERNAME) \
+ -initialdir ~$::tcl_platform(user) \
-initialfile "5 12 2" -title Foo]}
then {
Click ok
}
return $x
-} -result [file normalize [file join ~$::env(USERNAME) "5 12 2"]]
+} -result [file normalize [file join ~$::tcl_platform(user) "5 12 2"]]
test winDialog-5.12.3 {tk_getSaveFile: initial directory: .} -constraints {
nt testwinevent
@@ -594,7 +594,7 @@ test winDialog-5.12.6 {tk_getSaveFile: initial directory: relative} -constraints
test winDialog-5.12.7 {tk_getOpenFile: initial directory: ~} -constraints {
nt testwinevent
} -body {
- set fn [file tail [lindex [glob ~/*] 0]]
+ set fn [file tail [lindex [glob -types f ~/*] 0]]
unset -nocomplain x
start {set x [tk_getOpenFile \
-initialdir ~ \
generated by cgit v0.12 at 2025-12-28 15:32:30 (GMT)