ycl

Artifact Content
Login

Artifact 39aae40b6454b8c424b5af21641dd4c5748f28f1:


#! /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

		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] && [llength $command]} {
				set command [lindex $command[set command {}] 0]
				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 {fconfigure stdout -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}