/[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.11.2.1 by wlott, Sun Mar 8 15:27:05 1992 UTC revision 1.32 by rtoy, Mon Sep 20 13:50:52 2010 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 21  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 36  Line 35 
35    (rusage c-call:int))    (rusage c-call:int))
36    
37  (eval-when (load eval compile)  (eval-when (load eval compile)
38    (defconstant wait-wstopped #o177)    (defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
39    (defconstant wait-wnohang 1)    (defconstant wait-wuntraced #-svr4 2 #+svr4 4)
40    (defconstant wait-wuntraced 2))    (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. "    "Return any available status information on child processed. "
# Line 90  Line 89 
89    input                     ; Stream to child's input or nil.    input                     ; Stream to child's input or nil.
90    output                    ; Stream from child's output or nil.    output                    ; Stream from child's output or nil.
91    error                     ; Stream from child's error output or nil.    error                     ; Stream from child's error output or nil.
   give-child-tty            ; If T, give tty-control to the child while waiting  
92    status-hook               ; Closure to call when PROC changes status.    status-hook               ; Closure to call when PROC changes status.
93    plist                     ; Place for clients to stash tings.    plist                     ; Place for clients to stash tings.
94    cookie                    ; List of the number of pipes from the subproc.    cookie                    ; List of the number of pipes from the subproc.
# Line 107  Line 105 
105  (defun process-status (proc)  (defun process-status (proc)
106    "Return the current status of process.  The result is one of :running,    "Return the current status of process.  The result is one of :running,
107     :stopped, :exited, :signaled."     :stopped, :exited, :signaled."
108      (declare (type process proc))
109    (get-processes-status-changes)    (get-processes-status-changes)
110    (process-%status proc))    (process-%status proc))
111    
112    
113  ;;; PROCESS-WAIT -- Public.  ;;; PROCESS-WAIT -- Public.
114  ;;;  ;;;
115  (defun process-wait (proc &optional (stop-action :error) (continue-first t))  (defun process-wait (proc &optional check-for-stopped)
116    "Wait for PROC to quit running for some reason.  Returns PROC.  If the    "Wait for PROC to quit running for some reason.  Returns PROC."
117    optional STOP-ACTION is :RETURN, process-wait returns when the process    (declare (type process proc))
118    stops; if it is :CONTINUE, the process is automatically sent a SIGCONT; if    (loop
119    it is :ERROR (the default), an error is signalled (which allows the user to      (case (process-status proc)
120    either continue the process or return from process-wait); if it is NIL,        (:running)
121    nothing is done.  If the optional argument CONTINUE-FIRST is T (the default)        (:stopped
122    and the process is stopped right now, it will also be continued before         (when check-for-stopped
123    waiting [this is different than (process-kill ... :sigcont) followed by           (return)))
124    process-wait because it avoids a race condition]."        (t
125    (let ((pgrp (unix:unix-getpgrp (unix:unix-getpid)))         (when (zerop (car (process-cookie proc)))
126          (diddle-tty-pgrp (process-give-child-tty proc)))           (return))))
127      (unwind-protect      (system:serve-all-events 1))
         (progn  
           (when diddle-tty-pgrp  
             ;; give the tty to our child  
             (setf (unix:tty-process-group) (process-pid proc)))  
           ;; this must be done after handing over control of the tty  
           (when (and continue-first (eq (process-status proc) :stopped))  
             (process-kill proc :sigcont :process-group))  
   
           (loop  
             (case (process-status proc)  
               (:running)  
               (:stopped  
                (case stop-action  
                  ((nil))  
                  (:continue  
                   ;; try and restart it  
                   (process-kill proc :sigcont :process-group))  
                  (:error  
                   (when diddle-tty-pgrp  
                     ;; grab the tty for the duration of the error loop  
                     (setf (unix:tty-process-group) pgrp))  
                   (restart-case (error "Subprocess ~d stopped."  
                                         (process-pid proc))  
                     (continue () :report "continue the process"  
                       (when diddle-tty-pgrp  
                         ;; give the tty back to our child  
                         (setf (unix:tty-process-group) (process-pid proc)))  
                       (process-kill proc :sigcont :process-group))  
                     (return () :report "return from process-wait"  
                       (return))))  
                  (t  
                   ;; just return from process-wait  
                   (return))))  
               (t  
                (when (zerop (car (process-cookie proc)))  
                  (return))))  
             (system:serve-all-events 1)))  
   
       (when diddle-tty-pgrp  
         ;; grab the tty back for ourselves  
         (setf (unix:tty-process-group) pgrp))))  
128    proc)    proc)
129    
130    
131    #-hpux
132  ;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal  ;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal
133  ;;;  ;;;
134  ;;; Finds the current foreground process group id.  ;;; Finds the current foreground process group id.
135  ;;;  ;;;
136  (defun find-current-foreground-process (proc)  (defun find-current-foreground-process (proc)
137    (unix:tty-process-group (system:fd-stream-fd (ext:process-pty proc))))    (alien:with-alien ((result c-call:int))
138        (multiple-value-bind
139            (wonp error)
140            (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
141                             unix:TIOCGPGRP
142                             (alien:alien-sap (alien:addr result)))
143          (unless wonp
144            (error (intl:gettext "TIOCPGRP ioctl failed: ~S")
145                   (unix:get-unix-error-msg error)))
146          result))
147      (process-pid proc))
148    
149    
150  ;;; PROCESS-KILL -- public  ;;; PROCESS-KILL -- public
# Line 184  Line 153 
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    "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."
159      (declare (type process proc))
160    (let ((pid (ecase whom    (let ((pid (ecase whom
161                 ((:pid :process-group)                 ((:pid :process-group)
162                  (process-pid proc))                  (process-pid proc))
163                 (:pty-process-group                 (:pty-process-group
164                    #-hpux
165                  (find-current-foreground-process proc)))))                  (find-current-foreground-process proc)))))
166      (multiple-value-bind (okay errno)      (multiple-value-bind
167                           (if (eq whom :pid)          (okay errno)
168                               (unix:unix-kill pid signal)          (case whom
169                               (unix:unix-killpg pid signal))            #+hpux
170              (:pty-process-group
171               (unix:unix-ioctl (system:fd-stream-fd (process-pty proc))
172                                unix:TIOCSIGSEND
173                                (system:int-sap
174                                 (unix:unix-signal-number signal))))
175              ((:process-group #-hpux :pty-process-group)
176               (unix:unix-killpg pid signal))
177              (t
178               (unix:unix-kill pid signal)))
179        (cond ((not okay)        (cond ((not okay)
180               (values nil errno))               (values nil errno))
181              ((and (eql pid (process-pid proc))              ((and (eql pid (process-pid proc))
# Line 208  Line 188 
188              (t              (t
189               t)))))               t)))))
190    
191    
192  ;;; PROCESS-ALIVE-P -- public  ;;; PROCESS-ALIVE-P -- public
193  ;;;  ;;;
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."    "Returns T if the process is still alive, NIL otherwise."
198      (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)
201              (eq status :stopped))              (eq status :stopped))
# Line 226  Line 208 
208  ;;;  ;;;
209  (defun process-close (proc)  (defun process-close (proc)
210    "Close all streams connected to PROC and stop maintaining the status slot."    "Close all streams connected to PROC and stop maintaining the status slot."
211    (macrolet ((frob (stream)    (declare (type process proc))
212                 `(when ,stream (close ,stream))))    (macrolet ((frob (stream abort)
213      (frob (process-pty proc))                 `(when ,stream (close ,stream :abort ,abort))))
214      (frob (process-input proc))      (frob (process-pty    proc)   t) ; Don't FLUSH-OUTPUT to dead process.
215      (frob (process-output proc))      (frob (process-input  proc)   t) ; 'cause it will generate SIGPIPE.
216      (frob (process-error proc))      (frob (process-output proc) nil)
217      (system:without-interrupts      (frob (process-error  proc) nil))
218        (setf *active-processes* (delete proc *active-processes*)))    (system:without-interrupts
219      proc))     (setf *active-processes* (delete proc *active-processes*)))
220      proc)
221    
222  ;;; SIGCHLD-HANDLER -- Internal.  ;;; SIGCHLD-HANDLER -- Internal.
223  ;;;  ;;;
# Line 283  Line 266 
266  ;;; for the master side of the pty, the file descriptor for the slave side of  ;;; for the master side of the pty, the file descriptor for the slave side of
267  ;;; the pty, and the name of the tty device for the slave side.  ;;; the pty, and the name of the tty device for the slave side.
268  ;;;  ;;;
269    #-irix
270    (defun find-a-pty ()
271      _N"Returns the master fd, the slave fd, and the name of the tty"
272      (multiple-value-bind (error master-fd slave-fd)
273          (unix:unix-openpty nil nil nil)
274        (when (zerop error)
275          #-glibc2
276          (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
277            (let ((sap (alien:alien-sap stuff)))
278              (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
279              (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
280              (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
281              (unix:unix-ioctl master-fd unix:TIOCGETP sap)
282              (setf (alien:slot stuff 'unix:sg-flags)
283                    (logand (alien:slot stuff 'unix:sg-flags)
284                            (lognot 8)))    ; ~ECHO
285              (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
286          (return-from find-a-pty
287                       (values master-fd
288                               slave-fd
289                               (unix:unix-ttyname slave-fd))))
290        (error (intl:gettext "Could not find a pty."))))
291    
292    #+irix
293    (alien:def-alien-routine ("_getpty" c-getpty) c-call:c-string
294      (fildes c-call:int :out)
295      (oflag c-call:int)
296      (mode c-call:int)
297      (nofork c-call:int))
298    
299    #+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    (dolist (char '(#\p #\q))    (multiple-value-bind (line master-fd)
303      (dotimes (digit 16)      (c-getpty (logior unix:o_rdwr unix:o_ndelay) #o600 0)
304        (let* ((master-name (format nil "/dev/pty~C~X" char digit))      (let* ((slave-name line)
305               (master-fd (unix:unix-open master-name             (slave-fd (unix:unix-open slave-name unix:o_rdwr #o666)))
306                                          unix:o_rdwr        (when slave-fd
307                                          #o666)))          ; Maybe put a vhangup here?
308          (when master-fd          #-glibc2
309            (let* ((slave-name (format nil "/dev/tty~C~X" char digit))          (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
310                   (slave-fd (unix:unix-open slave-name            (let ((sap (alien:alien-sap stuff)))
311                                             unix:o_rdwr              (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
312                                             #o666)))              (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
313              (when slave-fd              (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
314                ; Maybe put a vhangup here?              (unix:unix-ioctl master-fd unix:TIOCGETP sap)
315                (alien:with-alien ((stuff (alien:struct unix:sgttyb)))              (setf (alien:slot stuff 'unix:sg-flags)
316                  (let ((sap (alien:alien-sap stuff)))                    (logand (alien:slot stuff 'unix:sg-flags)
317                    (unix:unix-ioctl slave-fd unix:TIOCGETP sap)                            (lognot 8))) ; ~ECHO
318                    (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP              (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
319                    (unix:unix-ioctl slave-fd unix:TIOCSETP sap)          (return-from find-a-pty
320                    (unix:unix-ioctl master-fd unix:TIOCGETP sap)                       (values master-fd
321                    (setf (alien:slot stuff 'unix:sg-flags)                               slave-fd
322                          (logand (alien:slot stuff 'unix:sg-flags)                               slave-name))))
323                                  (lognot 8))) ; ~ECHO      (unix:unix-close master-fd))
324                    (unix:unix-ioctl master-fd unix:TIOCSETP sap)))    (error (intl:gettext "Could not find a pty.")))
               (return-from find-a-pty  
                            (values master-fd  
                                    slave-fd  
                                    slave-name)))  
           (unix:unix-close master-fd))))))  
   (error "Could not find a pty."))  
325    
326  ;;; OPEN-PTY -- internal  ;;; OPEN-PTY -- internal
327  ;;;  ;;;
328  (defun open-pty (pty cookie)  (defun open-pty (pty cookie &optional (external-format :default))
329    (when pty    (when pty
330      (multiple-value-bind      (multiple-value-bind
331          (master slave name)          (master slave name)
# Line 327  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 (intl:gettext "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)))
342        (values name        (values name
343                (system:make-fd-stream master :input t :output t)))))                (system:make-fd-stream master :input t :output t
344                                         :external-format external-format)))))
345    
346    
347    (defmacro round-bytes-to-words (n)
348      `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
349    
350    (defun string-list-to-c-strvec (string-list)
351      ;;
352      ;; Make a pass over string-list to calculate the amount of memory
353      ;; needed to hold the strvec.
354      (let ((string-bytes 0)
355            ;; We need an extra for the null, and an extra 'cause exect clobbers
356            ;; argv[-1].
357            (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
358        (declare (fixnum string-bytes vec-bytes))
359        (dolist (s string-list)
360          (check-type s simple-string)
361          (incf string-bytes (round-bytes-to-words (1+ (length s)))))
362        ;;
363        ;; Now allocate the memory and fill it in.
364        (let* ((total-bytes (+ string-bytes vec-bytes))
365               (vec-sap (system:allocate-system-memory total-bytes))
366               (string-sap (sap+ vec-sap vec-bytes))
367               (i #-alpha 4 #+alpha 8))
368          (declare (type (and unsigned-byte fixnum) total-bytes i)
369                   (type system:system-area-pointer vec-sap string-sap))
370          (dolist (s string-list)
371            (declare (simple-string s))
372            (let ((n (length s)))
373              ;;
374              ;; Blast the string into place
375              #-unicode
376              (kernel:copy-to-system-area (the simple-string s)
377                                          (* vm:vector-data-offset vm:word-bits)
378                                          string-sap 0
379                                          (* (1+ n) vm:byte-bits))
380              #+unicode
381              (progn
382                ;; FIXME: Do we need to apply some kind of transformation
383                ;; to convert Lisp unicode strings to C strings?  Utf-8?
384                (dotimes (k n)
385                  (setf (sap-ref-8 string-sap k)
386                        (logand #xff (char-code (aref s k)))))
387                (setf (sap-ref-8 string-sap n) 0))
388              ;;
389              ;; Blast the pointer to the string into place
390              (setf (sap-ref-sap vec-sap i) string-sap)
391              (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
392              (incf i #-alpha 4 #+alpha 8)))
393          ;; Blast in last null pointer
394          (setf (sap-ref-sap vec-sap i) (int-sap 0))
395          (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
396    
397    
398    (defmacro with-c-strvec ((var str-list) &body body)
399      (let ((sap (gensym "SAP-"))
400            (size (gensym "SIZE-")))
401        `(multiple-value-bind
402             (,sap ,var ,size)
403             (string-list-to-c-strvec ,str-list)
404           (unwind-protect
405               (progn
406                 ,@body)
407             (system:deallocate-system-memory ,sap ,size)))))
408    
409    (alien:def-alien-routine spawn c-call:int
410      (program c-call:c-string)
411      (argv (* c-call:c-string))
412      (envp (* c-call:c-string))
413      (pty-name c-call:c-string)
414      (stdin c-call:int)
415      (stdout c-call:int)
416      (stderr c-call:int))
417    
 ;;; SETUP-CHILD -- internal  
 ;;;  
 ;;;   Execs the program after setting up the environment correctly. This  
 ;;; routine never returns under any condition.  
 ;;;  
 (defun setup-child (pfile args env stdin stdout stderr pty-name  
                           grab-tty before-execve)  
   (unwind-protect  
       (handler-bind ((error #'(lambda (condition)  
                                 (declare (ignore condition))  
                                 (unix:unix-exit 2))))  
         ;; Put us in our own pgrp.  
         (unix:unix-setpgrp 0 (unix:unix-getpid))  
         (when grab-tty  
           ;; Grab the controlling tty from our parent (doing this here  
           ;; as well as in process-wait avoids a race condition).  
           (setf (unix:tty-process-group) (unix:unix-getpid)))  
         ;; If we want a pty, set it up.  
         (when pty-name  
           (let ((old-tty (unix:unix-open "/dev/tty" unix:o_rdwr 0)))  
             (when old-tty  
               (unix:unix-ioctl old-tty unix:TIOCNOTTY nil)  
               (unix:unix-close old-tty)))  
           (let ((new-tty (unix:unix-open pty-name unix:o_rdwr 0)))  
             (when new-tty  
               (unix:unix-dup2 new-tty 0)  
               (unix:unix-dup2 new-tty 1)  
               (unix:unix-dup2 new-tty 2))))  
         ;; Setup the three standard descriptors.  
         (when stdin  
           (unix:unix-dup2 stdin 0))  
         (when stdout  
           (unix:unix-dup2 stdout 1))  
         (when stderr  
           (unix:unix-dup2 stderr 2))  
         ;; Arange for all the unused FD's to be closed.  
         (do ((fd (1- (unix:unix-getdtablesize))  
                  (1- fd)))  
             ((= fd 3))  
           (unix:unix-fcntl fd unix:f-setfd 1))  
         ;; Do the before-execve  
         (when before-execve  
           (funcall before-execve))  
         ;; Exec the program  
         (multiple-value-bind  
             (okay errno)  
             (unix:unix-execve pfile args env)  
           (declare (ignore okay))  
           ;; If the magic number if bogus, try just a shell script.  
           (when (eql errno unix:ENOEXEC)  
             (unix:unix-execve "/bin/sh" (cons pfile args) env))))  
     ;; If exec returns, we lose.  
     (unix:unix-exit 1)))  
418    
419  ;;; RUN-PROGRAM -- public  ;;; RUN-PROGRAM -- public
420  ;;;  ;;;
421  ;;;   RUN-PROGRAM uses fork and execve to run a different program. Strange  ;;;   RUN-PROGRAM uses fork and execve to run a different program. Strange
422  ;;; stuff happens to keep the unix state of the world coherent.  ;;; stuff happens to keep the unix state of the world coherent.
423  ;;;  ;;;
424  ;;; The child process needs to get it's input from somewhere, and send it's  ;;; The child process needs to get its input from somewhere, and send its
425  ;;; output (both standard and error) to somewhere. We have to do different  ;;; output (both standard and error) to somewhere. We have to do different
426  ;;; things depending on where these somewheres really are.  ;;; things depending on where these somewheres really are.
427  ;;;  ;;;
# Line 427  Line 455 
455  (defun run-program (program args  (defun run-program (program args
456                      &key (env *environment-list*) (wait t) pty input                      &key (env *environment-list*) (wait t) pty input
457                      if-input-does-not-exist output (if-output-exists :error)                      if-input-does-not-exist output (if-output-exists :error)
458                      (error :output) (if-error-exists :error)                      (error :output) (if-error-exists :error) status-hook
459                      (give-child-tty t)                      (external-format :default))
460                      status-hook    "RUN-PROGRAM creates a new process and runs the unix program in the
461                      before-execve)     file specified by the simple-string PROGRAM.  ARGS are the standard
   "Run-program creates a new process and runs the unix progam in the  
    file specified by the simple-string program.  Args are the standard  
462     arguments that can be passed to a Unix program, for no arguments     arguments that can be passed to a Unix program, for no arguments
463     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).
464    
465     Run program will either return NIL or a PROCESS structure.  See the CMU     RUN-PROGRAM will either return NIL or a PROCESS structure.  See the CMU
466     Common Lisp Users Manual for details about the PROCESS structure.     Common Lisp Users Manual for details about the PROCESS structure.
467    
468     The keyword arguments have the following meanings:     The keyword arguments have the following meanings:
# Line 444  Line 470 
470          An A-LIST mapping keyword environment variables to simple-string          An A-LIST mapping keyword environment variables to simple-string
471          values.          values.
472       :wait -       :wait -
473          If NIL, continue running Lisp until the program finishes.          If non-NIL (default), wait until the created process finishes.  If
474          Otherwise, wait until the created process finishes.          NIL, continue running Lisp until the program finishes.
         The actual value controls what happens if the process stops while being  
         waited for:  
            :UNTIL-STOPPED - return immediately.  
            :CONTINUING-WHEN-STOPPED - send it a SIGCONT and keep waiting.  
            :IGNORING-WHEN-STOPPED - let it stay stopped (and keep waiting).  
            T - signal an error.  
475       :pty -       :pty -
476          Either T, NIL, or a stream.  Unless NIL, the subprocess is established          Either T, NIL, or a stream.  Unless NIL, the subprocess is established
477          under a PTY.  If :pty is a stream, all output to this pty is sent to          under a PTY.  If :pty is a stream, all output to this pty is sent to
# Line 471  Line 491 
491             nil (default) - return nil from run-program.             nil (default) - return nil from run-program.
492       :output -       :output -
493          Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard          Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
494          input for the current process is inherited.  If NIL, /dev/null          output for the current process is inherited.  If NIL, /dev/null
495          is used.  If a pathname, the file so specified is used.  If a stream,          is used.  If a pathname, the file so specified is used.  If a stream,
496          all the output from the process is written to this stream. If          all the output from the process is written to this stream. If
497          :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can          :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
498          be read to get the output. Defaults to NIL.          be read to get the output. Defaults to NIL.
499       :if-output-exists (when :input is the name of a file) -       :if-output-exists (when :output is the name of a file) -
500          can be one of:          can be one of:
501             :error (default) - generates an error if the file already exists.             :error (default) - generates an error if the file already exists.
502             :supersede - output from the program supersedes the file.             :supersede - output from the program supersedes the file.
# Line 486  Line 506 
506          Same as :output and :if-output-exists, except that :error can also be          Same as :output and :if-output-exists, except that :error can also be
507          specified as :output in which case all error output is routed to the          specified as :output in which case all error output is routed to the
508          same place as normal output.          same place as normal output.
      :give-child-tty -  
         If T, the child is given control of the tty while it is being waited  
         for (meaning that any keyboard interrupts will go to the child  
         process and not the waiting lisp).  
509       :status-hook -       :status-hook -
510          This is a function the system calls whenever the status of the          This is a function the system calls whenever the status of the
511          process changes.  The function takes the process as an argument.          process changes.  The function takes the process as an argument.
512       :before-execve -       :external-format -
513          This is a function, without arguments, RUN-PROGRAM runs in the child          This is the external-format used for communication with the subprocess."
         process just before turning it into the specified program."  
514    
515    ;; Make sure the interrupt handler is installed.    ;; Make sure the interrupt handler is installed.
516    (system:enable-interrupt unix:sigchld #'sigchld-handler)    (system:enable-interrupt unix:sigchld #'sigchld-handler)
517    ;; Make sure all the args are okay.    ;; Make sure all the args are okay.
518    (unless (every #'simple-string-p args)    (unless (every #'simple-string-p args)
519      (error "All args to program must be simple strings -- ~S." args))      (error (intl:gettext "All args to program must be simple strings -- ~S.") args))
520    ;; Pre-pend the program to the argument list.    ;; Prepend the program to the argument list.
521    (push (namestring program) args)    (push (namestring program) args)
522    ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup    ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
523    ;; info.  Also, establish proc at this level so we can return it.    ;; info.  Also, establish proc at this level so we can return it.
524    (let (*close-on-error* *close-in-parent* *handlers-installed* proc)    (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
525      (unwind-protect      (unwind-protect
526          (let ((pfile (namestring (truename (merge-pathnames program "path:"))))          (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
527                (cookie (list 0)))                (cookie (list 0)))
528              (unless pfile
529                (error (intl:gettext "No such program: ~S") program))
530            (multiple-value-bind            (multiple-value-bind
531                (stdin input-stream)                (stdin input-stream)
532                (get-descriptor-for input cookie :direction :input                (get-descriptor-for input cookie :direction :input
533                                    :if-does-not-exist if-input-does-not-exist)                                    :if-does-not-exist if-input-does-not-exist
534                                      :external-format external-format)
535              (multiple-value-bind              (multiple-value-bind
536                  (stdout output-stream)                  (stdout output-stream)
537                  (get-descriptor-for output cookie :direction :output                  (get-descriptor-for output cookie :direction :output
538                                      :if-exists if-output-exists)                                      :if-does-not-exist :create
539                                        :if-exists if-output-exists
540                                        :external-format external-format)
541                (multiple-value-bind                (multiple-value-bind
542                    (stderr error-stream)                    (stderr error-stream)
543                    (if (eq error :output)                    (if (eq error :output)
544                        (values stdout output-stream)                        (values stdout output-stream)
545                        (get-descriptor-for error cookie :direction :output                        (get-descriptor-for error cookie :direction :output
546                                            :if-exists if-error-exists))                                            :if-does-not-exist :create
547                                              :if-exists if-error-exists
548                                              :external-format external-format))
549                  (multiple-value-bind (pty-name pty-stream)                  (multiple-value-bind (pty-name pty-stream)
550                                       (open-pty pty cookie)                                       (open-pty pty cookie external-format)
551                    ;; Make sure we are not notified about the child death before                    ;; Make sure we are not notified about the child death before
552                    ;; we have installed the process struct in *active-processes*                    ;; we have installed the process struct in *active-processes*
553                    (system:without-interrupts                    (system:without-interrupts
554                      (multiple-value-bind                      (with-c-strvec (argv args)
555                          (child-pid errno)                        (with-c-strvec
556                          (unix:unix-fork)                            (envp (mapcar #'(lambda (entry)
557                        (cond ((zerop child-pid)                                              (concatenate
558                               ;; We are the child. Note: setup-child NEVER returns                                               'string
559                               (setup-child pfile args env stdin stdout stderr                                               (symbol-name (car entry))
560                                            pty-name                                               "="
561                                            (and give-child-tty wait)                                               (cdr entry)))
562                                            before-execve))                                          env))
563                              ((minusp child-pid)                          (let ((child-pid
564                               ;; This should only happen if the bozo has too                                 (without-gcing
565                               ;; many running procs.                                  (spawn pfile argv envp pty-name
566                               (error "Could not fork child process: ~A"                                         stdin stdout stderr))))
567                                      (unix:get-unix-error-msg errno)))                            (when (< child-pid 0)
568                              (t                              (error (intl:gettext "Could not fork child process: ~A")
569                               ;; We are the parent.                                     (unix:get-unix-error-msg)))
570                               (setf proc                            (setf proc (make-process :pid child-pid
571                                     (make-process :pid child-pid                                                     :%status :running
572                                                   :%status :running                                                     :pty pty-stream
573                                                   :pty pty-stream                                                     :input input-stream
574                                                   :input input-stream                                                     :output output-stream
575                                                   :output output-stream                                                     :error error-stream
576                                                   :error error-stream                                                     :status-hook status-hook
577                                                   :give-child-tty give-child-tty                                                     :cookie cookie))
                                                  :status-hook status-hook  
                                                  :cookie cookie))  
578                               (push proc *active-processes*))))))))))                               (push proc *active-processes*))))))))))
579        (dolist (fd *close-in-parent*)        (dolist (fd *close-in-parent*)
580          (unix:unix-close fd))          (unix:unix-close fd))
# Line 564  Line 584 
584          (dolist (handler *handlers-installed*)          (dolist (handler *handlers-installed*)
585            (system:remove-fd-handler handler))))            (system:remove-fd-handler handler))))
586      (when (and wait proc)      (when (and wait proc)
587        (process-wait proc        (process-wait proc))
                     (case wait  
                       ;; decide what to do when the process stops  
                       (:until-stopped :return)  
                       (:continuing-when-stopped :continue)  
                       (:ignoring-when-stopped nil)  
                       (t :error))))  
588      proc))      proc))
589    
590  ;;; COPY-DESCRIPTOR-TO-STREAM -- internal  ;;; COPY-DESCRIPTOR-TO-STREAM -- internal
# Line 594  Line 608 
608                        (unix:unix-select (1+ descriptor) (ash 1 descriptor)                        (unix:unix-select (1+ descriptor) (ash 1 descriptor)
609                                          0 0 0)                                          0 0 0)
610                      (cond ((null result)                      (cond ((null result)
611                             (error "Could not select on sub-process: ~A"                             (error (intl:gettext "Could not select on sub-process: ~A")
612                                    (unix:get-unix-error-msg readable/errno)))                                    (unix:get-unix-error-msg readable/errno)))
613                            ((zerop result)                            ((zerop result)
614                             (return))))                             (return))))
# Line 614  Line 628 
628                               (system:remove-fd-handler handler)                               (system:remove-fd-handler handler)
629                               (setf handler nil)                               (setf handler nil)
630                               (decf (car cookie))                               (decf (car cookie))
631                               (error "Could not read input from sub-process: ~A"                               (error (intl:gettext "Could not read input from sub-process: ~A")
632                                      (unix:get-unix-error-msg errno)))                                      (unix:get-unix-error-msg errno)))
633                              (t                              (t
634                                 #-unicode
635                               (kernel:copy-from-system-area                               (kernel:copy-from-system-area
636                                (alien-sap buf) 0                                (alien-sap buf) 0
637                                string (* vm:vector-data-offset vm:word-bits)                                string (* vm:vector-data-offset vm:word-bits)
638                                (* count vm:byte-bits))                                (* count vm:byte-bits))
639                                 #+unicode
640                                 (let ((sap (alien-sap buf)))
641                                   (dotimes (k count)
642                                     (setf (aref string k)
643                                           (code-char (sap-ref-8 sap k)))))
644                               (write-string string stream                               (write-string string stream
645                                             :end count)))))))))))                                             :end count)))))))))))
646    
# Line 631  Line 651 
651  ;;; second value.  ;;; second value.
652  ;;;  ;;;
653  (defun get-descriptor-for (object cookie &rest keys &key direction  (defun get-descriptor-for (object cookie &rest keys &key direction
654                                                             external-format
655                                    &allow-other-keys)                                    &allow-other-keys)
656    (cond ((eq object t)    (cond ((eq object t)
657           ;; No new descriptor is needed.           ;; No new descriptor is needed.
658           (values nil nil))           (values -1 nil))
659          ((eq object nil)          ((eq object nil)
660           ;; Use /dev/null.           ;; Use /dev/null.
661           (multiple-value-bind           (multiple-value-bind
# Line 646  Line 667 
667                                 (t unix:o_rdwr))                                 (t unix:o_rdwr))
668                               #o666)                               #o666)
669             (unless fd             (unless fd
670               (error "Could not open \"/dev/null\": ~A"               (error (intl:gettext "Could not open \"/dev/null\": ~A")
671                      (unix:get-unix-error-msg errno)))                      (unix:get-unix-error-msg errno)))
672             (push fd *close-in-parent*)             (push fd *close-in-parent*)
673             (values fd nil)))             (values fd nil)))
# Line 655  Line 676 
676               (read-fd write-fd)               (read-fd write-fd)
677               (unix:unix-pipe)               (unix:unix-pipe)
678             (unless read-fd             (unless read-fd
679               (error "Could not create pipe: ~A"               (error (intl:gettext "Could not create pipe: ~A")
680                      (unix:get-unix-error-msg write-fd)))                      (unix:get-unix-error-msg write-fd)))
681             (case direction             (case direction
682               (:input               (:input
683                (push read-fd *close-in-parent*)                (push read-fd *close-in-parent*)
684                (push write-fd *close-on-error*)                (push write-fd *close-on-error*)
685                (let ((stream (system:make-fd-stream write-fd :output t)))                (let ((stream (system:make-fd-stream write-fd :output t
686                                                       :external-format
687                                                       external-format)))
688                  (values read-fd stream)))                  (values read-fd stream)))
689               (:output               (:output
690                (push read-fd *close-on-error*)                (push read-fd *close-on-error*)
691                (push write-fd *close-in-parent*)                (push write-fd *close-in-parent*)
692                (let ((stream (system:make-fd-stream read-fd :input t)))                (let ((stream (system:make-fd-stream read-fd :input t
693                                                       :external-format
694                                                       external-format)))
695                  (values write-fd stream)))                  (values write-fd stream)))
696               (t               (t
697                (unix:unix-close read-fd)                (unix:unix-close read-fd)
698                (unix:unix-close write-fd)                (unix:unix-close write-fd)
699                (error "Direction must be either :INPUT or :OUTPUT, not ~S"                (error (intl:gettext "Direction must be either :INPUT or :OUTPUT, not ~S")
700                       direction)))))                       direction)))))
701          ((or (pathnamep object) (stringp object))          ((or (pathnamep object) (stringp object))
702           (with-open-stream (file (apply #'open object keys))           (with-open-stream (file (apply #'open object keys))
# Line 682  Line 707 
707                      (push fd *close-in-parent*)                      (push fd *close-in-parent*)
708                      (values fd nil))                      (values fd nil))
709                     (t                     (t
710                      (error "Could not duplicate file descriptor: ~A"                      (error (intl:gettext "Could not duplicate file descriptor: ~A")
711                             (unix:get-unix-error-msg errno)))))))                             (unix:get-unix-error-msg errno)))))))
712          ((system:fd-stream-p object)          ((system:fd-stream-p object)
713           (values (system:fd-stream-fd object) nil))           (values (system:fd-stream-fd object) nil))
# Line 691  Line 716 
716             (:input             (:input
717              (dotimes (count              (dotimes (count
718                        256                        256
719                        (error "Could not open a temporary file in /tmp"))                        (error (intl:gettext "Could not open a temporary file in /tmp")))
720                (let* ((name (format nil "/tmp/.run-program-~D" count))                (let* ((name (format nil "/tmp/.run-program-~D" count))
721                       (fd (unix:unix-open name                       (fd (unix:unix-open name
722                                           (logior unix:o_rdwr                                           (logior unix:o_rdwr
# Line 718  Line 743 
743              (multiple-value-bind (read-fd write-fd)              (multiple-value-bind (read-fd write-fd)
744                                   (unix:unix-pipe)                                   (unix:unix-pipe)
745                (unless read-fd                (unless read-fd
746                  (error "Cound not create pipe: ~A"                  (error (intl:gettext "Cound not create pipe: ~A")
747                         (unix:get-unix-error-msg write-fd)))                         (unix:get-unix-error-msg write-fd)))
748                (copy-descriptor-to-stream read-fd object cookie)                (copy-descriptor-to-stream read-fd object cookie)
749                (push read-fd *close-on-error*)                (push read-fd *close-on-error*)
750                (push write-fd *close-in-parent*)                (push write-fd *close-in-parent*)
751                (values write-fd nil)))))                (values write-fd nil)))))
752          (t          (t
753           (error "Invalid option to run-program: ~S" object))))           (error (intl:gettext "Invalid option to run-program: ~S") object))))
754    

Legend:
Removed from v.1.11.2.1  
changed lines
  Added in v.1.32

  ViewVC Help
Powered by ViewVC 1.1.5