4 # Simple socket command server. Supports many simultaneous sessions.
5 # Works in thread mode with each new connection receiving a new thread.
8 # cmdsrv::create port ?-idletime value? ?-initcmd cmd?
10 # port Tcp port where the server listens
11 # -idletime # of sec to idle before tearing down socket (def: 300 sec)
12 # -initcmd script to initialize new worker thread (def: empty)
18 # % cmdsrv::create 5000 -idletime 60
21 # Starts the server on the port 5000, sets idle timer to 1 minute.
22 # You can now use "telnet" utility to connect.
24 # Copyright (c) 2002 by Zoran Vasiljevic.
26 # See the file "license.terms" for information on usage and
27 # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
28 # -----------------------------------------------------------------------------
30 package require Tcl 8.4
31 package require Thread 2.5
33 namespace eval cmdsrv {
34 variable data; # Stores global configuration options
40 # Start the server on the given Tcp port.
43 # port Port where the server is listening
44 # args Variable number of arguments
53 proc cmdsrv::create {port args} {
57 if {[llength $args] % 2} {
58 error "wrong \# arguments, should be: key1 val1 key2 val2..."
62 # Setup default pool data.
67 -initcmd {source cmdsrv.tcl}
71 # Override with user-supplied data
74 foreach {arg val} $args {
76 -idletime {set data($arg) [expr {$val*1000}]}
77 -initcmd {append data($arg) \n $val}
79 error "unsupported pool option \"$arg\""
85 # Start the server on the given port. Note that we wrap
86 # the actual accept with a helper after/idle callback.
87 # This is a workaround for a well-known Tcl bug.
90 socket -server [namespace current]::_Accept -myaddr 127.0.0.1 $port
96 # Helper procedure to solve Tcl shared channel bug when responding
97 # to incoming socket connection and transfering the channel to other
102 # ipaddr IP address of the remote peer
103 # port Tcp port used for this connection
112 proc cmdsrv::_Accept {s ipaddr port} {
113 after idle [list [namespace current]::Accept $s $ipaddr $port]
119 # Accepts the incoming socket connection, creates the worker thread.
123 # ipaddr IP address of the remote peer
124 # port Tcp port used for this connection
127 # Creates new worker thread.
133 proc cmdsrv::Accept {s ipaddr port} {
138 # Configure socket for sane operation
141 fconfigure $s -blocking 0 -buffering none -translation {auto crlf}
147 puts -nonewline $s "% "
150 # Create worker thread and transfer socket ownership
153 set tid [thread::create [append data(-initcmd) \n thread::wait]]
154 thread::transfer $tid $s ; # This flushes the socket as well
157 # Start event-loop processing in the remote thread
160 thread::send -async $tid [subst {
161 array set [namespace current]::data {[array get data]}
162 fileevent $s readable {[namespace current]::Read $s}
163 proc exit args {[namespace current]::SockDone $s}
164 [namespace current]::StartIdleTimer $s
171 # Event loop procedure to read data from socket and collect the
172 # command to execute. If the command read from socket is complete
173 # it executes the command are prints the result back.
185 proc cmdsrv::Read {s} {
192 # Cover client closing connection
195 if {[eof $s] || [catch {read $s} line]} {
198 if {$line == "\n" || $line == ""} {
199 if {[catch {puts -nonewline $s "% "}]} {
202 return [StartIdleTimer $s]
206 # Construct command line to eval
209 append data(cmd) $line
210 if {[info complete $data(cmd)] == 0} {
211 if {[catch {puts -nonewline $s "> "}]} {
214 return [StartIdleTimer $s]
221 catch {uplevel \#0 $data(cmd)} ret
222 if {[catch {puts $s $ret}]} {
226 if {[catch {puts -nonewline $s "% "}]} {
233 # cmdsrv::SockDone --
235 # Tears down the thread and closes the socket if the remote peer has
236 # closed his side of the comm channel.
242 # Worker thread gets released.
248 proc cmdsrv::SockDone {s} {
255 # cmdsrv::StopIdleTimer --
257 # Cancel the connection idle timer.
263 # After event gets cancelled.
269 proc cmdsrv::StopIdleTimer {s} {
273 if {[info exists data(idleevent)]} {
274 after cancel $data(idleevent)
275 unset data(idleevent)
280 # cmdsrv::StartIdleTimer --
282 # Initiates the connection idle timer.
288 # After event gets posted.
294 proc cmdsrv::StartIdleTimer {s} {
298 set data(idleevent) \
299 [after $data(-idletime) [list [namespace current]::SockDone $s]]
302 # EOF $RCSfile: cmdsrv.tcl,v $
304 # Emacs Setup Variables
307 # indent-tabs-mode: nil
308 # tcl-basic-offset: 4