;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not
;;;; visible at GENESIS time.
-(define-alien-routine wrapped-environ (* c-string))
-(defun posix-environ ()
+#-win32 (define-alien-routine wrapped-environ (* c-string))
+#-win32 (defun posix-environ ()
"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))
+
;;; Convert as best we can from an SBCL representation of a Unix
;;; environment to a CMU CL representation.
;;;
\f
;;;; Import wait3(2) from Unix.
+#-win32
(define-alien-routine ("wait3" c-wait3) sb-alien:int
(status sb-alien:int :out)
(options sb-alien:int)
(rusage sb-alien:int))
+#-win32
(defun wait3 (&optional do-not-hang check-for-stopped)
+ #+sb-doc
"Return any available status information on child process. "
(multiple-value-bind (pid status)
(c-wait3 (logior (if do-not-hang
(not (zerop (ldb (byte 1 7) status)))))))))
\f
;;;; process control stuff
-
+#-win32
(defvar *active-processes* nil
+ #+sb-doc
"List of process structures for all active processes.")
+#-win32
(defvar *active-processes-lock*
(sb-thread:make-mutex :name "Lock for active processes."))
;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a
;;; mutex is needed. More importantly the sigchld signal handler also
;;; accesses it, that's why we need without-interrupts.
+#-win32
(defmacro with-active-processes-lock (() &body body)
`(without-interrupts
(sb-thread:with-mutex (*active-processes-lock*)
,@body)))
+
(defstruct (process (:copier nil))
pid ; PID of child process
%status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
exit-code ; either exit code or signal
core-dumped ; T if a core image was dumped
- pty ; stream to child's pty, or NIL
+ #-win32 pty ; stream to child's pty, or NIL
input ; stream to child's input, or NIL
output ; stream from child's output, or NIL
error ; stream from child's error output, or NIL
plist ; a place for clients to stash things
cookie) ; list of the number of pipes from the subproc
-(defmethod print-object ((process process) stream)
+
+
+#-win32 (defmethod print-object ((process process) stream)
(print-unreadable-object (process stream :type t)
(format stream
"~W ~S"
(process-status process)))
process)
-(defun process-status (proc)
- "Return the current status of process. The result is one of :RUNNING,
+#+sb-doc
+(setf (documentation 'process-p 'function)
+ "T if OBJECT is a PROCESS, NIL otherwise.")
+
+#+sb-doc
+(setf (documentation 'process-pid 'function) "The pid of the child process.")
+
+#-win32
+(defun process-status (process)
+ #+sb-doc
+ "Return the current status of PROCESS. The result is one of :RUNNING,
:STOPPED, :EXITED, or :SIGNALED."
(get-processes-status-changes)
- (process-%status proc))
-
-(defun process-wait (proc &optional check-for-stopped)
- "Wait for PROC to quit running for some reason. Returns PROC."
+ (process-%status process))
+
+#+sb-doc
+(setf (documentation 'process-exit-code 'function)
+ "The exit code or the signal of a stopped process.")
+
+#+sb-doc
+(setf (documentation 'process-core-dumped 'function)
+ "T if a core image was dumped by the process.")
+
+#+sb-doc
+(setf (documentation 'process-pty 'function)
+ "The pty stream of the process or NIL.")
+
+#+sb-doc
+(setf (documentation 'process-input 'function)
+ "The input stream of the process or NIL.")
+
+#+sb-doc
+(setf (documentation 'process-output 'function)
+ "The output stream of the process or NIL.")
+
+#+sb-doc
+(setf (documentation 'process-error 'function)
+ "The error stream of the process or NIL.")
+
+#+sb-doc
+(setf (documentation 'process-status-hook 'function)
+ "A function that is called when PROCESS changes its status.
+The function is called with PROCESS as its only argument.")
+
+#+sb-doc
+(setf (documentation 'process-plist 'function)
+ "A place for clients to stash things.")
+
+#-win32
+(defun process-wait (process &optional check-for-stopped)
+ #+sb-doc
+ "Wait for PROCESS to quit running for some reason.
+ When CHECK-FOR-STOPPED is T, also returns when PROCESS is
+ stopped. Returns PROCESS."
(loop
- (case (process-status proc)
+ (case (process-status process)
(:running)
(:stopped
(when check-for-stopped
(return)))
(t
- (when (zerop (car (process-cookie proc)))
+ (when (zerop (car (process-cookie process)))
(return))))
(sb-sys:serve-all-events 1))
- proc)
+ process)
-#-hpux
+#-(or hpux win32)
;;; Find the current foreground process group id.
(defun find-current-foreground-process (proc)
(with-alien ((result sb-alien:int))
result))
(process-pid proc))
-(defun process-kill (proc signal &optional (whom :pid))
- "Hand SIGNAL to PROC. If WHOM is :PID, use the kill Unix system call. If
+#-win32
+(defun process-kill (process signal &optional (whom :pid))
+ #+sb-doc
+ "Hand SIGNAL to PROCESS. If WHOM is :PID, use the kill Unix system call. If
WHOM is :PROCESS-GROUP, use the killpg Unix system call. If WHOM is
:PTY-PROCESS-GROUP deliver the signal to whichever process group is
currently in the foreground."
(let ((pid (ecase whom
((:pid :process-group)
- (process-pid proc))
+ (process-pid process))
(:pty-process-group
#-hpux
- (find-current-foreground-process proc)))))
+ (find-current-foreground-process process)))))
(multiple-value-bind
(okay errno)
(case whom
#+hpux
(:pty-process-group
- (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
+ (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty process))
sb-unix:TIOCSIGSEND
(sb-sys:int-sap
signal)))
(sb-unix:unix-kill pid signal)))
(cond ((not okay)
(values nil errno))
- ((and (eql pid (process-pid proc))
+ ((and (eql pid (process-pid process))
(= signal sb-unix:sigcont))
- (setf (process-%status proc) :running)
- (setf (process-exit-code proc) nil)
- (when (process-status-hook proc)
- (funcall (process-status-hook proc) proc))
+ (setf (process-%status process) :running)
+ (setf (process-exit-code process) nil)
+ (when (process-status-hook process)
+ (funcall (process-status-hook process) process))
t)
(t
t)))))
-(defun process-alive-p (proc)
- "Return T if the process is still alive, NIL otherwise."
- (let ((status (process-status proc)))
+#-win32
+(defun process-alive-p (process)
+ #+sb-doc
+ "Return T if PROCESS is still alive, NIL otherwise."
+ (let ((status (process-status process)))
(if (or (eq status :running)
(eq status :stopped))
t
nil)))
-(defun process-close (proc)
- "Close all streams connected to PROC and stop maintaining the status slot."
+#-win32
+(defun process-close (process)
+ #+sb-doc
+ "Close all streams connected to PROCESS and stop maintaining the status slot."
(macrolet ((frob (stream abort)
`(when ,stream (close ,stream :abort ,abort))))
- (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process, ..
- (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE.
- (frob (process-output proc) nil)
- (frob (process-error proc) nil))
+ (frob (process-pty process) t) ; Don't FLUSH-OUTPUT to dead process, ..
+ (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE.
+ (frob (process-output process) nil)
+ (frob (process-error process) nil))
(with-active-processes-lock ()
- (setf *active-processes* (delete proc *active-processes*)))
- proc)
+ (setf *active-processes* (delete process *active-processes*)))
+ process)
;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes
-(defun sigchld-handler (ignore1 ignore2 ignore3)
+#-win32 (defun sigchld-handler (ignore1 ignore2 ignore3)
(declare (ignore ignore1 ignore2 ignore3))
(get-processes-status-changes))
-(defun get-processes-status-changes ()
+#-win32 (defun get-processes-status-changes ()
(loop
(multiple-value-bind (pid what code core)
(wait3 t t)
(defvar *close-in-parent* nil)
;;; list of handlers installed by RUN-PROGRAM
-(defvar *handlers-installed* nil)
+#-win32 (defvar *handlers-installed* nil)
;;; Find an unused pty. Return three values: the file descriptor for
;;; 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.
-(defun find-a-pty ()
+#-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))
(sb-unix:unix-close master-fd))))))
(error "could not find a pty"))
-(defun open-pty (pty cookie)
+#-win32 (defun open-pty (pty cookie)
(when pty
(multiple-value-bind
(master slave name)
(copy-descriptor-to-stream new-fd pty cookie)))
(values name
(sb-sys:make-fd-stream master :input t :output t
+ :element-type :default
:dual-channel-p t)))))
(defmacro round-bytes-to-words (n)
,@body)
(sb-sys:deallocate-system-memory ,sap ,size)))))
-(sb-alien:define-alien-routine spawn sb-alien:int
+#-win32 (sb-alien:define-alien-routine spawn sb-alien:int
(program sb-alien:c-string)
(argv (* sb-alien:c-string))
(envp (* sb-alien:c-string))
(stdout sb-alien:int)
(stderr sb-alien:int))
+#+win32 (sb-alien:define-alien-routine spawn 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)
+ (wait sb-alien:int))
+
;;; Is UNIX-FILENAME the name of a file that we can execute?
-(defun unix-filename-is-executable-p (unix-filename)
+#-win32 (defun unix-filename-is-executable-p (unix-filename)
(declare (type simple-string unix-filename))
(setf unix-filename (coerce unix-filename 'base-string))
(values (and (eq (sb-unix:unix-file-kind unix-filename) :file)
(defun find-executable-in-search-path (pathname
&optional
(search-path (posix-getenv "PATH")))
- "Find the first executable file matching PATHNAME in any of the colon-separated list of pathnames SEARCH-PATH"
- (loop for end = (position #\: search-path :start (if end (1+ end) 0))
+ #+sb-doc
+ "Find the first executable file matching PATHNAME in any of the
+colon-separated list of pathnames SEARCH-PATH"
+ (loop for end = (position #-win32 #\: #+win32 #\; search-path :start (if end (1+ end) 0))
and start = 0 then (and end (1+ end))
while start
;; <Krystof> the truename of a file naming a directory is the
;; that's noncompliant -- CSR, c. 2003-08-10
for truename = (probe-file (subseq search-path start end))
for fullpath = (when truename (merge-pathnames pathname truename))
- when (and fullpath
+ when #-win32 (and fullpath
(unix-filename-is-executable-p (namestring fullpath)))
+ #+win32 t
return fullpath))
;;; FIXME: There shouldn't be two semiredundant versions of the
;;;
;;; RUN-PROGRAM returns a PROCESS structure for the process if
;;; the fork worked, and NIL if it did not.
-(defun run-program (program args
+
+#-win32 (defun run-program (program args
&key
(env nil env-p)
(environment (if env-p
(error :output)
(if-error-exists :error)
status-hook)
+ #+sb-doc
"RUN-PROGRAM creates a new Unix process running the Unix program found in
the file specified by the PROGRAM argument. ARGS are the standard
arguments that can be passed to a Unix 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 NIL or a PROCESS structure. See the CMU
- Common Lisp Users Manual for details about the PROCESS structure.
+ RUN-PROGRAM will return a PROCESS structure or NIL on failure.
+ See the CMU Common Lisp Users Manual for details about the
+ PROCESS structure.
+
+ Notes about Unix environments (as in the :ENVIRONMENT and :ENV args):
- notes about Unix environments (as in the :ENVIRONMENT and :ENV args):
- 1. 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.
- 2. 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
- doing this, read about it first. (The Perl community has a lot of good
- documentation about this and other security issues in script-like
- programs.)
+ - 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.
+
+ - 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
+ doing this, read about it first. (The Perl community has a lot of good
+ documentation about this and other security issues in script-like
+ programs.)
The &KEY arguments have the following meanings:
- :ENVIRONMENT
- a list of SIMPLE-BASE-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
- :SEARCH
- Look for PROGRAM in each of the directories along the $PATH
- environment variable. Otherwise an absolute pathname is required.
- (See also FIND-EXECUTABLE-IN-SEARCH-PATH)
- :WAIT
- If non-NIL (default), wait until the created process finishes. If
- NIL, continue running Lisp until the program finishes.
- :PTY
- Either T, NIL, or a stream. Unless NIL, the subprocess is established
- under a PTY. If :pty is a stream, all output to this pty is sent to
- this stream, otherwise the PROCESS-PTY slot is filled in with a stream
- connected to pty that can read output and write input.
- :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
- 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
- its output to the process. Defaults to NIL.
- :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
- can be one of:
- :ERROR to generate an error
- :CREATE to create an empty file
- 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
- 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
- be read to get the output. Defaults to NIL.
- :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
- can be one of:
- :ERROR (the default) to generate an error
- :SUPERSEDE to supersede the file with output from the program
- :APPEND to append output from the program to the file
- NIL to return NIL from RUN-PROGRAM, without doing anything
- :ERROR and :IF-ERROR-EXISTS
- Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
- specified as :OUTPUT in which case all error output is routed to the
- 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."
+
+ :ENVIRONMENT
+ a list of SIMPLE-BASE-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
+ :SEARCH
+ Look for PROGRAM in each of the directories along the $PATH
+ environment variable. Otherwise an absolute pathname is required.
+ (See also FIND-EXECUTABLE-IN-SEARCH-PATH)
+ :WAIT
+ If non-NIL (default), wait until the created process finishes. If
+ NIL, continue running Lisp until the program finishes.
+ :PTY
+ Either T, NIL, or a stream. Unless NIL, the subprocess is established
+ under a PTY. If :pty is a stream, all output to this pty is sent to
+ this stream, otherwise the PROCESS-PTY slot is filled in with a stream
+ connected to pty that can read output and write input.
+ :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
+ 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
+ its output to the process. Defaults to NIL.
+ :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
+ can be one of:
+ :ERROR to generate an error
+ :CREATE to create an empty file
+ 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
+ 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
+ be read to get the output. Defaults to NIL.
+ :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
+ can be one of:
+ :ERROR (the default) to generate an error
+ :SUPERSEDE to supersede the file with output from the program
+ :APPEND to append output from the program to the file
+ NIL to return NIL from RUN-PROGRAM, without doing anything
+ :ERROR and :IF-ERROR-EXISTS
+ Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
+ specified as :OUTPUT in which case all error output is routed to the
+ 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."
(when (and env-p environment-p)
(error "can't specify :ENV and :ENVIRONMENT simultaneously"))
(process-wait proc))
proc))
+#+win32 (defun run-program (program args
+ &key
+ (wait t)
+ search
+ input
+ if-input-does-not-exist
+ output
+ (if-output-exists :error)
+ (error :output)
+ (if-error-exists :error)
+ status-hook)
+ "RUN-PROGRAM creates a new process specified by the PROGRAM 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).
+
+ RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
+ Common Lisp Users Manual for details about the PROCESS structure.
+
+ The &KEY arguments have the following meanings:
+ :SEARCH
+ Look for PROGRAM in each of the directories along the $PATH
+ environment variable. Otherwise an absolute pathname is required.
+ (See also FIND-EXECUTABLE-IN-SEARCH-PATH)
+ :WAIT
+ If non-NIL (default), wait until the created process finishes. If
+ 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
+ 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
+ its output to the process. Defaults to NIL.
+ :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
+ can be one of:
+ :ERROR to generate an error
+ :CREATE to create an empty file
+ 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
+ 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
+ be read to get the output. Defaults to NIL.
+ :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
+ can be one of:
+ :ERROR (the default) to generate an error
+ :SUPERSEDE to supersede the file with output from the program
+ :APPEND to append output from the program to the file
+ NIL to return NIL from RUN-PROGRAM, without doing anything
+ :ERROR and :IF-ERROR-EXISTS
+ Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
+ specified as :OUTPUT in which case all error output is routed to the
+ 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."
+
+ ;; Prepend the program to the argument list.
+ (push (namestring program) args)
+ (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to
+ ;; communicate cleanup info.
+ *close-on-error*
+ *close-in-parent*
+ ;; Establish PROC at this level so that we can return it.
+ 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)))
+ (unwind-protect
+ (let ((pfile
+ (if search
+ (namestring (find-executable-in-search-path program))
+ (namestring program)))
+ (cookie (list 0)))
+ (unless pfile
+ (error "no such program: ~S" program))
+ (multiple-value-bind (stdin input-stream)
+ (get-descriptor-for input cookie
+ :direction :input
+ :if-does-not-exist if-input-does-not-exist)
+ (multiple-value-bind (stdout output-stream)
+ (get-descriptor-for output cookie
+ :direction :output
+ :if-exists if-output-exists)
+ (multiple-value-bind (stderr error-stream)
+ (if (eq error :output)
+ (values stdout output-stream)
+ (get-descriptor-for error cookie
+ :direction :output
+ :if-exists if-error-exists))
+ (with-c-strvec (args-vec simple-args)
+ (let ((iwait (if wait 1 0)))
+ (declare (type fixnum iwait))
+ (let ((child-pid
+ (without-gcing
+ (spawn pfile args-vec
+ stdin stdout stderr
+ iwait))))
+ (when (< child-pid 0)
+ (error "couldn't spawn program: ~A"
+ (strerror)))
+ (setf proc
+ (if wait
+ nil
+ (make-process :pid child-pid
+ :%status :running
+ :input input-stream
+ :output output-stream
+ :error error-stream
+ :status-hook status-hook
+ :cookie cookie)))))))))))
+ 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.
(sb-unix:unix-read descriptor
(alien-sap buf)
256)
- (cond ((or (and (null count)
- (eql errno sb-unix:eio))
- (eql count 0))
+ (cond (#-win32(or (and (null count)
+ (eql errno sb-unix:eio))
+ (eql count 0))
+ #+win32(<= count 0)
(sb-sys:remove-fd-handler handler)
(setf handler nil)
(decf (car cookie))
;; Use /dev/null.
(multiple-value-bind
(fd errno)
- (sb-unix:unix-open #.(coerce "/dev/null" 'base-string)
+ (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)
(: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 (sb-sys:make-fd-stream write-fd :output t
+ :element-type :default)))
(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)))
+ (let ((stream (sb-sys:make-fd-stream read-fd :input t
+ :element-type :default)))
(values write-fd stream)))
(t
(sb-unix:unix-close read-fd)
projects / sbcl.git / blobdiff