"Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs."
(c-strings->string-list (wrapped-environ))))
-;#+win32 (sb-alien:define-alien-routine msvcrt-environ (* c-string))
+#+win32
+(progn
+ (defun decode-windows-environment (environment)
+ (loop until (zerop (sap-ref-8 environment 0))
+ collect
+ (let ((string (sb-alien::c-string-to-string environment
+ (sb-alien::default-c-string-external-format)
+ 'character)))
+ (loop for value = (sap-ref-8 environment 0)
+ do (setf environment (sap+ environment 1))
+ until (zerop value))
+ string)))
-;;; Convert as best we can from an SBCL representation of a Unix
-;;; environment to a CMU CL representation.
-;;;
-;;; * (UNIX-ENVIRONMENT-CMUCL-FROM-SBCL '("Bletch=fub" "Noggin" "YES=No!"))
-;;; WARNING:
-;;; smashing case of "Bletch=fub" in conversion to CMU-CL-style
-;;; environment alist
-;;; WARNING:
-;;; no #\= in "Noggin", eliding it in CMU-CL-style environment alist
-;;; ((:BLETCH . "fub") (:YES . "No!"))
-(defun unix-environment-cmucl-from-sbcl (sbcl)
- (mapcan
- (lambda (string)
- (declare (string string))
- (let ((=-pos (position #\= string :test #'equal)))
- (if =-pos
- (list
- (let* ((key-as-string (subseq string 0 =-pos))
- (key-as-upcase-string (string-upcase key-as-string))
- (key (keywordicate key-as-upcase-string))
- (val (subseq string (1+ =-pos))))
- (unless (string= key-as-string key-as-upcase-string)
- (warn "smashing case of ~S in conversion to CMU-CL-style ~
- environment alist"
- string))
- (cons key val)))
- (warn "no #\\= in ~S, eliding it in CMU-CL-style environment alist"
- string))))
- sbcl))
+ (defun encode-windows-environment (list)
+ (let* ((external-format (sb-alien::default-c-string-external-format))
+ octets
+ (length 1)) ;; 1 for \0 at the very end
+ (setf octets
+ (loop for x in list
+ for octet =
+ (string-to-octets x :external-format external-format
+ :null-terminate t)
+ collect octet
+ do
+ (incf length (length octet))))
+ (let ((mem (allocate-system-memory length))
+ (index 0))
+
+ (loop for string in octets
+ for length = (length string)
+ do
+ (copy-ub8-to-system-area string 0 mem index length)
+ (incf index length))
+ (setf (sap-ref-8 mem index) 0)
+ (values mem mem length))))
+
+ (defun posix-environ ()
+ (decode-windows-environment
+ (alien-funcall (extern-alien "GetEnvironmentStrings"
+ (function system-area-pointer))))))
;;; Convert from a CMU CL representation of a Unix environment to a
;;; SBCL representation.
;;;; Import wait3(2) from Unix.
#-win32
-(define-alien-routine ("waitpid" c-waitpid) sb-alien:int
- (pid sb-alien:int)
- (status sb-alien:int :out)
- (options sb-alien:int))
+(define-alien-routine ("waitpid" c-waitpid) int
+ (pid int)
+ (status int :out)
+ (options int))
#-win32
(defun waitpid (pid &optional do-not-hang check-for-stopped)
#+sb-doc
"List of process structures for all active processes.")
-#-win32
(defvar *active-processes-lock*
(sb-thread:make-mutex :name "Lock for active processes."))
;;; mutex is needed. More importantly the sigchld signal handler also
;;; accesses it, that's why we need without-interrupts.
(defmacro with-active-processes-lock (() &body body)
- #-win32
`(sb-thread::with-system-mutex (*active-processes-lock*)
- ,@body)
- #+win32
- `(progn ,@body))
+ ,@body))
(defstruct (process (:copier nil))
pid ; PID of child process
%status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
- exit-code ; either exit code or signal
+ %exit-code ; either exit code or signal
core-dumped ; T if a core image was dumped
#-win32 pty ; stream to child's pty, or NIL
input ; stream to child's input, or NIL
(print-unreadable-object (process stream :type t)
(let ((status (process-status process)))
(if (eq :exited status)
- (format stream "~S ~S" status (process-exit-code process))
+ (format stream "~S ~S" status (process-%exit-code process))
(format stream "~S ~S" (process-pid process) status)))
process))
(setf (documentation 'process-pid 'function) "The pid of the child process.")
#+win32
-(define-alien-routine ("GetExitCodeProcess@8" get-exit-code-process)
+(define-alien-routine ("GetExitCodeProcess" get-exit-code-process)
int
(handle unsigned) (exit-code unsigned :out))
+(defun process-exit-code (process)
+ #+sb-doc
+ "Return the exit code of PROCESS."
+ (or (process-%exit-code process)
+ (progn (get-processes-status-changes)
+ (process-%exit-code process))))
+
(defun process-status (process)
#+sb-doc
"Return the current status of PROCESS. The result is one of :RUNNING,
"Wait for PROCESS to quit running for some reason. When
CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns
PROCESS."
+ (declare (ignorable check-for-stopped))
+ #+win32
+ (let ((pid (process-pid process)))
+ (when (and pid (plusp pid))
+ (without-interrupts
+ (do ()
+ ((= 0
+ (with-local-interrupts
+ (sb-win32:wait-object-or-signal pid))))))))
+ #-win32
(loop
(case (process-status process)
(:running)
(t
(when (zerop (car (process-cookie process)))
(return))))
- (sb-sys:serve-all-events 1))
+ (serve-all-events 1))
process)
#-win32
;;; Find the current foreground process group id.
(defun find-current-foreground-process (proc)
- (with-alien ((result sb-alien:int))
+ (with-alien ((result int))
(multiple-value-bind
(wonp error)
- (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
+ (sb-unix:unix-ioctl (fd-stream-fd (process-pty proc))
sb-unix:TIOCGPGRP
- (alien-sap (sb-alien:addr result)))
+ (alien-sap (addr result)))
(unless wonp
(error "TIOCPGRP ioctl failed: ~S" (strerror error)))
result))
((and (eql pid (process-pid process))
(= signal sb-unix:sigcont))
(setf (process-%status process) :running)
- (setf (process-exit-code process) nil)
+ (setf (process-%exit-code process) nil)
(when (process-status-hook process)
(funcall (process-status-hook process) process))
t)
;; maybe it should be set to :CLOSED, or similar?
(with-active-processes-lock ()
(setf *active-processes* (delete process *active-processes*)))
+ #+win32
+ (let ((handle (shiftf (process-pid process) nil)))
+ (when (and handle (plusp handle))
+ (or (sb-win32:close-handle handle)
+ (sb-win32::win32-error 'process-close))))
process)
(defun get-processes-status-changes ()
(waitpid (process-pid proc) t t)
(when pid
(setf (process-%status proc) what)
- (setf (process-exit-code proc) code)
+ (setf (process-%exit-code proc) code)
(setf (process-core-dumped proc) core)
(when (process-status-hook proc)
(push proc exited))
t)))
#+win32
(lambda (proc)
- (multiple-value-bind (ok code)
- (get-exit-code-process (process-pid proc))
- (when (and (plusp ok) (/= code 259))
- (setf (process-%status proc) :exited
- (process-exit-code proc) code)
- (when (process-status-hook proc)
- (push proc exited))
- t)))
+ (let ((pid (process-pid proc)))
+ (when pid
+ (multiple-value-bind (ok code)
+ (sb-win32::get-exit-code-process pid)
+ (when (and (plusp ok) (/= code 259))
+ (setf (process-%status proc) :exited
+ (process-%exit-code proc) code)
+ (when (process-status-hook proc)
+ (push proc exited))
+ t)))))
*active-processes*)))
;; Can't call the hooks before all the processes have been deal
;; with, as calling a hook may cause re-entry to
;; First try to use the Unix98 pty api.
(let* ((master-name (coerce (format nil "/dev/ptmx") 'base-string))
(master-fd (sb-unix:unix-open master-name
- sb-unix:o_rdwr
+ (logior sb-unix:o_rdwr
+ sb-unix:o_noctty)
#o666)))
(when master-fd
(grantpt master-fd)
(unlockpt master-fd)
(let* ((slave-name (ptsname master-fd))
(slave-fd (sb-unix:unix-open slave-name
- sb-unix:o_rdwr
+ (logior sb-unix:o_rdwr
+ sb-unix:o_noctty)
#o666)))
(when slave-fd
(return-from find-a-pty
(let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit)
'base-string))
(master-fd (sb-unix:unix-open master-name
- sb-unix:o_rdwr
+ (logior sb-unix:o_rdwr
+ sb-unix:o_noctty)
#o666)))
(when master-fd
(let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit)
'base-string))
(slave-fd (sb-unix:unix-open slave-name
- sb-unix:o_rdwr
+ (logior sb-unix:o_rdwr
+ sb-unix:o_noctty)
#o666)))
(when slave-fd
(return-from find-a-pty
(push new-fd *close-on-error*)
(copy-descriptor-to-stream new-fd pty cookie external-format)))
(values name
- (sb-sys:make-fd-stream master :input t :output t
+ (make-fd-stream master :input t :output t
:external-format external-format
:element-type :default
:dual-channel-p t)))))
;; A-T-S-L even for simple encodings like ASCII. Multibyte encodings
;; may need more than a single byte of zeros; assume 4 byte is enough
;; for everyone.
+#-win32
(defmacro round-null-terminated-bytes-to-words (n)
- (let ((bytes-per-word (/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)))
- `(logandc2 (the sb-vm:signed-word (+ (the fixnum ,n)
- 4 (1- ,bytes-per-word)))
- (1- ,bytes-per-word))))
+ `(logandc2 (the sb-vm:signed-word (+ (the fixnum ,n)
+ 4 (1- sb-vm:n-word-bytes)))
+ (1- sb-vm:n-word-bytes)))
+#-win32
(defun string-list-to-c-strvec (string-list)
- (let* ((bytes-per-word (/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))
- ;; We need an extra for the null, and an extra 'cause exect
+ (let* (;; We need an extra for the null, and an extra 'cause exect
;; clobbers argv[-1].
- (vec-bytes (* bytes-per-word (+ (length string-list) 2)))
+ (vec-bytes (* sb-vm:n-word-bytes (+ (length string-list) 2)))
(octet-vector-list (mapcar (lambda (s)
(string-to-octets s))
string-list))
(length s)))))
(total-bytes (+ string-bytes vec-bytes))
;; Memory to hold the vector of pointers and all the strings.
- (vec-sap (sb-sys:allocate-system-memory total-bytes))
+ (vec-sap (allocate-system-memory total-bytes))
(string-sap (sap+ vec-sap vec-bytes))
;; Index starts from [1]!
- (vec-index-offset bytes-per-word))
+ (vec-index-offset sb-vm:n-word-bytes))
(declare (sb-vm:signed-word vec-bytes)
(sb-vm:word string-bytes total-bytes)
- (sb-sys:system-area-pointer vec-sap string-sap))
+ (system-area-pointer vec-sap string-sap))
(dolist (octets octet-vector-list)
(declare (type (simple-array (unsigned-byte 8) (*)) octets))
(let ((size (length octets)))
;; Copy string.
(sb-kernel:copy-ub8-to-system-area octets 0 string-sap 0 size)
;; NULL-terminate it
- (setf (sap-ref-32 string-sap size) 0)
+ (sb-kernel:system-area-ub8-fill 0 string-sap size 4)
;; Put the pointer in the vector.
(setf (sap-ref-sap vec-sap vec-index-offset) string-sap)
;; Advance string-sap for the next string.
(setf string-sap (sap+ string-sap
(round-null-terminated-bytes-to-words size)))
- (incf vec-index-offset bytes-per-word)))
+ (incf vec-index-offset sb-vm:n-word-bytes)))
;; Final null pointer.
(setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0))
- (values vec-sap (sap+ vec-sap bytes-per-word) total-bytes)))
+ (values vec-sap (sap+ vec-sap sb-vm:n-word-bytes) total-bytes)))
-(defmacro with-c-strvec ((var str-list) &body body)
+#-win32
+(defmacro with-args ((var str-list) &body body)
(with-unique-names (sap size)
`(multiple-value-bind (,sap ,var ,size)
(string-list-to-c-strvec ,str-list)
(unwind-protect
(progn
,@body)
- (sb-sys:deallocate-system-memory ,sap ,size)))))
+ (deallocate-system-memory ,sap ,size)))))
+
+(defmacro with-environment ((var str-list &key null) &body body)
+ (once-only ((null null))
+ (with-unique-names (sap size)
+ `(multiple-value-bind (,sap ,var ,size)
+ (if ,null
+ (values nil (int-sap 0))
+ #-win32 (string-list-to-c-strvec ,str-list)
+ #+win32 (encode-windows-environment ,str-list))
+ (unwind-protect
+ (progn
+ ,@body)
+ (unless ,null
+ (deallocate-system-memory ,sap ,size)))))))
+#-win32
+(define-alien-routine spawn
+ int
+ (program c-string)
+ (argv (* c-string))
+ (stdin int)
+ (stdout int)
+ (stderr int)
+ (search int)
+ (envp (* c-string))
+ (pty-name c-string)
+ (wait int)
+ (dir c-string))
+
+#+win32
+(defun escape-arg (arg stream)
+ ;; Normally, #\\ doesn't have to be escaped
+ ;; But if #\" follows #\\, then they have to be escaped.
+ ;; Do that by counting the number of consequent backslashes, and
+ ;; upon encoutering #\" immediately after them, output the same
+ ;; number of backslashes, plus one for #\"
+ (write-char #\" stream)
+ (loop with slashes = 0
+ for i below (length arg)
+ for previous-char = #\a then char
+ for char = (char arg i)
+ do
+ (case char
+ (#\"
+ (loop repeat slashes
+ do (write-char #\\ stream))
+ (write-string "\\\"" stream))
+ (t
+ (write-char char stream)))
+ (case char
+ (#\\
+ (incf slashes))
+ (t
+ (setf slashes 0)))
+ finally
+ ;; The final #\" counts too, but doesn't need to be escaped itself
+ (loop repeat slashes
+ do (write-char #\\ stream)))
+ (write-char #\" stream))
-(sb-alien:define-alien-routine spawn
- #-win32 sb-alien:int
- #+win32 sb-win32::handle
- (program sb-alien:c-string)
- (argv (* sb-alien:c-string))
- (stdin sb-alien:int)
- (stdout sb-alien:int)
- (stderr sb-alien:int)
- (search sb-alien:int)
- (envp (* sb-alien:c-string))
- (pty-name sb-alien:c-string)
- (wait sb-alien:int))
+(defun prepare-args (args)
+ (cond #-win32
+ ((every #'simple-string-p args)
+ args)
+ #-win32
+ (t
+ (loop for arg in args
+ collect (coerce arg 'simple-string)))
+ #+win32
+ (t
+ (with-output-to-string (str)
+ (loop for (arg . rest) on args
+ do
+ (cond ((find-if (lambda (c) (find c '(#\Space #\Tab #\")))
+ arg)
+ (escape-arg arg str))
+ (t
+ (princ arg str)))
+ (when rest
+ (write-char #\Space str)))))))
;;; FIXME: There shouldn't be two semiredundant versions of the
;;; documentation. Since this is a public extension function, the
;;; the fork worked, and NIL if it did not.
(defun run-program (program args
&key
- #-win32 (env nil env-p)
- #-win32 (environment
- (if env-p
- (unix-environment-sbcl-from-cmucl env)
- (posix-environ))
- environment-p)
+ (env nil env-p)
+ (environment
+ (when env-p
+ (unix-environment-sbcl-from-cmucl env))
+ environment-p)
(wait t)
search
#-win32 pty
(error :output)
(if-error-exists :error)
status-hook
- (external-format :default))
+ (external-format :default)
+ directory)
#+sb-doc
#.(concatenate
'string
default external format for streams.
RUN-PROGRAM will return a PROCESS structure. See the CMU Common Lisp
-Users Manual for details about the PROCESS structure."#-win32"
+Users Manual for details about the PROCESS structure.
Notes about Unix environments (as in the :ENVIRONMENT and :ENV args):
- The SBCL implementation of RUN-PROGRAM, like Perl and many other
programs, but unlike the original CMU CL implementation, copies
- the Unix environment by default.
-
+ the Unix environment by default."#-win32"
- Running Unix programs from a setuid process, or in any other
situation where the Unix environment is under the control of someone
else, is a mother lode of security problems. If you are contemplating
programs.)""
The &KEY arguments have the following meanings:
-"#-win32"
:ENVIRONMENT
a list of STRINGs describing the new Unix environment
(as in \"man environ\"). The default is to copy the environment of
the current process.
:ENV
an alternative lossy representation of the new Unix environment,
- for compatibility with CMU CL""
+ for compatibility with CMU CL
:SEARCH
Look for PROGRAM in each of the directories in the child's $PATH
environment variable. Otherwise an absolute pathname is required.
This is a function the system calls whenever the status of the
process changes. The function takes the process as an argument.
:EXTERNAL-FORMAT
- The external-format to use for :INPUT, :OUTPUT, and :ERROR :STREAMs.")
- #-win32
+ The external-format to use for :INPUT, :OUTPUT, and :ERROR :STREAMs.
+ :DIRECTORY
+ Specifies the directory in which the program should be run.
+ NIL (the default) means the directory is unchanged.")
(when (and env-p environment-p)
(error "can't specify :ENV and :ENVIRONMENT simultaneously"))
- ;; Prepend the program to the argument list.
- (push (namestring program) args)
- (labels (;; It's friendly to allow the caller to pass any string
- ;; designator, but internally we'd like SIMPLE-STRINGs.
- ;;
- ;; Huh? We let users pass in symbols and characters for
- ;; the arguments, but call NAMESTRING on the program
- ;; name... -- RMK
- (simplify-args (args)
- (loop for arg in args
- as escaped-arg = (escape-arg arg)
- collect (coerce escaped-arg 'simple-string)))
- (escape-arg (arg)
- #-win32 arg
- ;; Apparently any spaces or double quotes in the arguments
- ;; need to be escaped on win32.
- #+win32 (if (position-if
- (lambda (c) (find c '(#\" #\Space))) arg)
- (write-to-string arg)
- arg)))
- (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to
- ;; communicate cleanup info.
- *close-on-error*
- *close-in-parent*
- ;; Some other binding used only on non-Win32. FIXME:
- ;; nothing seems to set this.
- #-win32 *handlers-installed*
- ;; Establish PROC at this level so that we can return it.
- proc
- (simple-args (simplify-args args))
- (progname (native-namestring program))
- ;; Gag.
- (cookie (list 0)))
- (unwind-protect
- ;; Note: despite the WITH-* names, these macros don't
- ;; expand into UNWIND-PROTECT forms. They're just
- ;; syntactic sugar to make the rest of the routine slightly
- ;; easier to read.
- (macrolet ((with-fd-and-stream-for (((fd stream) which &rest args)
- &body body)
- `(multiple-value-bind (,fd ,stream)
- ,(ecase which
- ((:input :output)
- `(get-descriptor-for ,@args))
- (:error
- `(if (eq ,(first args) :output)
- ;; kludge: we expand into
- ;; hard-coded symbols here.
- (values stdout output-stream)
- (get-descriptor-for ,@args))))
- ,@body))
- (with-open-pty (((pty-name pty-stream) (pty cookie))
- &body body)
- #+win32 `(declare (ignore ,pty ,cookie))
- #+win32 `(let (,pty-name ,pty-stream) ,@body)
- #-win32 `(multiple-value-bind (,pty-name ,pty-stream)
- (open-pty ,pty ,cookie :external-format external-format)
- ,@body))
- (with-args-vec ((vec args) &body body)
- `(with-c-strvec (,vec ,args)
- ,@body))
- (with-environment-vec ((vec env) &body body)
- #+win32 `(let (,vec) ,@body)
- #-win32 `(with-c-strvec (,vec ,env) ,@body)))
- (with-fd-and-stream-for ((stdin input-stream) :input
- input cookie
- :direction :input
- :if-does-not-exist if-input-does-not-exist
- :external-format external-format
- :wait wait)
- (with-fd-and-stream-for ((stdout output-stream) :output
- output cookie
+ (let* (;; Clear various specials used by GET-DESCRIPTOR-FOR to
+ ;; communicate cleanup info.
+ *close-on-error*
+ *close-in-parent*
+ ;; Some other binding used only on non-Win32. FIXME:
+ ;; nothing seems to set this.
+ #-win32 *handlers-installed*
+ ;; Establish PROC at this level so that we can return it.
+ proc
+ (progname (native-namestring program))
+ (args (prepare-args (cons progname args)))
+ (directory (and directory (native-namestring directory)))
+ ;; Gag.
+ (cookie (list 0)))
+ (unwind-protect
+ ;; Note: despite the WITH-* names, these macros don't
+ ;; expand into UNWIND-PROTECT forms. They're just
+ ;; syntactic sugar to make the rest of the routine slightly
+ ;; easier to read.
+ (macrolet ((with-fd-and-stream-for (((fd stream) which &rest args)
+ &body body)
+ `(multiple-value-bind (,fd ,stream)
+ ,(ecase which
+ ((:input :output)
+ `(get-descriptor-for ,@args))
+ (:error
+ `(if (eq ,(first args) :output)
+ ;; kludge: we expand into
+ ;; hard-coded symbols here.
+ (values stdout output-stream)
+ (get-descriptor-for ,@args))))
+ (unless ,fd
+ (return-from run-program))
+ ,@body))
+ (with-open-pty (((pty-name pty-stream) (pty cookie))
+ &body body)
+ (declare (ignorable pty-name pty-stream pty cookie))
+ #+win32
+ `(progn ,@body)
+ #-win32
+ `(multiple-value-bind (,pty-name ,pty-stream)
+ (open-pty ,pty ,cookie :external-format external-format)
+ ,@body)))
+ (with-fd-and-stream-for ((stdin input-stream) :input
+ input cookie
+ :direction :input
+ :if-does-not-exist if-input-does-not-exist
+ :external-format external-format
+ :wait wait)
+ (with-fd-and-stream-for ((stdout output-stream) :output
+ output cookie
+ :direction :output
+ :if-exists if-output-exists
+ :external-format external-format)
+ (with-fd-and-stream-for ((stderr error-stream) :error
+ error cookie
:direction :output
- :if-exists if-output-exists
+ :if-exists if-error-exists
:external-format external-format)
- (with-fd-and-stream-for ((stderr error-stream) :error
- error cookie
- :direction :output
- :if-exists if-error-exists
- :external-format external-format)
- (with-open-pty ((pty-name pty-stream) (pty cookie))
- ;; Make sure we are not notified about the child
- ;; death before we have installed the PROCESS
- ;; structure in *ACTIVE-PROCESSES*.
- (let (child)
- (with-active-processes-lock ()
- (with-args-vec (args-vec simple-args)
- (with-environment-vec (environment-vec environment)
- (setq child (without-gcing
- (spawn progname args-vec
- stdin stdout stderr
- (if search 1 0)
- environment-vec pty-name
- (if wait 1 0))))
- (unless (= child -1)
- (setf proc
- (apply
- #'make-process
- :pid child
- :input input-stream
- :output output-stream
- :error error-stream
- :status-hook status-hook
- :cookie cookie
- #-win32 (list :pty pty-stream
- :%status :running)
- #+win32 (if wait
- (list :%status :exited
- :exit-code child)
- (list :%status :running))))
- (push proc *active-processes*)))))
- ;; Report the error outside the lock.
- (when (= child -1)
- (error "couldn't fork child process: ~A"
- (strerror)))))))))
- (dolist (fd *close-in-parent*)
+ (with-open-pty ((pty-name pty-stream) (pty cookie))
+ ;; Make sure we are not notified about the child
+ ;; death before we have installed the PROCESS
+ ;; structure in *ACTIVE-PROCESSES*.
+ (let (child)
+ (with-active-processes-lock ()
+ (with-environment (environment-vec environment
+ :null (not (or environment environment-p)))
+ (setq child
+ #+win32
+ (sb-win32::mswin-spawn
+ progname
+ args
+ stdin stdout stderr
+ search environment-vec wait directory)
+ #-win32
+ (with-args (args-vec args)
+ (without-gcing
+ (spawn progname args-vec
+ stdin stdout stderr
+ (if search 1 0)
+ environment-vec pty-name
+ (if wait 1 0) directory))))
+ (unless (minusp child)
+ (setf proc
+ (make-process
+ :input input-stream
+ :output output-stream
+ :error error-stream
+ :status-hook status-hook
+ :cookie cookie
+ #-win32 :pty #-win32 pty-stream
+ :%status #-win32 :running
+ #+win32 (if wait
+ :exited
+ :running)
+ :pid #-win32 child
+ #+win32 (if wait
+ nil
+ child)
+ #+win32 :%exit-code #+win32 (and wait child)))
+ (push proc *active-processes*))))
+ ;; Report the error outside the lock.
+ (case child
+ (-1
+ (error "Couldn't fork child process: ~A"
+ (strerror)))
+ (-2
+ (error "Couldn't execute ~S: ~A"
+ progname (strerror)))
+ (-3
+ (error "Couldn't change directory to ~S: ~A"
+ directory (strerror))))))))))
+ (dolist (fd *close-in-parent*)
+ (sb-unix:unix-close fd))
+ (unless proc
+ (dolist (fd *close-on-error*)
(sb-unix:unix-close fd))
- (unless proc
- (dolist (fd *close-on-error*)
- (sb-unix:unix-close fd))
- #-win32
- (dolist (handler *handlers-installed*)
- (sb-sys:remove-fd-handler handler)))
#-win32
- (when (and wait proc)
- (unwind-protect
- (process-wait proc)
- (dolist (handler *handlers-installed*)
- (sb-sys:remove-fd-handler handler)))))
- proc)))
+ (dolist (handler *handlers-installed*)
+ (remove-fd-handler handler)))
+ #-win32
+ (when (and wait proc)
+ (unwind-protect
+ (process-wait proc)
+ (dolist (handler *handlers-installed*)
+ (remove-fd-handler handler)))))
+ proc))
;;; Install a handler for any input that shows up on the file
;;; descriptor. The handler reads the data and writes it to the
(error "Don't know how to copy to stream of element-type ~S"
et)))))
(setf handler
- (sb-sys:add-fd-handler
+ (add-fd-handler
descriptor
:input
(lambda (fd)
(eql errno sb-unix:eio))
(eql count 0))
#+win32 (<= count 0))
- (sb-sys:remove-fd-handler handler)
+ (remove-fd-handler handler)
(setf handler nil)
(decf (car cookie))
(sb-unix:unix-close descriptor)
while reading from child: ~S~:>" buf))
(return))
((null count)
- (sb-sys:remove-fd-handler handler)
+ (remove-fd-handler handler)
(setf handler nil)
(decf (car cookie))
(error
(t
(incf read-end count)
(funcall copy-fun))))))))
+ #-win32
(push handler *handlers-installed*)))
;;; FIXME: something very like this is done in SB-POSIX to treat
;;; maybe also with SB-POSIX)?
(defun get-stream-fd-and-external-format (stream direction)
(typecase stream
- (sb-sys:fd-stream
- (values (sb-sys:fd-stream-fd stream) nil (stream-external-format stream)))
+ (fd-stream
+ (values (fd-stream-fd stream) nil (stream-external-format stream)))
(synonym-stream
(get-stream-fd-and-external-format
(symbol-value (synonym-stream-symbol stream)) direction))
(get-stream-fd-and-external-format
(two-way-stream-output-stream stream) direction))))))
+(defun get-temporary-directory ()
+ #-win32 (or (sb-ext:posix-getenv "TMPDIR")
+ "/tmp")
+ #+win32 (or (sb-ext:posix-getenv "TEMP")
+ "C:/Temp"))
+
\f
;;; Find a file descriptor to use for object given the direction.
;;; Returns the descriptor. If object is :STREAM, returns the created
;; run afoul of disk quotas or to choke on small /tmp file systems.
(flet ((make-temp-fd ()
(multiple-value-bind (fd name/errno)
- (sb-unix:sb-mkstemp "/tmp/.run-program-XXXXXX" #o0600)
+ (sb-unix:sb-mkstemp (format nil "~a/.run-program-XXXXXX"
+ (get-temporary-directory))
+ #o0600)
(unless fd
(error "could not open a temporary file: ~A"
(strerror name/errno)))
+ ;; Can't unlink an open file on Windows
+ #-win32
(unless (sb-unix:unix-unlink name/errno)
(sb-unix:unix-close fd)
(error "failed to unlink ~A" name/errno))
fd)))
- (cond ((eq object t)
- ;; No new descriptor is needed.
- (values -1 nil))
- ((or (eq object nil)
- (and (typep object 'broadcast-stream)
- (not (broadcast-stream-streams object))))
- ;; Use /dev/null.
- (multiple-value-bind
- (fd errno)
- (sb-unix:unix-open #-win32 #.(coerce "/dev/null" 'base-string)
- #+win32 #.(coerce "nul" 'base-string)
- (case direction
- (:input sb-unix:o_rdonly)
- (:output sb-unix:o_wronly)
- (t sb-unix:o_rdwr))
- #o666)
- (unless fd
- (error #-win32 "~@<couldn't open \"/dev/null\": ~2I~_~A~:>"
- #+win32 "~@<couldn't open \"nul\" device: ~2I~_~A~:>"
- (strerror errno)))
- (push fd *close-in-parent*)
- (values fd nil)))
- ((eq object :stream)
- (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe)
- (unless read-fd
- (error "couldn't create pipe: ~A" (strerror write-fd)))
- (case direction
- (:input
- (push read-fd *close-in-parent*)
- (push write-fd *close-on-error*)
- (let ((stream (sb-sys:make-fd-stream write-fd :output t
- :element-type :default
- :external-format
- external-format)))
- (values read-fd stream)))
- (:output
- (push read-fd *close-on-error*)
- (push write-fd *close-in-parent*)
- (let ((stream (sb-sys:make-fd-stream read-fd :input t
- :element-type :default
- :external-format
- external-format)))
- (values write-fd stream)))
- (t
- (sb-unix:unix-close read-fd)
- (sb-unix:unix-close write-fd)
- (error "Direction must be either :INPUT or :OUTPUT, not ~S."
- direction)))))
- ((or (pathnamep object) (stringp object))
- ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather
- ;; than munge the &rest list for OPEN, just disable keyword
- ;; validation there.
- (with-open-stream (file (apply #'open object :allow-other-keys t
- keys))
+ (let ((dev-null #.(coerce #-win32 "/dev/null" #+win32 "nul" 'base-string)))
+ (cond ((eq object t)
+ ;; No new descriptor is needed.
+ (values -1 nil))
+ ((or (eq object nil)
+ (and (typep object 'broadcast-stream)
+ (not (broadcast-stream-streams object))))
+ ;; Use /dev/null.
(multiple-value-bind
(fd errno)
- (sb-unix:unix-dup (sb-sys:fd-stream-fd file))
- (cond (fd
- (push fd *close-in-parent*)
- (values fd nil))
- (t
- (error "couldn't duplicate file descriptor: ~A"
- (strerror errno)))))))
+ (sb-unix:unix-open dev-null
+ (case direction
+ (:input sb-unix:o_rdonly)
+ (:output sb-unix:o_wronly)
+ (t sb-unix:o_rdwr))
+ #o666)
+ (unless fd
+ (error "~@<couldn't open ~S: ~2I~_~A~:>"
+ dev-null (strerror errno)))
+ #+win32
+ (setf (sb-win32::inheritable-handle-p fd) t)
+ (push fd *close-in-parent*)
+ (values fd nil)))
+ ((eq object :stream)
+ (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe)
+ (unless read-fd
+ (error "couldn't create pipe: ~A" (strerror write-fd)))
+ #+win32
+ (setf (sb-win32::inheritable-handle-p read-fd)
+ (eq direction :input)
+ (sb-win32::inheritable-handle-p write-fd)
+ (eq direction :output))
+ (case direction
+ (:input
+ (push read-fd *close-in-parent*)
+ (push write-fd *close-on-error*)
+ (let ((stream (make-fd-stream write-fd :output t
+ :element-type :default
+ :external-format
+ external-format)))
+ (values read-fd stream)))
+ (:output
+ (push read-fd *close-on-error*)
+ (push write-fd *close-in-parent*)
+ (let ((stream (make-fd-stream read-fd :input t
+ :element-type :default
+ :external-format
+ external-format)))
+ (values write-fd stream)))
+ (t
+ (sb-unix:unix-close read-fd)
+ (sb-unix:unix-close write-fd)
+ (error "Direction must be either :INPUT or :OUTPUT, not ~S."
+ direction)))))
+ ((or (pathnamep object) (stringp object))
+ ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather
+ ;; than munge the &rest list for OPEN, just disable keyword
+ ;; validation there.
+ (with-open-stream (file (apply #'open object :allow-other-keys t
+ keys))
+ (when file
+ (multiple-value-bind
+ (fd errno)
+ (sb-unix:unix-dup (fd-stream-fd file))
+ (cond (fd
+ (push fd *close-in-parent*)
+ (values fd nil))
+ (t
+ (error "couldn't duplicate file descriptor: ~A"
+ (strerror errno))))))))
((streamp object)
(ecase direction
(:input
external-format)
(push read-fd *close-on-error*)
(push write-fd *close-in-parent*)
- (return (values write-fd nil)))))))
- (t
- (error "invalid option to RUN-PROGRAM: ~S" object)))))
+ (return (values write-fd nil)))))
+ (t
+ (error "invalid option to RUN-PROGRAM: ~S" object))))))))
projects / sbcl.git / blobdiff