(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED " 7-Jul-2022 10:42:46" 
{DSK}<users>kaplan>local>medley3.5>working-medley>library>UNIXCOMM.;6
 20326  

      :CHANGES-TO (FNS INITIALIZE-NEW-SHELL-DEVICE)

      :PREVIOUS-DATE " 3-Jul-2022 16:16:31" 
{DSK}<users>kaplan>local>medley3.5>working-medley>library>UNIXCOMM.;5)


(* ; "
Copyright (c) 1988-1990, 2018, 2022 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]
        (PROP FILETYPE UNIXCOMM)))



(* ;; "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  3-Jul-2022 16:04 by rmk: Removed external format here, the device has the environmental defaultg")


    (* ;; "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
 (AND (BOUNDP '*NEW-SHELL-DEVICE)
                               (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) 

                   (* ;; "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  7-Jul-2022 10:41 by rmk")


                                                             (* ; "Edited  3-Jul-2022 16:04 by rmk")


                                                             (* ; "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)
                                    DEFAULTEXTERNALFORMAT _ (SYSTEM-EXTERNALFORMAT])

(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  3-Jul-2022 16:15 by rmk")


                                                             (* ; "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
                                DEFAULTEXTERNALFORMAT _ (AND (STRPOS ".UTF-8" (UNIX-GETENV "LANG"))
                                                             :UTF-8])

(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
)
)

(PUTPROPS UNIXCOMM
 FILETYPE
 FAKE-COMPILE-FILE)
(PUTPROPS UNIXCOMM COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 2018 2022))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2492 8463 (FORK-SHELL 2502 . 3699) (FORK-UNIX 3701 . 3877) (UNIX-KILL 3879 . 4068) (
UNIX-WRITE 4070 . 4781) (CREATE-SHELL-STREAM 4783 . 6099) (CREATE-PROCESS-STREAM 6101 . 7560) (
UNIXCOMM-AROUNDEXITFN 7562 . 8461)) (8511 13805 (INITIALIZE-NEW-SHELL-DEVICE 8521 . 9920) (
UNIX-GET-NEXT-BUFFER 9922 . 12122) (UNIX-BACKFILEPTR-NEW 12124 . 12603) (UNIX-STREAM-EOFP-NEW 12605 . 
13151) (UNIX-STREAM-OUT 13153 . 13409) (UNIX-STREAM-CLOSE 13411 . 13803)) (14061 15926 (
CREATE-UNIX-SOCKET-STREAM 14071 . 14932) (ACCEPT-UNIX-SOCKET-STREAM 14934 . 15924)) (16275 19735 (
UNIX-BACKFILEPTR 16285 . 16783) (UNIX-READ 16785 . 17307) (INITIALIZE-SHELL-DEVICE 17309 . 18329) (
UNIX-STREAM-IN 18331 . 18707) (UNIX-STREAM-EOFP 18709 . 19483) (UNIX-STREAM-PEEK 19485 . 19733)))))
STOP