########
#
# After at most $timeout milliseconds, return a string of at most $number_of_characters.
#
# [Hide stuff inside some namespace.]
#
########
proc read_with_timeout {channel number_of_characters timeout} {
# Preserve existing fileevent on $channel in order to restore it on return.
# Define timeout handler.
# Create character-at-a-time fileevent handler which accumulates result string.
# Restore original fileevent.
}Variation, from entirely different direction: Expect's timeout.
Also note that some channels (serial ports?) already admit timeout configuration.Is it time for a TIP to propose that Tcl do this for all platforms/devices/...?
Not sure why you only want to have a "character-at-a-time" fileevent handler, but if you care to do this more efficiently (reading in chunks), does something like the following do what you want? (forgive the verbosity and lack of testing, I just coded this up in a few minutes)- Todd Coram
namespace eval ::timed {
variable orig_event
variable orig_config
variable result
variable error
array set orig_event [list]
array set orig_config [list]
array set result [list]
array set error [list]
proc read {channel count timeout} {
variable orig_event
variable orig_config
variable error
variable result
set orig_event($channel) [fileevent $channel readable]
set orig_config($channel) [fconfigure $channel]
set result($channel) ""
set error($channel) ""
fconfigure $channel -blocking 0
set timer_id [after $timeout \
[namespace code [list cancel $channel "timeout"]]]
fileevent $channel readable\
[namespace code [list read_accum $channel $count ""]]
vwait ::timed::result($channel)
after cancel $timer_id
if {[llength $orig_event($channel)] > 0} {
fileevent $channel readable $orig_event($channel)
}
eval fconfigure $channel $orig_config($channel)
if {$error($channel) != ""} {
error $error($channel)
}
return $result($channel)
}
proc gets { channel timeout { line_p "" } } {
if { $line_p ne "" } {
upvar $line_p line
}
set size 0
set line ""
while { 1 } {
if { [catch {[namespace current]::read $channel 1 $timeout} char] } {
return -1
} elseif { $char eq "\n" } {
if { $line_p eq "" } {
return $line
} else {
return [string length $line]
}
} else {
append line $char
}
}
}
proc read_accum {channel count accum} {
variable result
set bytes [::read $channel $count]
if {[eof $channel]} {
cancel $channel "eof"
return
}
append accum $bytes
incr count -[string bytelength $bytes]
if {$count > 0} {
fileevent $channel readable \
[namespace code [list read_accum $channel $count $accum]]
} else {
set result($channel) $accum
}
}
proc cancel {channel reason} {
variable result
variable error
set result($channel) ""
set error($channel) "[namespace current]::read failed: $reason"
}
}EF I have modified the code above so that it also supports a gets-level. The code does no buffering, so it is not for production use. Also, I changed the behaviour of read_accum so that it only sets the result once all data asked for has been read, which should better comply to what the regular read command does.George Peter Staplin: I corrected the namespace usage with variable, because the namespace resolution rules outside of procedures are less than ideal. This may be fixed in the core for Tcl 9.0. For example:
$ tclsh8.4
% set g "I'm global"
I'm global
% namespace eval ::Timed { set g "I'm in ::Timed -- I think" }
I'm in ::Timed -- I think
% set g
I'm in ::Timed -- I thinkFurthermore I think that string bytelength is probably not what is desired. It's rarely what is needed even with binary data. See the manual and wiki pages for string bytelength.George Peter Staplin Jan 9, 2006 - I wrote my own solution to this problem. It seems to work properly based on my testing. I used patterns from An Alternative to Namespace for creating code that should support any namespace. You can also of course use cat file.tcl | sed s/NS_/whatever/g > whatever.tcl
# By George Peter Staplin
# Revision 5
proc NS_gets {fd timeout} {
#
# NS_read emulates gets when len is -1.
#
NS_read $fd -1 $timeout
}
proc NS_read {fd len timeout} {
global NS_read_state
set NS_read_state($fd,error) 0
set NS_read_state($fd,remaining) $len
set NS_read_state($fd,timeout) [after $timeout [list NS_read.abort $fd]]
set NS_read_state($fd,pending_data) ""
set NS_read_state($fd,data) ""
set NS_read_state($fd,old_fileevent) [fileevent $fd readable]
set NS_read_state($fd,old_blocking) [fconfigure $fd -blocking]
fconfigure $fd -blocking 0
fileevent $fd readable [list NS_read.callback $fd]
vwait NS_read_state($fd,data)
#
# Copy the data object so that we can cleanup the NS_read_state array.
#
set data $NS_read_state($fd,data)
#
# Copy the error object for the same reason as above.
#
set error $NS_read_state($fd,error)
#
# Replace the fileevent with the previous fileevent handler.
# We do this so that any fileevent handler prior to NS_read will be restored.
#
fileevent $fd readable $NS_read_state($fd,old_fileevent)
#
# Restore the original blocking mode, so that any other fileevents
# or reads will work as before the NS_read/NS_gets.
#
fconfigure $fd -blocking $NS_read_state($fd,old_blocking)
#
# Cleanup the state, because we are about to return.
#
array unset NS_read_state $fd,*
if {$error} {
#
# A timeout error occured during the read.
#
return -code error $data
}
return $data
}
proc NS_read.callback fd {
global NS_read_state
if {-1 == $NS_read_state($fd,remaining)} {
#
# We are supposed to emulate gets, so read until \n
#
append NS_read_state($fd,pending_data) [set c [read $fd 1]]
if {"\n" eq $c} {
#
# This causes the vwait in NS_read to release, so that we
# can return a result in NS_read.
#
set NS_read_state($fd,data) $NS_read_state($fd,pending_data)
#
# Cancel the timeout, because we are done reading, and we don't
# want it firing now that we have all of the data.
#
after cancel $NS_read_state($fd,timeout)
}
return
}
append NS_read_state($fd,pending_data) \
[set chunk [read $fd $NS_read_state($fd,remaining)]]
#
# We could use incr var -[string length ...] but that results in shimmering.
# This is a little faster normally, because it avoids shimmering.
#
set NS_read_state($fd,remaining) \
[expr {$NS_read_state($fd,remaining) - [string length $chunk]}]
if {$NS_read_state($fd,remaining) <= 0} {
set NS_read_state($fd,data) $NS_read_state($fd,pending_data)
after cancel $NS_read_state($fd,timeout)
}
}
proc NS_read.abort fd {
global NS_read_state
#
# The timeout was reached before enough data could be read.
# By setting the error key, and the data in this manner the
# NS_read will return -code error with the data as the message.
#
set NS_read_state($fd,error) 1
set NS_read_state($fd,data) "NS_read timeout"
}
proc main { } {
puts -nonewline "NS_read enter 4 characters followed by Return: "
flush stdout
puts READ10:[NS_read stdin 5 3000]
puts -nonewline "NS_gets: "
flush stdout
puts GETS:[NS_gets stdin 3000]
catch {vwait forever}
}
mainRFox June 11, 2012 There's a really nasty and not too uncommon case where this breaks down. Suppose this is part of a package that is communicating with some device or remote thingy. The remote thing gets commands, and then returns responses. The remote thingy has a manual, local control, and you'd like a user interface to reflect that the manual control is on so you use an self rescheduling after proc to send status requests that ask the device if it's in remote mode...and again read with timeout.What can happen is that you are in the vwait for the response from a command and, since vwait runs the event loop, the after can and does fire...and you re-enter the whole thing...at which point all holy heck breaks loose.
ES - 2016-06-03 20:42:46I read the challenge and said this should be easy. I read the proposed solutions and could not comprehend the need for such complexity. I tried a simple code that I thought should do the same, but it did not work. Now I am confused! Should this not have worked as is?Let's say I expect 1024 bytes to come in through a serial port, opened and set to -blocking true mode. If something goes wrong and the receive takes longer than 1s, let's bail:
set P_tty [open /dev/ttyUSB0 RDWR]
chan configure $P_tty -mode 38400,n,8,1 -buffering none -blocking true -translation binary -eofchar {}
set size 1024
# either a completed (blocking) read of all data, or a 1s timeout, whatever comes first
after 1000 {set timeout 1}
set databuffer [read $P_tty $size]
set timeout 0
vwait timeout
if {$timeout} {
puts [format "Timed out, received only %d bytes" [string length $databuffer]]
} \
else {
puts [format "Received %d data, as requested" [string length $databuffer]]
}bll 2016-6-3 Your read is blocking. Even though the after will run, your code will never reach the vwait. There's no way to interrupt the read. The channel has to be non-blocking, then: # this is a code snippet to demonstrate one possible method of solving timeouts
fconfigure $chan -blocking false
fconfigure $chan -buffering line
set myflag 0
fileevent $chan readable [list set myflag 2]
after 2000 [list set myflag 1] ; # timeout
# wait for either data to come in or for a timeout to occur
vwait myflag
# at this point, even though there may be data on the channel, it probably
# is only the first character, and you will need to wait for the rest of the data
# to be recieved. This can be done a character at a time like the above code, or...
if { $myflag == 2 } {
fconfigure $chan -blocking true
# note that this will stop all processing while the gets waits for the data to arrive.
# if you don't want to stop processing, it needs to be coded differently.
# Also note, that this will not handle receipt of partial data -- the timeout is
# no longer active. This is only good for well behaved, known interfaces.
set rc [gets $chan line]
fconfigure $chan -blocking false
}ES - 2016-06-05 01:17:03Thanks for that. I guess my implicit assumption was that after 1000 {...} sort of runs in its own thread, and interrupts this - blocked - thread when the counter expires.However, your scheme will only work when the incoming channel is line-by-line. In my (hardware-related) application, there is an unstructured stream of bytes, and I want to get them in as fast as possible. I know there are at most N bytes, but I also know that the channel may drop bytes, in which case I may never get my full N count, so I need to time out and ask for a re-send.Perhaps this could do it?
chan configure $P_tty -mode 38400,n,8,1 -buffering auto -blocking false -translation binary -eofchar {}
after 1000 {set timeout 1}
set databuffer {}
while 1 {
append databuffer [read $P_tty $size]
if { [string length $databuffer] >= $size} { break }
}
set timeout 0
vwait timeoutbll 2016-6-4 Not exactly. That would get stuck in the while loop forever.If you receive any data, the timer should be started over (this is the common situation, I'm sure there are applications where a single global timeout is wanted).With a busy loop like this, you don't need the vwait at all. This is not an event driven model.set timeout 0
set rcvsize 0
set afterid [after 1000 {set timeout 1}]
while { $timeout == 0 && $rcvsize < $size } {
set txt [read $P_tty $size]
set len [string length $txt]
if { $len > 0 } {
after cancel $afterid
append databuffer $txt
incr rcvsize $len
set afterid [after 1000 {set timeout 1}]
}
after 1 ; # so it doesn't suck up all the CPU.
}An event driven model will leave your GUI responsive, and other processing can be done, the read can be cancelled, etc. and you don't have to worry about it eating up all the CPU resources. An event driven model would be something along these lines:proc rcvdata { } {
global vars
after cancel $vars(afterid)
set txt [read $chan $vars(size)]
set len [string length $txt]
incr vars(totsize) $len
append vars(databuffer) $txt
if { $vars(totsize) > $vars(size) } {
set vars(myflag) 2
return
}
set vars(afterid) [after $vars(timeout) [list set vars(myflag) 1]]
}
global vars
set vars(size) 1024
set vars(myflag) 0
set vars(totsize) 0
set vars(databuffer) {}
set vars(timeout) 1000
set vars(afterid) [after $vars(timeout) [list set vars(myflag) 1]]
fileevent $chan readable rcvdata
vwait vars(myflag)
fileevent $chan readable {} ; # turn off fileevent handler.
# check $vars(myflag) -- 1 is a timeout, 2 means the databuffer is full
I haven't tested this, if you want me to make sure it works, drop another note in here or e-mail me.ES - 2016-06-06 14:14:38I see. Aside from the issue of global vs. per-read timeout, your v.1 is exactly the same as mine, except there is no vwait, and that's what I wanted: a "blocking" read as fast as possible but with a bail out if things go wrong. In my case of an external hardware which must be serviced as fast as possible a brief spike in CPU is fine. Most of the time, the first read will complete the operation, it's just for those rare occasions that the real-world interference causes a packet drop. I am thinking I should actually calculate the timeout time as size divided by baud rate, +20%, though for USB "serial" ports that number will be a gross overkill, as the actual comm speeds are of the order 1-3Mbs, not 38.4kbs - the "BAUD_RATE" is not real. For the actual serial links, this should be OK: [Edited]
set BAUD_RATE 38400
set size 1024
chan configure $P_tty -mode $BAUD_RATE,n,8,1 -buffering auto -buffersize $size -blocking false -translation binary -eofchar {}
set timeout 0
after [expr 1200*$size/($BAUD_RATE/8)] {set timeout 1}
set databuffer {}
while {$timeout == 0} {
append databuffer [read $P_tty $size]
if { [string length $databuffer] >= $size} { break }
after 1 ;# to ensure GUI remains alive
}I will test your event-driven version; my gut feeling is it will be too slow. Thanks!