;;; accesses it, that's why we need without-interrupts.
(defmacro with-active-processes-lock (() &body body)
#-win32
- `(without-interrupts
- (sb-thread:with-mutex (*active-processes-lock*)
- ,@body))
+ `(sb-thread::call-with-system-mutex (lambda () ,@body) *active-processes-lock*)
+ #+win32
`(progn ,@body))
(defstruct (process (:copier nil))
;;; 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)
: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
(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)
(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)
;; 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))
- (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)
;;; 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)))))
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:
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
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
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
(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
- (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
: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
(write-string string stream
:end count)))))))))))
+(defun get-stream-fd (stream direction)
+ (typecase stream
+ (sb-sys:fd-stream
+ (values (sb-sys:fd-stream-fd stream) nil))
+ (synonym-stream
+ (get-stream-fd (symbol-value (synonym-stream-symbol stream)) direction))
+ (two-way-stream
+ (ecase direction
+ (:input
+ (get-stream-fd (two-way-stream-input-stream stream) direction))
+ (:output
+ (get-stream-fd (two-way-stream-output-stream stream) direction))))))
+
;;; Find a file descriptor to use for object given the direction.
;;; Returns the descriptor. If object is :STREAM, returns the created
;;; stream as the second value.
(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)))
(t
(error "couldn't duplicate file descriptor: ~A"
(strerror errno)))))))
- ((sb-sys:fd-stream-p object)
- (values (sb-sys:fd-stream-fd object) nil))
((streamp object)
(ecase direction
(:input
- ;; FIXME: We could use a better way of setting up
- ;; temporary files, both here and in LOAD-FOREIGN.
- (dotimes (count
- 256
- (error "could not open a temporary file in /tmp"))
- (let* ((name (coerce (format nil "/tmp/.run-program-~D" count)
- 'base-string))
- (fd (sb-unix:unix-open name
- (logior sb-unix:o_rdwr
- sb-unix:o_creat
- sb-unix:o_excl)
- #o666)))
- (sb-unix:unix-unlink name)
- (when fd
- (let ((newline (string #\Newline)))
- (loop
- (multiple-value-bind
- (line no-cr)
- (read-line object nil nil)
- (unless line
- (return))
- (sb-unix:unix-write
- fd
- ;; FIXME: this really should be
- ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...).
- ;; RUN-PROGRAM should take an
- ;; external-format argument, which should
- ;; be passed down to here. Something
- ;; similar should happen on :OUTPUT, too.
- (map '(vector (unsigned-byte 8)) #'char-code line)
- 0 (length line))
- (if no-cr
- (return)
- (sb-unix:unix-write fd newline 0 1)))))
- (sb-unix:unix-lseek fd 0 sb-unix:l_set)
- (push fd *close-in-parent*)
- (return (values fd nil))))))
+ (or (get-stream-fd object :input)
+ ;; FIXME: We could use a better way of setting up
+ ;; temporary files
+ (dotimes (count
+ 256
+ (error "could not open a temporary file in /tmp"))
+ (let* ((name (coerce (format nil "/tmp/.run-program-~D" count)
+ 'base-string))
+ (fd (sb-unix:unix-open name
+ (logior sb-unix:o_rdwr
+ sb-unix:o_creat
+ sb-unix:o_excl)
+ #o666)))
+ (sb-unix:unix-unlink name)
+ (when fd
+ (let ((newline (string #\Newline)))
+ (loop
+ (multiple-value-bind
+ (line no-cr)
+ (read-line object nil nil)
+ (unless line
+ (return))
+ (sb-unix:unix-write
+ fd
+ ;; FIXME: this really should be
+ ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...).
+ ;; RUN-PROGRAM should take an
+ ;; external-format argument, which should
+ ;; be passed down to here. Something
+ ;; similar should happen on :OUTPUT, too.
+ (map '(vector (unsigned-byte 8)) #'char-code line)
+ 0 (length line))
+ (if no-cr
+ (return)
+ (sb-unix:unix-write fd newline 0 1)))))
+ (sb-unix:unix-lseek fd 0 sb-unix:l_set)
+ (push fd *close-in-parent*)
+ (return (values fd nil)))))))
(:output
- (multiple-value-bind (read-fd write-fd)
- (sb-unix:unix-pipe)
- (unless read-fd
- (error "couldn't create pipe: ~S" (strerror write-fd)))
- (copy-descriptor-to-stream read-fd object cookie)
- (push read-fd *close-on-error*)
- (push write-fd *close-in-parent*)
- (values write-fd nil)))))
+ (or (get-stream-fd object :output)
+ (multiple-value-bind (read-fd write-fd)
+ (sb-unix:unix-pipe)
+ (unless read-fd
+ (error "couldn't create pipe: ~S" (strerror write-fd)))
+ (copy-descriptor-to-stream read-fd object cookie)
+ (push read-fd *close-on-error*)
+ (push write-fd *close-in-parent*)
+ (values write-fd nil))))))
(t
(error "invalid option to RUN-PROGRAM: ~S" object))))
projects / sbcl.git / blobdiff