[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].

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 {myaddr localhost}} {
	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 ]]