Tcl Source Code

Artifact f600e520b917408c622f0493268a410594921796:

if {[llength $argv]!=1} {
    puts stderr "Usage: tclsh server.tcl <PAUSE_TIME>"
    puts stderr "  where PAUSE_TIME is in ms."
    exit
}

set PAUSE_TIME [lindex $argv 0]

proc ReadMe { chan } {
    global input_count write_queue write_error PAUSE_TIME
    if {[catch {gets $chan line} bytes]} {
	puts "INPUT ERROR on socket $chan: $bytes"
	return
    }
    if {$bytes < 0} {
	if {[fblocked $chan]} {
	    # 'gets' call is blocked until a whole line is available
	    return
	}
	if {[eof $chan]} {
	    puts "INPUT EOF detected on socket $chan; closing socket."
	    close $chan
	    unset input_count($chan)
	    unset write_error($chan)
	    unset write_queue($chan)
	    return
	}
    }
    puts [format "\[%2d\]==>$line" [incr input_count($chan)]]
    set outmsg [format "Message %2d received: $line" $input_count($chan)]
    if {!$write_error($chan)} {
	lappend write_queue($chan) $outmsg
	fileevent $chan writable [list WriteMe $chan]
    }
    return 0
}

proc WriteMe { chan } {
    global write_queue write_error

    if {!$write_error($chan)} {
	set response [lindex $write_queue($chan) 0]
	puts " Response: $response"
	if {[catch {puts $chan $response} errmsg]} {
	    puts "OUTPUT ERROR on socket $chan: $errmsg"
	    set write_error($chan) 1
	    return
	}
    }
    set write_queue($chan) [lrange $write_queue($chan) 1 end]
    if {[llength $write_queue($chan)]<1} {
	fileevent $chan writable {}
    }

}

proc Service { chan addr port } {
    global input_count write_error write_queue
    fconfigure $chan -blocking 0 -buffering line -translation {auto crlf}
    fileevent $chan readable "[list ReadMe $chan]; after \$PAUSE_TIME"
    set input_count($chan) 0
    set write_error($chan) 0
    set write_queue($chan) {}
}

set sock [socket -server Service 11111]

vwait forever