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