Commit 02fdcabc authored by Steffen Michels's avatar Steffen Michels

Merge branch '88-pipes-broken-on-macos-when-using-pseudo-ttys' into 'master'

fix non-blocking reads on pty's

Closes #88

See merge request !328
parents de9abe45 68c82100
Pipeline #41989 passed with stage
in 2 minutes and 9 seconds
......@@ -28,11 +28,11 @@ FIONREAD :== 0x4004667F
F_SETFD :== 2
FD_CLOEXEC :== 1
O_RDWR :== 02
O_NOCTTY :== 0400
O_RDWR :== 0x2
O_NOCTTY :== 0x20000
TCSANOW :== 0
TIOCSCTTY :== 0x540E
TIOCSCTTY :== 0x20007461
ECHO :== 0x8
ECHONL :== 0x40
......
......@@ -24,6 +24,8 @@ import System._Posix
import Text.GenJSON
DEFAULT_READ_BUF :== 1024
:: WritePipe = WritePipe !Int
:: ReadPipe = ReadPipe !Int
......@@ -120,10 +122,14 @@ runProcessPty path args mCurrentDirectory opts world
where
childProcess :: !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
childProcess slavePty masterPty pipeExecErrorOut pipeExecErrorIn world
//Close the master side
# (res, world) = close masterPty world
| res == -1 = getLastOSError world
//Disable echo
//sizeof(struct termios) on linux gives 60, on mac 72, lets play safe
# termios = malloc 128
| termios == 0 = abort "malloc failed"
| termios == 0 = getLastOSError world
# (res, world) = tcgetattr slavePty termios world
| res == -1 = getLastOSError world
......@@ -132,11 +138,15 @@ where
# (res, world) = tcsetattr slavePty TCSANOW termios world
| res == -1 = getLastOSError world
# world = freeSt termios world
//Close the master side
# (res, world) = close masterPty world
| res == -1 = getLastOSError world
//Close our stdio
# (res, world) = close STDIN_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close STDOUT_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close STDERR_FILENO world
| res == -1 = getLastOSError world
//Connect the pty to the stdio
# (res, world) = dup2 slavePty STDIN_FILENO world
| res == -1 = getLastOSError world
......@@ -145,6 +155,10 @@ where
# (res, world) = dup2 slavePty STDERR_FILENO world
| res == -1 = getLastOSError world
// Close slavePty since it is duped anyway
# (res, world) = close slavePty world
| res == -1 = getLastOSError world
//Set the correct ioctl settings
# world = (if opts.childInNewSession setsid id) world
# (res, world) = if opts.childControlsTty (0, world)
......@@ -158,8 +172,8 @@ where
parentProcess :: !Int !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
parentProcess slavePty masterPty pid pipeExecErrorOut pipeExecErrorIn world
//sizeof(struct termios) on linux gives 60, lets play safe
# termios = malloc 64
| termios == 0 = abort "malloc failed"
# termios = malloc 128
| termios == 0 = getLastOSError world
# (res, world) = tcgetattr masterPty termios world
| res == -1 = getLastOSError world
......@@ -340,63 +354,72 @@ callProcess path args mCurrentDirectory world
readPipeNonBlocking :: !ReadPipe !*World -> (!MaybeOSError String, !*World)
readPipeNonBlocking (ReadPipe fd) world
# ptr = malloc 4
# (res, world) = ioctl fd FIONREAD ptr world
| res == -1
# world = freeSt ptr world
= getLastOSError world
# (n, ptr) = readP (\ptr -> readInt4Z ptr 0) ptr
# world = freeSt ptr world
| n == 0 = (Ok "", world)
# buffer = malloc n
# (res, world) = read fd buffer n world
| res == -1
# world = freeSt buffer world
= getLastOSError world
# (str, buffer) = readP (\ptr -> derefCharArray ptr n) buffer
# world = freeSt buffer world
= (Ok str, world)
# (timeout, world) = mallocSt 16 world
| timeout == 0 = getLastOSError world
# timeout = IF_INT_64_OR_32
(writeInt (writeInt timeout 0 0) 8 0)
(writeInt (writeInt (writeInt (writeInt timeout 0 0) 4 0) 8 0) 12 0)
# ((res, world), timeout) = readP (\ptr->readSelect [fd] ptr world) timeout
# world = freeSt timeout world
| isError res = (liftError res, world)
| and (fromOk res) = realRead fd world
= (Ok "", world)
readPipeBlocking :: !ReadPipe !*World -> (!MaybeOSError String, !*World)
readPipeBlocking pipe=:(ReadPipe fd) world
# readfds = malloc 128
// init array
# readfds = seq [\ptr -> writeIntElemOffset ptr i 0 \\ i <- [0..IF_INT_64_OR_32 15 31]] readfds
// set bit for fd
# readfds = readPipeBlockingSetFdBit fd readfds
// wait
# (res, world) = select_ (fd + 1) readfds 0 0 0 world
# world = freeSt readfds world
| res == -1 = getLastOSError world
= readPipeNonBlocking pipe world
readPipeBlocking (ReadPipe fd) world
# (res, world) = readSelect [fd] 0 world
| isError res = (liftError res, world)
= realRead fd world
readPipeBlockingMulti :: ![ReadPipe] !*World -> (!MaybeOSError [String], !*World)
readPipeBlockingMulti pipes world
#readfds = malloc 128
// init array
#readfds = seq [\ptr -> writeIntElemOffset ptr i 0 \\ i <- [0..IF_INT_64_OR_32 15 31]] readfds
// set bits for fds
#readfds = seq [readPipeBlockingSetFdBit fd \\ ReadPipe fd <- pipes] readfds
// wait
# (res, world) = select_ (maxFd + 1) readfds 0 0 0 world
# world = freeSt readfds world
| res == -1 = getLastOSError world
= seq [ \(res, world) -> case res of
Ok res`
#(r, world) = readPipeNonBlocking pipe world
= (seqErrors r (\r` -> Ok [r`:res`]), world)
error = (error, world)
\\ pipe <- reverse pipes
]
(Ok [], world)
# (res, world) = readSelect [fd\\ReadPipe fd<-pipes] 0 world
| isError res = (liftError res, world)
= seq
[ \(res, world) -> case res of
Ok res`
# (r, world) = if ready
(realRead fd world)
(Ok "", world)
= (seqErrors r (\r` -> Ok [r`:res`]), world)
error = (error, world)
\\ ReadPipe fd <- reverse pipes & ready <- reverse (fromOk res)
]
(Ok [], world)
realRead :: !Int !*World -> (!MaybeOSError String, !*World)
realRead fd world
# (buf, world) = mallocSt DEFAULT_READ_BUF world
| buf == 0 = getLastOSError world
# (res, world) = read fd buf DEFAULT_READ_BUF world
| res == -1
= getLastOSError (freeSt buf world)
# (str, buf) = readP (\ptr->derefCharArray ptr res) buf
= (Ok str, freeSt buf world)
readSelect :: ![Int] !Pointer !*World -> (!MaybeOSError [Bool], !*World)
readSelect fds timeout world
# readfds = malloc 128
| readfds == 0 = getLastOSError world
# readfds = seq [\ptr -> writeIntElemOffset ptr i 0 \\ i <- [0..IF_INT_64_OR_32 15 31]] readfds
# readfds = seq [setFdBit fd\\fd<-fds] readfds
# (res, world) = select_ (maximum fds + 1) readfds 0 0 timeout world
| res == -1 = getLastOSError (freeSt readfds world)
# (res, readfds) = seqList [readP (getFdBit fd)\\fd<-fds] readfds
# world = freeSt readfds world
= (Ok res, world)
where
maxFd = maximum [fd \\ ReadPipe fd <- pipes]
readPipeBlockingSetFdBit :: !Int !Pointer -> Pointer
readPipeBlockingSetFdBit fd ptr
# offset = fromInt fd / IF_INT_64_OR_32 64 32
# val = (readIntElemOffset ptr offset) bitor (1 << (fd rem IF_INT_64_OR_32 64 32))
= writeIntElemOffset ptr offset val
setFdBit :: !Int !Pointer -> Pointer
setFdBit fd ptr
# offset = fromInt fd / IF_INT_64_OR_32 64 32
# val = (readIntElemOffset ptr offset) bitor (1 << (fd rem IF_INT_64_OR_32 64 32))
= writeIntElemOffset ptr offset val
getFdBit :: !Int !Pointer -> Bool
getFdBit fd ptr
# offset = fromInt fd / IF_INT_64_OR_32 64 32
# val = (readIntElemOffset ptr offset) bitand (1 << (fd rem IF_INT_64_OR_32 64 32))
= val <> 0
writePipe :: !String !WritePipe !*World -> (!MaybeOSError (), !*World)
writePipe str (WritePipe fd) world
......
......@@ -26,7 +26,7 @@ COCLLIBS:=\
-I $(COCLPATH)/main\
-I $(COCLPATH)/main/Unix
BINARIES:=checktest test commentstest gentest snappytest tartest
BINARIES:=systemprocesstest checktest test commentstest gentest snappytest tartest
RUN_BINARIES:=$(addprefix run_,$(BINARIES))
all: $(RUN_BINARIES)
......
module systemprocesstest
import StdEnv
import System.CommandLine
import System.Process
import Data.Error
import Data.Func
import Text
pty = runProcessPty "/bin/sh" ["-c", "sleep 2 && echo bork"] Nothing defaultPtyOptions
pio = runProcessIO "/bin/sh" ["-c", "sleep 2 && echo bork"] Nothing
test msg expected rpf pf world
# (Ok (handle,io),world) = pf world
# (Ok output,world) = rpf io.stdOut world
# (Ok out,world) = waitForProcess handle world
# (Ok _,world) = closeProcessIO io world
# f = if (expected <> trim output)
(setReturnCode 1 o snd o fclose (stderr <<< msg <<< "Expected: '" <<< expected <<< "', Got: '" <<< trim output <<< "'\n"))
id
= f world
Start world
= test "ptynb: " "" readPipeNonBlocking pty
$ test "pty b: " "bork" readPipeBlocking pio
$ test "pionb: " "" readPipeNonBlocking pio
$ test "pio b: " "bork" readPipeBlocking pio
$ world
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment