Attachment "tkScreenDiscovery.tcl" to
ticket [2b1ce317]
added by
kjnash
2023-08-23 15:14:48.
#! /usr/bin/env wish
# ::tk_listScreens
#
# 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.
#
# The screen [winfo screen .] is always included.
#
# Arguments:
# maxDisplays - (optional) number of displays to try
# maxScreens - (optional) number of screens to try for each display
#
# Returns a Tcl list of screens on which a Tk toplevel can be created.
# FIXME [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"
# - None of these matches the VNC example from the bug report!
proc ::tk_listScreens {{maxDisplays 30} {maxScreens 20}} {
set onX11 [expr {[tk windowingsystem] eq "x11"}]
set usingSDL [expr {[info exists ::tk::sdltk] && $::tk::sdltk}]
set wtop [::tk::UnusedWindowPath .__temporary__toplevel_name_]
# Create a brute-force list of trial display numbers.
set candidates {}
for {set display 0} {$display < $maxDisplays} {incr display} {
lappend candidates $display
}
if {$onX11 && !$usingSDL} {
# Add any larger numbers that appear to match a TCP/TCP6/UNIX socket.
lappend candidates {*}[::tk::DisplaysFromSockets $maxDisplays]
}
# Prepend elements with : for simple comparison with $baseDisplay.
set candidates2 {}
foreach display $candidates {
lappend candidates2 :${display}
}
# Append the display of "." if it is not already in the list (e.g. high
# display number or not a simple ":N").
# The regsub strips .screen if this is present.
set baseDisplay [regsub {\.[0-9]+$} [winfo screen .] {}]
if {$baseDisplay ni $candidates2} {
lappend candidates2 $baseDisplay
}
set screenList {}
foreach display $candidates2 {
for {set screen 0} {$screen < $maxScreens} {incr screen} {
set id ${display}.${screen}
if {![catch {
toplevel $wtop -screen $id
destroy $wtop
}]} {
lappend screenList $id
}
}
}
# Append the screen of "." if it is not already in the list
# (e.g. if it has a high screen number).
set baseScreen [winfo screen .]
if {$baseScreen ni $screenList} {
lappend screenList $baseScreen
}
return $screenList
}
# ::tk::UnusedWindowPath
#
# Argument:
# prefix - a valid Tk window path whose parent exists
#
# Returns the prefix argument with an integer suffix.
# The value is a Tk window path that is not already in use.
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
}
# 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".
proc ::tk::DisplaysFromSockets {{from 30}} {
set onX11 [expr {[tk windowingsystem] eq "x11"}]
set usingSDL [expr {[info exists ::tk::sdltk] && $::tk::sdltk}]
if {(!$onX11) || $usingSDL} {
return
}
# Std location, HP/UX, some Solaris - says https://stackoverflow.com/questions/11367354/obtaining-list-of-all-xorg-displays
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
#
# Arguments
# proto - protocol - tcp or tcp6
# from - minimum port number to examine; subtracted from results
# to - maximum port number to examine
# min - ignore results that are smaller than this
#
# Returns a list of listening TCP or TCP6 port numbers, less a constant.
# Useful if the system has /proc/net/tcp{,6} but not netstat.
proc ::tk::ListeningTcpPorts {proto from to min} {
set onX11 [expr {[tk windowingsystem] eq "x11"}]
set usingSDL [expr {[info exists ::tk::sdltk] && $::tk::sdltk}]
if {(!$onX11) || $usingSDL} {
return
}
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
