diff --git a/gash/shell.scm b/gash/shell.scm index 165dbb1..f615ac0 100644 --- a/gash/shell.scm +++ b/gash/shell.scm @@ -167,45 +167,46 @@ environment variable bindings @var{bindings}." ;;; Redirects. -(define (redir->parameter+port redir) - "Convert @var{redir} into a pair consisting of the current-port -parameter to be updated and the port that should be its new value (or -@code{#f} if it should be considered closed)." +(define (process-redir redir) + "Convert @var{redir} into a list consisting of the current-port +parameter to be updated, the port that should be its new value (or +@code{#f} if it should be considered closed), and a boolean indicating +if it is our responsibility to close the port." - (define* (make-parameter+port fd target #:optional (open-flags 0)) + (define* (make-processed-redir fd target #:optional (open-flags 0)) (let ((port (match target ((? port?) target) ((? string?) (open target open-flags)) ;; TODO: Verify open-flags. ((? integer?) ((fd->current-port target))) (#f #f)))) - `(,(fd->current-port fd) . ,port))) + `(,(fd->current-port fd) ,port ,(string? target)))) (match redir (('< (? integer? fd) (? string? filename)) - (make-parameter+port fd filename O_RDONLY)) + (make-processed-redir fd filename O_RDONLY)) (('> (? integer? fd) (? string? filename)) ;; TODO: Observe noclobber. - (make-parameter+port fd filename (logior O_WRONLY O_CREAT O_TRUNC))) + (make-processed-redir fd filename (logior O_WRONLY O_CREAT O_TRUNC))) (('>! (? integer? fd) (? string? filename)) - (make-parameter+port fd filename (logior O_WRONLY O_CREAT O_TRUNC))) + (make-processed-redir fd filename (logior O_WRONLY O_CREAT O_TRUNC))) (('>> fd filename) - (make-parameter+port fd filename (logior O_WRONLY O_CREAT O_APPEND))) + (make-processed-redir fd filename (logior O_WRONLY O_CREAT O_APPEND))) (('<> fd filename) - (make-parameter+port fd filename (logior O_RDWR O_CREAT))) + (make-processed-redir fd filename (logior O_RDWR O_CREAT))) (('<& (? integer? fd1) (? integer? fd2)) - (make-parameter+port fd1 fd2)) + (make-processed-redir fd1 fd2)) (('<& (? integer? fd) '-) - (make-parameter+port fd #f)) + (make-processed-redir fd #f)) (('>& (? integer? fd1) (? integer? fd2)) - (make-parameter+port fd1 fd2)) + (make-processed-redir fd1 fd2)) (('>& (? integer? fd) '-) - (make-parameter+port fd #f)) + (make-processed-redir fd #f)) (('<< (? integer? fd) text) (let ((port (tmpfile))) (display text port) (seek port 0 SEEK_SET) - (make-parameter+port fd port))))) + (make-processed-redir fd port))))) (define (sh:set-redirects redirs) "Put the redirects @var{redirs} into effect." @@ -213,11 +214,10 @@ parameter to be updated and the port that should be its new value (or (match redirs (() #t) ((redir . rest) - (match (false-if-exception - (redir->parameter+port redir)) + (match (false-if-exception (process-redir redir)) (#f (set-status! 1) (errexit)) - ((parameter . port) + ((parameter port close?) (parameter port) (loop rest))))))) @@ -228,15 +228,15 @@ parameter to be updated and the port that should be its new value (or ;; only way. ((fold-right (lambda (redir thunk) (lambda () - (match (false-if-exception - (redir->parameter+port redir)) + (match (false-if-exception (process-redir redir)) (#f (set-status! 1) (errexit)) - ((parameter . port) + ((parameter port close?) (parameterize ((parameter port)) (thunk)) - (when (output-port? port) - (force-output port)))))) + (cond + (close? (close-port port)) + ((output-port? port) (force-output port))))))) thunk redirs)))