src/os/create-process-unix.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Wrapper over lfp_spawn(3)
   4 ;;;
   5
   6 (in-package :iolib.os)
   7
   8 (defclass process ()
   9   ((pid    :initarg :pid :reader process-pid)
  10    (status :initform nil :reader process-exit-status)
  11    (reaped :initform nil)
  12    (stdin  :initform nil :reader process-stdin)
  13    (stdout :initform nil :reader process-stdout)
  14    (stderr :initform nil :reader process-stderr)))
  15
  16 (defmethod initialize-instance :after ((process process) &key stdin stdout stderr)
  17   (with-slots ((in stdin) (out stdout) (err stderr))
  18       process
  19     (setf in  (and stdin  (make-instance 'iolib.streams:dual-channel-gray-stream :fd stdin))
  20           out (and stdout (make-instance 'iolib.streams:dual-channel-gray-stream :fd stdout))
  21           err (and stderr (make-instance 'iolib.streams:dual-channel-gray-stream :fd stderr)))))
  22
  23 (defmethod close ((process process) &key abort)
  24   (with-slots (pid reaped stdin stdout stderr)
  25       process
  26     (when stdin  (close stdin  :abort abort))
  27     (when stdout (close stdout :abort abort))
  28     (when stderr (close stderr :abort abort))
  29     (unless reaped
  30       (isys:waitpid pid (if abort isys:wnohang 0)))
  31     (setf pid nil stdin nil stdout nil stderr nil)))
  32
  33 (defmethod print-object ((o process) s)
  34   (print-unreadable-object (o s :type t :identity t)
  35     (format s "~S ~S" :pid (process-pid o))))
  36
  37 (defun exit-status (status)
  38   (cond
  39     ((isys:wifexited status)
  40      (isys:wexitstatus status))
  41     ((isys:wifsignaled status)
  42      (values (isys:wtermsig* status)
  43              (isys:wcoredump status)))))
  44
  45 (defmethod process-wait ((process process))
  46   (let ((status (nth-value 1 (isys:waitpid (process-pid process) 0))))
  47     (multiple-value-prog1
  48         (exit-status status)
  49       (setf (slot-value process 'reaped) t
  50             (slot-value process 'status) status))))
  51
  52 (defmethod process-kill ((process process) &optional (signum :sigterm))
  53   (isys:kill (process-pid process) signum)
  54   process)
  55 \f
  56
  57 (defmacro with-lfp-spawn-arguments ((attributes file-actions pid) &body body)
  58   (with-gensyms (spawnattr-initialized-p file-actions-initialized-p)
  59     `(with-foreign-objects ((,attributes 'lfp-spawnattr-t)
  60                             (,file-actions 'lfp-spawn-file-actions-t)
  61                             (,pid 'pid-t))
  62        (let (,spawnattr-initialized-p
  63              ,file-actions-initialized-p)
  64          (unwind-protect
  65               (progn
  66                 (lfp-spawnattr-init ,attributes)
  67                 (setf ,spawnattr-initialized-p t)
  68                 (lfp-spawn-file-actions-init ,file-actions)
  69                 (setf ,file-actions-initialized-p t)
  70                 ,@body)
  71            (when ,spawnattr-initialized-p
  72              (lfp-spawnattr-destroy ,attributes))
  73            (when ,file-actions-initialized-p
  74              (lfp-spawn-file-actions-destroy ,file-actions)))))))
  75
  76 (defun allocate-argv (argv argc program arglist)
  77   ;; copy program name
  78   (setf (mem-aref argv :pointer 0)
  79         (foreign-string-alloc program))
  80   ;; copy program arguments
  81   (loop :for i :from 1
  82         :for arg :in arglist :do
  83         (setf (mem-aref argv :pointer i)
  84               (foreign-string-alloc arg)))
  85   ;; final null pointer
  86   (setf (mem-aref argv :pointer (1- argc)) (null-pointer)))
  87
  88 (defun find-program (program)
  89   (cond
  90     ((eql :shell program)
  91      "/bin/sh")
  92     (t
  93      (file-path-namestring program))))
  94
  95 (defmacro with-argv (((arg0 argv) program arguments) &body body)
  96   (with-gensyms (argc)
  97     `(let ((,program (find-program ,program))
  98            (,argc (+ 2 (length ,arguments))))
  99        (with-foreign-object (,argv :pointer ,argc)
 100          (unwind-protect
 101               (progn
 102                 (allocate-argv ,argv ,argc ,program ,arguments)
 103                 (let ((,arg0 (mem-ref ,argv :pointer)))
 104                   ,@body))
 105            (deallocate-null-ended-list ,argv))))))
 106
 107 (defun redirect-one-stream (file-actions fd stream &optional flags (mode #o644) close-old-fd)
 108   (flet ((dup-from-path (path)
 109            (lfp-spawn-file-actions-addopen file-actions fd path flags mode))
 110          (dup-from-fd (oldfd)
 111            (lfp-spawn-file-actions-adddup2 file-actions oldfd fd)
 112            (when close-old-fd
 113              (lfp-spawn-file-actions-addclose file-actions oldfd))))
 114     (etypecase stream
 115       ((eql t) nil)
 116       ((or string file-path pathname)
 117        (dup-from-path (file-path-namestring stream)))
 118       ((eql :null)
 119        (dup-from-path "/dev/null"))
 120       (unsigned-byte
 121        (dup-from-fd stream))
 122       (iolib.streams:dual-channel-fd-mixin
 123        (dup-from-fd (iolib.streams:fd-of stream)))
 124       (null
 125        (lfp-spawn-file-actions-addclose file-actions fd)))))
 126
 127 (defun redirect-to-pipes (file-actions fd keep-write-fd)
 128   (multiple-value-bind (pipe-parent pipe-child)
 129       (isys:pipe)
 130     (when keep-write-fd (rotatef pipe-parent pipe-child))
 131     (lfp-spawn-file-actions-adddup2 file-actions pipe-child fd)
 132     (lfp-spawn-file-actions-addclose file-actions pipe-parent)
 133     (lfp-spawn-file-actions-addclose file-actions pipe-child)
 134     (values pipe-parent pipe-child)))
 135
 136 (defun setup-redirections (file-actions stdin stdout stderr)
 137   (let (infd infd-child outfd outfd-child errfd errfd-child)
 138     ;; Standard input
 139     (if (eql :pipe stdin)
 140         (setf (values infd infd-child)
 141               (redirect-to-pipes file-actions +stdin+ t))
 142         (redirect-one-stream file-actions +stdin+ stdin isys:o-rdonly))
 143     ;; Standard output
 144     (if (eql :pipe stdout)
 145         (setf (values outfd outfd-child)
 146               (redirect-to-pipes file-actions +stdout+ nil))
 147         (redirect-one-stream file-actions +stdout+ stdout (logior isys:o-wronly
 148                                                                   isys:o-creat)))
 149     ;; Standard error
 150     (if (eql :pipe stderr)
 151         (setf (values errfd errfd-child)
 152               (redirect-to-pipes file-actions +stderr+ nil))
 153         (redirect-one-stream file-actions +stderr+ stderr (logior isys:o-wronly
 154                                                                   isys:o-creat)))
 155     (values infd infd-child outfd outfd-child errfd errfd-child)))
 156
 157 (defun close-fds (&rest fds)
 158   (dolist (fd fds)
 159     (when fd (isys:close fd))))
 160
 161 (defmacro with-redirections (((infd outfd errfd) (file-actions stdin stdout stderr))
 162                              &body body)
 163   (with-gensyms (infd-child outfd-child errfd-child)
 164     `(multiple-value-bind (,infd ,infd-child ,outfd ,outfd-child ,errfd ,errfd-child)
 165          (setup-redirections ,file-actions ,stdin ,stdout ,stderr)
 166        (unwind-protect-case ()
 167            (locally ,@body)
 168          (:always
 169           (close-fds ,infd-child ,outfd-child ,errfd-child))
 170          (:abort
 171           (close-fds ,infd ,outfd ,errfd))))))
 172
 173 (defun process-other-spawn-args (attributes uid gid resetids current-directory)
 174   (when uid
 175     (lfp-spawnattr-setuid attributes uid))
 176   (when gid
 177     (lfp-spawnattr-setgid attributes gid))
 178   (when resetids
 179     (lfp-spawnattr-setflags attributes lfp-spawn-resetids))
 180   (when current-directory
 181     (lfp-spawnattr-setcwd attributes current-directory)))
 182
 183 ;; program: :shell - the system shell
 184 ;;          file-path designator - a path
 185 ;; arguments: list
 186 ;; environment: t - inherit environment
 187 ;;              nil - NULL environment
 188 ;;              alist - the environment to use
 189 ;; stdin, stdout, stderr:
 190 ;;         file-path designator - open file, redirect to it
 191 ;;         :null - redirect to /dev/null - useful because /dev/null doesn't exist on Windows
 192 ;;         file-descriptor designator(integer or stream) - file descriptor, redirecto to it
 193 ;;         :pipe - create pipe, redirect the child descriptor to one end and wrap the other end
 194 ;;                 into a stream which goes into PROCESS slot
 195 ;;         t - inherit
 196 ;;         nil - close
 197 ;; uid: user id - unsigned-byte or string
 198 ;; gid: group id - unsigned-byte or string
 199 ;; resetids: boolean - reset effective UID and GID to saved IDs
 200 ;; current-directory: path - a directory to switch to before executing
 201
 202 (defun create-process (program-and-args &key (environment t)
 203                        (stdin :pipe) (stdout :pipe) (stderr :pipe)
 204                        uid gid resetids current-directory)
 205   (destructuring-bind (program &rest arguments)
 206       (ensure-list program-and-args)
 207     (with-argv ((arg0 argv) program arguments)
 208       (with-c-environment (envp environment)
 209         (with-lfp-spawn-arguments (attributes file-actions pid)
 210           (with-redirections ((infd outfd errfd) (file-actions stdin stdout stderr))
 211             (process-other-spawn-args attributes uid gid resetids current-directory)
 212             (lfp-spawnp pid arg0 argv envp file-actions attributes)
 213             (make-instance 'process :pid (mem-ref pid 'pid-t)
 214                            :stdin infd :stdout outfd :stderr errfd)))))))
 215
 216 (defun run-program (program-and-args &key (environment t) (stderr t))
 217   (flet ((slurp (stream)
 218            (with-output-to-string (s)
 219              (loop :for c := (read-char stream nil nil)
 220                    :while c :do (write-char c s)))))
 221     (let ((process (create-process program-and-args
 222                                    :environment environment
 223                                    :stdout :pipe
 224                                    :stderr (if stderr :pipe +stdout+))))
 225       (unwind-protect
 226            (values (process-wait process)
 227                    (slurp (process-stdout process))
 228                    (if stderr
 229                        (slurp (process-stderr process))
 230                        (make-string 0)))
 231         (close process)))))