1.0.1.16:

[sbcl.git] / src / code / run-program.lisp

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index bf685c8..ea4fe4c 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -392,25 +392,52 @@ status slot."
 ;;; the master side of the pty, the file descriptor for the slave side
 ;;; of the pty, and the name of the tty device for the slave side.
 #-win32
 ;;; the master side of the pty, the file descriptor for the slave side
 ;;; of the pty, and the name of the tty device for the slave side.
 #-win32

-(defun find-a-pty ()
-  (dolist (char '(#\p #\q))
-    (dotimes (digit 16)
-      (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
-                                           #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
-                                              #o666)))
-            (when slave-fd
-              (return-from find-a-pty
-                (values master-fd
-                        slave-fd
-                        slave-name)))
-            (sb-unix:unix-close master-fd))))))
-  (error "could not find a pty"))
+(progn
+  (define-alien-routine ptsname c-string (fd int))
+  (define-alien-routine grantpt boolean (fd int))
+  (define-alien-routine unlockpt boolean (fd int))
+
+  (defun find-a-pty ()
+    ;; 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
+                                         #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
+                                            #o666)))
+          (when slave-fd
+            (return-from find-a-pty
+              (values master-fd
+                      slave-fd
+                      slave-name)))
+          (sb-unix:unix-close master-fd))
+        (error "could not find a pty")))
+    ;; No dice, try using the old-school method.
+    (dolist (char '(#\p #\q))
+      (dotimes (digit 16)
+        (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
+                                             #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
+                                                #o666)))
+              (when slave-fd
+                (return-from find-a-pty
+                  (values master-fd
+                          slave-fd
+                          slave-name)))
+              (sb-unix:unix-close master-fd))))))
+    (error "could not find a pty")))

 
 #-win32
 (defun open-pty (pty cookie)
 
 #-win32
 (defun open-pty (pty cookie)

@@ -432,7 +459,9 @@ status slot."
                                      :dual-channel-p t)))))
 
 (defmacro round-bytes-to-words (n)
                                      :dual-channel-p t)))))
 
 (defmacro round-bytes-to-words (n)

-  `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
+  (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))))

 
 (defun string-list-to-c-strvec (string-list)
   ;; Make a pass over STRING-LIST to calculate the amount of memory
 
 (defun string-list-to-c-strvec (string-list)
   ;; Make a pass over STRING-LIST to calculate the amount of memory

@@ -440,7 +469,7 @@ status slot."
   (let ((string-bytes 0)
         ;; We need an extra for the null, and an extra 'cause exect
         ;; clobbers argv[-1].
   (let ((string-bytes 0)
         ;; We need an extra for the null, and an extra 'cause exect
         ;; clobbers argv[-1].

-        (vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)
+        (vec-bytes (* #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)

                       (+ (length string-list) 2))))
     (declare (fixnum string-bytes vec-bytes))
     (dolist (s string-list)
                       (+ (length string-list) 2))))
     (declare (fixnum string-bytes vec-bytes))
     (dolist (s string-list)

@@ -450,7 +479,7 @@ status slot."
     (let* ((total-bytes (+ string-bytes vec-bytes))
            (vec-sap (sb-sys:allocate-system-memory total-bytes))
            (string-sap (sap+ vec-sap vec-bytes))
     (let* ((total-bytes (+ string-bytes vec-bytes))
            (vec-sap (sb-sys:allocate-system-memory total-bytes))
            (string-sap (sap+ vec-sap vec-bytes))

-           (i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)))
+           (i #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)))

       (declare (type (and unsigned-byte fixnum) total-bytes i)
                (type sb-sys:system-area-pointer vec-sap string-sap))
       (dolist (s string-list)
       (declare (type (and unsigned-byte fixnum) total-bytes i)
                (type sb-sys:system-area-pointer vec-sap string-sap))
       (dolist (s string-list)

@@ -466,11 +495,11 @@ status slot."
           ;; Blast the pointer to the string into place.
           (setf (sap-ref-sap vec-sap i) string-sap)
           (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
           ;; Blast the pointer to the string into place.
           (setf (sap-ref-sap vec-sap i) string-sap)
           (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))

-          (incf i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits))))
+          (incf i #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))))

       ;; Blast in the last null pointer.
       (setf (sap-ref-sap vec-sap i) (int-sap 0))
       ;; Blast in the last null pointer.
       (setf (sap-ref-sap vec-sap i) (int-sap 0))

-      (values vec-sap (sap+ vec-sap #.(/ sb-vm::n-machine-word-bits
-                                         sb-vm::n-byte-bits))
+      (values vec-sap (sap+ vec-sap #.(/ sb-vm:n-machine-word-bits
+                                         sb-vm:n-byte-bits))

               total-bytes))))
 
 (defmacro with-c-strvec ((var str-list) &body body)
               total-bytes))))
 
 (defmacro with-c-strvec ((var str-list) &body body)

@@ -504,7 +533,7 @@ status slot."
 
 ;;; Is UNIX-FILENAME the name of a file that we can execute?
 (defun unix-filename-is-executable-p (unix-filename)
 
 ;;; Is UNIX-FILENAME the name of a file that we can execute?
 (defun unix-filename-is-executable-p (unix-filename)

-  (let ((filename (coerce unix-filename 'base-string)))
+  (let ((filename (coerce unix-filename 'string)))

     (values (and (eq (sb-unix:unix-file-kind filename) :file)
                  #-win32
                  (sb-unix:unix-access filename sb-unix:x_ok)))))
     (values (and (eq (sb-unix:unix-file-kind filename) :file)
                  #-win32
                  (sb-unix:unix-access filename sb-unix:x_ok)))))

@@ -759,7 +788,7 @@ argument. ARGS are the standard arguments that can be passed to a
 program. For no arguments, use NIL (which means that just the name of
 the program is passed as arg 0).
 
 program. For no arguments, use NIL (which means that just the name of
 the program is passed as arg 0).
 

-RUN-PROGRAM will either return a PROCESS structure. See the CMU
+RUN-PROGRAM will return a PROCESS structure. See the CMU

 Common Lisp Users Manual for details about the PROCESS structure.
 
    The &KEY arguments have the following meanings:
 Common Lisp Users Manual for details about the PROCESS structure.
 
    The &KEY arguments have the following meanings:

@@ -772,7 +801,7 @@ Common Lisp Users Manual for details about the PROCESS structure.
         NIL, continue running Lisp until the program finishes.
      :INPUT
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
         NIL, continue running Lisp until the program finishes.
      :INPUT
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard

-        input for the current process is inherited.  If NIL, /dev/null
+        input for the current process is inherited.  If NIL, nul

         is used.  If a pathname, the file so specified is used.  If a stream,
         all the input is read from that stream and send to the subprocess.  If
         :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
         is used.  If a pathname, the file so specified is used.  If a stream,
         all the input is read from that stream and send to the subprocess.  If
         :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends

@@ -784,7 +813,7 @@ Common Lisp Users Manual for details about the PROCESS structure.
            NIL (the default) to return NIL from RUN-PROGRAM
      :OUTPUT
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
            NIL (the default) to return NIL from RUN-PROGRAM
      :OUTPUT
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard

-        output for the current process is inherited.  If NIL, /dev/null
+        output for the current process is inherited.  If NIL, nul

         is used.  If a pathname, the file so specified is used.  If a stream,
         all the output from the process is written to this stream. If
         :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
         is used.  If a pathname, the file so specified is used.  If a stream,
         all the output from the process is written to this stream. If
         :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can

@@ -812,7 +841,17 @@ Common Lisp Users Manual for details about the PROCESS structure.
         proc
         ;; It's friendly to allow the caller to pass any string
         ;; designator, but internally we'd like SIMPLE-STRINGs.
         proc
         ;; It's friendly to allow the caller to pass any string
         ;; designator, but internally we'd like SIMPLE-STRINGs.

-        (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args)))
+        (simple-args
+          (mapcar
+            (lambda (x)
+              (coerce
+                ;; Apparently any spaces or double quotes in the arguments
+                ;; need to be escaped on win32.
+                (if (position-if (lambda (c) (find c '(#\" #\Space))) x)
+                    (write-to-string x)
+                    x)
+                'simple-string))
+            args)))

     (unwind-protect
          (let ((pfile
                 (if search
     (unwind-protect
          (let ((pfile
                 (if search

@@ -842,11 +881,17 @@ Common Lisp Users Manual for details about the PROCESS structure.
                                          (spawn pfile args-vec
                                                 stdin stdout stderr
                                                 (if wait 1 0)))))
                                          (spawn pfile args-vec
                                                 stdin stdout stderr
                                                 (if wait 1 0)))))

-                            (when (< handle 0)
+                            (when (= handle -1)

                               (error "Couldn't spawn program: ~A" (strerror)))
                             (setf proc
                                   (if wait
                               (error "Couldn't spawn program: ~A" (strerror)))
                             (setf proc
                                   (if wait

-                                      (make-process :%status :exited
+                                      (make-process :pid handle
+                                                    :%status :exited
+                                                    :input input-stream
+                                                    :output output-stream
+                                                    :error error-stream
+                                                    :status-hook status-hook
+                                                    :cookie cookie

                                                     :exit-code handle)
                                       (make-process :pid handle
                                                     :%status :running
                                                     :exit-code handle)
                                       (make-process :pid handle
                                                     :%status :running

@@ -854,13 +899,14 @@ Common Lisp Users Manual for details about the PROCESS structure.
                                                     :output output-stream
                                                     :error error-stream
                                                     :status-hook status-hook
                                                     :output output-stream
                                                     :error error-stream
                                                     :status-hook status-hook

-                                                    :cookie cookie))))))))))
-    ;; FIXME: this should probably use PROCESS-WAIT instead instead
-    ;; of special argument to SPAWN.
-    (unless wait
-      (push proc *active-processes*))
-    (when (and wait status-hook)
-      (funcall status-hook proc))
+                                                    :cookie cookie)))
+                            (push proc *active-processes*)))))))
+      (dolist (fd *close-in-parent*)
+        (sb-unix:unix-close fd)))
+    (unless proc
+      (dolist (fd *close-on-error*)
+        (sb-unix:unix-close fd)))
+

     proc))
 
 ;;; Install a handler for any input that shows up on the file
     proc))
 
 ;;; Install a handler for any input that shows up on the file

@@ -958,7 +1004,8 @@ Common Lisp Users Manual for details about the PROCESS structure.
                                   (t sb-unix:o_rdwr))
                                 #o666)
            (unless fd
                                   (t sb-unix:o_rdwr))
                                 #o666)
            (unless fd

-             (error "~@<couldn't open \"/dev/null\": ~2I~_~A~:>"
+             (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)))
                     (strerror errno)))
            (push fd *close-in-parent*)
            (values fd nil)))