[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.

----
======
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 ---------
}
======
----
!!!!!!
%| [Category Object Orientation] | [Category Package] |%
!!!!!!