[EG]: Simple implementation of 'fifo2' channel driver in pure Tcl. See also [memchan].

======
package require Tcl 8.5

namespace eval memchan {
    variable id 0

    # fifo2 handler. This is the body of a namespace ensemble.
    # Could be a tcloo class, but I want this code to run in 8.5 without extras too
    variable f2h {
        variable events ""
        variable data   ""
        variable peerinfo   ""

        proc initialize {chan mode} {
            return [list initialize finalize watch read write cget cgetall]
        }

        proc finalize {chan} {
            variable peerinfo

            set peerchan [dict get $peerinfo chan]
            if {$peerchan in [chan names]} {
                # close the peer channel
                chan close $peerchan
            }
            destroy
        }

        proc watch {chan evs} {
            variable events
            variable data

            set events $evs
            if {[string length $data] > 0 && "read" in $events} {
                chan postevent $chan read
            }
        }

        proc write {chan str} {
            variable peerinfo

            set peercmd  [dict get $peerinfo cmd]
            set peerchan [dict get $peerinfo chan]
            $peercmd add $peerchan $str
            return [string length $str]
        }

        proc read {chan count} {
            variable data
            variable events

            set result [string range $data 0 [expr {$count - 1}]]
            set data [string range $data $count end]
            if {[string length $data] > 0 && "read" in $events} {
                chan postevent $chan read
            }
            return $result
        }

        proc cget {chan opt} {
            variable data
            variable peerinfo

            switch -exact -- $opt {
                -rlength {
                    set result [string length $data]
                }
                -wlength {
                    set peercmd [dict get $peerinfo cmd]
                    set result  [$peercmd getsize]
                }
                default {
                    return -code error "bad option \"$opt\""
                }
            }
            return $result
        }

        proc cgetall {chan} {
            foreach opt {-rlength -wlength} {
                lappend result $opt [cget $chan $opt]
            }
            return $result
        }

        proc add {chan str} {
            variable events
            variable data

            append data $str
            if {[string length $data] > 0 && "read" in $events} {
                chan postevent $chan read
            }
        }

        proc setpeerinfo {peerchan peercmd} {
            variable peerinfo

            dict set peerinfo chan $peerchan
            dict set peerinfo cmd  $peercmd
        }

        proc getsize {} {
            variable data
            return [string length $data]
        }

        proc destroy {} {
            namespace delete [namespace current]
        }

        # we rely on these two lines being the last ones on the handler body
        namespace export -clear *
        namespace ensemble create
    }
}

proc memchan::fifo2 {} {
    variable f2h
    variable id

    set hd1 [namespace eval fifo2#[incr id] $f2h]
    set hd2 [namespace eval fifo2#[incr id] $f2h]
    set fd1 [chan create {read write} $hd1]
    set fd2 [chan create {read write} $hd2]
    $hd1 setpeerinfo $fd2 $hd2
    $hd2 setpeerinfo $fd1 $hd1
    # we want immediate delivery by default
    chan configure $fd1 -buffering none
    chan configure $fd2 -buffering none

    return [list $fd1 $fd2]
}

############################################################################
# testing

if {$argv0 eq [info script]} {
    proc eventHandler {fd} {
        chan puts "Reading data from $fd"
        chan puts **[chan gets $fd]**
    }
    lassign [memchan::fifo2] fd1 fd2
    chan event $fd1 readable [list eventHandler $fd1]
    chan event $fd2 readable [list eventHandler $fd2]
    
    after 1000 {
        chan puts "Writing data into $fd1"
        chan puts -nonewline $fd1 "Hello World"
    }
    after 2000 {
        chan puts "Writing data into $fd2"
        chan puts -nonewline $fd2 "Hello There !!"
    }

    after 4000 {
        chan puts "\nDisabling $fd2 events\nWriting five lines into $fd1"
        chan event $fd2 readable {}
        chan puts  $fd1 "line 1\nline 2\nline 3\nline 4\nline5"
    }
    after 5000 {
        chan puts "Enabling $fd2 events"
        chan event $fd2 readable [list eventHandler $fd2]
    }

    after 8000 exit

    if {[info commands tk] eq ""} {
        vwait forever
    }    
}
======

<<categories>>Category Channel