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 } } }