#! /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
