mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-23 12:00:21 +02:00
Code Activity

2000-11-06 Gary Houston <ghouston@arglist.com>

Browse source 
* popen.scm (open-process): bug fix: don't use
	close-all-ports-except to close ports in the child process, since
	it causes port buffers to be flushed.  they may be flushed again
	in the parent, causing duplicate output.  use a more elaborate
	method for setting up the child descriptors (thanks to David
	Pirotte for the bug report).
	standard file descriptors 0, 1, 2 in the child process
	are now set up from current-input-port etc., where possible.
This commit is contained in:
Gary Houston 2000-11-07 21:36:42 +00:00
parent c2ca44933f
commit 8ccc61e837
2 changed files with 70 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

11
ice-9/ChangeLog
View file

@ -1,3 +1,14 @@
2000-11-06 Gary Houston <ghouston@arglist.com>
* popen.scm (open-process): bug fix: don't use
close-all-ports-except to close ports in the child process, since
it causes port buffers to be flushed. they may be flushed again
in the parent, causing duplicate output. use a more elaborate
method for setting up the child descriptors (thanks to David
Pirotte for the bug report).
standard file descriptors 0, 1, 2 in the child process
are now set up from current-input-port etc., where possible.
2000-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
* syncase.scm (eval): string=? requires a string argument.

63
ice-9/popen.scm
View file

@ -12,6 +12,10 @@
;; a weak hash-table to store the process ids.
(define-public port/pid-table (make-weak-key-hash-table 31))
(define (ensure-fdes port mode)
(or (false-if-exception (fileno port))
(open-fdes *null-device* mode)))
;; run a process connected to an input or output port.
;; mode: OPEN_READ or OPEN_WRITE.
;; returns port/pid pair.
@ -23,10 +27,61 @@
(cond ((= pid 0)
;; child
(set-batch-mode?! #t)
(close-all-ports-except (if reading (cdr p) (car p)))
(move->fdes (if reading (cdr p) (car p))
(if reading 1 0))
(apply execlp prog prog args))
;; select the three file descriptors to be used as
;; standard descriptors 0, 1, 2 for the new process. one
;; is the pipe to the parent, the other two are taken
;; from the current Scheme input/output/error ports if
;; possible.
(let ((input-fdes (if reading
(ensure-fdes (current-input-port)
O_RDONLY)
(fileno (car p))))
(output-fdes (if reading
(fileno (cdr p))
(ensure-fdes (current-output-port)
O_WRONLY)))
(error-fdes (ensure-fdes (current-error-port)
O_WRONLY)))
;; close all file descriptors in ports inherited from
;; the parent except for the three selected above.
;; this is to avoid causing problems for other pipes in
;; the parent.
;; use low-level system calls, not close-port or the
;; scsh routines, to avoid side-effects such as
;; flushing port buffers or evicting ports.
(port-for-each (lambda (pt-entry)
(false-if-exception
(let ((pt-fileno (fileno pt-entry)))
(if (not (or (= pt-fileno input-fdes)
(= pt-fileno output-fdes)
(= pt-fileno error-fdes)))
(close-fdes pt-fileno))))))
;; copy the three selected descriptors to the standard
;; descriptors 0, 1, 2. note that it's possible that
;; output-fdes or input-fdes is equal to error-fdes.
(cond ((not (= input-fdes 0))
(if (= output-fdes 0)
(set! output-fdes (dup->fdes 0)))
(if (= error-fdes 0)
(set! error-fdes (dup->fdes 0)))
(dup2 input-fdes 0)))
(cond ((not (= output-fdes 1))
(if (= error-fdes 1)
(set! error-fdes (dup->fdes 1)))
(dup2 output-fdes 1)))
(dup2 error-fdes 2)
(apply execlp prog prog args)))
(else
;; parent
(if reading