X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=3cc2e85aa7328fd6acaba749a0418173f7780bd1;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=0417401ce26c2249b129b6cdc81a2b3d305c23ee;hpb=6113d10bd637c220036cb74b45f03354fe1f872d;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 0417401..3cc2e85 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -507,14 +507,18 @@ status slot." (setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0)) (values vec-sap (sap+ vec-sap bytes-per-word) total-bytes))) -(defmacro with-c-strvec ((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))))) +(defmacro with-c-strvec ((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 (sb-sys:int-sap 0)) + (string-list-to-c-strvec ,str-list)) + (unwind-protect + (progn + ,@body) + (unless ,null + (sb-sys:deallocate-system-memory ,sap ,size))))))) (sb-alien:define-alien-routine spawn #-win32 sb-alien:int @@ -576,9 +580,8 @@ status slot." &key #-win32 (env nil env-p) #-win32 (environment - (if env-p - (unix-environment-sbcl-from-cmucl env) - (posix-environ)) + (when env-p + (unix-environment-sbcl-from-cmucl env)) environment-p) (wait t) search @@ -729,6 +732,8 @@ Users Manual for details about the PROCESS structure."#-win32" ;; 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) @@ -740,9 +745,13 @@ Users Manual for details about the PROCESS structure."#-win32" (with-args-vec ((vec args) &body body) `(with-c-strvec (,vec ,args) ,@body)) - (with-environment-vec ((vec env) &body body) + (with-environment-vec ((vec) &body body) #+win32 `(let (,vec) ,@body) - #-win32 `(with-c-strvec (,vec ,env) ,@body))) + #-win32 + `(with-c-strvec + (,vec environment + :null (not (or environment environment-p))) + ,@body))) (with-fd-and-stream-for ((stdin input-stream) :input input cookie :direction :input @@ -766,34 +775,40 @@ Users Manual for details about the PROCESS structure."#-win32" (let (child) (with-active-processes-lock () (with-args-vec (args-vec simple-args) - (with-environment-vec (environment-vec environment) + (with-environment-vec (environment-vec) (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*))))) + (if wait 1 0)))))) + (unless (minusp child) + (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))))))))) + #+win32 + (when (minusp child) + (error "Couldn't execute ~S: ~A" progname (strerror))) + #-win32 + (case child + (-2 + (error "Couldn't execute ~S: ~A" progname (strerror))) + (-1 + (error "Couldn't fork child process: ~A" (strerror)))))))))) (dolist (fd *close-in-parent*) (sb-unix:unix-close fd)) (unless proc @@ -924,6 +939,12 @@ Users Manual for details about the PROCESS structure."#-win32" (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")) + ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created @@ -942,10 +963,14 @@ Users Manual for details about the PROCESS structure."#-win32" ;; 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 opened file on Windows + #-win32 (unless (sb-unix:unix-unlink name/errno) (sb-unix:unix-close fd) (error "failed to unlink ~A" name/errno)) @@ -1004,15 +1029,16 @@ Users Manual for details about the PROCESS structure."#-win32" ;; validation there. (with-open-stream (file (apply #'open object :allow-other-keys t keys)) - (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))))))) + (when file + (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)))))))) ((streamp object) (ecase direction (:input