[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?

Default values for '''port''' and '''myaddr''' are 9876 and localhost respectively. If the remote access capability isn't needed anymore, the server socket can be shut down again with

 tkconclient::stop

'''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 9876} {myaddr 127.0.0.1}} {
	variable socket
	if {$socket ne ""} stop
	set server [socket -server [namespace current]::accept \
			-myaddr $myaddr $port]
	rename ::puts [namespace current]::puts
	interp alias {} ::puts {} [namespace current]::_puts
    }
    proc stop {} {
	variable server
	if {$server ne ""} {
	    close $socket
	    rename [namespace current]::puts ::puts
	}
    }
    proc accept {sock host port} {
	variable socket
	set socket $sock
	fconfigure $sock -blocking 0 -buffering none
	fileevent $sock readable [namespace current]::handle
    }
    proc handle {} {
	variable script
	variable socket
	append script [read $socket]
	if {[info complete $script]} {
	    catch {uplevel "#0" $script} result
	    if {$result ne ""} {
		puts $socket $result
	    }
	    set script ""
	}
    }
    ## This proc 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 ]]