#! /bin/env tclsh
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl ns} {
nsjoin join
variable
which
}
}
variable procs
apply [list {} {
foreach name {double min} {
alias $name [nsjoin {} tcl mathfunc $name]
}
foreach name {+ - /} {
alias $name [nsjoin {} tcl mathop $name]
}
} [namespace current]]
package require {ycl chan methods}
package require {ycl string}
aliases {
{ycl coro call} {
autocall
body
hi
last
reply
}
{ycl eval} {
upcall
}
{ycl knit} {
knit
}
{ycl ns} {
nsjoin join
normalize
object
}
{ycl proc} {
checkargs
}
{ycl string} {
stringcmp cmp
}
}
variable {doc carve} {
description {
carve parts out of the data in a channel
write the remainder to a new channel
}
arguments {
in {
description {
the channel to carve
}
}
out {
description {
the channel to write the remainder to
}
}
skip {
description {
a list where every two items are
the offset at which to skip
the number of bytes to skip
}
}
}
}
proc carve {in out skip} {
set last 0
set cursor 0
foreach {location size} $skip {
if {$location <= $last} {
error [list {locations out of order}]
}
set last $location
set needed [expr {$location - $cursor}]
if {$needed > 0} {
chan copy $in $out -size $needed
}
seek $in $size current
set cursor [expr {$cursor + $needed + $size}]
}
chan copy $in $out
return
}
variable {doc comp} {
description {
Compare contents of two channels, returning the index of the first
character that differs, or -1.
}
}
knit cmp_async {chan1 chan2 {chunksize 65535}} {
set cursor 0
[` foreach x {1 2} {
set buf${x} {}
set buf${x}size 0
}]
while 1 {
[` foreach x {1 2} {
set chunk#{x} [read $chan#{x} $chunksize]
set chunk#{x}size [string length $chunk#{x}]
append buf#{x} $chunk#{x}
incr buf#{x}size $chunk#{x}size
}]
set size [min $buf1size $buf2size]
[` foreach x {1 2} {
set chunk#{x} [string range $buf#{x} 0 $size-1]
set buf#{x} [string range $buf#{x}[set buf#{x} {}] $size end]
set buf#{x}size [- $buf#{x}size $size]
}]
set cursor2 [stringcmp $chunk1 $chunk2]
if {$cursor2 >= 0} {
set cursor [+ $cursor $cursor2]
return $cursor
} else {
incr cursor $size
}
if {[eof $chan1] && [eof $chan2]} {
return -1
}
}
yield
}
proc cmp_coro {chan1 chan2 {chunksize 65536}} {
yield [info coroutine]
cmp_async $chan1 $chan2 $chunksize
}
proc cmp_new {chan1 chan2 {chunksize 655366}} {
set name [nsjoin # [info cmdcount]]
coroutine $name cmp_coro $chan1 $chan2 $chunksize
}
proc cmp {chan1 chan2 {chunksize 65536}} {
set coro [cmp_new $chan1 $chan2 $chunksize]
while {[namespace which $coro] ne {}} {
set res [$coro]
}
return $res
}
proc command {chan wordname} {
upvar $wordname word
commandmethod [list [which gets] $chan] [list [which eof] $chan] word
}
dict set doc routines commandmethod {
description {
reads a command from a channel
where each command is represented as a list followed by a newline
i.e. [info complete] returns true for the command
but not for any prefix of it
filtering out empty commands is out of the scope of this routine
stores the command in the variable having the specified name
}
}
proc commandmethod {gets eof commandvar} {
upvar $commandvar command
set command {}
while 1 {
set count [{*}$gets line]
if {$count < 0} {
if {[{*}$eof]} {
if {[string length $command]} {
error [list {incomplete command}]
}
set wordname {}
return -1
}
} else {
append command $line
if {[info complete $command\n]} {
return [string length $command]
} else {
append command \n
}
}
}
}
proc connect {chan1 chan2} {
package require Thread
namespace eval [nsjoin {} thread] {
namespace ensemble create
namespace export *
}
set tid [thread create]
if {[chan pending output $chan1] > -1} {
lassign [chan pipe] pr1 pw1
} else {
set pr1 {}
set pw1 {}
}
if {[chan pending input $chan2] > -1} {
lassign [chan pipe] pr2 pw2
} else {
set pr2 {}
set pw2 {}
}
foreach name [list $chan1 $chan2 $pr1 $pw2] {
if {$name ne {}} {
chan configure $name -blocking 0
thread transfer $tid $name
}
}
# send async because the thread can actually finish up and [thread release]
# before this call returns
thread send -async $tid [list apply [list {
sourcechan targetchan inchan outchan} {
try {
namespace eval thread {
namespace ensemble create
namespace export *
}
proc copy {source target} {
puts -nonewline $target [read $source 8192]
}
proc outwrite {source target} {
variable targetread
variable outwrite
if {$targetread} {
copy $source $target
set targetread 0
set outwrite 0
} else {
set outwrite 1
}
}
proc sourcein {source target} {
variable sourcein
variable sourcewrite
if {[eof $source]} {
close $source read
close $target write
return
}
if {$sourcewrite} {
copy $source $target
set sourcein 0
set sourcewrite 0
} else {
set sourcein 1
}
}
proc sourceread {source target} {
variable sourceread
variable targetwrite
if {[eof $source]} {
close $source read
close $target write
return
}
if {$targetwrite} {
copy $source $target
set targetwrite 0
set sourceread 0
} else {
set sourceread 1
}
}
proc sourcewrite {source target} {
variable sourcein
variable sourcewrite
if {$sourcein} {
copy $source $target
set sourcein 0
set sourcewrite 0
} else {
set sourcewrite 1
}
}
proc targetread {source target} {
variable targetread
variable outwrite
if {[eof $source]} {
close $source read
close $target write
thread release
return
}
if {$outwrite} {
copy $source $target
set targetread 0
set outwrite 0
} else {
set targetread 1
}
}
proc targetwrite {source target} {
variable sourceread
variable targetwrite
if {[eof $source]} {
if {[chan pending input $target] == -1} {
close $target
thread release
}
}
if {$sourceread} {
copy $source $target
set sourceread 0
set targetwrite 0
} else {
set targetwrite 1
}
}
variable sourceread 0
variable sourcewrite 0
variable targetread 0
variable targetwrite 0
variable outwrite 0
variable outread 0
variable sourcein 0
variable targetin 0
if {$inchan ne {}} {
chan event $inchan readable [list sourcein $sourcein $sourcechan]
chan event $sourcechan writable [list sourcewrite $sourcein $sourcechan]
}
chan event $sourcechan readable [list sourceread $sourcechan $targetchan]
chan event $targetchan writable [list targetwrite $sourcechan $targetchan]
if {$outchan ne {}} {
chan event $targetchan readable [list targetread $targetchan $outchan]
chan event $outchan writable [list outwrite $targetchan $outchan]
}
} on error {tres topts} {
puts stderr $tres
}
}] $chan1 $chan2 $pr1 $pw2]
return [list $pw1 $pr2]
}
# Expects to be called from an asynchronous coroutine
proc events {chan args} {
dict update args readable readable writable writable {}
set res {}
catch {[dict set res readable [chan event $chan readable]]}
catch {[dict set res writable [chan event $chan writable]]}
# Because [catch] swallows any errors below, produce an error here if not
# in a coroutine .
yieldto [info coroutine]
if {[info exists readable]} {
catch [list chan event $chan readable $readable]
}
if {[info exists writable]} {
catch [list chan event $chan writable $writable]
}
return $res
}
variable doc::gets {
description {
get the next line from the channel or cause the caller to break
if there is no next line
returns an error in the case of a partial read (data at the end of the
file not followed by a newline)
}
}
proc gets {chan args} {
tailcall dogets [list coroutine::util gets $chan] [
list eof $chan] [list ::chan blocked $chan] {*}$args
}
proc dogets {gets eof blocked args} {
package require coroutine
proc dogets {gets eof blocked args} {
if {[llength $args] == 1} {
set varmode 1
upvar [lindex $args 0] var
} elseif {[llength $args] > 1} {
# produce an error message
::gets stdout {*}$args
} else {
set varmode 0
}
if 0 {
to do
test that -1 is correctly returned in all relevant cases
}
while {![{*}$eof]} {
set line [{*}$gets]
set len [string length $line]
if {[{*}$eof]} {
if {$line ne {}} {
error [list {partial read}]
}
set len -1
} elseif {$len == 0} {
if {[{*}$blocked]} {
set len -1
}
}
if {$varmode} {
set var $line
return $len
} else {
return $line
}
}
return -code break
}
tailcall dogets $gets $eof $blocked {*}$args
}
variable {doc interpolate} {
description {
interplate parts into a channel
}
args {
carved {
description {
channel containing data to be transformed by interpolation
}
}
out {
description {
channel to write the transformed data to
}
}
content {
description {
a command that
each time it is called returns
a list containing
an offset at which to interpolate data
a channel containing data to interpolate
returns -code break when there is nothing else to
interpolate
closes each channel that it reads data to interpolate from
}
}
}
}
proc interpolate {carved out content} {
set cursor 0
while 1 {
lassign [{*}$content] offset chan
try {
set needed [expr {$offset - $cursor}]
if {$needed} {
set copied1 [chan copy $carved $out -size $needed]
}
set copied2 [chan copy $chan $out]
} finally {
close $chan
}
set cursor [expr {$cursor + $copied1 + $copied2}]
}
chan copy $carved $out
return
}
proc isatty chan {
#{to do} {Handle more platforms}
expr {[catch {chan configure $chan -mode}] == 0}
}
variable {doc iter} {
description {
Sets a channel to non-blocking and produces a {ycl coro call autocall}
command to iterate through the contents of the channel .
}
}
proc iter chan {
set name [nsjoin [namespace current] [info cmdcount]]
set coro [coroutine $name\0 apply [list chan [body {
set chan_blocking_orig [chan configure $chan -blocking]
chan configure $chan -blocking 0
set buf {}
set args [lassign [hi] cmd]
while 1 {
switch $cmd {
eof {
set eof [expr {[llength $buf] == 0 && [eof $chan]}]
set args [lassign [reply $eof] cmd]
}
prepend {
set buf [linsert $buf[set buf {}] 0 {*}[split [lindex $args[set args {}] 0] {}]]
set args [lassign [reply $buf] cmd]
}
next {
set args [dict merge {size 1} $args[set args {}]]
dict update args size size {}
if {[llength $buf]} {
set buf [lassign $buf[set buf {}] char]
set args [lassign [reply $char] cmd]
} else {
set saved [[yclprefix] chan chan events $chan readable [list [info coroutine]]]
while 1 {
yield
lappend buf {*}[split [read $chan 8192] {}]
if {[llength $buf]} {
[yclprefix] chan chan release $chan $saved
break
} else {
if {[eof $chan]} {
[yclprefix] chan chan release $chan $saved
# A channel that is currently [eof] may
# change state to not [eof] later, so don't
# return here , allowing caller to decide .
#return
set args [lassign [last] cmd]
break
}
}
}
}
}
default {
error [list {unknown subcmd} $cmd]
}
}
}
}] [namespace current]] $chan]
autocall $name
}
variable {doc iter_lines} {
description {
Produce a {ycl coro call autocall} command that iterates through the
lines of data in a channel.
}
args {
chan {
description {
A channel.
}
positional true
}
}
actions {}
}
proc iter_lines chan {
set name [nsjoin [namespace current] [info cmdcount]]
coroutine $name\0 apply [list chan [body {
hi
while 1 {
set line [{*}$chan gets]
if {$line eq {} && [{*}$chan eof]} {
last -code break
}
reply $line
}
}] [namespace current]] $chan
autocall $name
}
variable {doc osboth} {
description
[osout] and [osin] together
returns
list
input channel
output channel
both are configured to -translation binary -blocking 0
}
proc osboth chan {
lassign [chan pipe] pr1 pw1
lassign [chan pipe] pr2 pw2
chan configure $pr1 -translation binary -blocking 0
chan configure $pw1 -translation binary -blocking 0
chan configure $pr2 -translation binary -blocking 0
chan configure $pw2 -translation binary -blocking 0
set coro1 [coroutine osboth_out_[info cmdcount] \
osout_main $chan $pw1 $pr2 0]
coroutine osboth_in_[info cmdcount] osboth_in \
$pr2 $chan $pw2 $coro1
list $pr1 $pw2
}
proc osboth_in {chan write upstream coro} {
chan event $chan readable [list [info coroutine] \
$chan $write $upstream $coro]
lassign [yieldto return -level 0 [info coroutine]] chan write upstream coro
while 1 {
chan event $chan readable {}
chan event $write writable [list [info coroutine]]
set res [yield]
chan event $write writable {}
set data [read $chan 8192]
if {[string length $data]} {
if {[eof $write]} {
chan event $write readable [list $coro]
}
puts -nonewline $write $data
}
if {[eof $chan]} {
flush $write
return
} else {
chan event $chan readable [
list [info coroutine] $chan $write $upstream $coro]
lassign [yieldto return -level 0] chan write upstream coro
}
}
}
variable {doc osin} {
description
like [osout] but creates an os pipe that feeds $chan
returns
the writable channel of the pipe
configured to -translation binary -blocking 0
}
proc osin chan {
lassign [chan pipe] pr1 pw1
chan configure $pr1 -translation binary -blocking 0
chan configure $pw1 -translation binary
coroutine osin_[info cmdcount] osin_main $pr1 $chan $pr1
return $pw1
}
proc osin_main {chan write upstream} {
chan event $chan readable [list [info coroutine] \
$chan $write $upstream]
lassign [yieldto return -level 0 [info coroutine]] chan write upstream
set count 0
while 1 {
chan event $chan readable {}
chan event $write writable [list [info coroutine]]
set res [yield]
chan event $write writable {}
set data [read $chan 8192]
if {[string length $data]} {
incr count [string length $data]
puts -nonewline $write $data
}
if {[eof $chan]} {
if {[eof $upstream]} {
close $write
return
} else {
yield
}
} else {
chan event $chan readable [
list [info coroutine] $chan $write $upstream]
lassign [yieldto return -level 0] chan write upstream
}
}
}
variable {doc osout} {
description {
create an os pipe fed by $chan
the returned channels are configured to -translation binary
and the original channel retains its configuration
this makes the returned channels suitable for redirection via
[exec]
to read or write to one of the returned channels in Tcl
configure the original channel to -translation binary after
converting it with this routine
and configure the returned channels to the desired encoding and
translation
when the os channel is going to be used in an [exec]
redirction and encoding/translation are desired
the caller can reconfigure the original channel after creating the
output pipe
}
args {
chan
description
the channel that feeds the pipe
}
returns
the read side of the pipe
configured to -translation binary -blocking 0
}
proc osout chan {
lassign [chan pipe] pr1 pw1
chan configure $pr1 -translation binary
chan configure $pw1 -translation binary -blocking 0
coroutine osout_[info cmdcount] osout_main $chan $pw1 $chan 0
return $pr1
}
proc osout_main {chan write upstream cursor} {
chan event $chan readable [list [info coroutine] \
$chan $write $upstream $cursor]
lassign [yieldto return -level 0 [info coroutine]] chan write upstream cursor
while 1 {
chan event $chan readable {}
chan event $write writable [list [info coroutine]]
set res [yield]
chan event $write writable {}
seek $chan $cursor
set data [read $chan 8192]
set cursor [tell $chan]
if {[string length $data]} {
puts -nonewline $write $data
}
if {[eof $chan]} {
if {[eof $upstream]} {
close $write
return
} else {
yield
}
} else {
chan event $chan readable [
list [info coroutine] $chan $write $upstream $cursor]
lassign [yieldto return -level 0] chan write upstream cursor
}
}
}
variable doc::readbreak {
description {
like [read]
but return a break code once there is no more data to be read
}
}
proc readbreak {chan args} {
tailcall doreadbreak [list ::coroutine::util read $chan] [
list ::eof $chan] {*}$args
}
proc doreadbreak {read eof args} {
if {[{*}$eof]} {
return -code break
}
{*}$read {*}$args
}
proc release {chan spec} {
catch {[chan event $chan readable [dict get $spec readable]]}
catch {[chan event $chan writable [dict get $spec writable]]}
}
proc write {chan text} {
puts -nonewline $chan $text
}
namespace eval # {}
##this must come at the end of the script
#package require {ycl chan vso}