DKF: This page contains some experimental code to create channels (TIP#219) and transforms (TIP#230) using TclOO to provide the support machinery. It's not really finished yet.
APN tcllib has modules with TclOO-based virtual channel support classes as well as several channel implementations (possibly based on the code below).
package require TclOO 0.6
package provide chanobj 0.1
namespace eval ::chanobj {
namespace path ::oo
namespace export \
readableChannel writableChannel readwriteChannel \
readTransform writeTransform readwriteTransform
######################################################################
# Support for scripted channels a la TIP 219
#
class create Channel {
variable options channel blocking readableEvents writableEvents
constructor {initialOptions args} {
set options $initialOptions
dict set options -objectCommand [self]
}
method initialize {id mode} {
set channel $id
set methods [info object methods [self] -all]
set result {}
foreach m {
initialize finalize watch read write seek configure cget
cgetall blocking
} {
if {$m in $methods} {
lappend result $m
}
}
return $result
}
destructor {
if {$channel ne ""} {
close $channel
}
}
method finalize {id} {
set channel {}
my destroy
}
method watch {id events} {
set readableEvents [expr {"read" in $events}]
set writableEvents [expr {"write" in $events}]
}
method Post events {
chan postevent $channel $events
}
method configure {id option value} {
dict set options $option $value
}
method cget {id option} {
return [dict get $options $option]
}
method cgetall {id} {
return $options
}
method blocking {id mode} {
set blocking $mode
}
}
class create readableChannel {
superclass chanobj::Channel
variable location
constructor {initialOptions {seekable 0}} {
set location 0
if {$seekable} {
oo::objdefine [self] mixin ::chanobj::Seekable
}
next $initialOptions
}
method read {id count} {
set bytes [my ReadAt $location $count]
incr location [string length $bytes]
return $bytes
}
method ReadAt {position count} {
return -code error "method not implemented"
}
}
class create writableChannel {
superclass chanobj::Channel
variable location blocking
constructor {initialOptions {seekable 0}} {
set location 0
if {$seekable} {
oo::objdefine [self] mixin ::chanobj::Seekable
}
next $initialOptions
}
method write {id bytes} {
set length [my WriteAt $location $bytes]
incr location $length
return $length
}
method WriteAt {position bytes} {
return -code error "method not implemented"
}
}
class create readwriteChannel {
superclass chanobj::readableChannel chanobj::writableChannel
constructor {initialOptions {seekable 0}} {
next $initialOptions $seekable
}
}
class create Seekable {
variable location
method seek {id offset base} {
switch $base {
start {
if {$offset < 0} {
set location 0
} else {
set location $offset
}
}
current {
if {$offset + $location < 0} {
set location 0
} else {
incr location $offset
}
}
end {
set end [my GetEnd]
if {$offset + $end < 0} {
set location 0
} else {
set location [expr {$offset + $end}]
}
}
}
return $location
}
method GetPosition {} {
return $location
}
method GetEnd {} {
return -code error "method not implemented"
}
}
######################################################################
# Support for scripted channel transformss a la TIP 230
#
class create Transform {
variable chan readFilter writeFilter
constructor {channelId} {
set chan $channelId
chan push $chan [self]
}
destructor {
if {$chan ne ""} {
chan pop $chan
}
}
method initialize {handle mode} {
set readFilter [expr {"read" in $mode}]
set writeFilter [expr {"write" in $mode}]
set result {}
set methods [info object methods [self] -all]
foreach m {
clear finalize initialize
drain limit? read
flush write
} {
if {$m in $methods} {
lappend result $m
}
}
return $result
}
method finalize {handle} {
set chan {}
}
method clear {handle} {
}
}
class create readTransform {
variable defaultLimit
superclass chanobj::Transform
constructor channelId {
next $channelId
set defaultLimit -1
}
method drain {handle} {
my read $handle {}
}
method limit? {handle} {
return $defaultLimit
}
method read {handle buffer} {
my TransformIn $buffer
}
method TransformIn {binData} {
return $binData
}
}
class create writeTransform {
superclass chanobj::Transform
method flush {handle} {
my write $handle {}
}
method write {handle buffer} {
my TransformOut $buffer
}
method TransformOut {binData} {
return $binData
}
}
class create readwriteTransform {
superclass chanobj::readTransform chanobj::writeTransform
}
}
if 0 {Now for the demonstration of the above machinery.
}
if {$::argv0 eq [info script]} {
namespace import chanobj::*
oo::class create uppercaser {
superclass readTransform
constructor ch {
next $ch
# Since we're going to unstack and we're simple, we need to make
# the limit small to curb buffering problems.
my variable defaultLimit
set defaultLimit 1
}
method TransformIn data {
# A very simple upper-casing example
return [string toupper $data]
}
}
oo::class create mangler {
superclass writeTransform
method TransformOut data {
binary scan $data c* v
set i -1
foreach c $v {
incr i
if {$c >= 32} {
lset v $i [expr {$c | 1}]
}
}
binary format c* $v
}
}
oo::class create stringChan {
superclass readableChannel
variable s
constructor {string encoding} {
next [dict create -original $string] 0
set s [encoding convertto $encoding $string]
}
method ReadAt {p c} {
return [string range $s $p [expr {$p+$c-1}]]
}
self method new {s {enc utf-8}} {
set c [chan create read [next $s $enc]]
chan configure $c -encoding $enc
return $c
}
}
oo::class create hopper {
superclass writableChannel
variable buf
constructor {} {
next {} 0
set buf {}
}
method WriteAt {pos bytes} {
# Not seekable, so can ignore $pos
append buf $bytes
return [string length $bytes]
}
method cget {id opt} {
if {$opt eq "-data"} {
return $buf
}
next $id $opt
}
method cgetall {id} {
dict replace [next $id] -data $buf
}
self method new {} {
chan create write [next]
}
}
set f [open [info script]]
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts ---------
set xform [uppercaser new $f]
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts ---------
$xform destroy
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts ---------
set xform [mangler new stdout]
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts ---------
$xform destroy
puts [gets $f]
puts [gets $f]
puts [gets $f]
puts [gets $f]
close $f
puts ---------
set f [stringChan new "1 potato\n2 potato\n3 potato\n4...\n"]
puts [gets $f]
puts [gets $f]
puts [gets $f]
# Next line used to test untidy closing behaviour.
#[fconfigure $f -objectCommand] destroy
chan copy $f stdout
close $f
puts ---------
set f1 [hopper new]
puts $f1 "The quick brown fox"
puts $f1 "jumps over the lazy dog."
flush $f1
puts -nonewline [fconfigure $f1 -data]
close $f1
puts ---------
}