/[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.28.14.1 - (hide annotations)
Thu Feb 25 20:34:51 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.28: +31 -30 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

works (once the piglatin translation is added).
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.28.14.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/run-program.lisp,v 1.28.14.1 2010/02/25 20:34:51 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.28.14.1 (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.28.14.1 _N"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.28.14.1 _N"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.28.14.1 _N"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.28.14.1 _N"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.28.14.1 (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.28.14.1 _N"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.28.14.1 _N"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.28.14.1 _N"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.28.14.1 _N"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.28.14.1 _N"List of file descriptors to close when RUN-PROGRAM returns in the parent.")
259 ram 1.1 (defvar *handlers-installed* nil
260 rtoy 1.28.14.1 _N"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.28.14.1 _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.28.14.1 (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.28.14.1 _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.28.14.1 (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.28.14.1 (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.28.14.1 _N"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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (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.28.14.1 (error _"Invalid option to run-program: ~S" object))))
742 ram 1.1

  ViewVC Help
Powered by ViewVC 1.1.5