#! /usr/bin/env tclsh
namespace eval interface {
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl eval} {
upcall
}
{ycl ns} {
nsjoin join
nscall
object
}
{ycl proc} {
imports
}
}
proc new name {
variable systemns
set new [upcall 1 object $name]
$new .extend $systemns
$new = refchan [chan create {read write} [list $new]]
return $new
}
variable systemns [nsjoin [namespace parent] system]
imports [namespace parent] [namespace current] {
new
}
}
namespace eval system {
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl ns} {
nsjoin join
}
{ycl proc} {
checkargs
}
{ycl var} {
$
}
}
alias chan_ [nsjoin {} chan]
namespace eval doc {}
variable doc::.init {
args {
_ {}
chan {
description {
the {ycl chan} to reflect
}
}
}
}
proc .init {_ args} {
$_ .vars chan deletechan
set deletechan 0
checkargs [$ doc .init] {*}$args
# the channel must remain in binary mode as long as it is backing
# a reflected channel
$chan configure -translation binary
return $_
}
proc blocking {_ chanid mode} {
# to do
# does Tcl call [watch] to update interest or is the call to this
# routine the signal to change interest?
#
# for now
# assume that Tcl calls [watch]
$_ .vars blocking chan
set wasblocking $blocking
set blocking $mode
$chan configure -blocking $mode
}
proc chan _ {
$_ .vars refchan
return $refchan
}
proc cget {_ chanid args} {
$_ .vars chan
$chan configure {*}$args
}
proc cgetall {_ chanid args} {
$_ .vars chan
$chan configure {*}$args
}
proc configure {args} {
$_ .vars chan
tailcall $chan configure {*}$args
}
proc finalize {_ chanid args} {
$_ .vars chan deletechan
try {
if {$deletechan} {
rename $chan {}
}
} finally {
rename $_ {}
}
return
}
proc initialize {_ chanid mode} {
$_ .vars blocking chan readposted watchread watchwrite
set blocking 0
set readposted 0
set watchread 0
set watchwrite 0
return {
blocking configure cget cgetall
finalize initialize read seek watch write
}
}
proc read {_ chanid args} {
$_ .vars blocking chan readposted watchread
set data [$chan read {*}$args]
set readposted 0
if {!$blocking} {
if {$watchread} {
if {[$chan pending input] > 0} {
after 0 [list $_ readevent $chanid]
set readposted 1
}
}
if {$data eq {} && ![$chan eof]} {
return -code error EAGAIN
}
}
return $data
}
proc readevent {_ chanid} {
$_ .vars readposted watchread
set readposted 0
if {$watchread} {
chan_ postevent $chanid read
}
}
proc seek {_ chanid offset base} {
$_ .vars chan
tailcall $chan seek $offset $base
}
proc watch {_ chanid eventspec} {
$_ .vars chan watchread watchwrite
if {{read} in $eventspec} {
set watchread 1
$chan event readable [list $_ readevent $chanid]
} else {
set watchread 0
$chan event readable {}
}
if {{write} in $eventspec} {
set watchwrite 1
$chan event writable [list $_ writeevent $chanid]
} else {
set watchwrite 0
$chan event writable {}
}
}
proc write {_ chanid data} {
$_ .vars chan
$chan puts -nonewline $data
# write is only called when Tcl really wants something written to the lower channel
#
# so flush as well
$chan flush
return [string length $data]
}
proc writeevent {_ chanid} {
chan_ postevent $chanid write
}
}