Attachment "tkScreenDiscovery.tcl" to
ticket [2b1ce317]
added by
kjnash
2023-09-01 17:03:03.
#! /usr/bin/env wish
# ------------------------------------------------------------------------------
# Command ::tk_listScreens
# ------------------------------------------------------------------------------
# Attempt to discover all the screens available to Tk. Return them as a list.
#
# Brute-force search for available screens on the localhost, with screen
# identifiers :D.S where D and S are non-negative integers. Tk quickly
# detects if there is no display, so the search is fast.
#
# On X11, in addition to displays from 0 to $maxDisplays-1, test for displays
# whose presence is suggested by the existence of a UNIX, TCP, or TCP6 socket.
#
# If the screen [winfo screen .] includes a hostname, and this is not equivalent
# to localhost, also do a brute-force search on that hostname, but for a smaller
# range of display and screen numbers, and again include display numbers
# suggested by X11 sockets.
#
# The screen [winfo screen .] is always included.
#
# If [winfo screen .] includes the hostname localhost, localhost4, localhost6,
# 127.0.0.1, or ::1, that hostname is retained in the list elements for that
# screen and for other screens on the same display, but is elided for other
# displays from the same host. Tk is already using that display name, and we do
# not want two identifiers for the same screen.
#
# Notes
#
# [Bug 2912473] refers to unusual VNC screen names such as "::1:1.0"
# 1. How can these be discovered?
# 2. What is a legal screen name? X(7) states:
# hostname:displaynumber.screennumber
# - On localhost, hostname is empty.
# - On hosts reached by TCP/IP, hostname can be an IP address, or a full or
# partial domain name.
# - On DECnet, hostname is nodename followed by ":" (in addition to the ":"
# that always follows hostname), e.g. "hydra::0.1"
# - the VNC example has hostname ::1, the IPv6 localhost.
#
# winfo(n) lies that host is {}, i.e. that screen is ":D.S" but in fact
# it can be "H:D.S".
#
# Arguments:
# maxLocalDisplays - (optional) number of displays to try on localhost
# maxLocalScreens - (optional) number of screens to try for each display
# maxHostDisplays - (optional) number of displays to try on other host
# maxHostScreens - (optional) number of screens to try for each display
#
# Return Value: a Tcl list of screens on which a Tk toplevel can be created.
# ------------------------------------------------------------------------------
proc ::tk_listScreens {
{maxLocalDisplays 30} {maxLocalScreens 20}
{maxHostDisplays 3} {maxHostScreens 2}
} {
set onX11 [expr {[tk windowingsystem] eq "x11"}]
set usingSDL [expr {[info exists ::tk::sdltk] && $::tk::sdltk}]
set wtop [::tk::UnusedWindowPath .__temporary__toplevel_name_]
if {(!$onX11) || $usingSDL} {
set SocketNumbers {}
} else {
# On X11, find any numbers that appear to match a TCP/TCP6/UNIX socket.
set SocketNumbers [::tk::DisplaysFromSockets]
}
# Process the hostname, display, and screen of [winfo screen .].
# If not X11, hostname is {}, fullDisplay is :D.S, useHost is 0, stripMe is 1
lassign [::tk::ExamineRootScreen] fullDisplay rootHost rootDisplay useHost stripMe
### Local Displays (hostname == {}, 127.0.0.1, etc) ###
# Create a list of trial display numbers: brute-force plus detected sockets.
set LocalNumbers [::tk::NumList $maxLocalDisplays]
set LocalNumbers [lsort -integer -unique [concat $LocalNumbers $SocketNumbers]]
set LocalDisplays {}
foreach display $LocalNumbers {
lappend LocalDisplays :${display}
}
if {$stripMe} {
# OK if pos is -1.
# Remove rootDisplay from LocalDisplays, add fullDisplay.
# Avoid two descriptions of the same screen when fullDisplay
# is prepended to LocalDisplays.
set pos [lsearch -exact $LocalDisplays $rootDisplay]
set LocalDisplays [lreplace $LocalDisplays $pos $pos]
set LocalDisplays [linsert $LocalDisplays 0 $fullDisplay]
}
### Host Displays (hostname neither empty nor localhost etc) ###
### Used on X11 only.
set HostDisplays {}
if {$useHost} {
set HostNumbers [::tk::NumList $maxHostDisplays]
set HostNumbers [lsort -integer -unique [concat $HostNumbers $SocketNumbers]]
foreach display $HostNumbers {
lappend HostDisplays ${rootHost}:${display}
}
set pos [lsearch -exact $HostDisplays $fullDisplay]
set HostDisplays [lreplace $HostDisplays $pos $pos]
set HostDisplays [linsert $HostDisplays 0 $fullDisplay]
}
# We now have two lists of candidate displays.
# $fullDisplay is the display of window "." and has been included in one
# of the lists, without duplication.
set screenList {}
foreach {Candidates maxScreens} [list $LocalDisplays $maxLocalScreens \
$HostDisplays $maxHostScreens \
] {
foreach display $Candidates {
for {set screen 0} {$screen < $maxScreens} {incr screen} {
set id ${display}.${screen}
if {![catch {
toplevel $wtop -screen $id
destroy $wtop
}]} {
lappend screenList $id
}
}
}
}
# Move the screen of "." to the start of the list, add it if absent
# (e.g. if it has a high screen number).
set baseScreen [winfo screen .]
set pos [lsearch -exact $screenList $baseScreen]
set screenList [lreplace $screenList $pos $pos]
set screenList [linsert $screenList 0 $baseScreen]
return $screenList
}
# ------------------------------------------------------------------------------
# Command ::tk::ExamineRootScreen
# ------------------------------------------------------------------------------
# Command to analyse [winfo screen .] and return a list of values that are
# helpful when searching for other screens.
#
# Hostnames 127.0.0.1, ::1, localhost, localhost4, localhost6, are identical to
# host {}.
# A screen name is hostname:D.S where D and S are non-negative integers.
# The full display name is hostname:D
# The display is :D
#
# When rootHost is not {} and is not localhost or equivalent -
# Should the script search host == rootHost, or host == {}, or both?
# - If $rootHost is an alias of localhost, and is not detected as such, its
# display will be recorded twice.
# - If $rootHost is the name of this host, then on X11 listening
# sockets will have been detected by ::tk::DisplaysFromSockets.
# But we may need to use host $rootHost to connect.
# - If $rootHost is the name of a different host, the script's
# attempts to create a toplevel amount to a portscan. Also the
# displays without a hostname may not be useful, and the attempts
# to create a toplevel on these displays will likely fail for lack
# of permission.
# - In either case the connection attempts on the non-{} host will be slow.
# A smaller search will be used.
#
# Arguments: none
#
# Return Value: a Tcl list of values derived from the root window:
# fullDisplay - the name hostname:D of the display used by the window
# rootHost - the hostname
# rootDisplay - the display :D
# useHost - (boolean) use the host name, i.e. it is not equivalent to {}
# stripMe - (boolean) remove :D from the list before adding hostname:D
# ------------------------------------------------------------------------------
proc ::tk::ExamineRootScreen {} {
# The regsub strips .screen if it is present (it should be).
set fullDisplay [regsub {\.[0-9]+$} [winfo screen .] {}]
if {[regexp {^(.*)(:[0-9]+)$} $fullDisplay DUM rootHost rootDisplay]} {
if {$rootHost in {{} 127.0.0.1 ::1 localhost localhost4 localhost6}} {
set useHost 0
set stripMe 1
} elseif {
(![catch {exec ping -c 1 $rootHost | grep -q {(127\.0\.0\.1)\|(::1)}}])
|| (![catch {exec ping6 -c 1 $rootHost | grep -q {(127\.0\.0\.1)\|(::1)}}])
} {
# $rootHost resolves to the local host.
set useHost 0
set stripMe 1
} else {
# rootHost is not {} and is not localhost or equivalent.
set useHost 1
set stripMe 0
}
} else {
# Unexpected form for $fullDisplay
set useHost 0
set stripMe 0
set rootHost {}
set rootDisplay {}
}
return [list $fullDisplay $rootHost $rootDisplay $useHost $stripMe]
}
# ------------------------------------------------------------------------------
# Command ::tk::UnusedWindowPath
# ------------------------------------------------------------------------------
# Return a Tk window path that is not already in use.
#
# Argument:
# prefix - a valid Tk window path whose parent exists
#
# Returns the prefix argument with an integer suffix.
# ------------------------------------------------------------------------------
proc ::tk::UnusedWindowPath {prefix} {
set parent [join [lrange [split $prefix .] 0 end-1] .]
if {$parent eq {}} {
set parent .
}
if {[string index $prefix 0] ne {.}} {
return -code error "bad window prefix \"$prefix\""
}
if {(![winfo exists $parent])} {
return -code error "parent window \"$parent\" does not exist"
}
for {set num 0} {1} {incr num} {
set tryWin ${prefix}${num}
if {![winfo exists $tryWin]} {
break
}
}
return $tryWin
}
# ------------------------------------------------------------------------------
# Command ::tk::NumList
# ------------------------------------------------------------------------------
# Return a list of $num integers, from 0 to ($num - 1).
# ------------------------------------------------------------------------------
proc ::tk::NumList {num} {
set ls {}
for {set i 0} {$i < $num} {incr i} {
lappend ls $i
}
return $ls
}
# For X11
# ------------------------------------------------------------------------------
# ::tk::DisplaysFromSockets
# ------------------------------------------------------------------------------
#
# Argument
# from - ignore display numbers smaller than this
#
# Return a list of display numbers guessed from names of UNIX domain sockets and
# port numbers of TCP/TCP6 servers. Ignore values less than argument "from".
# X11 sockets directory: standard location is /tmp/.X11-unix/, other locations
# listed are for HP/UX, some Solaris - states
# https://stackoverflow.com/questions/11367354/obtaining-list-of-all-xorg-displays
# ------------------------------------------------------------------------------
proc ::tk::DisplaysFromSockets {{from 0}} {
set x11Sockets {
/tmp/.X11-unix/X*
/usr/spool/sockets/X11/X*
/var/tsol/doors/.X11-unix/X*
}
if {[catch {glob {*}$x11Sockets} fileList]} {
return
}
set displayList {}
foreach disp $fileList {
set dname [string range [file tail $disp] 1 end]
if { [file writable $disp]
&& ([file type $disp] eq {socket})
&& [string is integer -strict $dname]
&& ($dname >= $from)
} {
lappend displayList $dname
}
}
if {![catch {exec netstat -ntl | grep {^tcp} \
| grep -o {:6[0-9][0-9][0-9] } | sed -e {s/^:6//; s/ //}} res]
} {
# Simple if netstat is installed.
foreach line [split $res \n] {
set num [expr {$line}]
if {$num >= $from} {
lappend displayList $num
}
}
} else {
lappend displayList {*}[ListeningTcpPorts tcp 6000 6999 $from]
lappend displayList {*}[ListeningTcpPorts tcp6 6000 6999 $from]
}
set displayList [lsort -integer -unique $displayList]
return $displayList
}
# ------------------------------------------------------------------------------
# ::tk::ListeningTcpPorts
# ------------------------------------------------------------------------------
# Command to return a list of listening TCP or TCP6 port numbers, each one
# reduced by a constant number.
# The command is useful if the system has /proc/net/tcp{,6} but not netstat.
#
# Arguments
# proto - protocol - tcp or tcp6
# from - minimum port number to examine; also subtracted from each result
# to - maximum port number to examine
# min - ignore results that are smaller than this
#
# Return Value: a Tcl list of integers, each one a candidate display number.
# ------------------------------------------------------------------------------
proc ::tk::ListeningTcpPorts {proto from to min} {
if {$proto ni {tcp tcp6}} {
return -code error {argument proto must be "tcp" or "tcp6"}
}
set displays {}
set pattern {(?i)^[[:xdigit:]]+:([[:xdigit:]]+) [[:xdigit:]]+:0000 0A$}
if {[catch {open /proc/net/$proto} fin]} {
return
}
set code [catch {
while {[gets $fin line] >= 0} {
if {[string is list -strict $line]} {
set lline [lrange $line 1 3]
if {[regexp $pattern $lline DUM hex]} {
scan $hex %x foo
if {$foo >= $from + $min && $foo <= $to} {
incr foo -$from
lappend displays $foo
}
}
}
}
} res info]
close $fin
if {$code == 1} {
return -code error -info $info $res
}
return $displays
}
puts [tk_listScreens]
exit
