X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=eb9aa47ea8c19bed7a4b9b58eb4627fab5e0e34a;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=807f32c58a9e5ba88c8dd1a5d3d0717874792131;hpb=68991b9cf496d21d872246942c27edb83fdeb22d;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 807f32c..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) @@ -259,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)) @@ -478,7 +487,7 @@ status slot." (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))))) @@ -487,17 +496,17 @@ status slot." ;; 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)) @@ -507,13 +516,13 @@ status slot." (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))) @@ -526,37 +535,99 @@ status slot." ;; 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 &key null) &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) + (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 (sb-sys:int-sap 0)) - (string-list-to-c-strvec ,str-list)) + (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 - (sb-sys:deallocate-system-memory ,sap ,size))))))) + (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)) -(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) - (pwd sb-alien: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)) + +(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 @@ -603,11 +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 - (when env-p - (unix-environment-sbcl-from-cmucl env)) - environment-p) + (env nil env-p) + (environment + (when env-p + (unix-environment-sbcl-from-cmucl env)) + environment-p) (wait t) search #-win32 pty @@ -634,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 @@ -650,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. @@ -708,176 +777,135 @@ Users Manual for details about the PROCESS structure."#-win32" :DIRECTORY Specifies the directory in which the program should be run. NIL (the default) means the directory is unchanged.") - #-win32 (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-no-with - ((&optional no) - (&whole form with-something parameters &body body)) - (declare (ignore with-something parameters)) - (typecase no - (keyword `(progn ,@body)) - (null form) - (t `(let ,no (declare (ignorable ,@no)) ,@body)))) - (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) - `(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) &body body) - #+win32 `(let (,vec) ,@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 - :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-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 + :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-no-with (#+win32 (pty-name pty-stream)) - (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-no-with (#+win32 (args-vec)) - (with-args-vec (args-vec simple-args) - (with-no-with (#+win32 (environment-vec)) - (with-environment-vec (environment-vec) - (let ((pwd-string - (and directory-p (native-namestring directory)))) - (setq child - #+win32 - (sb-win32::mswin-spawn - progname - (with-output-to-string (argv) - (dolist (arg simple-args) - (write-string arg argv) - (write-char #\Space argv))) - stdin stdout stderr - search nil wait pwd-string) - #-win32 - (without-gcing - (spawn progname args-vec - stdin stdout stderr - (if search 1 0) - environment-vec pty-name - (if wait 1 0) - pwd-string)))) - (unless (minusp child) - (setf proc - (apply - #'make-process - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie - #-win32 (list :pty pty-stream - :%status :running - :pid child) - #+win32 (if wait - (list :%status :exited - :%exit-code child) - (list :%status :running - :pid 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*) + (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 @@ -917,7 +945,7 @@ Users Manual for details about the PROCESS structure."#-win32" (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) @@ -948,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) @@ -958,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 @@ -979,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)) @@ -1023,7 +1051,7 @@ Users Manual for details about the PROCESS structure."#-win32" (unless fd (error "could not open a temporary file: ~A" (strerror name/errno))) - ;; Can't unlink an opened file on Windows + ;; Can't unlink an open file on Windows #-win32 (unless (sb-unix:unix-unlink name/errno) (sb-unix:unix-close fd) @@ -1065,7 +1093,7 @@ Users Manual for details about the PROCESS structure."#-win32" (:input (push read-fd *close-in-parent*) (push write-fd *close-on-error*) - (let ((stream (sb-sys:make-fd-stream write-fd :output t + (let ((stream (make-fd-stream write-fd :output t :element-type :default :external-format external-format))) @@ -1073,7 +1101,7 @@ Users Manual for details about the PROCESS structure."#-win32" (:output (push read-fd *close-on-error*) (push write-fd *close-in-parent*) - (let ((stream (sb-sys:make-fd-stream read-fd :input t + (let ((stream (make-fd-stream read-fd :input t :element-type :default :external-format external-format))) @@ -1092,7 +1120,7 @@ Users Manual for details about the PROCESS structure."#-win32" (when file (multiple-value-bind (fd errno) - (sb-unix:unix-dup (sb-sys:fd-stream-fd file)) + (sb-unix:unix-dup (fd-stream-fd file)) (cond (fd (push fd *close-in-parent*) (values fd nil))