Tcl Source Code

Artifact 24fbdf5512675c4e8b2c400f480a0f418b191589f6b0939a849419feb9d00952:

Attachment "refchan-async-redux.tcl" to ticket [de232b49f2] added by apnadkarni 2024-04-02 07:37:43.

---

namespace eval refchan {
    namespace ensemble create
    namespace export *
    # Change to taste depending on how much CPU you want to hog
    variable delay 0

    proc finalize {chan args} {
        namespace upvar c_$chan timer timer
        catch {after cancel $timer}
        namespace delete c_$chan
    }

    proc initialize {chan args} {
        namespace eval c_$chan {}
        namespace upvar c_$chan watching watching
        namespace upvar c_$chan timer timer
        set watching {}
        list finalize initialize seek watch write
    }


    proc watch {chan args} {
        namespace upvar c_$chan watching watching
        if {"write" in $args} {
            if {"write" ni $watching} {
                lappend watching write
            }
        } else {
            set watching {}
        }
        update $chan
    }

    proc write {chan data} {
        return [string length $data]
    }

    # paraphrased from tcllib
    proc update {chan} {
        namespace upvar c_$chan watching watching
        namespace upvar c_$chan timer timer
        variable delay
        catch {after cancel $timer}
        if {"write" in $watching} {
            set timer [after idle after $delay \
                           [namespace code [list post $chan]]]
        }
    }

    proc post {chan} {
        variable delay
        namespace upvar c_$chan watching watching
        namespace upvar c_$chan timer timer
        if {"write" in $watching} {
            set timer [after idle after $delay \
                           [namespace code [list post $chan]]]
            chan postevent $chan write
        }
    }
}
set f [chan create w [namespace which refchan]]
chan configure $f -blocking 0
set data "some data"
set x 0
chan event $f writable [namespace code {
    puts $f $data
    incr count [string length $data]
    if {$count > 262144} {
        chan event $f writable {}
        set x done
    }
}]
set token [after 10000 [namespace code {
    set x timeout
}]]
vwait [namespace which -variable x]
close $f
puts count:$count
puts $x