Updated 2014-06-18 10:36:35 by RLE

Reinhard Max - 2005-09-12

This piece of code can be added to any Tcl application to allow remote access from tkcon (or even telnet or netcat). To open the debugging socket, call
 tkconclient::start port ?myaddr?

The default value for myaddr is localhost. Applications that want to use this code need to run the Tcl event loop. When a remote connection exists, [puts] output to stdout and stderr is redirected to the socket.

The code doesn't currently support concurrent client connections. Subsequent connection attempts are rejected if a connection is established already.

If the remote access capability isn't needed anymore, the command tkconclient::stop can be used to shut down the server socket, and the current client connection if there exists one. To shut down a client connection from the remote side, the word bye can be sent as a pseudo-command.

There is currently no access control to the socket!, so care must be taken, especially when opening debugging connections on a publically accessible interface.
 namespace eval tkconclient {
    variable script ""
    variable server ""
    variable socket ""
    namespace export start stop
    proc start {port {myaddr localhost}} {
        variable socket
        variable server
        if {$socket ne "" || $server ne ""} stop
        set server [socket -server [namespace current]::accept \
                        -myaddr $myaddr $port]
    }
    proc stop {} {
        variable server
        if {$server ne ""} {
            closesocket
            close $server
            set server ""
        }
    }
    proc closesocket {} {
        variable socket
        catch {close $socket}
        set socket ""
        # Restore [puts]
        rename ::puts ""
        rename [namespace current]::puts ::puts
    }
    proc accept {sock host port} {
        variable socket
        fconfigure $sock -blocking 0 -buffering none
        if {$socket ne ""} {
            puts $sock "Only one connection at a time, please!"
            close $sock
        } else {
            set socket $sock
            fileevent $sock readable [namespace current]::handle
            # Redirect [puts]
            rename ::puts [namespace current]::puts
            interp alias {} ::puts {} [namespace current]::_puts
        }
    }
    proc handle {} {
        variable script
        variable socket
        if {[eof $socket]} {
            closesocket
            return
        }
        if {![catch {read $socket} chunk]} {
            if {$chunk eq "bye\n"} {
                puts $socket "Bye!"
                closesocket
                return
            }
            append script $chunk
            if {[info complete $script]} {
                catch {uplevel "#0" $script} result
                if {$result ne ""} {
                    puts $socket $result
                }
                set script ""
            }
        } else {
            closesocket
        }
    }
    ## This procedure is partially borrowed from tkcon
    proc _puts args {
        variable socket
        set len [llength $args]
        foreach {arg1 arg2 arg3} $args { break }
    
        switch $len {
            1 {
                puts $socket $arg1
            }
            2 {
                switch -- $arg1 {
                    -nonewline - stdout - stderr {
                        puts $socket $arg2
                    }
                    default {
                        set len 0
                    }
                }
            }
            3 {
                if {$arg1 eq "-nonewline" &&
                    ($arg2 eq "stdout" || $arg2 eq "stderr")} {
                    puts $socket $arg3
                } elseif {($arg1 eq "stdout" || $arg1 eq "stderr") \
                              && $arg3 eq "-nonewline"} {
                    puts $socket $arg2
                } else {
                    set len 0
                }
            }
            default {
                set len 0
            }
        }
        ## $len == 0 means it wasn't handled above.
        if {$len == 0} {
            global errorCode errorInfo
            if {[catch [linsert $args 0 puts] msg]} {
                regsub tkcon_tcl_puts $msg puts msg
                regsub -all tkcon_tcl_puts $errorInfo puts errorInfo
                return -code error $msg
            }
            return $msg
        }
    }
 }