/[cmucl]/src/code/run-program.lisp
ViewVC logotype

Diff of /src/code/run-program.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.28 by rtoy, Thu Jun 11 16:03:59 2009 UTC revision 1.28.14.1 by rtoy, Thu Feb 25 20:34:51 2010 UTC
# Line 19  Line 19 
19  ;;;  ;;;
20    
21  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
22    (intl:textdomain "cmucl")
23    
24  (export '(run-program process-status process-exit-code process-core-dumped  (export '(run-program process-status process-exit-code process-core-dumped
25            process-wait process-kill process-input process-output process-plist            process-wait process-kill process-input process-output process-plist
# Line 39  Line 40 
40    (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced))    (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced))
41    
42  (defun wait3 (&optional do-not-hang check-for-stopped)  (defun wait3 (&optional do-not-hang check-for-stopped)
43    "Return any available status information on child processed. "    _N"Return any available status information on child processed. "
44    (multiple-value-bind (pid status)    (multiple-value-bind (pid status)
45                         (c-wait3 (logior (if do-not-hang                         (c-wait3 (logior (if do-not-hang
46                                            wait-wnohang                                            wait-wnohang
# Line 77  Line 78 
78  ;;;; Process control stuff.  ;;;; Process control stuff.
79    
80  (defvar *active-processes* nil  (defvar *active-processes* nil
81    "List of process structures for all active processes.")    _N"List of process structures for all active processes.")
82    
83  (defstruct (process (:print-function %print-process))  (defstruct (process (:print-function %print-process))
84    pid                       ; PID of child process.    pid                       ; PID of child process.
# Line 102  Line 103 
103  ;;; PROCESS-STATUS -- Public.  ;;; PROCESS-STATUS -- Public.
104  ;;;  ;;;
105  (defun process-status (proc)  (defun process-status (proc)
106    "Return the current status of process.  The result is one of :running,    _N"Return the current status of process.  The result is one of :running,
107     :stopped, :exited, :signaled."     :stopped, :exited, :signaled."
108    (declare (type process proc))    (declare (type process proc))
109    (get-processes-status-changes)    (get-processes-status-changes)
# Line 112  Line 113 
113  ;;; PROCESS-WAIT -- Public.  ;;; PROCESS-WAIT -- Public.
114  ;;;  ;;;
115  (defun process-wait (proc &optional check-for-stopped)  (defun process-wait (proc &optional check-for-stopped)
116    "Wait for PROC to quit running for some reason.  Returns PROC."    _N"Wait for PROC to quit running for some reason.  Returns PROC."
117    (declare (type process proc))    (declare (type process proc))
118    (loop    (loop
119      (case (process-status proc)      (case (process-status proc)
# Line 140  Line 141 
141                           unix:TIOCGPGRP                           unix:TIOCGPGRP
142                           (alien:alien-sap (alien:addr result)))                           (alien:alien-sap (alien:addr result)))
143        (unless wonp        (unless wonp
144          (error "TIOCPGRP ioctl failed: ~S"          (error _"TIOCPGRP ioctl failed: ~S"
145                 (unix:get-unix-error-msg error)))                 (unix:get-unix-error-msg error)))
146        result))        result))
147    (process-pid proc))    (process-pid proc))
# Line 151  Line 152 
152  ;;; Hand a process a signal.  ;;; Hand a process a signal.
153  ;;;  ;;;
154  (defun process-kill (proc signal &optional (whom :pid))  (defun process-kill (proc signal &optional (whom :pid))
155    "Hand SIGNAL to PROC.  If whom is :pid, use the kill Unix system call.  If    _N"Hand SIGNAL to PROC.  If whom is :pid, use the kill Unix system call.  If
156     whom is :process-group, use the killpg Unix system call.  If whom is     whom is :process-group, use the killpg Unix system call.  If whom is
157     :pty-process-group deliver the signal to whichever process group is currently     :pty-process-group deliver the signal to whichever process group is currently
158     in the foreground."     in the foreground."
# Line 193  Line 194 
194  ;;; Returns T if the process is still alive, NIL otherwise.  ;;; Returns T if the process is still alive, NIL otherwise.
195  ;;;  ;;;
196  (defun process-alive-p (proc)  (defun process-alive-p (proc)
197    "Returns T if the process is still alive, NIL otherwise."    _N"Returns T if the process is still alive, NIL otherwise."
198    (declare (type process proc))    (declare (type process proc))
199    (let ((status (process-status proc)))    (let ((status (process-status proc)))
200      (if (or (eq status :running)      (if (or (eq status :running)
# Line 206  Line 207 
207  ;;; Close all the streams held open by PROC.  ;;; Close all the streams held open by PROC.
208  ;;;  ;;;
209  (defun process-close (proc)  (defun process-close (proc)
210    "Close all streams connected to PROC and stop maintaining the status slot."    _N"Close all streams connected to PROC and stop maintaining the status slot."
211    (declare (type process proc))    (declare (type process proc))
212    (macrolet ((frob (stream abort)    (macrolet ((frob (stream abort)
213                 `(when ,stream (close ,stream :abort ,abort))))                 `(when ,stream (close ,stream :abort ,abort))))
# Line 252  Line 253 
253  ;;;; RUN-PROGRAM and close friends.  ;;;; RUN-PROGRAM and close friends.
254    
255  (defvar *close-on-error* nil  (defvar *close-on-error* nil
256    "List of file descriptors to close when RUN-PROGRAM exits due to an error.")    _N"List of file descriptors to close when RUN-PROGRAM exits due to an error.")
257  (defvar *close-in-parent* nil  (defvar *close-in-parent* nil
258    "List of file descriptors to close when RUN-PROGRAM returns in the parent.")    _N"List of file descriptors to close when RUN-PROGRAM returns in the parent.")
259  (defvar *handlers-installed* nil  (defvar *handlers-installed* nil
260    "List of handlers installed by RUN-PROGRAM.")    _N"List of handlers installed by RUN-PROGRAM.")
261    
262    
263  ;;; FIND-A-PTY -- internal  ;;; FIND-A-PTY -- internal
# Line 267  Line 268 
268  ;;;  ;;;
269  #-irix  #-irix
270  (defun find-a-pty ()  (defun find-a-pty ()
271    "Returns the master fd, the slave fd, and the name of the tty"    _N"Returns the master fd, the slave fd, and the name of the tty"
272    (multiple-value-bind (error master-fd slave-fd)    (multiple-value-bind (error master-fd slave-fd)
273        (unix:unix-openpty nil nil nil)        (unix:unix-openpty nil nil nil)
274      (when (zerop error)      (when (zerop error)
# Line 286  Line 287 
287                     (values master-fd                     (values master-fd
288                             slave-fd                             slave-fd
289                             (unix:unix-ttyname slave-fd))))                             (unix:unix-ttyname slave-fd))))
290      (error "Could not find a pty.")))      (error _"Could not find a pty.")))
291    
292  #+irix  #+irix
293  (alien:def-alien-routine ("_getpty" c-getpty) c-call:c-string  (alien:def-alien-routine ("_getpty" c-getpty) c-call:c-string
# Line 297  Line 298 
298    
299  #+irix  #+irix
300  (defun find-a-pty ()  (defun find-a-pty ()
301    "Returns the master fd, the slave fd, and the name of the tty"    _N"Returns the master fd, the slave fd, and the name of the tty"
302    (multiple-value-bind (line master-fd)    (multiple-value-bind (line master-fd)
303      (c-getpty (logior unix:o_rdwr unix:o_ndelay) #o600 0)      (c-getpty (logior unix:o_rdwr unix:o_ndelay) #o600 0)
304      (let* ((slave-name line)      (let* ((slave-name line)
# Line 320  Line 321 
321                               slave-fd                               slave-fd
322                               slave-name))))                               slave-name))))
323      (unix:unix-close master-fd))      (unix:unix-close master-fd))
324    (error "Could not find a pty."))    (error _"Could not find a pty."))
325    
326  ;;; OPEN-PTY -- internal  ;;; OPEN-PTY -- internal
327  ;;;  ;;;
# Line 334  Line 335 
335        (when (streamp pty)        (when (streamp pty)
336          (multiple-value-bind (new-fd errno) (unix:unix-dup master)          (multiple-value-bind (new-fd errno) (unix:unix-dup master)
337            (unless new-fd            (unless new-fd
338              (error "Could not UNIX:UNIX-DUP ~D: ~A"              (error _"Could not UNIX:UNIX-DUP ~D: ~A"
339                     master (unix:get-unix-error-msg errno)))                     master (unix:get-unix-error-msg errno)))
340            (push new-fd *close-on-error*)            (push new-fd *close-on-error*)
341            (copy-descriptor-to-stream new-fd pty cookie)))            (copy-descriptor-to-stream new-fd pty cookie)))
# Line 454  Line 455 
455                      &key (env *environment-list*) (wait t) pty input                      &key (env *environment-list*) (wait t) pty input
456                      if-input-does-not-exist output (if-output-exists :error)                      if-input-does-not-exist output (if-output-exists :error)
457                      (error :output) (if-error-exists :error) status-hook)                      (error :output) (if-error-exists :error) status-hook)
458    "RUN-PROGRAM creates a new process and runs the unix program in the    _N"RUN-PROGRAM creates a new process and runs the unix program in the
459     file specified by the simple-string PROGRAM.  ARGS are the standard     file specified by the simple-string PROGRAM.  ARGS are the standard
460     arguments that can be passed to a Unix program, for no arguments     arguments that can be passed to a Unix program, for no arguments
461     use NIL (which means just the name of the program is passed as arg 0).     use NIL (which means just the name of the program is passed as arg 0).
# Line 511  Line 512 
512    (system:enable-interrupt unix:sigchld #'sigchld-handler)    (system:enable-interrupt unix:sigchld #'sigchld-handler)
513    ;; Make sure all the args are okay.    ;; Make sure all the args are okay.
514    (unless (every #'simple-string-p args)    (unless (every #'simple-string-p args)
515      (error "All args to program must be simple strings -- ~S." args))      (error _"All args to program must be simple strings -- ~S." args))
516    ;; Pre-pend the program to the argument list.    ;; Pre-pend the program to the argument list.
517    (push (namestring program) args)    (push (namestring program) args)
518    ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup    ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
# Line 521  Line 522 
522          (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))          (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
523                (cookie (list 0)))                (cookie (list 0)))
524            (unless pfile            (unless pfile
525              (error "No such program: ~S" program))              (error _"No such program: ~S" program))
526            (multiple-value-bind            (multiple-value-bind
527                (stdin input-stream)                (stdin input-stream)
528                (get-descriptor-for input cookie :direction :input                (get-descriptor-for input cookie :direction :input
# Line 557  Line 558 
558                                  (spawn pfile argv envp pty-name                                  (spawn pfile argv envp pty-name
559                                         stdin stdout stderr))))                                         stdin stdout stderr))))
560                            (when (< child-pid 0)                            (when (< child-pid 0)
561                              (error "Could not fork child process: ~A"                              (error _"Could not fork child process: ~A"
562                                     (unix:get-unix-error-msg)))                                     (unix:get-unix-error-msg)))
563                            (setf proc (make-process :pid child-pid                            (setf proc (make-process :pid child-pid
564                                                     :%status :running                                                     :%status :running
# Line 600  Line 601 
601                        (unix:unix-select (1+ descriptor) (ash 1 descriptor)                        (unix:unix-select (1+ descriptor) (ash 1 descriptor)
602                                          0 0 0)                                          0 0 0)
603                      (cond ((null result)                      (cond ((null result)
604                             (error "Could not select on sub-process: ~A"                             (error _"Could not select on sub-process: ~A"
605                                    (unix:get-unix-error-msg readable/errno)))                                    (unix:get-unix-error-msg readable/errno)))
606                            ((zerop result)                            ((zerop result)
607                             (return))))                             (return))))
# Line 620  Line 621 
621                               (system:remove-fd-handler handler)                               (system:remove-fd-handler handler)
622                               (setf handler nil)                               (setf handler nil)
623                               (decf (car cookie))                               (decf (car cookie))
624                               (error "Could not read input from sub-process: ~A"                               (error _"Could not read input from sub-process: ~A"
625                                      (unix:get-unix-error-msg errno)))                                      (unix:get-unix-error-msg errno)))
626                              (t                              (t
627                               #-unicode                               #-unicode
# Line 658  Line 659 
659                                 (t unix:o_rdwr))                                 (t unix:o_rdwr))
660                               #o666)                               #o666)
661             (unless fd             (unless fd
662               (error "Could not open \"/dev/null\": ~A"               (error _"Could not open \"/dev/null\": ~A"
663                      (unix:get-unix-error-msg errno)))                      (unix:get-unix-error-msg errno)))
664             (push fd *close-in-parent*)             (push fd *close-in-parent*)
665             (values fd nil)))             (values fd nil)))
# Line 667  Line 668 
668               (read-fd write-fd)               (read-fd write-fd)
669               (unix:unix-pipe)               (unix:unix-pipe)
670             (unless read-fd             (unless read-fd
671               (error "Could not create pipe: ~A"               (error _"Could not create pipe: ~A"
672                      (unix:get-unix-error-msg write-fd)))                      (unix:get-unix-error-msg write-fd)))
673             (case direction             (case direction
674               (:input               (:input
# Line 683  Line 684 
684               (t               (t
685                (unix:unix-close read-fd)                (unix:unix-close read-fd)
686                (unix:unix-close write-fd)                (unix:unix-close write-fd)
687                (error "Direction must be either :INPUT or :OUTPUT, not ~S"                (error _"Direction must be either :INPUT or :OUTPUT, not ~S"
688                       direction)))))                       direction)))))
689          ((or (pathnamep object) (stringp object))          ((or (pathnamep object) (stringp object))
690           (with-open-stream (file (apply #'open object keys))           (with-open-stream (file (apply #'open object keys))
# Line 694  Line 695 
695                      (push fd *close-in-parent*)                      (push fd *close-in-parent*)
696                      (values fd nil))                      (values fd nil))
697                     (t                     (t
698                      (error "Could not duplicate file descriptor: ~A"                      (error _"Could not duplicate file descriptor: ~A"
699                             (unix:get-unix-error-msg errno)))))))                             (unix:get-unix-error-msg errno)))))))
700          ((system:fd-stream-p object)          ((system:fd-stream-p object)
701           (values (system:fd-stream-fd object) nil))           (values (system:fd-stream-fd object) nil))
# Line 703  Line 704 
704             (:input             (:input
705              (dotimes (count              (dotimes (count
706                        256                        256
707                        (error "Could not open a temporary file in /tmp"))                        (error _"Could not open a temporary file in /tmp"))
708                (let* ((name (format nil "/tmp/.run-program-~D" count))                (let* ((name (format nil "/tmp/.run-program-~D" count))
709                       (fd (unix:unix-open name                       (fd (unix:unix-open name
710                                           (logior unix:o_rdwr                                           (logior unix:o_rdwr
# Line 730  Line 731 
731              (multiple-value-bind (read-fd write-fd)              (multiple-value-bind (read-fd write-fd)
732                                   (unix:unix-pipe)                                   (unix:unix-pipe)
733                (unless read-fd                (unless read-fd
734                  (error "Cound not create pipe: ~A"                  (error _"Cound not create pipe: ~A"
735                         (unix:get-unix-error-msg write-fd)))                         (unix:get-unix-error-msg write-fd)))
736                (copy-descriptor-to-stream read-fd object cookie)                (copy-descriptor-to-stream read-fd object cookie)
737                (push read-fd *close-on-error*)                (push read-fd *close-on-error*)
738                (push write-fd *close-in-parent*)                (push write-fd *close-in-parent*)
739                (values write-fd nil)))))                (values write-fd nil)))))
740          (t          (t
741           (error "Invalid option to run-program: ~S" object))))           (error _"Invalid option to run-program: ~S" object))))
742    

Legend:
Removed from v.1.28  
changed lines
  Added in v.1.28.14.1

  ViewVC Help
Powered by ViewVC 1.1.5