Artifact 87ce459336673d38cfc78415fa941c0710b515d4:

• File packages/exec/lib/exec.test.tcl — part of check-in [1c252a3cd0] at 2020-06-22 00:31:53 on branch trunk — chan new routines

  carve

  interpolate

  keep

  further development

  best working version so far

  notes

  new routines

  absorb addrspaceex

  "eval" option to [ls]

  "message" design for interactive output

  add zip processing to [fin]

  sqlite

  lossless

  work in progress

  add test

  string

  printable

  new interface

  tree

  much faster [last] and [pivot] routines

  (user: pooryorick size: 10455)

#! /bin/env tclsh

package require {ycl test}
proc handle_io {res key output} {
	upvar 0 $res[unset res] res
	dict set res $key $output
}


proc suite_main {} {
	package require {ycl list}
	namespace import [yclprefix]::list::sl
	package require {ycl exec}
	namespace path [namespace parent]
	package require [list ycl string printable]
	namespace import [yclprefix]::string::printable
	[yclprefix]::test::init
	namespace import [yclprefix]::test::cleanup1

	variable tclscript1
	variable tclscript2

	if 0 {
		warning: this test currently might fail if stdout comes in before stderr
	}


	test exec {} -body {
		set res1 [exec | [
			list [info nameofexecutable] -encoding utf-8] <<$tclscript1]
		lappend res [dict get $res1 status]
		lappend res [printable [dict get $res1 out] tclescapes 1]
	} -cleanup [cleanup1] -result [sl {
		0 {hello\ on\ stdout\n}
	}]


	test exec_readstderr {} -body {
		set res1 [exec read stderr | [list [info nameofexecutable] -encoding utf-8] <<$tclscript1]
		lappend res [dict get $res1 status]
		lappend res [printable [dict get $res1 out] tclescapes 1]
		lappend res [printable [dict get $res1 errout] tclescapes 1]
	} -cleanup [cleanup1] -result [sl {
		0 {hello\ on\ stdout\n} {hello\ on\ stderr\n}
	}]


	test exec_binary {} -body {
		set res1 [exec binary true read stderr | [
			list [info nameofexecutable] -encoding utf-8] <<$tclscript2]
		lappend res [dict get $res1 status]
		lappend res [printable [dict get $res1 out] tclescapes 1]
		lappend res [printable [dict get $res1 errout] tclescapes 1]
	} -cleanup [cleanup1] -result [sl {
		0
			{hello\x00\ on\ stdout\r\ngoodbye\ on\ stdout\n\r}
			{hello\x00\ on\ stderr\r\ngoodbye\ on\ stderr\n\r}
	}]


	test exec_err {} -body {
		set command {
			puts stdout {hello on stdout}
			puts stderr {hello on stderr}
			exit 3
		}

		set status [catch {exec read stderr | [list [
			info nameofexecutable] -encoding utf-8] <<$command} eres eval]
		lappend res [dict get $eres status]
		lappend res [printable [dict get $eres out] tclescapes 1]
		lappend res [printable [dict get $eres errout] tclescapes 1]
	} -cleanup [cleanup1] -result [sl {
		3 {hello\ on\ stdout\n} {hello\ on\ stderr\n}
	}]


	# This test requires that the tclsh interpreter receiving a script to
	# execute on stdin exit with a non-zero status when the script raises an
	# error.  As of 8.6.4, tclsh does not behave this way.  
	test exec_err2 {} -body {
		set command {
			puts {set ::tcl_interactive 0}
			puts {puts {hello on stdout}}
			puts {puts stderr {hello on stderr}}
			puts {if {[catch {hello} cres copts]} {
				puts stderr $cres
				exit 1
			}}
		}

		set status [catch {exec read stderr | [list [info nameofexecutable] -encoding utf-8] <<$command | [list [info nameofexecutable]]} eres eval]
		lappend res [dict get $eres status]
		lappend res [printable [dict get $eres out] tclescapes 1]
		lappend res [printable [dict get $eres errout] tclescapes 1]
	} -cleanup [cleanup1] -result [sl {
		1 {hello\ on\ stdout\n} {hello\ on\ stderr\ninvalid\ command\ name\ \"hello\"\n}
	}]


	test exec_pipe_stderr {} -body {
		set command {
			puts stdout {hello on stdout}
			puts stderr {hello on stderr}
			puts stderr {hello2 on stderr}
			exit 0
		}

		lassign [chan pipe] pr1 pw1

		set res1 [exec | [list [
			info nameofexecutable] -encoding utf-8] <<$command 2>@$pw1]
		close $pw1
		lappend res [dict get $res1 status]
		lappend res [printable [dict get $res1 out] tclescapes 1]
		lappend res [dict exists $res1 errout]
		lappend res [printable [read $pr1] tclescapes 1]
		close $pr1
		set res
	} -cleanup [cleanup1] -result [sl {
		0 {hello\ on\ stdout\n} 0 {hello\ on\ stderr\nhello2\ on\ stderr\n}
	}]


	test exec_pipe_stderr_pipeerror {} -body {
		set command {
			puts bleep
			while 1 {
				set res [gets stdin]
				if {$res eq {}} {
					if {[eof stdin]} {
						break
					}
				}
				puts stderr [list hey $res]
			}
		}
		set command2 {
			for ((i=1; i<10000;i++)); do
				echo 'puts hello; puts stderr goodbye'
			done
			exit 7
		}

		lassign [chan pipe] pr2 pw2

		set eres [exec open stdout | bash <<$command2 | [
			list [info nameofexecutable] -encoding utf-8]  2>@$pw2]
		close $pw2 
		lappend res [printable [string range [
			::coroutine::util::read $pr2] 0 15] tclescapes 1]
		close $pr2
		lappend res [printable [string range [
			read [dict get $eres outchan]] 0 15] tclescapes 1]
		set outchan [dict get $eres outchan]
		chan configure $outchan -blocking 1
		lappend res [catch {close $outchan} cres copts]
		lappend res $cres
		set res
	} -cleanup [cleanup1] -result [sl {
		{goodbye\ngoodbye\n}
		{hello\nhello\nhell}
		1 {child process exited abnormally}
	}]


	test exec_tee {} -body {
		#TODO: make this test meaningful
		set pres [exec | [
			list [info nameofexecutable]] << $tclscript2]

		lappend res [printable [dict get $pres out] tclescapes 1]
		lappend res [printable [dict exists $pres errout] tclescapes 1]
	} -cleanup [cleanup1] -result [sl {
		# If not in binary mode, \n\r gets translated to \n, and the \r in \r\n
		# gets translated to \n.
		{hello\x00\ on\ stdout\ngoodbye\ on\ stdout\n\n}
		0
	}]


	test exec_redir_binary {} -body {
		lassign [chan pipe] pr2 pw2
		chan configure $pr2 -translation binary
		set pres [exec keepnewline yes binary yes open both | [
			info nameofexecutable] << $tclscript2 2>@$pw2]
		close $pw2
		lappend res [printable [::coroutine::util::read [
			dict get $pres outchan]] tclescapes 1]
		lappend res [printable [::coroutine::util::read $pr2] tclescapes 1]
		close [dict get $pres outchan]
		close $pr2
		#lappend res [dict get $pres out]
		#lappend res [dict get $pres errout]
		set res
	} -cleanup [cleanup1] -result [sl {
		{hello\x00\ on\ stdout\r\ngoodbye\ on\ stdout\n\r}
		{hello\x00\ on\ stderr\r\ngoodbye\ on\ stderr\n\r}
	}]


	test exec_translation {} -body {
		set res1 [exec translation {stdout binary stderr binary} read stderr | [
			list [info nameofexecutable] -encoding utf-8] <<$tclscript2]
		lappend res [dict get $res1 status]
		lappend res [printable [dict get $res1 out] tclescapes 1]
		lappend res [printable [dict get $res1 errout] tclescapes 1]
	} -cleanup [cleanup1] -result [sl {
		0
			{hello\x00\ on\ stdout\r\ngoodbye\ on\ stdout\n\r}
			{hello\x00\ on\ stderr\r\ngoodbye\ on\ stderr\n\r}
	}]


	test bgexec {} -body {
		set command {
			for {set i 0} {$i < 10000} {incr i} {
				puts stdout {hello on stdout}
				puts stderr {hello on stderr}
			}
			exit 0
		}
		lassign [chan pipe] pr2 pw2
		set pres [exec | [info nameofexecutable] <<$command 2>@$pw2 &]

		close $pw2
		chan configure $pr2 -blocking 0

		set onout [list {chan varname} {
			variable done
			set data [read $chan]
			if {$data eq {} && [eof $chan]} {
				close $chan
				set done 1
			} else {
				incr $varname [string length $data]
			}
		} [namespace current]]
		lappend res [dict exists $pres outchan]
		chan event $pr2 readable [list apply $onout $pr2 [
			namespace current]::var2]
		vwait [namespace current]::done

		lappend res [set [namespace current]::var2]
		set res
	} -cleanup [cleanup1] -result [sl {
		0 160000
	}]


	test bgexec_err {} -body {
		lassign [chan pipe] pr pw
		set pres [exec open {} | [info nameofexecutable] << {
			puts hello
			exit 3
		} >@$pw &]]
		# No need to close $pw.  It should have been transfered to a separate
		# tplex thread, and is closed automatically when appropriate
		#close $pw

		# $pw should no longer exist in this thread

		lappend res [expr {$pw in [chan names]}]
		lappend res [::coroutine::util::read $pr]
		catch [close $pr]
		set res
	} -cleanup [cleanup1] -result [sl {
		0 hello\n
	}]


	test extern {} -body {
		set res {}
		set res1 {hello world}
		try {
			set chan [file tempfile tmpname]
			puts $chan {
				set fname [lindex $argv 0]
				set chan [open $fname]
				set data [read $chan]
				close $chan
				set chan [open $fname {WRONLY TRUNC}]
				puts $chan [string map {hello goodbye} $data]
			}
			flush $chan
			seek $chan 0
			extern res1 [list [info nameofexecutable] -encoding utf-8 $tmpname]
			lappend res $res1
		} finally {
			if {$chan in [chan names]} {
				close $chan
			}
			if {[file exists $tmpname]} {
				file delete $tmpname
			}
		}

		return $res
	} -cleanup [cleanup1] -result [sl {
		{goodbye world}
	}]


	test filter {} -body {
		set chan [filter {
			while {[gets stdin data] >= 0} {
				puts [expr {$data ** $data}]
			}
		}]
		for {set i 0} {$i < 10} {incr i} {
			puts $chan $i 
		}
		close $chan write
		while {[gets $chan data] >= 0} {
			lappend res $data
		}
		return $res
	} -cleanup [cleanup1] -result [sl {
		1 1 4 27 256 3125 46656 823543 16777216 387420489
	}]


	test filter_error {} -body {
		set chan [filter {
			while {[gets stdin data] >= 0} {
				something wrong
			}
		}]
		for {set i 0} {$i < 10} {incr i} {
			puts $chan $i 
		}
		close $chan write
		while {[gets $chan data] >= 0} {
			lappend res $data
		}
		lappend res [catch close $chan]
		return $res
	} -cleanup [cleanup1] -result [sl {
		1
	}]


	test splitredir {} -body {
		lappend res [splitredir >]
		lappend res [splitredir >file1]
		lappend res [splitredir 2>]
		lappend res [splitredir 2>file1]
		lappend res [splitredir >&]
		lappend res [splitredir >&file1]
		lappend res [splitredir >>]
		lappend res [splitredir >>file1]
		lappend res [splitredir 2>>]
		lappend res [splitredir 2>>file1]
		lappend res [splitredir >>&]
		lappend res [splitredir >>&file1]
		lappend res [splitredir >@]
		lappend res [splitredir >@file1]
		lappend res [splitredir 2>@]
		lappend res [splitredir 2>@file1]
		lappend res [splitredir >&@]
		lappend res [splitredir >&@file1]
		lappend res [splitredir <]
		lappend res [splitredir <file1]
		lappend res [splitredir <@]
		lappend res [splitredir <@file1]
		lappend res [splitredir <<]
		lappend res [splitredir <<file1]
	} -cleanup [cleanup1] -result [sl {
		{> {}}
		{> file1}
		{2> {}}
		{2> file1}
		{>& {}}
		{>& file1}
		{>> {}}
		{>> file1}
		{2>> {}}
		{2>> file1}
		{>>& {}}
		{>>& file1}
		{>@ {}}
		{>@ file1}
		{2>@ {}}
		{2>@ file1}
		{>&@ {}}
		{>&@ file1}
		{< {}}
		{< file1}
		{<@ {}}
		{<@ file1}
		{<< {}}
		{<< file1}
	}]


	cleanupTests
}

variable tclscript1 {
	puts stdout {hello on stdout}
	puts stderr {hello on stderr}
	exit 0
}

variable tclscript2 {
	puts -nonewline stdout "hello\x00 on stdout\r\n"
	puts -nonewline stderr "hello\x00 on stderr\r\n"
	puts -nonewline stdout "goodbye on stdout\n\r"
	puts -nonewline stderr "goodbye on stderr\n\r"
	exit 0
}