Tk Source Code

Artifact [56ddcc71]
Login

Artifact 56ddcc7124f183e31692aed5d46ba21679838a6d1e3ed6ff365c09b717619416:

Attachment "test_scaling.tcl" to ticket [a9ee4410] added by cjmcdonald 2019-09-12 12:15:54.
# This test script demonstrates a problem with Windows dpi scaling on
# Windows 10 (1803) systems with screens with different dpi.  Wish is
# built with a "system" dpiaware manifest, which means that Tk uses the dpi
# of the primary screen, and Microsoft Windows will bitmap scale toplevels
# on any other screens to get the correct size.  But Windows can sometimes
# associate the wrong screen dpi with a toplevel, making it too big or too
# small or positioning it incorrectly.

# Run the script on a system with multiple screens with significantly
# different dpi, eg a laptop screen and an external monitor.  Move
# Toplevel 2 to a different screen from Toplevel 1.  Clicking on each Pop-up
# button should produce a pop-up marker over the button, but with mismatched
# dpi it is sometimes sized and positioned incorrectly on one or other screen.
# If nothing appears to happen when clicking on a button it may be that the
# pop-up has been positioned completely off the screen.

wm title . "Toplevel 1"

button .b1 -text "Pop-up Here" \
    -command {popup .}
pack .b1 -pady 1c -padx 3c

toplevel .t2

wm title .t2 "Toplevel 2"

button .t2.b2 -text "Pop-up Here" \
    -command {popup .t2}
pack .t2.b2 -pady 1c -padx 3c


proc popup { parent } {

    if { $parent eq "." } {
	set pd .pd
    } else {
	set pd $parent.pd
    }
    destroy $pd

    # The likelihood of seeing a problem appears to be affected by which
    # different "wm" subcommands are used for the pop-up window, and their
    # order.

    toplevel $pd -background red
    wm withdraw $pd
    wm overrideredirect $pd 1

    wm transient $pd $parent

    wm geometry $pd  [winfo width $parent]x[winfo height $parent]
    wm geometry $pd +[winfo rootx $parent]+[winfo rooty $parent]

    bind $pd <ButtonPress> [list destroy $pd]

    label $pd.label -text "Click here to\ndismiss pop-up" -background red
    pack $pd.label -padx 4m -pady 4m

    wm deiconify $pd
    raise $pd
}