ycl

Artifact [35ab8f0997]
Login
☰Home Timeline Branches Tags Tickets Wiki Login
Check-ins Using Download Hex

Artifact 35ab8f0997601c40a901349f3bb2bf4bbcf02fac:

#! /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}
This page was generated in about 0.017s by Fossil 2.22 [66ee0beb9b] 2023-05-31 15:26:08