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