Close ports opened for redirects.
* gash/shell.scm (redir->parameter+port): Rename this... (process-redirect): ...to this, and make it return a list with the third element being a boolean indicating if the port was opened by us. (sh:with-redirects): Close ports when the new boolean is set.
This commit is contained in:
parent
22205a00a3
commit
121d9cb435
|
@ -167,45 +167,46 @@ environment variable bindings @var{bindings}."
|
||||||
|
|
||||||
;;; Redirects.
|
;;; Redirects.
|
||||||
|
|
||||||
(define (redir->parameter+port redir)
|
(define (process-redir redir)
|
||||||
"Convert @var{redir} into a pair consisting of the current-port
|
"Convert @var{redir} into a list consisting of the current-port
|
||||||
parameter to be updated and the port that should be its new value (or
|
parameter to be updated, the port that should be its new value (or
|
||||||
@code{#f} if it should be considered closed)."
|
@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
|
(let ((port (match target
|
||||||
((? port?) target)
|
((? port?) target)
|
||||||
((? string?) (open target open-flags))
|
((? string?) (open target open-flags))
|
||||||
;; TODO: Verify open-flags.
|
;; TODO: Verify open-flags.
|
||||||
((? integer?) ((fd->current-port target)))
|
((? integer?) ((fd->current-port target)))
|
||||||
(#f #f))))
|
(#f #f))))
|
||||||
`(,(fd->current-port fd) . ,port)))
|
`(,(fd->current-port fd) ,port ,(string? target))))
|
||||||
|
|
||||||
(match redir
|
(match redir
|
||||||
(('< (? integer? fd) (? string? filename))
|
(('< (? integer? fd) (? string? filename))
|
||||||
(make-parameter+port fd filename O_RDONLY))
|
(make-processed-redir fd filename O_RDONLY))
|
||||||
(('> (? integer? fd) (? string? filename))
|
(('> (? integer? fd) (? string? filename))
|
||||||
;; TODO: Observe noclobber.
|
;; 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))
|
(('>! (? 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)
|
(('>> 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)
|
(('<> 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))
|
(('<& (? integer? fd1) (? integer? fd2))
|
||||||
(make-parameter+port fd1 fd2))
|
(make-processed-redir fd1 fd2))
|
||||||
(('<& (? integer? fd) '-)
|
(('<& (? integer? fd) '-)
|
||||||
(make-parameter+port fd #f))
|
(make-processed-redir fd #f))
|
||||||
(('>& (? integer? fd1) (? integer? fd2))
|
(('>& (? integer? fd1) (? integer? fd2))
|
||||||
(make-parameter+port fd1 fd2))
|
(make-processed-redir fd1 fd2))
|
||||||
(('>& (? integer? fd) '-)
|
(('>& (? integer? fd) '-)
|
||||||
(make-parameter+port fd #f))
|
(make-processed-redir fd #f))
|
||||||
(('<< (? integer? fd) text)
|
(('<< (? integer? fd) text)
|
||||||
(let ((port (tmpfile)))
|
(let ((port (tmpfile)))
|
||||||
(display text port)
|
(display text port)
|
||||||
(seek port 0 SEEK_SET)
|
(seek port 0 SEEK_SET)
|
||||||
(make-parameter+port fd port)))))
|
(make-processed-redir fd port)))))
|
||||||
|
|
||||||
(define (sh:set-redirects redirs)
|
(define (sh:set-redirects redirs)
|
||||||
"Put the redirects @var{redirs} into effect."
|
"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
|
(match redirs
|
||||||
(() #t)
|
(() #t)
|
||||||
((redir . rest)
|
((redir . rest)
|
||||||
(match (false-if-exception
|
(match (false-if-exception (process-redir redir))
|
||||||
(redir->parameter+port redir))
|
|
||||||
(#f (set-status! 1)
|
(#f (set-status! 1)
|
||||||
(errexit))
|
(errexit))
|
||||||
((parameter . port)
|
((parameter port close?)
|
||||||
(parameter port)
|
(parameter port)
|
||||||
(loop rest)))))))
|
(loop rest)))))))
|
||||||
|
|
||||||
|
@ -228,15 +228,15 @@ parameter to be updated and the port that should be its new value (or
|
||||||
;; only way.
|
;; only way.
|
||||||
((fold-right (lambda (redir thunk)
|
((fold-right (lambda (redir thunk)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(match (false-if-exception
|
(match (false-if-exception (process-redir redir))
|
||||||
(redir->parameter+port redir))
|
|
||||||
(#f (set-status! 1)
|
(#f (set-status! 1)
|
||||||
(errexit))
|
(errexit))
|
||||||
((parameter . port)
|
((parameter port close?)
|
||||||
(parameterize ((parameter port))
|
(parameterize ((parameter port))
|
||||||
(thunk))
|
(thunk))
|
||||||
(when (output-port? port)
|
(cond
|
||||||
(force-output port))))))
|
(close? (close-port port))
|
||||||
|
((output-port? port) (force-output port)))))))
|
||||||
thunk
|
thunk
|
||||||
redirs)))
|
redirs)))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue