github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-14 15:55:51 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request #805 from Interlisp/process-utf8

Browse Source 
assume process streams are UTF-8
This commit is contained in:
rmkaplan 2022-06-26 18:43:07 -07:00 committed by GitHub
commit 13e2b5cda6
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 920 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

460
sources/UNIXCOMM Normal file
View File

@ -0,0 +1,460 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Jun-2022 14:27:33" {DSK}<home>larry>medley>library>UNIXCOMM.;2 19997
:CHANGES-TO (FNS CREATE-PROCESS-STREAM)
:PREVIOUS-DATE "25-Apr-2018 07:31:56" {DSK}<home>larry>medley>library>UNIXCOMM.;1)
(* ; "
Copyright (c) 1988-1990, 2018 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT UNIXCOMMCOMS)
(RPAQQ UNIXCOMMCOMS
[
(* ;; "streams to UNIX processes & pseudo terminals")
(* ;; "this stuff should really be implemented in terms of {SHELL} and {PTY} devices")
(COMS (* ; "Forking stuff")
(FNS FORK-SHELL FORK-UNIX UNIX-KILL UNIX-WRITE CREATE-SHELL-STREAM
CREATE-PROCESS-STREAM UNIXCOMM-AROUNDEXITFN))
[COMS (* ; "Operations on the shell device")
(FNS INITIALIZE-NEW-SHELL-DEVICE UNIX-GET-NEXT-BUFFER UNIX-BACKFILEPTR-NEW
UNIX-STREAM-EOFP-NEW UNIX-STREAM-OUT UNIX-STREAM-CLOSE)
(GLOBALVARS *NEW-SHELL-DEVICE*)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITIALIZE-NEW-SHELL-DEVICE))
(ADDVARS (AROUNDEXITFNS UNIXCOMM-AROUNDEXITFN]
(COMS (* ;
 "Stuff for direct manipulation of Unix sockets")
(FNS CREATE-UNIX-SOCKET-STREAM ACCEPT-UNIX-SOCKET-STREAM))
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNIX-CHANNEL)
(P (CHECKIMPORTS '(FILEIO LLSUBRS)
T)))
[COMS
(* ;; "Obsolete stuff. This is for pre-Medley1.2, where there wasn't support for buffered input on the shell device")
(FNS UNIX-BACKFILEPTR UNIX-READ INITIALIZE-SHELL-DEVICE UNIX-STREAM-IN UNIX-STREAM-EOFP
UNIX-STREAM-PEEK)
(GLOBALVARS *SHELL-DEVICE*)
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNIX-PEEKEDCHAR UNIX-LASTCHAR))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITIALIZE-SHELL-DEVICE]
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* ;; "streams to UNIX processes & pseudo terminals")
(* ;; "this stuff should really be implemented in terms of {SHELL} and {PTY} devices")
(* ; "Forking stuff")
(DEFINEQ
(FORK-SHELL
[LAMBDA (TERMTYPE COMMAND) (* ; "Edited 14-Feb-90 14:27 by bvm")
(if (SUBRCALL UNIX-HANDLECOMM 8)
then (* ;
 "Yes, lde supports this new version")
[SUBRCALL UNIX-HANDLECOMM 11 (if (NULL TERMTYPE)
then ""
elseif (TYPEP TERMTYPE 'ONED-ARRAY)
then TERMTYPE
else (\DTEST (LISP-TO-UNIX-TERMTYPE TERMTYPE)
'ONED-ARRAY))
(if (NULL COMMAND)
then ""
else (\DTEST COMMAND 'ONED-ARRAY]
elseif COMMAND
then (* ;
 "have to use a different old call")
(FORK-UNIX COMMAND)
else (SUBRCALL UNIX-HANDLECOMM 4])
(FORK-UNIX
[LAMBDA (STR) (* ; "Edited 25-May-88 15:47 by drc:")
(SUBRCALL UNIX-HANDLECOMM 0 (\DTEST STR 'ONED-ARRAY])
(UNIX-KILL
[LAMBDA (CONN) (* ; "Edited 25-May-88 16:04 by drc:")
(if CONN
then (SUBRCALL UNIX-HANDLECOMM 3 CONN 0])
(UNIX-WRITE
[LAMBDA (CONN VAL) (* ; "Edited 24-Sep-90 11:27 by jds")
(* ;; "Write a byte (VAL) to the outgoing pipe connection CONN. If the write fails for non-fatal reasons (i.e., would block), loop unitl it succeeds. If the write returns NIL (meaning total failure), pass that along to the caller.")
(PROG (LENGTH-WRITTEN)
WRITE-LOOP
[SETQ LENGTH-WRITTEN (SUBRCALL UNIX-HANDLECOMM 1 (\DTEST CONN 'SMALLP)
(\DTEST VAL 'SMALLP]
(COND
((AND LENGTH-WRITTEN (IEQP 0 LENGTH-WRITTEN))
(BLOCK)
(GO WRITE-LOOP)))
(RETURN LENGTH-WRITTEN])
(CREATE-SHELL-STREAM
[LAMBDA (TERMTYPE COMMAND) (* ; "Edited 21-May-90 15:39 by jrb:")
(LET ((CHAN (FORK-SHELL TERMTYPE COMMAND))
(SHELL-DEV (if (SUBRCALL UNIX-HANDLECOMM 8)
then (* ;
 "SUBRCALL tests that this is supported")
*NEW-SHELL-DEVICE*
else *SHELL-DEVICE*)))
(COND
(CHAN (LET ((STR (create STREAM
ACCESS _ 'BOTH
DEVICE _ SHELL-DEV)))
(CL:SETF (UNIX-CHANNEL STR)
CHAN)
(* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.")
(push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
STR)
(STREAMPROP STR 'SENDSCREENPARAMS (FUNCTION UNIX.SENDSCREENPARAMS))
(STREAMPROP STR 'SETDISPLAYTYPE (FUNCTION UNIX.SETDISPLAYTYPE))
STR])
(CREATE-PROCESS-STREAM
[LAMBDA (COMM) (* ; "Edited 26-Jun-2022 13:52 by larry")
(* ;
 "Edited 26-Jun-2022 13:31 by lmm - set external format of shell stream to utf-8 ??")
(* ; "Edited 21-May-90 15:39 by jrb:")
(LET* ((SHELL-DEV (if (SUBRCALL UNIX-HANDLECOMM 8)
then (* ;
 "SUBRCALL tests that this is supported")
*NEW-SHELL-DEVICE*
else *SHELL-DEVICE*))
(STR (create STREAM
ACCESS _ 'BOTH
DEVICE _ SHELL-DEV
EOLCONVENTION _ LF.EOLC))
(CHAN (FORK-UNIX COMM)))
(if CHAN
then (CL:SETF (UNIX-CHANNEL STR)
CHAN)
(\EXTERNALFORMAT STR ':UTF-8)
(* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.")
(push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
STR)
STR
else NIL])
(UNIXCOMM-AROUNDEXITFN
[LAMBDA (EVENT) (* ; "Edited 2-Jul-90 16:35 by jrb:")
(CASE EVENT
((AFTERLOGOUT AFTERMAKESYS AFTERSAVEVM AFTERSYSOUT) (for STREAM
in (fetch (FDEV OPENFILELST)
of *SHELL-DEVICE*)
do (CLOSEF STREAM)))
((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT)
(* ;;
 "Make sure any Unix sockets get closed here, so their file system handles get closed as well")
(for STREAM in (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
when (EQ -3 (SUBRCALL UNIX-HANDLECOMM 14 (UNIX-CHANNEL STREAM)))
do (CLOSEF STREAM))))])
)
(* ; "Operations on the shell device")
(DEFINEQ
(INITIALIZE-NEW-SHELL-DEVICE
[LAMBDA NIL (* ; "Edited 12-Feb-90 17:00 by bvm")
(SETQ *NEW-SHELL-DEVICE* (create FDEV
FDBINABLE _ T
NODIRECTORIES _ T
DEVICENAME _ (FUNCTION UNIX-PTY-NEW)
BIN _ (FUNCTION \BUFFERED.BIN)
BOUT _ (FUNCTION UNIX-STREAM-OUT)
PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN)
CLOSEFILE _ (FUNCTION UNIX-STREAM-CLOSE)
GETFILEINFO _ (FUNCTION NILL)
SETFILEINFO _ (FUNCTION NILL)
EOFP _ (FUNCTION UNIX-STREAM-EOFP-NEW)
BACKFILEPTR _ (FUNCTION UNIX-BACKFILEPTR-NEW)
GETNEXTBUFFER _ (FUNCTION UNIX-GET-NEXT-BUFFER)
BLOCKIN _ (FUNCTION \BUFFERED.BINS])
(UNIX-GET-NEXT-BUFFER
[LAMBDA (STREAM WHATFOR NOERRORFLG) (* ;
 "Edited 13-Jun-90 01:07 by mitani")
(CASE WHATFOR
(READ [PROG ([BUF (ffetch (STREAM CBUFPTR) of (\DTEST STREAM 'STREAM]
(CONN (UNIX-CHANNEL STREAM))
LEN)
RETRY
(BLOCK) (* ;
 "Just so other procs get to run when someone is pounding output at Chat")
(if [AND CONN (SETQ LEN (SUBRCALL UNIX-HANDLECOMM 9 (\DTEST CONN 'SMALLP)
(OR BUF (replace (STREAM CBUFPTR)
of STREAM
with (SETQ BUF
(NCREATE 'VMEMPAGEP]
then (if (EQ LEN T)
then (* ;
 " no input available, but still alive")
(if NOERRORFLG
then (RETURN NIL)
else (* ;
 "Called from BIN--wait and try again")
(GO RETRY))
else (UNINTERRUPTABLY
(replace (STREAM COFFSET) of STREAM
with 0)
(replace (STREAM CBUFSIZE) of STREAM
with LEN))
(RETURN T))
else (RETURN (AND (NOT NOERRORFLG)
(\EOF.ACTION STREAM])
(T (SHOULDNT)))])
(UNIX-BACKFILEPTR-NEW
[LAMBDA (STREAM) (* ;
 "Edited 13-Jun-90 01:07 by mitani")
(COND
((AND (fetch (STREAM CBUFPTR) of STREAM)
(> (fetch (STREAM COFFSET) of STREAM)
0))
(add (fetch (STREAM COFFSET) of STREAM)
-1))
(T (ERROR "Can't back up this unix Stream" STREAM])
(UNIX-STREAM-EOFP-NEW
[LAMBDA (STREAM) (* ;
 "Edited 13-Jun-90 01:07 by mitani")
(* ;;; "true if bsp STREAM is at end of file, i.e. is at a mark")
(COND
((AND (ffetch (STREAM CBUFPTR) of (\DTEST STREAM 'STREAM))
(< (ffetch (STREAM COFFSET) of STREAM)
(ffetch (STREAM CBUFSIZE) of STREAM)))
NIL)
(T (NOT (UNIX-GET-NEXT-BUFFER STREAM 'READ T])
(UNIX-STREAM-OUT
[LAMBDA (STREAM CHAR) (* ; "Edited 12-Jun-90 12:58 by jrb:")
(OR (UNIX-WRITE (UNIX-CHANNEL STREAM)
(\DTEST CHAR 'SMALLP))
(CL:ERROR 'XCL:STREAM-NOT-OPEN STREAM])
(UNIX-STREAM-CLOSE
[LAMBDA (STREAM) (* ; "Edited 12-Aug-88 13:24 by drc:")
(PROG1 (UNIX-KILL (UNIX-CHANNEL STREAM))
(CL:SETF (UNIX-CHANNEL STREAM)
NIL)
(CL:SETF (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
(REMOVE STREAM (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*))))])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *NEW-SHELL-DEVICE*)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(INITIALIZE-NEW-SHELL-DEVICE)
(ADDTOVAR AROUNDEXITFNS UNIXCOMM-AROUNDEXITFN)
)
(* ; "Stuff for direct manipulation of Unix sockets")
(DEFINEQ
(CREATE-UNIX-SOCKET-STREAM
[LAMBDA (PATHNAME) (* ; "Edited 29-May-90 16:23 by jrb:")
(LET [(STR (create STREAM
ACCESS _ 'BOTH
DEVICE _ *NEW-SHELL-DEVICE*
EOLCONVENTION _ LF.EOLC))
(CHAN (SUBRCALL UNIX-HANDLECOMM 12 (\DTEST PATHNAME 'ONED-ARRAY]
(if CHAN
then (CL:SETF (UNIX-CHANNEL STR)
CHAN)
(* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.")
(push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
STR)
STR
else NIL])
(ACCEPT-UNIX-SOCKET-STREAM
[LAMBDA (SOCKSTREAM) (* ; "Edited 29-May-90 16:31 by jrb:")
(LET ((CHAN (UNIX-CHANNEL SOCKSTREAM))
NEWCHAN)
(SELECTQ (SETQ NEWCHAN (SUBRCALL UNIX-HANDLECOMM 13 CHAN))
((-1 NIL)
NEWCHAN)
(LET ((NEWSTREAM (create STREAM
ACCESS _ 'BOTH
DEVICE _ *NEW-SHELL-DEVICE*
EOLCONVENTION _ LF.EOLC)))
(CL:SETF (UNIX-CHANNEL NEWSTREAM)
NEWCHAN)
(* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.")
(push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
NEWSTREAM)
NEWSTREAM])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS UNIX-CHANNEL MACRO ((STR)
(fetch (STREAM F1) of STR)))
)
(CHECKIMPORTS '(FILEIO LLSUBRS)
T)
)
(* ;;
"Obsolete stuff. This is for pre-Medley1.2, where there wasn't support for buffered input on the shell device"
)
(DEFINEQ
(UNIX-BACKFILEPTR
[LAMBDA (STREAM) (* ; "Edited 14-Dec-88 09:52 by bane")
(* ;; "The trick here is to use the existing mechanisms for UNIX-PEEKCHAR")
(COND
((UNIX-PEEKEDCHAR STREAM)
(ERROR "Can only back up one character" STREAM))
((NOT (UNIX-LASTCHAR STREAM))
(ERROR "Can't back up past beginning of stream" STREAM))
(T (CL:SETF (UNIX-PEEKEDCHAR STREAM)
(UNIX-LASTCHAR STREAM])
(UNIX-READ
[LAMBDA (STREAM NO-ERROR) (* ; "Edited 14-Dec-88 09:18 by bane")
(LET* [(CONN (UNIX-CHANNEL STREAM))
(CH (AND CONN (SUBRCALL UNIX-HANDLECOMM 2 (\DTEST CONN 'SMALLP)
0]
(COND
((EQ CH T)
NIL)
[(EQ CH NIL)
(COND
(NO-ERROR NIL)
(T (\EOF.ACTION STREAM]
(T (CL:SETF (UNIX-LASTCHAR STREAM)
CH])
(INITIALIZE-SHELL-DEVICE
[LAMBDA NIL (* ; "Edited 14-Dec-88 10:45 by bane")
(SETQ *SHELL-DEVICE* (create FDEV
NODIRECTORIES _ T
DEVICENAME _ 'UNIX-PTY
BIN _ 'UNIX-STREAM-IN
BOUT _ 'UNIX-STREAM-OUT
PEEKBIN _ 'UNIX-STREAM-PEEK
CLOSEFILE _ 'UNIX-STREAM-CLOSE
GETFILEINFO _ 'NILL
SETFILEINFO _ 'NILL
EOFP _ 'UNIX-STREAM-EOFP
BACKFILEPTR _ 'UNIX-BACKFILEPTR])
(UNIX-STREAM-IN
[LAMBDA (STREAM) (* ; "Edited 9-May-88 15:05 by ")
(LET (CH)
(if (SETQ CH (UNIX-PEEKEDCHAR STREAM))
then (CL:SETF (UNIX-PEEKEDCHAR STREAM)
NIL)
else (while (NOT (SETQ CH (UNIX-READ STREAM))) do (BLOCK)))
CH])
(UNIX-STREAM-EOFP
[LAMBDA (STREAM) (* ; "Edited 2-Apr-90 11:51 by jds")
(* ;; "EOFP method for unix-shell streams. Notices when there are chars yet to read and doesn't set EOFP.")
(AND (NOT (UNIX-PEEKEDCHAR STREAM))
(LET* [(CONN (UNIX-CHANNEL STREAM))
(CH (AND CONN (SUBRCALL UNIX-HANDLECOMM 2 (\DTEST CONN 'SMALLP)
0]
(COND
((EQ CH T)
NIL)
((EQ CH NIL)
T)
(T (CL:SETF (UNIX-PEEKEDCHAR STREAM)
CH)
(CL:SETF (UNIX-LASTCHAR STREAM)
CH)
NIL])
(UNIX-STREAM-PEEK
[LAMBDA (STREAM NO-ERROR) (* ; "Edited 24-Jun-88 15:07 by drc:")
(OR (UNIX-PEEKEDCHAR STREAM)
(CL:SETF (UNIX-PEEKEDCHAR STREAM)
(UNIX-READ STREAM NO-ERROR])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *SHELL-DEVICE*)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS UNIX-PEEKEDCHAR MACRO ((STR)
(FETCH (STREAM F2) OF STR)))
(PUTPROPS UNIX-LASTCHAR MACRO ((STR)
(FETCH (STREAM F3) OF STR)))
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(INITIALIZE-SHELL-DEVICE)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS UNIXCOMM COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 2018))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2648 8649 (FORK-SHELL 2658 . 3855) (FORK-UNIX 3857 . 4033) (UNIX-KILL 4035 . 4224) (
UNIX-WRITE 4226 . 4937) (CREATE-SHELL-STREAM 4939 . 6255) (CREATE-PROCESS-STREAM 6257 . 7746) (
UNIXCOMM-AROUNDEXITFN 7748 . 8647)) (8697 13685 (INITIALIZE-NEW-SHELL-DEVICE 8707 . 9800) (
UNIX-GET-NEXT-BUFFER 9802 . 12002) (UNIX-BACKFILEPTR-NEW 12004 . 12483) (UNIX-STREAM-EOFP-NEW 12485 .
13031) (UNIX-STREAM-OUT 13033 . 13289) (UNIX-STREAM-CLOSE 13291 . 13683)) (13941 15806 (
CREATE-UNIX-SOCKET-STREAM 13951 . 14812) (ACCEPT-UNIX-SOCKET-STREAM 14814 . 15804)) (16155 19334 (
UNIX-BACKFILEPTR 16165 . 16663) (UNIX-READ 16665 . 17187) (INITIALIZE-SHELL-DEVICE 17189 . 17928) (
UNIX-STREAM-IN 17930 . 18306) (UNIX-STREAM-EOFP 18308 . 19082) (UNIX-STREAM-PEEK 19084 . 19332)))))
STOP

460
sources/UNIXCOMM.LCOM Normal file
View File

@ -0,0 +1,460 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Jun-2022 14:27:33" {DSK}<home>larry>medley>library>UNIXCOMM.;2 19997
:CHANGES-TO (FNS CREATE-PROCESS-STREAM)
:PREVIOUS-DATE "25-Apr-2018 07:31:56" {DSK}<home>larry>medley>library>UNIXCOMM.;1)
(* ; "
Copyright (c) 1988-1990, 2018 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT UNIXCOMMCOMS)
(RPAQQ UNIXCOMMCOMS
[
(* ;; "streams to UNIX processes & pseudo terminals")
(* ;; "this stuff should really be implemented in terms of {SHELL} and {PTY} devices")
(COMS (* ; "Forking stuff")
(FNS FORK-SHELL FORK-UNIX UNIX-KILL UNIX-WRITE CREATE-SHELL-STREAM
CREATE-PROCESS-STREAM UNIXCOMM-AROUNDEXITFN))
[COMS (* ; "Operations on the shell device")
(FNS INITIALIZE-NEW-SHELL-DEVICE UNIX-GET-NEXT-BUFFER UNIX-BACKFILEPTR-NEW
UNIX-STREAM-EOFP-NEW UNIX-STREAM-OUT UNIX-STREAM-CLOSE)
(GLOBALVARS *NEW-SHELL-DEVICE*)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITIALIZE-NEW-SHELL-DEVICE))
(ADDVARS (AROUNDEXITFNS UNIXCOMM-AROUNDEXITFN]
(COMS (* ;
 "Stuff for direct manipulation of Unix sockets")
(FNS CREATE-UNIX-SOCKET-STREAM ACCEPT-UNIX-SOCKET-STREAM))
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNIX-CHANNEL)
(P (CHECKIMPORTS '(FILEIO LLSUBRS)
T)))
[COMS
(* ;; "Obsolete stuff. This is for pre-Medley1.2, where there wasn't support for buffered input on the shell device")
(FNS UNIX-BACKFILEPTR UNIX-READ INITIALIZE-SHELL-DEVICE UNIX-STREAM-IN UNIX-STREAM-EOFP
UNIX-STREAM-PEEK)
(GLOBALVARS *SHELL-DEVICE*)
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNIX-PEEKEDCHAR UNIX-LASTCHAR))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITIALIZE-SHELL-DEVICE]
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* ;; "streams to UNIX processes & pseudo terminals")
(* ;; "this stuff should really be implemented in terms of {SHELL} and {PTY} devices")
(* ; "Forking stuff")
(DEFINEQ
(FORK-SHELL
[LAMBDA (TERMTYPE COMMAND) (* ; "Edited 14-Feb-90 14:27 by bvm")
(if (SUBRCALL UNIX-HANDLECOMM 8)
then (* ;
 "Yes, lde supports this new version")
[SUBRCALL UNIX-HANDLECOMM 11 (if (NULL TERMTYPE)
then ""
elseif (TYPEP TERMTYPE 'ONED-ARRAY)
then TERMTYPE
else (\DTEST (LISP-TO-UNIX-TERMTYPE TERMTYPE)
'ONED-ARRAY))
(if (NULL COMMAND)
then ""
else (\DTEST COMMAND 'ONED-ARRAY]
elseif COMMAND
then (* ;
 "have to use a different old call")
(FORK-UNIX COMMAND)
else (SUBRCALL UNIX-HANDLECOMM 4])
(FORK-UNIX
[LAMBDA (STR) (* ; "Edited 25-May-88 15:47 by drc:")
(SUBRCALL UNIX-HANDLECOMM 0 (\DTEST STR 'ONED-ARRAY])
(UNIX-KILL
[LAMBDA (CONN) (* ; "Edited 25-May-88 16:04 by drc:")
(if CONN
then (SUBRCALL UNIX-HANDLECOMM 3 CONN 0])
(UNIX-WRITE
[LAMBDA (CONN VAL) (* ; "Edited 24-Sep-90 11:27 by jds")
(* ;; "Write a byte (VAL) to the outgoing pipe connection CONN. If the write fails for non-fatal reasons (i.e., would block), loop unitl it succeeds. If the write returns NIL (meaning total failure), pass that along to the caller.")
(PROG (LENGTH-WRITTEN)
WRITE-LOOP
[SETQ LENGTH-WRITTEN (SUBRCALL UNIX-HANDLECOMM 1 (\DTEST CONN 'SMALLP)
(\DTEST VAL 'SMALLP]
(COND
((AND LENGTH-WRITTEN (IEQP 0 LENGTH-WRITTEN))
(BLOCK)
(GO WRITE-LOOP)))
(RETURN LENGTH-WRITTEN])
(CREATE-SHELL-STREAM
[LAMBDA (TERMTYPE COMMAND) (* ; "Edited 21-May-90 15:39 by jrb:")
(LET ((CHAN (FORK-SHELL TERMTYPE COMMAND))
(SHELL-DEV (if (SUBRCALL UNIX-HANDLECOMM 8)
then (* ;
 "SUBRCALL tests that this is supported")
*NEW-SHELL-DEVICE*
else *SHELL-DEVICE*)))
(COND
(CHAN (LET ((STR (create STREAM
ACCESS _ 'BOTH
DEVICE _ SHELL-DEV)))
(CL:SETF (UNIX-CHANNEL STR)
CHAN)
(* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.")
(push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
STR)
(STREAMPROP STR 'SENDSCREENPARAMS (FUNCTION UNIX.SENDSCREENPARAMS))
(STREAMPROP STR 'SETDISPLAYTYPE (FUNCTION UNIX.SETDISPLAYTYPE))
STR])
(CREATE-PROCESS-STREAM
[LAMBDA (COMM) (* ; "Edited 26-Jun-2022 13:52 by larry")
(* ;
 "Edited 26-Jun-2022 13:31 by lmm - set external format of shell stream to utf-8 ??")
(* ; "Edited 21-May-90 15:39 by jrb:")
(LET* ((SHELL-DEV (if (SUBRCALL UNIX-HANDLECOMM 8)
then (* ;
 "SUBRCALL tests that this is supported")
*NEW-SHELL-DEVICE*
else *SHELL-DEVICE*))
(STR (create STREAM
ACCESS _ 'BOTH
DEVICE _ SHELL-DEV
EOLCONVENTION _ LF.EOLC))
(CHAN (FORK-UNIX COMM)))
(if CHAN
then (CL:SETF (UNIX-CHANNEL STR)
CHAN)
(\EXTERNALFORMAT STR ':UTF-8)
(* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.")
(push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
STR)
STR
else NIL])
(UNIXCOMM-AROUNDEXITFN
[LAMBDA (EVENT) (* ; "Edited 2-Jul-90 16:35 by jrb:")
(CASE EVENT
((AFTERLOGOUT AFTERMAKESYS AFTERSAVEVM AFTERSYSOUT) (for STREAM
in (fetch (FDEV OPENFILELST)
of *SHELL-DEVICE*)
do (CLOSEF STREAM)))
((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT)
(* ;;
 "Make sure any Unix sockets get closed here, so their file system handles get closed as well")
(for STREAM in (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
when (EQ -3 (SUBRCALL UNIX-HANDLECOMM 14 (UNIX-CHANNEL STREAM)))
do (CLOSEF STREAM))))])
)
(* ; "Operations on the shell device")
(DEFINEQ
(INITIALIZE-NEW-SHELL-DEVICE
[LAMBDA NIL (* ; "Edited 12-Feb-90 17:00 by bvm")
(SETQ *NEW-SHELL-DEVICE* (create FDEV
FDBINABLE _ T
NODIRECTORIES _ T
DEVICENAME _ (FUNCTION UNIX-PTY-NEW)
BIN _ (FUNCTION \BUFFERED.BIN)
BOUT _ (FUNCTION UNIX-STREAM-OUT)
PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN)
CLOSEFILE _ (FUNCTION UNIX-STREAM-CLOSE)
GETFILEINFO _ (FUNCTION NILL)
SETFILEINFO _ (FUNCTION NILL)
EOFP _ (FUNCTION UNIX-STREAM-EOFP-NEW)
BACKFILEPTR _ (FUNCTION UNIX-BACKFILEPTR-NEW)
GETNEXTBUFFER _ (FUNCTION UNIX-GET-NEXT-BUFFER)
BLOCKIN _ (FUNCTION \BUFFERED.BINS])
(UNIX-GET-NEXT-BUFFER
[LAMBDA (STREAM WHATFOR NOERRORFLG) (* ;
 "Edited 13-Jun-90 01:07 by mitani")
(CASE WHATFOR
(READ [PROG ([BUF (ffetch (STREAM CBUFPTR) of (\DTEST STREAM 'STREAM]
(CONN (UNIX-CHANNEL STREAM))
LEN)
RETRY
(BLOCK) (* ;
 "Just so other procs get to run when someone is pounding output at Chat")
(if [AND CONN (SETQ LEN (SUBRCALL UNIX-HANDLECOMM 9 (\DTEST CONN 'SMALLP)
(OR BUF (replace (STREAM CBUFPTR)
of STREAM
with (SETQ BUF
(NCREATE 'VMEMPAGEP]
then (if (EQ LEN T)
then (* ;
 " no input available, but still alive")
(if NOERRORFLG
then (RETURN NIL)
else (* ;
 "Called from BIN--wait and try again")
(GO RETRY))
else (UNINTERRUPTABLY
(replace (STREAM COFFSET) of STREAM
with 0)
(replace (STREAM CBUFSIZE) of STREAM
with LEN))
(RETURN T))
else (RETURN (AND (NOT NOERRORFLG)
(\EOF.ACTION STREAM])
(T (SHOULDNT)))])
(UNIX-BACKFILEPTR-NEW
[LAMBDA (STREAM) (* ;
 "Edited 13-Jun-90 01:07 by mitani")
(COND
((AND (fetch (STREAM CBUFPTR) of STREAM)
(> (fetch (STREAM COFFSET) of STREAM)
0))
(add (fetch (STREAM COFFSET) of STREAM)
-1))
(T (ERROR "Can't back up this unix Stream" STREAM])
(UNIX-STREAM-EOFP-NEW
[LAMBDA (STREAM) (* ;
 "Edited 13-Jun-90 01:07 by mitani")
(* ;;; "true if bsp STREAM is at end of file, i.e. is at a mark")
(COND
((AND (ffetch (STREAM CBUFPTR) of (\DTEST STREAM 'STREAM))
(< (ffetch (STREAM COFFSET) of STREAM)
(ffetch (STREAM CBUFSIZE) of STREAM)))
NIL)
(T (NOT (UNIX-GET-NEXT-BUFFER STREAM 'READ T])
(UNIX-STREAM-OUT
[LAMBDA (STREAM CHAR) (* ; "Edited 12-Jun-90 12:58 by jrb:")
(OR (UNIX-WRITE (UNIX-CHANNEL STREAM)
(\DTEST CHAR 'SMALLP))
(CL:ERROR 'XCL:STREAM-NOT-OPEN STREAM])
(UNIX-STREAM-CLOSE
[LAMBDA (STREAM) (* ; "Edited 12-Aug-88 13:24 by drc:")
(PROG1 (UNIX-KILL (UNIX-CHANNEL STREAM))
(CL:SETF (UNIX-CHANNEL STREAM)
NIL)
(CL:SETF (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
(REMOVE STREAM (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*))))])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *NEW-SHELL-DEVICE*)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(INITIALIZE-NEW-SHELL-DEVICE)
(ADDTOVAR AROUNDEXITFNS UNIXCOMM-AROUNDEXITFN)
)
(* ; "Stuff for direct manipulation of Unix sockets")
(DEFINEQ
(CREATE-UNIX-SOCKET-STREAM
[LAMBDA (PATHNAME) (* ; "Edited 29-May-90 16:23 by jrb:")
(LET [(STR (create STREAM
ACCESS _ 'BOTH
DEVICE _ *NEW-SHELL-DEVICE*
EOLCONVENTION _ LF.EOLC))
(CHAN (SUBRCALL UNIX-HANDLECOMM 12 (\DTEST PATHNAME 'ONED-ARRAY]
(if CHAN
then (CL:SETF (UNIX-CHANNEL STR)
CHAN)
(* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.")
(push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
STR)
STR
else NIL])
(ACCEPT-UNIX-SOCKET-STREAM
[LAMBDA (SOCKSTREAM) (* ; "Edited 29-May-90 16:31 by jrb:")
(LET ((CHAN (UNIX-CHANNEL SOCKSTREAM))
NEWCHAN)
(SELECTQ (SETQ NEWCHAN (SUBRCALL UNIX-HANDLECOMM 13 CHAN))
((-1 NIL)
NEWCHAN)
(LET ((NEWSTREAM (create STREAM
ACCESS _ 'BOTH
DEVICE _ *NEW-SHELL-DEVICE*
EOLCONVENTION _ LF.EOLC)))
(CL:SETF (UNIX-CHANNEL NEWSTREAM)
NEWCHAN)
(* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.")
(push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*)
NEWSTREAM)
NEWSTREAM])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS UNIX-CHANNEL MACRO ((STR)
(fetch (STREAM F1) of STR)))
)
(CHECKIMPORTS '(FILEIO LLSUBRS)
T)
)
(* ;;
"Obsolete stuff. This is for pre-Medley1.2, where there wasn't support for buffered input on the shell device"
)
(DEFINEQ
(UNIX-BACKFILEPTR
[LAMBDA (STREAM) (* ; "Edited 14-Dec-88 09:52 by bane")
(* ;; "The trick here is to use the existing mechanisms for UNIX-PEEKCHAR")
(COND
((UNIX-PEEKEDCHAR STREAM)
(ERROR "Can only back up one character" STREAM))
((NOT (UNIX-LASTCHAR STREAM))
(ERROR "Can't back up past beginning of stream" STREAM))
(T (CL:SETF (UNIX-PEEKEDCHAR STREAM)
(UNIX-LASTCHAR STREAM])
(UNIX-READ
[LAMBDA (STREAM NO-ERROR) (* ; "Edited 14-Dec-88 09:18 by bane")
(LET* [(CONN (UNIX-CHANNEL STREAM))
(CH (AND CONN (SUBRCALL UNIX-HANDLECOMM 2 (\DTEST CONN 'SMALLP)
0]
(COND
((EQ CH T)
NIL)
[(EQ CH NIL)
(COND
(NO-ERROR NIL)
(T (\EOF.ACTION STREAM]
(T (CL:SETF (UNIX-LASTCHAR STREAM)
CH])
(INITIALIZE-SHELL-DEVICE
[LAMBDA NIL (* ; "Edited 14-Dec-88 10:45 by bane")
(SETQ *SHELL-DEVICE* (create FDEV
NODIRECTORIES _ T
DEVICENAME _ 'UNIX-PTY
BIN _ 'UNIX-STREAM-IN
BOUT _ 'UNIX-STREAM-OUT
PEEKBIN _ 'UNIX-STREAM-PEEK
CLOSEFILE _ 'UNIX-STREAM-CLOSE
GETFILEINFO _ 'NILL
SETFILEINFO _ 'NILL
EOFP _ 'UNIX-STREAM-EOFP
BACKFILEPTR _ 'UNIX-BACKFILEPTR])
(UNIX-STREAM-IN
[LAMBDA (STREAM) (* ; "Edited 9-May-88 15:05 by ")
(LET (CH)
(if (SETQ CH (UNIX-PEEKEDCHAR STREAM))
then (CL:SETF (UNIX-PEEKEDCHAR STREAM)
NIL)
else (while (NOT (SETQ CH (UNIX-READ STREAM))) do (BLOCK)))
CH])
(UNIX-STREAM-EOFP
[LAMBDA (STREAM) (* ; "Edited 2-Apr-90 11:51 by jds")
(* ;; "EOFP method for unix-shell streams. Notices when there are chars yet to read and doesn't set EOFP.")
(AND (NOT (UNIX-PEEKEDCHAR STREAM))
(LET* [(CONN (UNIX-CHANNEL STREAM))
(CH (AND CONN (SUBRCALL UNIX-HANDLECOMM 2 (\DTEST CONN 'SMALLP)
0]
(COND
((EQ CH T)
NIL)
((EQ CH NIL)
T)
(T (CL:SETF (UNIX-PEEKEDCHAR STREAM)
CH)
(CL:SETF (UNIX-LASTCHAR STREAM)
CH)
NIL])
(UNIX-STREAM-PEEK
[LAMBDA (STREAM NO-ERROR) (* ; "Edited 24-Jun-88 15:07 by drc:")
(OR (UNIX-PEEKEDCHAR STREAM)
(CL:SETF (UNIX-PEEKEDCHAR STREAM)
(UNIX-READ STREAM NO-ERROR])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *SHELL-DEVICE*)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS UNIX-PEEKEDCHAR MACRO ((STR)
(FETCH (STREAM F2) OF STR)))
(PUTPROPS UNIX-LASTCHAR MACRO ((STR)
(FETCH (STREAM F3) OF STR)))
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(INITIALIZE-SHELL-DEVICE)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS UNIXCOMM COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 2018))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2648 8649 (FORK-SHELL 2658 . 3855) (FORK-UNIX 3857 . 4033) (UNIX-KILL 4035 . 4224) (
UNIX-WRITE 4226 . 4937) (CREATE-SHELL-STREAM 4939 . 6255) (CREATE-PROCESS-STREAM 6257 . 7746) (
UNIXCOMM-AROUNDEXITFN 7748 . 8647)) (8697 13685 (INITIALIZE-NEW-SHELL-DEVICE 8707 . 9800) (
UNIX-GET-NEXT-BUFFER 9802 . 12002) (UNIX-BACKFILEPTR-NEW 12004 . 12483) (UNIX-STREAM-EOFP-NEW 12485 .
13031) (UNIX-STREAM-OUT 13033 . 13289) (UNIX-STREAM-CLOSE 13291 . 13683)) (13941 15806 (
CREATE-UNIX-SOCKET-STREAM 13951 . 14812) (ACCEPT-UNIX-SOCKET-STREAM 14814 . 15804)) (16155 19334 (
UNIX-BACKFILEPTR 16165 . 16663) (UNIX-READ 16665 . 17187) (INITIALIZE-SHELL-DEVICE 17189 . 17928) (
UNIX-STREAM-IN 17930 . 18306) (UNIX-STREAM-EOFP 18308 . 19082) (UNIX-STREAM-PEEK 19084 . 19332)))))
STOP