X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=eb9aa47ea8c19bed7a4b9b58eb4627fab5e0e34a;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=dbb16ccf94fd19288207dca55c0492243f16e84d;hpb=4f82cd4c218dbaa287dd42a0833b05e7a8dd94d0;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index dbb16cc..eb9aa47 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -52,37 +52,46 @@ "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. @@ -97,10 +106,10 @@ ;;;; 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) @@ -145,7 +154,6 @@ #+sb-doc "List of process structures for all active processes.") -#-win32 (defvar *active-processes-lock* (sb-thread:make-mutex :name "Lock for active processes.")) @@ -153,16 +161,13 @@ ;;; 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 @@ -176,7 +181,7 @@ (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)) @@ -188,10 +193,17 @@ (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, @@ -237,6 +249,16 @@ The function is called with PROCESS as its only argument.") "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) @@ -246,18 +268,18 @@ PROCESS." (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)) @@ -287,7 +309,7 @@ PROCESS." ((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) @@ -318,6 +340,11 @@ status slot." ;; 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 () @@ -335,21 +362,23 @@ status slot." (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 @@ -386,14 +415,16 @@ status slot." ;; 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 @@ -408,13 +439,15 @@ status slot." (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 @@ -440,7 +473,7 @@ status slot." (error "could not find a pty")))))) #-win32 -(defun open-pty (pty cookie) +(defun open-pty (pty cookie &key (external-format :default)) (when pty (multiple-value-bind (master slave name) @@ -452,71 +485,149 @@ status slot." (unless new-fd (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno))) (push new-fd *close-on-error*) - (copy-descriptor-to-stream new-fd pty cookie))) + (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))))) -(defmacro round-bytes-to-words (n) - (let ((bytes-per-word (/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))) - `(logandc2 (the fixnum (+ (the fixnum ,n) - (1- ,bytes-per-word))) (1- ,bytes-per-word)))) +;; Null terminate strings only C-side: otherwise we can run into +;; 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) + `(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 :null-terminate t)) + (string-to-octets s)) string-list)) (string-bytes (reduce #'+ octet-vector-list :key (lambda (s) - (round-bytes-to-words (length s))))) + (round-null-terminated-bytes-to-words + (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)) - (declare (index string-bytes vec-bytes total-bytes) - (sb-sys:system-area-pointer vec-sap string-sap)) + (vec-index-offset sb-vm:n-word-bytes)) + (declare (sb-vm:signed-word vec-bytes) + (sb-vm:word string-bytes total-bytes) + (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 + (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-bytes-to-words size))) - (incf vec-index-offset bytes-per-word))) + (setf string-sap (sap+ string-sap + (round-null-terminated-bytes-to-words size))) + (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 @@ -563,12 +674,11 @@ status slot." ;;; 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 @@ -578,7 +688,9 @@ status slot." (if-output-exists :error) (error :output) (if-error-exists :error) - status-hook) + status-hook + (external-format :default) + (directory nil directory-p)) #+sb-doc #.(concatenate 'string @@ -593,14 +705,13 @@ The program arguments and the environment are encoded using the 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 @@ -609,14 +720,13 @@ Users Manual for details about the PROCESS structure."#-win32" 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. @@ -661,149 +771,181 @@ Users Manual for details about the PROCESS structure."#-win32" same place as normal output. :STATUS-HOOK This is a function the system calls whenever the status of the - process changes. The function takes the process as an argument.") - #-win32 + process changes. The function takes the process as an argument. + :EXTERNAL-FORMAT + 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) - ,@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 :default - :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-p (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 - :external-format :default) - (with-fd-and-stream-for ((stderr error-stream) :error - error cookie - :direction :output - :if-exists if-error-exists - :external-format :default) - (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*) + :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-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)) - ;; FIXME: nothing seems to set this. - #-win32 - (dolist (handler *handlers-installed*) - (sb-sys:remove-fd-handler handler)))) + #-win32 + (dolist (handler *handlers-installed*) + (remove-fd-handler handler))) #-win32 (when (and wait proc) - (process-wait proc)) - 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 ;;; stream. (defun copy-descriptor-to-stream (descriptor stream cookie external-format) (incf (car cookie)) - (let* (handler + (let* ((handler nil) (buf (make-array 256 :element-type '(unsigned-byte 8))) - (read-end 0)) + (read-end 0) + (et (stream-element-type stream)) + (copy-fun + (cond + ((member et '(character base-char)) + (lambda () + (let* ((decode-end read-end) + (string (handler-case + (octets-to-string + buf :end read-end + :external-format external-format) + (end-of-input-in-character (e) + (setf decode-end + (octet-decoding-error-start e)) + (octets-to-string + buf :end decode-end + :external-format external-format))))) + (unless (zerop (length string)) + (write-string string stream) + (when (/= decode-end (length buf)) + (replace buf buf :start2 decode-end :end2 read-end)) + (decf read-end decode-end))))) + ((member et '(:default (unsigned-byte 8)) :test #'equal) + (lambda () + (write-sequence buf stream :end read-end) + (setf read-end 0))) + (t + ;; FIXME. + (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) @@ -834,7 +976,7 @@ Users Manual for details about the PROCESS structure."#-win32" (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) @@ -844,7 +986,7 @@ Users Manual for details about the PROCESS structure."#-win32" 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 @@ -853,22 +995,9 @@ Users Manual for details about the PROCESS structure."#-win32" (strerror errno))) (t (incf read-end count) - (let* ((decode-end read-end) - (string (handler-case - (octets-to-string - buf :end read-end - :external-format external-format) - (end-of-input-in-character (e) - (setf decode-end - (octet-decoding-error-start e)) - (octets-to-string - buf :end decode-end - :external-format external-format))))) - (unless (zerop (length string)) - (write-string string stream) - (when (/= decode-end (length buf)) - (replace buf buf :start2 decode-end :end2 read-end)) - (decf read-end decode-end)))))))))))) + (funcall copy-fun)))))))) + #-win32 + (push handler *handlers-installed*))) ;;; FIXME: something very like this is done in SB-POSIX to treat ;;; streams as file descriptor designators; maybe we can combine these @@ -878,8 +1007,8 @@ Users Manual for details about the PROCESS structure."#-win32" ;;; 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)) @@ -892,6 +1021,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 @@ -910,75 +1045,88 @@ 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 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)) - ((eq object nil) - ;; 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 "~@" - #+win32 "~@" - (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 "~@" + 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 @@ -1012,19 +1160,32 @@ Users Manual for details about the PROCESS structure."#-win32" child process won't hang~:>" object)) |# (let ((fd (make-temp-fd)) - (newline (string #\Newline))) - (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (let ((vector (string-to-octets line))) - (sb-unix:unix-write - fd vector 0 (length vector))) - (if no-cr - (return) - (sb-unix:unix-write fd newline 0 1)))) + (et (stream-element-type object))) + (cond ((member et '(character base-char)) + (loop + (multiple-value-bind + (line no-cr) + (read-line object nil nil) + (unless line + (return)) + (let ((vector (string-to-octets + line + :external-format external-format))) + (sb-unix:unix-write + fd vector 0 (length vector))) + (if no-cr + (return) + (sb-unix:unix-write + fd #.(string #\Newline) 0 1))))) + ((member et '(:default (unsigned-byte 8)) + :test 'equal) + (loop with buf = (make-array 256 :element-type '(unsigned-byte 8)) + for p = (read-sequence buf object) + until (zerop p) + do (sb-unix:unix-write fd buf 0 p))) + (t + (error "Don't know how to copy from stream of element-type ~S" + et))) (sb-unix:unix-lseek fd 0 sb-unix:l_set) (push fd *close-in-parent*) (return (values fd nil))))) @@ -1049,6 +1210,6 @@ Users Manual for details about the PROCESS structure."#-win32" 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))))))))