Reinhard Max - 2005-09-12
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 ""
}
}
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 by tkcon 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
}
}
}