path: root/tests/aio.test

source [file dirname [info script]]/testing.tcl

needs constraint jim
constraint cmd socket
constraint cmd os.fork
constraint expr posixaio {$tcl_platform(platform) eq {unix} && !$tcl_platform(bootstrap)}

# Create and open in binary mode for compatibility between Windows and Unix
set f [open testdata.in wb]
$f puts test-data
$f close
# create a test file file with several lines
set f [open copy.in wb]
$f puts line1
$f puts line2
$f puts line3
$f close

set f [open testdata.in rb]

defer {
	$f close
	file delete testdata.in
	file delete copy.in
	file delete copy.out
}

test aio-1.1 {seek usage} -body {
	$f seek
} -returnCodes error -match glob -result {wrong # args: should be "* seek offset ?start|current|end"}

test aio-1.2 {seek start} -body {
	$f seek 2
	$f tell
} -result {2}

test aio-1.3 {seek start} -body {
	$f seek 4 start
	$f tell
} -result {4}

test aio-1.4 {read after seek} -body {
	set c [$f read 1]
	list $c [$f tell]
} -result {- 5}

test aio-1.5 {seek backwards} -body {
	$f seek -2 current
	set c [$f read 1]
	list $c [$f tell]
} -result {t 4}

test aio-1.6 {seek from end} -body {
	$f seek -2 end
	set c [$f read 2]
	list $c [$f tell]
} -result [list "a\n" 10]

test aio-1.7 {seek usage} -body {
	$f seek 4 bad
} -returnCodes error -match glob -result {wrong # args: should be "* seek offset ?start|current|end"}

test aio-1.8 {seek usage} -body {
	$f seek badint
} -returnCodes error -match glob -result {expected integer but got "badint"}

test aio-1.9 {seek bad pos} -body {
	$f seek -20
} -returnCodes error -match glob -result {testdata.in: Invalid argument}

test aio-2.1 {read usage} -body {
	$f read -nonoption
} -returnCodes error -result {bad option "-nonoption": must be -nonewline, or -pending}

test aio-2.2 {read usage} -body {
	$f read badint
} -returnCodes error -result {expected integer but got "badint"}

test aio-2.3 {read -ve len} -body {
	$f read " -20"
} -returnCodes error -result {invalid parameter: negative len}

test aio-2.4 {read too many args} -body {
	$f read 20 extra
} -returnCodes error -match glob -result {wrong # args: should be "* read ?-nonewline|len?"}

test aio-3.1 {copy to invalid fh} -body {
	$f copy lambda
} -returnCodes error -result {Not a filehandle: "lambda"}

test aio-3.2 {copy bad length} -body {
	$f copy stdout invalid
} -returnCodes error -result {expected integer but got "invalid"}

set badvar a

test aio-4.1 {gets invalid var} -body {
	$f gets badvar(abc)
} -returnCodes error -result {can't set "badvar(abc)": variable isn't array}

test aio-5.1 {puts usage} -body {
	stdout puts -badopt abc
} -returnCodes error -result {wrong # args: should be "stdout puts ?-nonewline? str"}

test aio-6.1 {eof} {
	$f seek 0
	$f eof
} {0}

test aio-6.2 {eof} {
	# eof won't trigger until we try to read
	$f seek 0 end
	$f eof
} {0}

test aio-6.3 {eof} {
	$f read 1
	$f eof
} {1}

test aio-7.1 {close args} -constraints socket -body {
	$f close badopt
} -returnCodes error -result {bad option "badopt": must be -nodelete, r, or w}

test aio-7.2 {close w on non-socket} -constraints socket -body {
	$f close w
} -returnCodes error -match regexp -result {(bad|socket)}

test aio-7.3 {close -nodelete on non-socket} -constraints socket -body {
	$f close -nodelete
} -returnCodes error -result {not supported}

test aio-8.1 {filename} {
	$f filename
} testdata.in

test aio-9.1 {open: posix modes} -constraints posixaio -body {
	set in [open testdata.in RDONLY]
	set buf [$in gets]
	$in close
	set buf
} -result {test-data}

test aio-9.2 {open: posix modes, bad modes} -constraints posixaio -body {
	open testdata.in {CREAT TRUNC}
} -returnCodes error -result {testdata.in: invalid open mode 'CREAT TRUNC'}

test aio-9.3 {open: posix modes, bad modes} -constraints posixaio -body {
	open testdata.in {WRONG TRUNC}
} -returnCodes error -result {bad access mode "WRONG": must be APPEND, BINARY, CREAT, EXCL, NOCTTY, RDONLY, RDWR, TRUNC, or WRONLY}

test aio-9.4 {open: posix modes} -constraints posixaio -cleanup {
	file delete testdata.out
} -body {
	set out [open testdata.out {WRONLY CREAT TRUNC}]
	$out puts write-data
	$out close
	# Now open for readwrite without truncate
	set io [open testdata.out {RDWR CREAT}]
	set buf [$io gets]
	$io close
	set buf
} -result {write-data}

test aio-10.1 {open: -noclose} -constraints os.fork -cleanup {
	file delete testdata.out
} -body {
	# Keep this file descriptor open for children
	set f [open testdata.out -noclose w]
	$f puts parent
	$f flush
	# Now the child process can write to the same file via the file descriptor
	exec sh -c "echo child >&[$f getfd]"
	$f close
	set in [open testdata.out]
	set lines [list [$in gets] [$in gets]]
	$in close
	set lines
} -result {parent child}

test copyto-1.1 {basic copyto} {
	set in [open copy.in]
	set out [open copy.out w]
	$in copyto $out
	$in close
	$out close
	set ff [open copy.out]
	set result [list [$ff gets] [$ff gets] [$ff gets]]
	$ff close
	set result
} {line1 line2 line3}

test copyto-1.2 {copyto with limit} {
	set in [open copy.in]
	set out [open copy.out w]
	$in copyto $out 8
	$in close
	$out close
	set ff [open copy.out]
	set result [list [$ff gets] [$ff gets] [$ff gets]]
	$ff close
	set result
} {line1 li {}}

test copyto-1.3 {copyto after gets} {
	set in [open copy.in]
	set out [open copy.out w]
	$in gets
	$in copyto $out
	$in close
	$out close
	set ff [open copy.out]
	set result [list [$ff gets] [$ff gets] [$ff gets]]
	$ff close
	set result
} {line2 line3 {}}

test copyto-1.4 {copyto after read} {
	set in [open copy.in]
	$in read 3
	set out [open copy.out w]
	$in copyto $out
	$in close
	$out close
	set ff [open copy.out]
	set result [list [$ff gets] [$ff gets] [$ff gets]]
	$ff close
	set result
} {e1 line2 line3}

test copyto-1.5 {copyto after gets, seek} {
	set in [open copy.in]
	$in gets
	$in seek 2 start
	set out [open copy.out w]
	$in copyto $out
	$in close
	$out close
	set ff [open copy.out]
	set result [list [$ff gets] [$ff gets] [$ff gets]]
	$ff close
	set result
} {ne1 line2 line3}

test copyto-1.6 {copyto from pipe} {
	set in [open "|cat copy.in"]
	set out [open copy.out w]
	$in copyto $out
	$in close
	$out close
	set ff [open copy.out]
	set result [list [$ff gets] [$ff gets] [$ff gets]]
	$ff close
	set result
} {line1 line2 line3}

test copyto-1.6 {copyto to pipe} {
	set out [open "|cat >copy.out" w]
	set in [open copy.in]
	$in copyto $out
	$in close
	$out close
	set ff [open copy.out]
	set result [list [$ff gets] [$ff gets] [$ff gets]]
	$ff close
	set result
} {line1 line2 line3}

# Creates a child process and returns {pid writehandle}
# The child expects to read $numlines lines of input and exits with a return
# code of 0 if ok
proc child_reader {numlines} {
	# create a pipe with the child as a slightly slow reader
	lassign [socket pipe] r w

	set pid [os.fork]
	if {$pid == 0} {
		# child
		$w close
		# sleep a moment to make sure the parent fills up the send buffer
		sleep 0.5
		set n 0
		while {[$r gets buf] >= 0} {
			incr n
		}
		#puts "child got $n/$numlines lines"
		$r close
		if {$n == $numlines} {
			# This is what we expect
			exit 99
		}
		# This is not expected
		exit 98
	}
	# parent
	$r close

	list $pid $w
}

test autoflush-1.1 {pipe writer, blocking} -constraints {socket os.fork} -body {
	lassign [child_reader 10000] pid w

	# Send data fast enough to fill up the send buffer
	loop i 10000 {
		$w puts "this is line $i"
	}

	# No autoflush needed. The write won't return
	# until queued
	$w close

	lassign [wait $pid] - - rc

	list $rc
} -result {99}

test autoflush-1.2 {pipe writer, non blocking} -constraints {socket os.fork} -body {
	lassign [child_reader 10000] pid w

	$w ndelay 1

	# Send data fast enough to fill up the send buffer
	# With older jimtcl this would return an error "pipe: Resource temporarily unavailable"
	loop i 10000 {
		$w puts "this is line $i"
	}

	# Now data should still be queued, wait for autoflush
	lassign [time {
		after idle {}
		vwait done
	}] t1

	# puts "autoflush finished in ${t1}us, closing pipe"
	$w close

	lassign [wait $pid] - - rc

	list $rc $t1
} -match glob -result {99 *}

testreport