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
  18                             :output-fd stdin)
  19           out (make-instance 'iolib.streams:dual-channel-gray-stream
  20                              :input-fd stdout)
  21           err (make-instance 'iolib.streams:dual-channel-gray-stream
  22                              :input-fd stderr))))
  23
  24 (defmethod close ((process process) &key abort)
  25   (with-slots (pid stdin stdout stderr)
  26       process
  27     (close stdin :abort abort)
  28     (close stdout :abort abort)
  29     (close stderr :abort abort)
  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 ":pid ~S" (process-pid o))))
  35
  36 (defmacro with-posix-spawn-arguments ((attributes file-actions pid) &body body)
  37   (with-gensyms (spawnattr-initialized-p file-actions-initialized-p)
  38     `(with-foreign-objects ((,attributes 'posix-spawnattr-t)
  39                             (,file-actions 'posix-spawn-file-actions-t)
  40                             (,pid 'pid-t))
  41        (let (,spawnattr-initialized-p
  42              ,file-actions-initialized-p)
  43          (unwind-protect
  44               (progn
  45                 (posix-spawnattr-init ,attributes)
  46                 (setf ,spawnattr-initialized-p t)
  47                 (posix-spawn-file-actions-init ,file-actions)
  48                 (setf ,file-actions-initialized-p t)
  49                 ,@body)
  50            (when ,spawnattr-initialized-p
  51              (posix-spawnattr-destroy ,attributes))
  52            (when ,file-actions-initialized-p
  53              (posix-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 (defmacro with-argv ((argv program arguments) &body body)
  68   (with-gensyms (argc)
  69     `(let ((,argc (+ 2 (length ,arguments))))
  70        (with-foreign-object (,argv :pointer ,argc)
  71          (unwind-protect
  72               (progn
  73                 (allocate-argv ,argv ,argc ,program ,arguments)
  74                 ,@body)
  75            (deallocate-null-ended-list ,argv))))))
  76
  77 (defmacro with-3-pipes ((stdin-r stdin-w stdout-r stdout-w stderr-r stderr-w)
  78                         &body body)
  79   `(multiple-value-bind (,stdin-r ,stdin-w) (isys:pipe)
  80      (multiple-value-bind (,stdout-r ,stdout-w) (isys:pipe)
  81        (multiple-value-bind (,stderr-r ,stderr-w) (isys:pipe)
  82          (unwind-protect-case ()
  83              (progn ,@body)
  84            ;; These are the FDs that we would use on the Lisp side
  85            (:abort
  86             (isys:close ,stdin-w)
  87             (isys:close ,stdout-r)
  88             (isys:close ,stderr-r))
  89            ;; These FDs are shared with the subprocess, must be closed always
  90            (:always
  91             (isys:close ,stdin-r)
  92             (isys:close ,stdout-w)
  93             (isys:close ,stderr-w)))))))
  94
  95 (defun create-process (program &optional arguments &key (search t) environment
  96                                ;; path uid gid effective
  97                                )
  98   (with-posix-spawn-arguments (attributes file-actions pid)
  99     (with-argv (argv program arguments)
 100       (with-c-environment (environment)
 101         (with-3-pipes (stdin-r stdin-w stdout-r stdout-w stderr-r stderr-w)
 102           (posix-spawn-file-actions-adddup2 file-actions stdin-r +stdin+)
 103           (posix-spawn-file-actions-adddup2 file-actions stdout-w +stdout+)
 104           (posix-spawn-file-actions-adddup2 file-actions stderr-w +stderr+)
 105           (with-foreign-string (cfile program)
 106             (if search
 107                 (posix-spawnp pid cfile file-actions attributes argv isys:*environ*)
 108                 (posix-spawn  pid cfile file-actions attributes argv isys:*environ*)))
 109           (make-instance 'process :pid (mem-ref pid 'pid-t)
 110                          :stdin stdin-w :stdout stdout-r :stderr stderr-r))))))
 111
 112 (defun run-program (program &optional arguments &key (search t) environment)
 113   (flet ((slurp-stream-into-string (stream)
 114            (with-output-to-string (s)
 115              (loop :for c := (read-char stream nil nil)
 116                    :while c :do (write-char c s)))))
 117     (let ((process (create-process program arguments
 118                                    :search search
 119                                    :environment environment)))
 120       (values (process-wait process)
 121               (slurp-stream-into-string (process-stdout process))
 122               (slurp-stream-into-string (process-stderr process))))))
 123
 124 (defun process-wait (process)
 125   (isys:waitpid (process-pid process) 0))
 126
 127 (defun process-kill (process signum)
 128   (isys:kill (process-pid process) signum))