Attachment "a0c1a9c6c6_sample.tcl" to
ticket [a0c1a9c6]
added by
serhiy.storchaka
2026-09-29 13:07:28.
# Sample for Tk bug a0c1a9c6c6: text layout is not thread safe when base
# chunks are used (macOS, and with bidi rendering also X11 and Windows).
# Several threads lay out text widgets at the same time. Without the fix
# wish crashes within seconds; with the fix it prints "ok".
#
# Xft is not thread safe itself, so every thread is initialized in turn and
# uses its own font family, to not crash in Xft instead.
#
# Run with: wish a0c1a9c6c6_sample.tcl ?nthreads? ?seconds?
package require Thread
set nthreads [expr {$argc > 0 ? [lindex $argv 0] : 4}]
set seconds [expr {$argc > 1 ? [lindex $argv 1] : 10}]
set setup {
load {} Tk
tk useinputmethods 0
wm title . "Thread [thread::id]: $family"
text .t -width 40 -height 20 -wrap word -font [list $family 10]
pack .t -fill both -expand 1
.t tag configure big -font [list $family 16]
.t tag configure red -foreground red
for {set i 0} {$i < 50} {incr i} {
.t insert end "Line $i: some text " {} "big text " big \
"red text " red "mixed [string repeat abc 10]\n"
}
update
proc run {deadline} {
set n 0
while {[clock milliseconds] < $deadline} {
# Relayout all lines: change the width and edit the text.
.t configure -width [expr {30 + $n % 20}]
.t insert 1.0 "x" red
.t delete 1.0
update
incr n
}
return $n
}
}
set families [lsort -unique [font families]]
set step [expr {[llength $families] / $nthreads}]
set tids {}
for {set i 0} {$i < $nthreads} {incr i} {
set tid [thread::create]
lappend tids $tid
set family [lindex $families [expr {$i * $step}]]
thread::send $tid [list set family $family]
thread::send $tid $setup
}
set deadline [expr {[clock milliseconds] + 1000 * $seconds}]
foreach tid $tids {
thread::send -async $tid [list run $deadline] ::result($tid)
}
set done 0
trace add variable ::result write {apply {args {incr ::done}}}
while {$done < $nthreads} {
vwait ::done
}
puts "ok: [join [lmap tid $tids {set ::result($tid)}] { }] relayouts"
exit
