Ludovic Courtès <l...@gnu.org> skribis:
> But this illustrates another problem: in the child process, right before
> ‘execve’, the finalization thread may be restarted, in which case it
> creates a new pipe.
>
> In the example below, the finalization pipe is on FDs 9 and 7, but
> ‘install-current-ports!’ blindly dups to FD 7, thereby closing one end
> of the finalization pipe that was just created:
The hack below addresses that (mostly) by reserving low-number file
descriptors before the signal and finalization threads create their
pipe. (In practice, we can only reserve FDs above 5; FDs 3 and 4 are
the “sleep pipe” I believe.)
It seems to be good enough though.
Thoughts?
Ludo’.
diff --git a/gash/shell.scm b/gash/shell.scm
index 3611067..68e74e7 100644
--- a/gash/shell.scm
+++ b/gash/shell.scm
@@ -68,14 +68,13 @@ not a @code{file-port?}, its corresponding file descriptor will refer
to @file{/dev/null}."
;; XXX: Input/output ports? Closing other FDs?
(for-each (lambda (i)
- (match ((fd->current-port i))
- ((? file-port? port)
- (dup port i))
- ((? input-port? port)
- (dup (open-file "/dev/null" "r") i))
- ((? output-port? port)
- (dup (open-file "/dev/null" "w") i))
- (_ #t)))
+ (gc)
+ (let ((current-port (fd->current-port i)))
+ (match (current-port)
+ ((? file-port? port)
+ (let ((new (dup port i)))
+ (redirect-port port new)))
+ (#f #t))))
(iota *fd-count*)))
(define (exec-utility bindings path name args)
@@ -89,8 +88,14 @@ to @file{/dev/null}."
;; the buffer) produces its output.
(flush-all-ports)
(match (primitive-fork)
- (0 (install-current-ports!)
- (apply execle path utility-env name args))
+ (0
+ (dynamic-wind
+ (lambda ()
+ (install-current-ports!))
+ (lambda ()
+ (apply execle path utility-env name args))
+ (lambda ()
+ (primitive-exit 127))))
(pid (match-let (((pid . status) (waitpid pid)))
(set-status! (status:exit-val status)))))))
@@ -182,7 +187,10 @@ if it is our responsibility to close the port."
(define* (make-processed-redir fd target #:optional (open-flags 0))
(let ((port (match target
((? port?) target)
- ((? string?) (open target open-flags))
+ ((? string?)
+ (let ((port (open target open-flags)))
+ (set-port-revealed! port 10)
+ port))
;; TODO: Verify open-flags.
((? integer?) ((fd->current-port target)))
(#f #f))))
@@ -213,6 +221,7 @@ if it is our responsibility to close the port."
(make-processed-redir fd #f))
(('<< (? integer? fd) text)
(let ((port (tmpfile)))
+ (set-port-revealed! port 10)
(display text port)
(seek port 0 SEEK_SET)
(make-processed-redir fd port)))))
@@ -264,6 +273,7 @@ process."
(lambda () #t)
(lambda ()
(restore-signals)
+ (gc)
(set-atexit! #f)
;; We need to preserve the status given to 'exit', so we
;; catch the 'quit' key here.
diff --git a/scripts/gash.in b/scripts/gash.in
index f851c1d..57506ba 100644
--- a/scripts/gash.in
+++ b/scripts/gash.in
@@ -21,5 +21,13 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define (main args)
+ ;; Reserve file descriptors 5 to 12 (roughly) before the signal and
+ ;; finalization threads grab them so that a script willing to use
+ ;; them can do so without breaking Guile.
+ (let loop ((i 3))
+ (when (<= i 10)
+ (open-fdes "/dev/null" (logior O_RDONLY O_CLOEXEC))
+ (loop (+ i 1))))
+
(setenv "SHELL" ((compose canonicalize-path car command-line)))
- ((@ (gash gash) main) (command-line)))
+ ((module-ref (resolve-interface '(gash gash)) 'main) (command-line)))
