Attachment "test_scrollbar_perf.tcl" to
ticket [7caf9e9e]
added by
mtmcp_
2026-05-28 16:07:26.
# ttk image-element scrollbar performance test
#
# Exercises the ttkImage.c hot path (ImageElementDraw) with a custom
# image-based ttk::scrollbar so the effect of the element pixmap cache
# patch is measurable.
#
# Usage:
# wish test_scrollbar_perf.tcl
#
# Live metrics:
# Drag-resize the window. Each <Configure> on the vertical
# scrollbar is timed (stamp at event, resample at next idle) and
# the running count / last / avg / min / max are shown in the
# status bar at the bottom, the popout log window, AND printed to
# stdout.
#
# Key-triggered benchmarks (focus the toplevel first):
# h horizontal sweep toplevel WIDTH min<->max with forced
# redraws at each step. Per-step times come
# from the <Configure> binding; the bench also
# reports total ms and ms/step.
# v vertical same, sweeping HEIGHT.
# d diagonal same, sweeping width and height together.
# r reset zero the running resize stats.
#
# A popout "Perf log" window collects every report line so they can
# be copy-pasted. "Copy all" puts the buffer on the clipboard,
# "Clear" empties it.
#
# Compare numbers between patched and unpatched Tk to validate the
# fix in tk-9.0-ttk-image-el-cache.diff.
# ------------------------------------------------------------------
package require Tk
# Hide the root while we build everything; deiconify it last so it
# ends up on top of the perf-log popout in the stacking order.
wm withdraw .
# ------------------------------------------------------------------
# Custom ttk image-element scrollbar (exercises ttkImage.c hot path).
# ------------------------------------------------------------------
image create photo img_thumb -width 14 -height 24
img_thumb put [string repeat {{#505050} } 14] -to 0 0 14 24
img_thumb transparency set 0 0 1
img_thumb transparency set 13 0 1
img_thumb transparency set 0 23 1
img_thumb transparency set 13 23 1
img_thumb put {{#80505050}} -to 1 0 2 1
img_thumb put {{#80505050}} -to 12 0 13 1
img_thumb put {{#80505050}} -to 1 23 2 24
img_thumb put {{#80505050}} -to 12 23 13 24
image create photo img_trough -width 14 -height 14
img_trough put [string repeat {{#2a2a2a} } 14] -to 0 0 14 14
image create photo img_uparrow -width 14 -height 10
img_uparrow put [string repeat {{#3a3a3a} } 14] -to 0 0 14 10
image create photo img_downarrow -width 14 -height 10
img_downarrow put [string repeat {{#3a3a3a} } 14] -to 0 0 14 10
# Horizontal-orientation arrows used by the horizontal scrollbar
image create photo img_leftarrow -width 10 -height 14
img_leftarrow put [string repeat {{#3a3a3a} } 10] -to 0 0 10 14
image create photo img_rightarrow -width 10 -height 14
img_rightarrow put [string repeat {{#3a3a3a} } 10] -to 0 0 10 14
ttk::style element create MyCustom.Vscroll.trough image img_trough -border {4 4 4 4} -sticky nswe
ttk::style element create MyCustom.Vscroll.thumb image img_thumb -border {4 6 4 6} -sticky nswe
ttk::style element create MyCustom.Vscroll.uparrow image img_uparrow
ttk::style element create MyCustom.Vscroll.downarrow image img_downarrow
ttk::style element create MyCustom.Hscroll.trough image img_trough -border {4 4 4 4} -sticky nswe
ttk::style element create MyCustom.Hscroll.thumb image img_thumb -border {6 4 6 4} -sticky nswe
ttk::style element create MyCustom.Hscroll.leftarrow image img_leftarrow
ttk::style element create MyCustom.Hscroll.rightarrow image img_rightarrow
ttk::style layout Vertical.TScrollbar {
MyCustom.Vscroll.trough -sticky ns -children {
MyCustom.Vscroll.uparrow -side top -sticky {}
MyCustom.Vscroll.downarrow -side bottom -sticky {}
MyCustom.Vscroll.thumb -sticky nswe
}
}
ttk::style layout Horizontal.TScrollbar {
MyCustom.Hscroll.trough -sticky ew -children {
MyCustom.Hscroll.leftarrow -side left -sticky {}
MyCustom.Hscroll.rightarrow -side right -sticky {}
MyCustom.Hscroll.thumb -sticky nswe
}
}
# ------------------------------------------------------------------
# Build UI
#
# IMPORTANT: pack the fixed-height widgets (.status, .log popout
# trigger area) BEFORE the expanding .f frame. With pack, the
# widget packed first gets its required space first; an expanding
# widget packed first can push later widgets off-screen as the
# toplevel shrinks. Packing .status first keeps it visible at any
# window size.
# ------------------------------------------------------------------
label .status -anchor w -justify left -font {Courier 9} -text "press h=width-sweep v=height-sweep d=diagonal-sweep r=reset" -relief sunken -padx 4 -pady 2
pack .status -fill x -side bottom
# Toolbar: same actions as the hotkeys. -takefocus 0 keeps focus on
# the toplevel so keypresses still work after clicking a button.
frame .toolbar -relief raised -borderwidth 1
ttk::button .toolbar.h -text "Width sweep (h)" -takefocus 0 -command {resizeBench h}
ttk::button .toolbar.v -text "Height sweep (v)" -takefocus 0 -command {resizeBench v}
ttk::button .toolbar.d -text "Diagonal sweep (d)" -takefocus 0 -command {resizeBench d}
ttk::button .toolbar.r -text "Reset stats (r)" -takefocus 0 -command {perf::reset}
ttk::button .toolbar.l -text "Show log" -takefocus 0 -command {log::show}
pack .toolbar.h .toolbar.v .toolbar.d .toolbar.r -side left -padx 2 -pady 2
pack .toolbar.l -side right -padx 2 -pady 2
pack .toolbar -fill x -side top
frame .f
text .f.t -wrap none -width 60 -height 30 -yscrollcommand {.f.vs set} -xscrollcommand {.f.hs set}
ttk::scrollbar .f.vs -orient vertical -command {.f.t yview}
ttk::scrollbar .f.hs -orient horizontal -command {.f.t xview}
grid .f.t -row 0 -column 0 -sticky nswe
grid .f.vs -row 0 -column 1 -sticky ns
grid .f.hs -row 1 -column 0 -sticky ew
grid rowconfigure .f 0 -weight 1
grid columnconfigure .f 0 -weight 1
pack .f -fill both -expand 1 -side top
for {set i 1} {$i <= 200} {incr i} {
.f.t insert end "Line $i: [string repeat {abcdefgh } 20]\n"
}
.f.t see 1.0
wm title . "Scrollbar Perf Test"
wm geometry . 600x500
wm minsize . 200 120
# ------------------------------------------------------------------
# Popout log window — copy-pastable stream of every report line.
# ------------------------------------------------------------------
namespace eval log {
proc build {} {
if {[winfo exists .log]} { return }
toplevel .log
wm title .log "Perf log"
wm geometry .log 640x320
frame .log.btns
button .log.btns.copy -text "Copy all" -command [namespace code copyAll]
button .log.btns.clear -text "Clear" -command [namespace code clear]
button .log.btns.save -text "Save..." -command [namespace code saveFile]
pack .log.btns.copy -side left -padx 2 -pady 2
pack .log.btns.clear -side left -padx 2 -pady 2
pack .log.btns.save -side left -padx 2 -pady 2
pack .log.btns -side top -fill x
# pack already manages .log (for .log.btns), so the text
# widget and its scrollbars live in their own frame where
# we can use grid.
frame .log.body
text .log.body.t -wrap none -font {Courier 9} -state disabled -yscrollcommand {.log.body.vs set} -xscrollcommand {.log.body.hs set}
ttk::scrollbar .log.body.vs -orient vertical -command {.log.body.t yview}
ttk::scrollbar .log.body.hs -orient horizontal -command {.log.body.t xview}
grid .log.body.t -row 0 -column 0 -sticky nswe
grid .log.body.vs -row 0 -column 1 -sticky ns
grid .log.body.hs -row 1 -column 0 -sticky ew
grid rowconfigure .log.body 0 -weight 1
grid columnconfigure .log.body 0 -weight 1
pack .log.body -side top -fill both -expand 1
# Closing the popout just hides it; data is preserved.
wm protocol .log WM_DELETE_WINDOW [list wm withdraw .log]
}
proc show {} {
build
wm deiconify .log
raise .log
}
proc append_line {msg} {
build
.log.body.t configure -state normal
.log.body.t insert end "$msg\n"
.log.body.t configure -state disabled
.log.body.t see end
}
proc copyAll {} {
clipboard clear
clipboard append [.log.body.t get 1.0 end-1c]
}
proc clear {} {
.log.body.t configure -state normal
.log.body.t delete 1.0 end
.log.body.t configure -state disabled
}
proc saveFile {} {
set f [tk_getSaveFile -defaultextension .log -initialfile scrollbar_perf.log]
if {$f eq ""} { return }
set ch [open $f w]
puts -nonewline $ch [.log.body.t get 1.0 end-1c]
close $ch
}
}
# ------------------------------------------------------------------
# Live <Configure> metrics
#
# Configure fires after geometry changes; the redraw runs as an
# idle callback. We stamp time on Configure, then resample again
# from `after idle` — the difference covers ttk image-element
# redraw work for that resize step. Bursts of Configures are
# coalesced by cancelling any still-pending idle sample.
# ------------------------------------------------------------------
namespace eval perf {
variable count 0
variable totalUs 0
variable minUs 0
variable maxUs 0
variable lastW 0
variable lastH 0
variable pendingT 0
variable pendingId ""
proc reset {} {
variable count 0
variable totalUs 0
variable minUs 0
variable maxUs 0
report "(stats reset)"
}
proc onConfigure {w h} {
variable lastW $w
variable lastH $h
variable pendingT [clock microseconds]
variable pendingId
if {$pendingId ne ""} { after cancel $pendingId }
set pendingId [after idle [namespace code finishSample]]
}
proc finishSample {} {
variable pendingId ""
variable pendingT
variable count
variable totalUs
variable minUs
variable maxUs
variable lastW
variable lastH
set dtUs [expr {[clock microseconds] - $pendingT}]
incr count
incr totalUs $dtUs
if {$count == 1 || $dtUs < $minUs} { set minUs $dtUs }
if {$dtUs > $maxUs} { set maxUs $dtUs }
set avg [expr {$totalUs / double($count)}]
report [format "resize n=%d last=%.2fms avg=%.2fms min=%.2fms max=%.2fms (%dx%d)" $count [expr {$dtUs/1000.0}] [expr {$avg/1000.0}] [expr {$minUs/1000.0}] [expr {$maxUs/1000.0}] $lastW $lastH]
}
proc report {msg} {
.status configure -text $msg
log::append_line $msg
puts $msg
}
}
bind .f.vs <Configure> {perf::onConfigure %w %h}
# ------------------------------------------------------------------
# Automated benchmarks (key triggered)
# ------------------------------------------------------------------
# Resize bench: programmatically resize the toplevel through a
# range along the requested axis (or both for diagonal), forcing
# a full redraw at each step. `update` (not `update idletasks`)
# is required — update.n notes that resize-triggered work only
# runs via real events, not idle alone.
#
# The <Configure> binding records per-step timings automatically.
# This proc adds an overall summary line at the end.
#
# direction: h | v | d
proc resizeBench {direction} {
set wMin 400 ; set wMax 900
set hMin 300 ; set hMax 700
set step 20
# Anchor at min before measuring so the first Configure of
# the run reflects an actual size change.
wm geometry . "${wMin}x${hMin}"
update
perf::reset
set t0 [clock microseconds]
set steps 0
switch -- $direction {
h {
set name horizontal
for {set w $wMin} {$w <= $wMax} {incr w $step} {
wm geometry . "${w}x${hMin}" ; update ; incr steps
}
for {set w $wMax} {$w >= $wMin} {incr w -$step} {
wm geometry . "${w}x${hMin}" ; update ; incr steps
}
}
v {
set name vertical
for {set h $hMin} {$h <= $hMax} {incr h $step} {
wm geometry . "${wMin}x${h}" ; update ; incr steps
}
for {set h $hMax} {$h >= $hMin} {incr h -$step} {
wm geometry . "${wMin}x${h}" ; update ; incr steps
}
}
d {
set name diagonal
set n [expr {($wMax - $wMin) / $step}]
for {set i 0} {$i <= $n} {incr i} {
set w [expr {$wMin + $i * $step}]
set h [expr {$hMin + int(($hMax - $hMin) * $i / double($n))}]
wm geometry . "${w}x${h}" ; update ; incr steps
}
for {set i $n} {$i >= 0} {incr i -1} {
set w [expr {$wMin + $i * $step}]
set h [expr {$hMin + int(($hMax - $hMin) * $i / double($n))}]
wm geometry . "${w}x${h}" ; update ; incr steps
}
}
default { error "bad direction: $direction" }
}
set elapsed [expr {([clock microseconds] - $t0) / 1000.0}]
set per [expr {$elapsed / $steps}]
perf::report [format "resize-bench (%s): %d steps in %.1fms (%.2fms/step)" $name $steps $elapsed $per]
}
bind . <KeyPress-h> {resizeBench h}
bind . <KeyPress-v> {resizeBench v}
bind . <KeyPress-d> {resizeBench d}
bind . <KeyPress-r> {perf::reset}
# Build the popout, then map the main window last so it comes up
# on top in the stacking order.
log::build
update idletasks
wm deiconify .
raise .
focus -force .
