[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 } } } ---- [[ [Category Debugging] - [Category Networking] ]]