--- a/UnixPTYStream.st Thu Dec 29 20:42:45 2016 +0100
+++ b/UnixPTYStream.st Thu Dec 29 22:53:02 2016 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1998 by eXept Software AG
All Rights Reserved
@@ -182,8 +184,7 @@
openPTYFor:aCommandString withMode:openMode inDirectory:aDirectory
"open a pty to the unix command in commandString"
- |blocked ptyFdArray execFdArray slaveFd masterFd shellAndArgs
- shellPath shellArgs mbx mbxName env|
+ |ptyFdArray slaveFd masterFd env remotePipeEnd result|
handle notNil ifTrue:[
"the pipe was already open ...
@@ -192,113 +193,54 @@
].
lastErrorNumber := nil.
- exitStatus := nil.
- exitSema := Semaphore new name:'pty exitSema'.
+ "stdio lib does not work with blocking pipes and interrupts
+ for WIN, Linux, Solaris and probably any other UNIX"
+ buffered := false.
+ hitEOF := false.
+ binary := false.
- OperatingSystem isVMSlike ifTrue:[
- mbx := OperatingSystem createMailBox.
- mbx isNil ifTrue:[
- lastErrorNumber := OperatingSystem currentErrorNumber.
- ^ self openError
- ].
- mbxName := OperatingSystem mailBoxNameOf:mbx.
- "/ 'mailBox is ' print. mbx print. ' name is ' print. mbxName printCR.
-
- shellPath := ''.
- shellArgs := aCommandString.
+ ptyFdArray := OperatingSystem makePTYPair.
+ ptyFdArray isNil ifTrue:[
+ lastErrorNumber := OperatingSystem lastErrorNumber.
+ ^ self openError:lastErrorNumber.
+ ].
- execFdArray := Array with:mbx with:mbx with:mbx.
- ] ifFalse:[
- ptyFdArray := OperatingSystem makePTYPair.
- ptyFdArray isNil ifTrue:[
- lastErrorNumber := OperatingSystem currentErrorNumber.
- ^ self openError
- ].
+ masterFd := ptyFdArray at:1.
+ slaveFd := ptyFdArray at:2.
- shellAndArgs := OperatingSystem commandAndArgsForOSCommand:aCommandString.
- shellPath := shellAndArgs at:1.
- shellArgs := shellAndArgs at:2.
-
- masterFd := ptyFdArray at:1.
- slaveFd := ptyFdArray at:2.
- execFdArray := Array with:slaveFd with:slaveFd with:slaveFd.
- ].
+ remotePipeEnd := self class forFileDescriptor:slaveFd mode:#readwrite buffered:false handleType:#pipeFilePointer.
env := Dictionary new.
env at:'TERM' put:'dumb'.
- env at:'SHELL' put:shellPath.
-
- "/ must block here, to avoid races due to early finishing
- "/ subprocesses ...
-
- blocked := OperatingSystem blockInterrupts.
+ env at:'SHELL' put:'/bin/sh'.
- pid := Processor
- monitor:[
- OperatingSystem
- exec:shellPath
- withArguments:shellArgs
- environment:env
- fileDescriptors:execFdArray
- fork:true
- newPgrp:true
- inDirectory:aDirectory
- showWindow:nil.
- ]
- action:[:status |
- status stillAlive ifFalse:[
- exitStatus := status.
- OperatingSystem closePid:pid.
- pid := nil.
- exitSema signal.
- ].
- ].
+ osProcess := OSProcess new
+ command:aCommandString;
+ directory:aDirectory;
+ environment:env;
+ inStream:remotePipeEnd;
+ outStream:remotePipeEnd;
+ errorStream:remotePipeEnd.
- (OperatingSystem isVMSlike) ifFalse:[
- OperatingSystem closeFd:slaveFd.
+ result := osProcess startProcess.
+
+ remotePipeEnd notNil ifTrue:[
+ remotePipeEnd close.
].
- pid notNil ifTrue:[
- (OperatingSystem isVMSlike) ifTrue:[
- "/
- "/ reopen the mailbox as a file ...
- "/
- mbxName := OperatingSystem mailBoxNameOf:mbx.
- mbxName notNil ifTrue:[
- self open:mbxName withMode:openMode
- ].
- ] ifFalse:[
- self setFileHandle:masterFd mode:openMode.
- ]
+ result ifTrue:[
+ self setFileHandle:masterFd mode:openMode.
] ifFalse:[
- lastErrorNumber := OperatingSystem currentErrorNumber.
- OperatingSystem isVMSlike ifTrue:[
- OperatingSystem destroyMailBox:mbx
- ] ifFalse:[
- OperatingSystem closeFd:masterFd.
- ].
+ "the pipe open failed for some reason ...
+ ... this may be either due to an invalid command string,
+ or due to the system running out of memory (when forking
+ the unix process)"
+ lastErrorNumber := OperatingSystem lastErrorNumber.
+ OperatingSystem closeFd:masterFd.
+ ^ self openError:lastErrorNumber.
].
- blocked ifFalse:[
- OperatingSystem unblockInterrupts
- ].
-
- lastErrorNumber notNil ifTrue:[
- "
- the pipe open failed for some reason ...
- ... this may be either due to an invalid command string,
- or due to the system running out of memory (when forking
- the unix process)
- "
- ^ self openError
- ].
-
- commandString := aCommandString.
- buffered := false.
-
- hitEOF := false.
- binary := false.
- Lobby register:self.
+ self registerForFinalization.
"Created: / 9.7.1998 / 20:21:42 / cg"
"Modified: / 9.7.1998 / 20:28:31 / cg"