- -blocksize
- "line" or an integer (default: "line"). Max # of chars read before each callback.
- -errorcommand
- command prefix (default: "channel error"). Callback to invoke if an error occurs on the channel. Called with channel, errorCode and error message args.
- -eofcommand
- command prefix (default: "chan close"). Callback to invoke when the channel reaches eof. Responsible for closing the channel.
proc accept {sock addr port} {
puts "CONNECT: $sock $addr\:$port"
chan configure $sock -buffering line
channel iterate $sock {sock line} { puts $sock $line }
# or just: channel iterate $sock puts, as puts takes the right args
}
socket -server accept 9000That's it! We can add disconnection logging easily, just change the channel iterate to: channel iterate $sock -eofcommand cleanup {sock line} { puts $sock $line }and add: proc cleanup sock {
puts "DISCONNECT: $sock"
close $sock
}Comments and suggestions very much welcome. In particular, if someone can check through the logic to make sure I have actually dealt with the various error conditions correctly. Possible future enhancements:- Add support for synchronous iteration too (i.e., basically just a read loop without using the event loop). Maybe make default, with a -async option?
- Related to above; support for blocking channels (currently all chans are configured -blocking 0).
- Should the "params body" form actually create a simple closure (as in simple closures and objects), to ease quoting issues? (Might then also add a -environment option to specify the environment dict).
- Anything else? Other commands people would like to see?
NEM slightly later: added a "with" command, which is a slight variation on using. Example:
channel with [open somefile.txt] fd { puts [read $fd] }I re-arranged the args slightly so that the channel comes before the varName. This is partly with an eye towards TOOTification -- if channel is first arg of all methods, then you can sugar an object-like interface: proc channel: {chan method args} {
uplevel 1 [linsert $args 0 ::channel $method $chan]
}
proc def {name = cmd args} { interp alias {} $name {} $cmd {*}$args }
def out = channel: [socket localhost 9000]
out configure -blocking 0 -buffering line
out puts "Enter text:"
out iterate {sock line} {
puts $line
puts $sock [gets stdin]
}
vwait foreverAlso changed the ensemble to delegate unknown commands to chan, as you can see from the above.SEH 20120502 -- If an eofcommand other than the default is specified that doesn't happen to close the channel, the command goes into an infinite loop, since a channel that has reached eof is still considered readable according to the manual. So the readable fileevent fires endlessly. I added a couple of lines to remove the readable fileevent if an error or eof is encountered (bumped version to 0.3).
Code edit
# channel.tcl --
#
# General high-level channel utilities to complement Tcl's [chan]
# ensemble.
#
# Copyright (c) 2006 Neil Madden.
#
# License: http://www.cs.nott.ac.uk/~nem/license.terms
#
package require Tcl 8.5
package provide channel 0.4
namespace eval channel {
namespace export iterate error with
namespace ensemble create -unknown ::channel::unknown
# delegate unknown commands to the ::chan ensemble
proc unknown {_ cmd args} { list ::chan $cmd }
# channel iterate chan ?options..? [cmd | params body]
#
# Arranges for a callback to be invoked for every block of data read
# from the channel. The callback can be given as either a command
# prefix list or as a pair of arguments specifying the parameters and
# body of an anonymous procedure to be invoked. In either case, the
# callback will be invoked for each block of data read from the
# channel with the channel and the data read as arguments. Note that
# the callback is executed in a new scope, rather than in the caller's
# scope, so variables defined outside of the body will not be
# visible when the body runs.
#
# OPTIONS
# -blocksize "line" or an integer > 0 [default: "line"]
# Maximum number of characters to read before each
# callback. If the value is "line" then [chan gets] is
# used rather than [chan read].
# -errorcommand cmd [default "channel error"]
# Callback to invoke if an error occurs on the
# channel. Called with the channel, the errorCode and
# the error message of the error as arguments.
# -eofcommand cmd [default "chan close"]
# Callback to invoke when the end of the channel is
# reached.
#
# RETURNS
# The channel.
#
# SIDE-EFFECTS
# Sets up a channel event handler to invoke the callback. Other
# side-effects may be caused by various callbacks. Configures the
# channel to be non-blocking.
#
proc iterate {chan args} {
set usage "channel iterate chan ?options..? (cmd | params body)"
if {[llength $args] < 1} {
return -code error "wrong # args: should be \"$usage\""
}
set options {
-blocksize "line"
-errorcommand ::channel::error
-eofcommand {::chan close}
}
if {[llength $args] % 2 == 0} {
if {[llength $args] < 2} {
return -code error "wrong # args: should be \"$usage\""
}
set params [lindex $args end-1]
set body [lindex $args end]
set ns [uplevel 1 { namespace current }]
set command [list ::apply [list $params $body $ns]]
set args [lrange $args 0 end-2]
} else {
set command [lindex $args end]
set args [lrange $args 0 end-1]
}
dict for {option value} $args {
if {![dict exists $options $option]} {
set ops [CommaJoin [dict keys $options]]
return -code error "invalid option \"$option\": must be $ops"
}
dict set options $option $value
}
chan configure $chan -blocking 0
chan event $chan readable [list [my ReadChan] $chan $command $options]
return $chan
}
# channel error chan code message --
#
# Default callback for handling errors on a channel. This callback
# simply closes the channel and then rethrows the error.
#
proc error {chan code message} {
catch { chan close $chan }
return -code error -errorcode $code $message
}
# channel with chan varName body --
#
# Assigns the varName with the channel given and then evaluates the
# body in the caller's scope. Once the body has completed the channel
# is closed (even in the case of error).
#
proc with {chan varName body} {
upvar 1 $varName var
set var $chan
set rc [catch { uplevel 1 $body } result ops]
catch { chan close $chan }
# TODO: do we need to process -level specially?
return -options $ops $result
}
interp alias {} [namespace current]::my {} namespace which -command
# CommaJoin list --
#
# Creates a human-readable version of the list, by separating elements
# with commas. The last two elements are separated by ", or " if there
# are more than 2 elements in total, and by " or " if there are
# exactly two elements.
#
proc CommaJoin list {
if {[llength $list] < 2} {
return $list
} elseif {[llength $list] == 2} {
return [join $list " or "]
} else {
set start [join [lrange $list 0 end-1] ", "]
return [concat $start ", or " [lindex $list end]]
}
}
# ReadChan chan command options --
#
# Main channel readable event handler. Invokes appropriate callbacks
# according to the condition of the channel.
#
proc ReadChan {chan command options} {
set size [dict get $options -blocksize]
if {$size eq "line"} {
set status [catch { gets $chan } data]
} else {
set status [catch { read $chan $size } data]
}
if {$status != 0} {
# Error occurred
chan event $chan readable {}
invoke [dict get $options -errorcommand] $chan $::errorCode $data
} elseif {[chan eof $chan]} {
chan event $chan readable {}
invoke [dict get $options -eofcommand] $chan
} elseif {[chan blocked $chan]} {
# Not enough data, just return
return
} else {
# OK
invoke $command $chan $data
}
}
proc invoke {cmd args} { uplevel #0 $cmd $args }
}
