[[Group project!]] ######## # # 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 port]s?) 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 think Furthermore 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} } main ------ [RFox] 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. ====== <> Channel