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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (hide annotations)
Mon Apr 19 02:18:04 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
Changes since 1.29: +12 -12 lines
Remove _N"" reader macro from docstrings when possible.
1 ram 1.1 ;;; -*- Package: Extensions; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; 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.
6     ;;;
7     (ext:file-comment
8 rtoy 1.30 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/run-program.lisp,v 1.30 2010/04/19 02:18:04 rtoy Exp $")
9 ram 1.3 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12 wlott 1.4 ;;; RUN-PROGRAM and friends. Facility for running unix programs from inside
13 ram 1.1 ;;; a lisp.
14     ;;;
15     ;;; Written by Jim Healy and Bill Chiles, November 1987, using an earlier
16     ;;; version written by David McDonald.
17     ;;;
18     ;;; Completely re-written by William Lott, July 1989 - January 1990.
19     ;;;
20    
21     (in-package "EXTENSIONS")
22 rtoy 1.29 (intl:textdomain "cmucl")
23 ram 1.1
24     (export '(run-program process-status process-exit-code process-core-dumped
25     process-wait process-kill process-input process-output process-plist
26     process-pty process-error process-status-hook process-alive-p
27     process-close process-pid process-p))
28    
29    
30     ;;;; Import WAIT3 from unix.
31    
32 wlott 1.8 (alien:def-alien-routine ("wait3" c-wait3) c-call:int
33     (status c-call:int :out)
34     (options c-call:int)
35     (rusage c-call:int))
36 ram 1.1
37     (eval-when (load eval compile)
38 ram 1.17 (defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
39     (defconstant wait-wuntraced #-svr4 2 #+svr4 4)
40     (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced))
41 ram 1.1
42     (defun wait3 (&optional do-not-hang check-for-stopped)
43 rtoy 1.30 "Return any available status information on child processed. "
44 ram 1.1 (multiple-value-bind (pid status)
45     (c-wait3 (logior (if do-not-hang
46     wait-wnohang
47     0)
48     (if check-for-stopped
49     wait-wuntraced
50     0))
51     0)
52     (cond ((or (minusp pid)
53     (zerop pid))
54     nil)
55     ((eql (ldb (byte 8 0) status)
56     wait-wstopped)
57     (values pid
58     :stopped
59     (ldb (byte 8 8) status)))
60     ((zerop (ldb (byte 7 0) status))
61     (values pid
62     :exited
63     (ldb (byte 8 8) status)))
64     (t
65     (let ((signal (ldb (byte 7 0) status)))
66     (values pid
67 wlott 1.8 (if (or (eql signal unix:sigstop)
68     (eql signal unix:sigtstp)
69     (eql signal unix:sigttin)
70     (eql signal unix:sigttou))
71 ram 1.1 :stopped
72     :signaled)
73     signal
74     (not (zerop (ldb (byte 1 7) status)))))))))
75    
76    
77    
78     ;;;; Process control stuff.
79    
80     (defvar *active-processes* nil
81 rtoy 1.30 "List of process structures for all active processes.")
82 ram 1.1
83     (defstruct (process (:print-function %print-process))
84 wlott 1.4 pid ; PID of child process.
85     %status ; Either :RUNNING, :STOPPED, :EXITED, or :SIGNALED.
86     exit-code ; Either exit code or signal
87     core-dumped ; T if a core image was dumped.
88     pty ; Stream to child's pty or nil.
89     input ; Stream to child's input or nil.
90     output ; Stream from child's output or nil.
91     error ; Stream from child's error output or nil.
92     status-hook ; Closure to call when PROC changes status.
93     plist ; Place for clients to stash tings.
94     cookie ; List of the number of pipes from the subproc.
95 ram 1.1 )
96    
97     (defun %print-process (proc stream depth)
98     (declare (ignore depth))
99     (format stream "#<process ~D ~S>"
100     (process-pid proc)
101     (process-status proc)))
102    
103     ;;; PROCESS-STATUS -- Public.
104     ;;;
105     (defun process-status (proc)
106 rtoy 1.30 "Return the current status of process. The result is one of :running,
107 ram 1.1 :stopped, :exited, :signaled."
108 pw 1.25 (declare (type process proc))
109 ram 1.1 (get-processes-status-changes)
110     (process-%status proc))
111    
112    
113     ;;; PROCESS-WAIT -- Public.
114     ;;;
115     (defun process-wait (proc &optional check-for-stopped)
116 rtoy 1.30 "Wait for PROC to quit running for some reason. Returns PROC."
117 pw 1.25 (declare (type process proc))
118 ram 1.1 (loop
119 wlott 1.4 (case (process-status proc)
120     (:running)
121     (:stopped
122     (when check-for-stopped
123     (return)))
124     (t
125     (when (zerop (car (process-cookie proc)))
126     (return))))
127 ram 1.1 (system:serve-all-events 1))
128     proc)
129    
130 wlott 1.4
131 ram 1.19 #-hpux
132 ram 1.1 ;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal
133     ;;;
134     ;;; Finds the current foreground process group id.
135     ;;;
136     (defun find-current-foreground-process (proc)
137 wlott 1.8 (alien:with-alien ((result c-call:int))
138 ram 1.1 (multiple-value-bind
139     (wonp error)
140 wlott 1.8 (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
141     unix:TIOCGPGRP
142     (alien:alien-sap (alien:addr result)))
143 ram 1.1 (unless wonp
144 rtoy 1.29 (error _"TIOCPGRP ioctl failed: ~S"
145 wlott 1.8 (unix:get-unix-error-msg error)))
146 ram 1.19 result))
147     (process-pid proc))
148    
149 ram 1.1
150     ;;; PROCESS-KILL -- public
151     ;;;
152     ;;; Hand a process a signal.
153     ;;;
154     (defun process-kill (proc signal &optional (whom :pid))
155 rtoy 1.30 "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If
156 ram 1.19 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
158     in the foreground."
159 pw 1.24 (declare (type process proc))
160 ram 1.1 (let ((pid (ecase whom
161     ((:pid :process-group)
162     (process-pid proc))
163     (:pty-process-group
164 ram 1.19 #-hpux
165 ram 1.1 (find-current-foreground-process proc)))))
166 ram 1.19 (multiple-value-bind
167     (okay errno)
168     (case whom
169 pw 1.21 #+hpux
170     (:pty-process-group
171 ram 1.19 (unix:unix-ioctl (system:fd-stream-fd (process-pty proc))
172     unix:TIOCSIGSEND
173     (system:int-sap
174 ram 1.20 (unix:unix-signal-number signal))))
175     ((:process-group #-hpux :pty-process-group)
176 ram 1.19 (unix:unix-killpg pid signal))
177     (t
178     (unix:unix-kill pid signal)))
179 ram 1.1 (cond ((not okay)
180     (values nil errno))
181     ((and (eql pid (process-pid proc))
182 wlott 1.9 (= (unix:unix-signal-number signal) unix:sigcont))
183 ram 1.1 (setf (process-%status proc) :running)
184     (setf (process-exit-code proc) nil)
185     (when (process-status-hook proc)
186     (funcall (process-status-hook proc) proc))
187     t)
188     (t
189     t)))))
190 ram 1.19
191 ram 1.1
192     ;;; PROCESS-ALIVE-P -- public
193     ;;;
194     ;;; Returns T if the process is still alive, NIL otherwise.
195     ;;;
196     (defun process-alive-p (proc)
197 rtoy 1.30 "Returns T if the process is still alive, NIL otherwise."
198 pw 1.25 (declare (type process proc))
199 ram 1.1 (let ((status (process-status proc)))
200     (if (or (eq status :running)
201     (eq status :stopped))
202     t
203     nil)))
204    
205     ;;; PROCESS-CLOSE -- public
206     ;;;
207     ;;; Close all the streams held open by PROC.
208     ;;;
209     (defun process-close (proc)
210 rtoy 1.30 "Close all streams connected to PROC and stop maintaining the status slot."
211 pw 1.25 (declare (type process proc))
212 pw 1.22 (macrolet ((frob (stream abort)
213     `(when ,stream (close ,stream :abort ,abort))))
214     (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process.
215     (frob (process-input proc) t) ; 'cause it will generate SIGPIPE.
216     (frob (process-output proc) nil)
217     (frob (process-error proc) nil))
218     (system:without-interrupts
219     (setf *active-processes* (delete proc *active-processes*)))
220     proc)
221 ram 1.1
222     ;;; SIGCHLD-HANDLER -- Internal.
223     ;;;
224 wlott 1.2 ;;; This is the handler for sigchld signals that RUN-PROGRAM establishes.
225 ram 1.1 ;;;
226     (defun sigchld-handler (ignore1 ignore2 ignore3)
227     (declare (ignore ignore1 ignore2 ignore3))
228     (get-processes-status-changes))
229    
230     ;;; GET-PROCESSES-STATUS-CHANGES -- Internal.
231     ;;;
232     (defun get-processes-status-changes ()
233     (loop
234     (multiple-value-bind (pid what code core)
235     (wait3 t t)
236     (unless pid
237     (return))
238     (let ((proc (find pid *active-processes* :key #'process-pid)))
239     (when proc
240     (setf (process-%status proc) what)
241     (setf (process-exit-code proc) code)
242     (setf (process-core-dumped proc) core)
243     (when (process-status-hook proc)
244     (funcall (process-status-hook proc) proc))
245     (when (or (eq what :exited)
246     (eq what :signaled))
247     (system:without-interrupts
248     (setf *active-processes*
249     (delete proc *active-processes*)))))))))
250    
251    
252    
253     ;;;; RUN-PROGRAM and close friends.
254    
255     (defvar *close-on-error* nil
256 rtoy 1.30 "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
257 ram 1.1 (defvar *close-in-parent* nil
258 rtoy 1.30 "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
259 ram 1.1 (defvar *handlers-installed* nil
260 rtoy 1.30 "List of handlers installed by RUN-PROGRAM.")
261 ram 1.1
262    
263     ;;; FIND-A-PTY -- internal
264     ;;;
265     ;;; Finds a pty that is not in use. Returns three values: the file descriptor
266     ;;; 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.
268     ;;;
269 hallgren 1.16 #-irix
270 ram 1.1 (defun find-a-pty ()
271 rtoy 1.29 _N"Returns the master fd, the slave fd, and the name of the tty"
272 cshapiro 1.27 (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 rtoy 1.29 (error _"Could not find a pty.")))
291 hallgren 1.16
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 ()
301 rtoy 1.29 _N"Returns the master fd, the slave fd, and the name of the tty"
302 hallgren 1.16 (multiple-value-bind (line master-fd)
303     (c-getpty (logior unix:o_rdwr unix:o_ndelay) #o600 0)
304     (let* ((slave-name line)
305     (slave-fd (unix:unix-open slave-name unix:o_rdwr #o666)))
306     (when slave-fd
307     ; Maybe put a vhangup here?
308 dtc 1.23 #-glibc2
309 hallgren 1.16 (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
310     (let ((sap (alien:alien-sap stuff)))
311     (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
312     (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
313     (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
314     (unix:unix-ioctl master-fd unix:TIOCGETP sap)
315     (setf (alien:slot stuff 'unix:sg-flags)
316     (logand (alien:slot stuff 'unix:sg-flags)
317     (lognot 8))) ; ~ECHO
318     (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
319     (return-from find-a-pty
320     (values master-fd
321     slave-fd
322     slave-name))))
323     (unix:unix-close master-fd))
324 rtoy 1.29 (error _"Could not find a pty."))
325 ram 1.1
326     ;;; OPEN-PTY -- internal
327     ;;;
328 wlott 1.4 (defun open-pty (pty cookie)
329 ram 1.1 (when pty
330     (multiple-value-bind
331     (master slave name)
332     (find-a-pty)
333     (push master *close-on-error*)
334     (push slave *close-in-parent*)
335     (when (streamp pty)
336 wlott 1.11 (multiple-value-bind (new-fd errno) (unix:unix-dup master)
337     (unless new-fd
338 rtoy 1.29 (error _"Could not UNIX:UNIX-DUP ~D: ~A"
339 wlott 1.11 master (unix:get-unix-error-msg errno)))
340 ram 1.1 (push new-fd *close-on-error*)
341 wlott 1.4 (copy-descriptor-to-stream new-fd pty cookie)))
342 ram 1.1 (values name
343     (system:make-fd-stream master :input t :output t)))))
344    
345    
346 wlott 1.13 (defmacro round-bytes-to-words (n)
347     `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
348    
349     (defun string-list-to-c-strvec (string-list)
350     ;;
351     ;; Make a pass over string-list to calculate the amount of memory
352     ;; needed to hold the strvec.
353     (let ((string-bytes 0)
354     ;; We need an extra for the null, and an extra 'cause exect clobbers
355     ;; argv[-1].
356 hallgren 1.15 (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
357 wlott 1.13 (declare (fixnum string-bytes vec-bytes))
358     (dolist (s string-list)
359     (check-type s simple-string)
360     (incf string-bytes (round-bytes-to-words (1+ (length s)))))
361     ;;
362     ;; Now allocate the memory and fill it in.
363     (let* ((total-bytes (+ string-bytes vec-bytes))
364     (vec-sap (system:allocate-system-memory total-bytes))
365     (string-sap (sap+ vec-sap vec-bytes))
366 hallgren 1.15 (i #-alpha 4 #+alpha 8))
367 wlott 1.13 (declare (type (and unsigned-byte fixnum) total-bytes i)
368     (type system:system-area-pointer vec-sap string-sap))
369     (dolist (s string-list)
370     (declare (simple-string s))
371     (let ((n (length s)))
372     ;;
373     ;; Blast the string into place
374 rtoy 1.28 #-unicode
375 wlott 1.13 (kernel:copy-to-system-area (the simple-string s)
376     (* vm:vector-data-offset vm:word-bits)
377     string-sap 0
378     (* (1+ n) vm:byte-bits))
379 rtoy 1.28 #+unicode
380     (progn
381     ;; FIXME: Do we need to apply some kind of transformation
382     ;; to convert Lisp unicode strings to C strings? Utf-8?
383     (dotimes (k n)
384     (setf (sap-ref-8 string-sap k)
385     (logand #xff (char-code (aref s k)))))
386     (setf (sap-ref-8 string-sap n) 0))
387 wlott 1.13 ;;
388     ;; Blast the pointer to the string into place
389     (setf (sap-ref-sap vec-sap i) string-sap)
390     (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
391 hallgren 1.15 (incf i #-alpha 4 #+alpha 8)))
392 wlott 1.13 ;; Blast in last null pointer
393     (setf (sap-ref-sap vec-sap i) (int-sap 0))
394 hallgren 1.15 (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
395 wlott 1.13
396    
397     (defmacro with-c-strvec ((var str-list) &body body)
398     (let ((sap (gensym "SAP-"))
399     (size (gensym "SIZE-")))
400     `(multiple-value-bind
401     (,sap ,var ,size)
402     (string-list-to-c-strvec ,str-list)
403     (unwind-protect
404     (progn
405     ,@body)
406     (system:deallocate-system-memory ,sap ,size)))))
407    
408     (alien:def-alien-routine spawn c-call:int
409     (program c-call:c-string)
410     (argv (* c-call:c-string))
411     (envp (* c-call:c-string))
412     (pty-name c-call:c-string)
413     (stdin c-call:int)
414     (stdout c-call:int)
415     (stderr c-call:int))
416    
417    
418 ram 1.1 ;;; RUN-PROGRAM -- public
419     ;;;
420 wlott 1.2 ;;; RUN-PROGRAM uses fork and execve to run a different program. Strange
421     ;;; stuff happens to keep the unix state of the world coherent.
422 ram 1.1 ;;;
423 emarsden 1.26 ;;; The child process needs to get its input from somewhere, and send its
424 ram 1.1 ;;; output (both standard and error) to somewhere. We have to do different
425     ;;; things depending on where these somewheres really are.
426     ;;;
427     ;;; For input, there are five options:
428     ;;; - T: Just leave fd 0 alone. Pretty simple.
429     ;;; - "file": Read from the file. We need to open the file and pull the
430     ;;; descriptor out of the stream. The parent should close this stream after
431     ;;; the child is up and running to free any storage used in the parent.
432     ;;; - NIL: Same as "file", but use "/dev/null" as the file.
433     ;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream
434     ;;; to create the output stream on the writeable descriptor, and pass the
435     ;;; readable descriptor to the child. The parent must close the readable
436     ;;; descriptor for EOF to be passed up correctly.
437     ;;; - a stream: If it's a fd-stream, just pull the descriptor out of it.
438     ;;; Otherwise make a pipe as in :STREAM, and copy everything across.
439     ;;;
440     ;;; For output, there are n options:
441     ;;; - T: Leave descriptor 1 alone.
442     ;;; - "file": dump output to the file.
443     ;;; - NIL: dump output to /dev/null.
444     ;;; - :STREAM: return a stream that can be read from.
445     ;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy
446     ;;; stuff from output to stream.
447     ;;;
448     ;;; For error, there are all the same options as output plus:
449     ;;; - :OUTPUT: redirect to the same place as output.
450     ;;;
451     ;;; RUN-PROGRAM returns a process struct for the process if the fork worked,
452     ;;; and NIL if it did not.
453     ;;;
454     (defun run-program (program args
455     &key (env *environment-list*) (wait t) pty input
456     if-input-does-not-exist output (if-output-exists :error)
457 wlott 1.13 (error :output) (if-error-exists :error) status-hook)
458 rtoy 1.30 "RUN-PROGRAM creates a new process and runs the unix program in the
459 emarsden 1.26 file specified by the simple-string PROGRAM. ARGS are the standard
460 ram 1.1 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).
462    
463 emarsden 1.26 RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
464 ram 1.1 Common Lisp Users Manual for details about the PROCESS structure.
465    
466     The keyword arguments have the following meanings:
467     :env -
468     An A-LIST mapping keyword environment variables to simple-string
469     values.
470     :wait -
471     If non-NIL (default), wait until the created process finishes. If
472     NIL, continue running Lisp until the program finishes.
473     :pty -
474     Either T, NIL, or a stream. Unless NIL, the subprocess is established
475     under a PTY. If :pty is a stream, all output to this pty is sent to
476     this stream, otherwise the PROCESS-PTY slot is filled in with a stream
477     connected to pty that can read output and write input.
478     :input -
479     Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
480     input for the current process is inherited. If NIL, /dev/null
481 wlott 1.4 is used. If a pathname, the file so specified is used. If a stream,
482 ram 1.1 all the input is read from that stream and send to the subprocess. If
483     :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
484     its output to the process. Defaults to NIL.
485     :if-input-does-not-exist (when :input is the name of a file) -
486     can be one of:
487     :error - generate an error.
488     :create - create an empty file.
489     nil (default) - return nil from run-program.
490     :output -
491     Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
492 wlott 1.13 output for the current process is inherited. If NIL, /dev/null
493 wlott 1.4 is used. If a pathname, the file so specified is used. If a stream,
494 ram 1.1 all the output from the process is written to this stream. If
495     :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
496     be read to get the output. Defaults to NIL.
497 emarsden 1.26 :if-output-exists (when :output is the name of a file) -
498 ram 1.1 can be one of:
499     :error (default) - generates an error if the file already exists.
500     :supersede - output from the program supersedes the file.
501     :append - output from the program is appended to the file.
502     nil - run-program returns nil without doing anything.
503     :error and :if-error-exists -
504     Same as :output and :if-output-exists, except that :error can also be
505 wlott 1.4 specified as :output in which case all error output is routed to the
506 ram 1.1 same place as normal output.
507     :status-hook -
508     This is a function the system calls whenever the status of the
509 wlott 1.13 process changes. The function takes the process as an argument."
510 ram 1.1
511     ;; Make sure the interrupt handler is installed.
512 wlott 1.8 (system:enable-interrupt unix:sigchld #'sigchld-handler)
513 ram 1.1 ;; Make sure all the args are okay.
514     (unless (every #'simple-string-p args)
515 rtoy 1.29 (error _"All args to program must be simple strings -- ~S." args))
516 ram 1.1 ;; Pre-pend the program to the argument list.
517     (push (namestring program) args)
518     ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
519     ;; info. Also, establish proc at this level so we can return it.
520     (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
521     (unwind-protect
522 wlott 1.14 (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
523 wlott 1.4 (cookie (list 0)))
524 wlott 1.14 (unless pfile
525 rtoy 1.29 (error _"No such program: ~S" program))
526 ram 1.1 (multiple-value-bind
527     (stdin input-stream)
528 wlott 1.4 (get-descriptor-for input cookie :direction :input
529 ram 1.1 :if-does-not-exist if-input-does-not-exist)
530     (multiple-value-bind
531     (stdout output-stream)
532 wlott 1.4 (get-descriptor-for output cookie :direction :output
533 emarsden 1.26 :if-does-not-exist :create
534 ram 1.1 :if-exists if-output-exists)
535     (multiple-value-bind
536     (stderr error-stream)
537     (if (eq error :output)
538     (values stdout output-stream)
539 wlott 1.4 (get-descriptor-for error cookie :direction :output
540 emarsden 1.26 :if-does-not-exist :create
541 ram 1.1 :if-exists if-error-exists))
542     (multiple-value-bind (pty-name pty-stream)
543 wlott 1.4 (open-pty pty cookie)
544 ram 1.1 ;; Make sure we are not notified about the child death before
545     ;; we have installed the process struct in *active-processes*
546     (system:without-interrupts
547 wlott 1.13 (with-c-strvec (argv args)
548     (with-c-strvec
549     (envp (mapcar #'(lambda (entry)
550     (concatenate
551     'string
552     (symbol-name (car entry))
553     "="
554     (cdr entry)))
555     env))
556     (let ((child-pid
557     (without-gcing
558     (spawn pfile argv envp pty-name
559     stdin stdout stderr))))
560     (when (< child-pid 0)
561 rtoy 1.29 (error _"Could not fork child process: ~A"
562 wlott 1.13 (unix:get-unix-error-msg)))
563     (setf proc (make-process :pid child-pid
564     :%status :running
565     :pty pty-stream
566     :input input-stream
567     :output output-stream
568     :error error-stream
569     :status-hook status-hook
570     :cookie cookie))
571 ram 1.1 (push proc *active-processes*))))))))))
572     (dolist (fd *close-in-parent*)
573 wlott 1.8 (unix:unix-close fd))
574 ram 1.1 (unless proc
575     (dolist (fd *close-on-error*)
576 wlott 1.8 (unix:unix-close fd))
577 ram 1.1 (dolist (handler *handlers-installed*)
578     (system:remove-fd-handler handler))))
579     (when (and wait proc)
580     (process-wait proc))
581     proc))
582    
583     ;;; COPY-DESCRIPTOR-TO-STREAM -- internal
584     ;;;
585     ;;; Installs a handler for any input that shows up on the file descriptor.
586     ;;; The handler reads the data and writes it to the stream.
587     ;;;
588 wlott 1.4 (defun copy-descriptor-to-stream (descriptor stream cookie)
589     (incf (car cookie))
590 ram 1.1 (let ((string (make-string 256))
591     handler)
592     (setf handler
593     (system:add-fd-handler descriptor :input
594     #'(lambda (fd)
595     (declare (ignore fd))
596     (loop
597 wlott 1.5 (unless handler
598     (return))
599 ram 1.1 (multiple-value-bind
600     (result readable/errno)
601 wlott 1.8 (unix:unix-select (1+ descriptor) (ash 1 descriptor)
602 ram 1.1 0 0 0)
603     (cond ((null result)
604 rtoy 1.29 (error _"Could not select on sub-process: ~A"
605 wlott 1.8 (unix:get-unix-error-msg readable/errno)))
606 ram 1.1 ((zerop result)
607     (return))))
608 wlott 1.10 (alien:with-alien ((buf (alien:array c-call:char 256)))
609     (multiple-value-bind
610     (count errno)
611     (unix:unix-read descriptor (alien-sap buf) 256)
612     (cond ((or (and (null count)
613     (eql errno unix:eio))
614     (eql count 0))
615     (system:remove-fd-handler handler)
616     (setf handler nil)
617     (decf (car cookie))
618     (unix:unix-close descriptor)
619     (return))
620     ((null count)
621     (system:remove-fd-handler handler)
622     (setf handler nil)
623     (decf (car cookie))
624 rtoy 1.29 (error _"Could not read input from sub-process: ~A"
625 wlott 1.10 (unix:get-unix-error-msg errno)))
626     (t
627 rtoy 1.28 #-unicode
628 wlott 1.10 (kernel:copy-from-system-area
629     (alien-sap buf) 0
630     string (* vm:vector-data-offset vm:word-bits)
631     (* count vm:byte-bits))
632 rtoy 1.28 #+unicode
633     (let ((sap (alien-sap buf)))
634     (dotimes (k count)
635     (setf (aref string k)
636     (code-char (sap-ref-8 sap k)))))
637 wlott 1.10 (write-string string stream
638     :end count)))))))))))
639 ram 1.1
640     ;;; GET-DESCRIPTOR-FOR -- internal
641     ;;;
642     ;;; Find a file descriptor to use for object given the direction. Returns
643     ;;; the descriptor. If object is :STREAM, returns the created stream as the
644     ;;; second value.
645     ;;;
646 wlott 1.4 (defun get-descriptor-for (object cookie &rest keys &key direction
647     &allow-other-keys)
648 ram 1.1 (cond ((eq object t)
649     ;; No new descriptor is needed.
650 wlott 1.13 (values -1 nil))
651 ram 1.1 ((eq object nil)
652     ;; Use /dev/null.
653     (multiple-value-bind
654     (fd errno)
655 wlott 1.8 (unix:unix-open "/dev/null"
656 ram 1.1 (case direction
657 wlott 1.8 (:input unix:o_rdonly)
658     (:output unix:o_wronly)
659     (t unix:o_rdwr))
660 ram 1.1 #o666)
661     (unless fd
662 rtoy 1.29 (error _"Could not open \"/dev/null\": ~A"
663 wlott 1.8 (unix:get-unix-error-msg errno)))
664 ram 1.1 (push fd *close-in-parent*)
665     (values fd nil)))
666     ((eq object :stream)
667     (multiple-value-bind
668     (read-fd write-fd)
669 wlott 1.8 (unix:unix-pipe)
670 ram 1.1 (unless read-fd
671 rtoy 1.29 (error _"Could not create pipe: ~A"
672 wlott 1.8 (unix:get-unix-error-msg write-fd)))
673 ram 1.1 (case direction
674     (:input
675     (push read-fd *close-in-parent*)
676     (push write-fd *close-on-error*)
677     (let ((stream (system:make-fd-stream write-fd :output t)))
678     (values read-fd stream)))
679     (:output
680     (push read-fd *close-on-error*)
681     (push write-fd *close-in-parent*)
682     (let ((stream (system:make-fd-stream read-fd :input t)))
683     (values write-fd stream)))
684     (t
685 wlott 1.8 (unix:unix-close read-fd)
686     (unix:unix-close write-fd)
687 rtoy 1.29 (error _"Direction must be either :INPUT or :OUTPUT, not ~S"
688 ram 1.1 direction)))))
689 wlott 1.4 ((or (pathnamep object) (stringp object))
690 ram 1.1 (with-open-stream (file (apply #'open object keys))
691 wlott 1.11 (multiple-value-bind
692     (fd errno)
693     (unix:unix-dup (system:fd-stream-fd file))
694     (cond (fd
695 ram 1.1 (push fd *close-in-parent*)
696     (values fd nil))
697     (t
698 rtoy 1.29 (error _"Could not duplicate file descriptor: ~A"
699 wlott 1.11 (unix:get-unix-error-msg errno)))))))
700 ram 1.1 ((system:fd-stream-p object)
701     (values (system:fd-stream-fd object) nil))
702     ((streamp object)
703     (ecase direction
704     (:input
705     (dotimes (count
706     256
707 rtoy 1.29 (error _"Could not open a temporary file in /tmp"))
708 ram 1.1 (let* ((name (format nil "/tmp/.run-program-~D" count))
709 wlott 1.8 (fd (unix:unix-open name
710     (logior unix:o_rdwr
711     unix:o_creat
712     unix:o_excl)
713 ram 1.1 #o666)))
714 wlott 1.8 (unix:unix-unlink name)
715 ram 1.1 (when fd
716     (let ((newline (string #\Newline)))
717     (loop
718     (multiple-value-bind
719     (line no-cr)
720     (read-line object nil nil)
721     (unless line
722     (return))
723 wlott 1.8 (unix:unix-write fd line 0 (length line))
724 ram 1.1 (if no-cr
725     (return)
726 wlott 1.8 (unix:unix-write fd newline 0 1)))))
727     (unix:unix-lseek fd 0 unix:l_set)
728 ram 1.1 (push fd *close-in-parent*)
729     (return (values fd nil))))))
730     (:output
731     (multiple-value-bind (read-fd write-fd)
732 wlott 1.8 (unix:unix-pipe)
733 ram 1.1 (unless read-fd
734 rtoy 1.29 (error _"Cound not create pipe: ~A"
735 wlott 1.8 (unix:get-unix-error-msg write-fd)))
736 wlott 1.4 (copy-descriptor-to-stream read-fd object cookie)
737 ram 1.1 (push read-fd *close-on-error*)
738     (push write-fd *close-in-parent*)
739     (values write-fd nil)))))
740     (t
741 rtoy 1.29 (error _"Invalid option to run-program: ~S" object))))
742 ram 1.1

  ViewVC Help
Powered by ViewVC 1.1.5