src/os/create-process-unix.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Wrapper over posix_spawn(3)
   4 ;;;
   5
   6 (in-package :iolib.os)
   7
   8 (defclass process ()
   9   ((pid    :initarg :pid :reader process-pid)
  10    (stdin  :initform nil :reader process-stdin)
  11    (stdout :initform nil :reader process-stdout)
  12    (stderr :initform nil :reader process-stderr)))
  13
  14 (defmethod initialize-instance :after ((process process) &key stdin stdout stderr)
  15   (with-slots ((in stdin) (out stdout) (err stderr))
  16       process
  17     (setf in (make-instance 'iolib.streams:dual-channel-gray-stream :fd stdin)
  18           out (make-instance 'iolib.streams:dual-channel-gray-stream :fd stdout)
  19           err (make-instance 'iolib.streams:dual-channel-gray-stream :fd stderr))))
  20
  21 (defmethod close ((process process) &key abort)
  22   (with-slots (pid stdin stdout stderr)
  23       process
  24     (close stdin :abort abort)
  25     (close stdout :abort abort)
  26     (close stderr :abort abort)
  27     (setf pid nil stdin nil stdout nil stderr nil)))
  28
  29 (defmethod print-object ((o process) s)
  30   (print-unreadable-object (o s :type t :identity t)
  31     (format s ":pid ~S" (process-pid o))))
  32
  33 (defmacro with-posix-spawn-arguments ((attributes file-actions pid) &body body)
  34   (with-gensyms (spawnattr-initialized-p file-actions-initialized-p)
  35     `(with-foreign-objects ((,attributes 'posix-spawnattr-t)
  36                             (,file-actions 'posix-spawn-file-actions-t)
  37                             (,pid 'pid-t))
  38        (let (,spawnattr-initialized-p
  39              ,file-actions-initialized-p)
  40          (unwind-protect
  41               (progn
  42                 (posix-spawnattr-init ,attributes)
  43                 (setf ,spawnattr-initialized-p t)
  44                 (posix-spawn-file-actions-init ,file-actions)
  45                 (setf ,file-actions-initialized-p t)
  46                 ,@body)
  47            (when ,spawnattr-initialized-p
  48              (posix-spawnattr-destroy ,attributes))
  49            (when ,file-actions-initialized-p
  50              (posix-spawn-file-actions-destroy ,file-actions)))))))
  51
  52 (defun allocate-argv (argv argc program arglist)
  53   ;; copy program name
  54   (setf (mem-aref argv :pointer 0)
  55         (foreign-string-alloc program))
  56   ;; copy program arguments
  57   (loop :for i :from 1
  58         :for arg :in arglist :do
  59         (setf (mem-aref argv :pointer i)
  60               (foreign-string-alloc arg)))
  61   ;; final null pointer
  62   (setf (mem-aref argv :pointer (1- argc)) (null-pointer)))
  63
  64 (defmacro with-argv ((argv program arguments) &body body)
  65   (with-gensyms (argc)
  66     `(let ((,argc (+ 2 (length ,arguments))))
  67        (with-foreign-object (,argv :pointer ,argc)
  68          (unwind-protect
  69               (progn
  70                 (allocate-argv ,argv ,argc ,program ,arguments)
  71                 ,@body)
  72            (deallocate-null-ended-list ,argv))))))
  73
  74 (defmacro with-3-pipes ((stdin-r stdin-w stdout-r stdout-w stderr-r stderr-w)
  75                         &body body)
  76   `(multiple-value-bind (,stdin-r ,stdin-w) (isys:pipe)
  77      (multiple-value-bind (,stdout-r ,stdout-w) (isys:pipe)
  78        (multiple-value-bind (,stderr-r ,stderr-w) (isys:pipe)
  79          (unwind-protect-case ()
  80              (progn ,@body)
  81            ;; These are the FDs that we would use on the Lisp side
  82            (:abort
  83             (isys:close ,stdin-w)
  84             (isys:close ,stdout-r)
  85             (isys:close ,stderr-r))
  86            ;; These FDs are shared with the subprocess, must be closed always
  87            (:always
  88             (isys:close ,stdin-r)
  89             (isys:close ,stdout-w)
  90             (isys:close ,stderr-w)))))))
  91
  92 (defun create-process (program &optional arguments &key (search t) environment
  93                                ;; path uid gid effective
  94                                )
  95   (with-posix-spawn-arguments (attributes file-actions pid)
  96     (with-argv (argv program arguments)
  97       (with-c-environment (environment)
  98         (with-3-pipes (stdin-r stdin-w stdout-r stdout-w stderr-r stderr-w)
  99           (posix-spawn-file-actions-adddup2 file-actions stdin-r +stdin+)
 100           (posix-spawn-file-actions-adddup2 file-actions stdout-w +stdout+)
 101           (posix-spawn-file-actions-adddup2 file-actions stderr-w +stderr+)
 102           (with-foreign-string (cfile program)
 103             (if search
 104                 (posix-spawnp pid cfile file-actions attributes argv isys:*environ*)
 105                 (posix-spawn  pid cfile file-actions attributes argv isys:*environ*)))
 106           (make-instance 'process :pid (mem-ref pid 'pid-t)
 107                          :stdin stdin-w :stdout stdout-r :stderr stderr-r))))))
 108
 109 (defun run-program (program &optional arguments &key (search t) environment)
 110   (flet ((slurp-stream-into-string (stream)
 111            (with-output-to-string (s)
 112              (loop :for c := (read-char stream nil nil)
 113                    :while c :do (write-char c s)))))
 114     (let ((process (create-process program arguments
 115                                    :search search
 116                                    :environment environment)))
 117       (values (process-wait process)
 118               (slurp-stream-into-string (process-stdout process))
 119               (slurp-stream-into-string (process-stderr process))))))
 120
 121 (defun process-wait (process)
 122   (isys:waitpid (process-pid process) 0))
 123
 124 (defun process-kill (process signum)
 125   (isys:kill (process-pid process) signum))