Add redirect semantics
* geesh/shell.scm (save-and-install-redirect!): New function. (restore-saved-fdes!): New function. (with-redirects): New public function. * tests/shell.scm: Test it. * .dir-locals.el: Indent it nicely.
This commit is contained in:
Timothy Sample
parent
9b879623de
commit
e6f732ada9
|
|
@ -8,4 +8,5 @@
|
|||
(eval . (put '<sh-while> 'scheme-indent-function 1))
|
||||
(eval . (put '<sh-with-redirects> 'scheme-indent-function 1))
|
||||
(eval . (put 'call-with-backquoted-input-port 'scheme-indent-function 1))
|
||||
(eval . (put 'make-script 'scheme-indent-function 1)))))
|
||||
(eval . (put 'make-script 'scheme-indent-function 1))
|
||||
(eval . (put 'sh:with-redirects 'scheme-indent-function 2)))))
|
||||
|
|
|
|||
|
|
@ -2,8 +2,10 @@
|
|||
#:use-module (geesh built-ins)
|
||||
#:use-module (geesh environment)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (sh:exec-let
|
||||
sh:exec))
|
||||
sh:exec
|
||||
sh:with-redirects))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
|
@ -70,3 +72,80 @@ it cannot be found, return @code{#f}."
|
|||
"Find and execute @var{name} with arguments @var{args} and
|
||||
environment @var{env}."
|
||||
(apply sh:exec-let env '() name args))
|
||||
|
||||
|
||||
;;; Redirects.
|
||||
|
||||
(define (save-and-install-redirect! env redir)
|
||||
"Install the redirect @var{redir} into the current process and
|
||||
return a pair consisting of the file descriptor that has been changed
|
||||
and a dup'ed copy of its old value. If @var{redir} is a here-document
|
||||
redirect, the return value is a pair where the first element is the
|
||||
pair previously described and the second element is the temporary
|
||||
filename used for the here-document contents."
|
||||
|
||||
(define* (save-and-dup2! fd target #:optional (open-flags 0))
|
||||
(let ((saved-fd (catch 'system-error
|
||||
(lambda () (dup fd))
|
||||
(lambda data
|
||||
(unless (= EBADF (system-error-errno data))
|
||||
(apply throw data))
|
||||
#f))))
|
||||
(match target
|
||||
((? string?) (dup2 (open-fdes target open-flags) fd))
|
||||
;; TODO: Verify open-flags.
|
||||
((? integer?) (dup2 target fd))
|
||||
(#f (close-fdes fd)))
|
||||
`(,fd . ,saved-fd)))
|
||||
|
||||
(match redir
|
||||
(('< (? integer? fd) (? string? filename))
|
||||
(save-and-dup2! fd filename O_RDONLY))
|
||||
(('> (? integer? fd) (? string? filename))
|
||||
;; TODO: Observe noclobber.
|
||||
(save-and-dup2! fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
|
||||
(('>! (? integer? fd) (? string? filename))
|
||||
(save-and-dup2! fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
|
||||
(('>> fd filename)
|
||||
(save-and-dup2! fd filename (logior O_WRONLY O_CREAT O_APPEND)))
|
||||
(('<> fd filename)
|
||||
(save-and-dup2! fd filename (logior O_RDWR O_CREAT)))
|
||||
(('<& (? integer? fd1) (? integer? fd2))
|
||||
(save-and-dup2! fd1 fd2))
|
||||
(('<& (? integer? fd) '-)
|
||||
(save-and-dup2! fd #f))
|
||||
(('>& (? integer? fd1) (? integer? fd2))
|
||||
(save-and-dup2! fd1 fd2))
|
||||
(('>& (? integer? fd) '-)
|
||||
(save-and-dup2! fd #f))
|
||||
(('<< (? integer? fd) text)
|
||||
(let ((port (mkstemp! (string-copy "/tmp/geesh-here-doc-XXXXXX"))))
|
||||
(display text port)
|
||||
(seek port 0 SEEK_SET)
|
||||
`(,(save-and-dup2! fd (port->fdes port)) . ,(port-filename port))))))
|
||||
|
||||
(define (restore-saved-fdes! fd-pair)
|
||||
"Restore a file-descriptor to its previous state as described by
|
||||
@var{fd-pair}, where @var{fd-pair} is a return value of
|
||||
@code{save-and-install-redirect!}."
|
||||
(match fd-pair
|
||||
(((fd . saved-fd) . filename)
|
||||
(restore-saved-fdes! `(,fd . ,saved-fd))
|
||||
(delete-file filename))
|
||||
((fd . #f)
|
||||
(close-fdes fd))
|
||||
((fd . saved-fd)
|
||||
(dup2 saved-fd fd))))
|
||||
|
||||
(define (sh:with-redirects env redirs thunk)
|
||||
"Call @var{thunk} with the redirects @var{redirs} in effect."
|
||||
(let ((saved-fds #f))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(flush-all-ports)
|
||||
(set! saved-fds
|
||||
(map (cut save-and-install-redirect! env <>) redirs)))
|
||||
thunk
|
||||
(lambda ()
|
||||
(flush-all-ports)
|
||||
(for-each restore-saved-fdes! (reverse saved-fds))))))
|
||||
|
|
|
|||
184
tests/shell.scm
184
tests/shell.scm
|
|
@ -127,4 +127,188 @@
|
|||
(lambda ()
|
||||
(sh:exec env "echo" "foo" "bar")))))
|
||||
|
||||
|
||||
;;; Redirects.
|
||||
|
||||
;; TODO: Tame this mess with some syntax.
|
||||
|
||||
(test-equal "Redirects built-in standard output to file"
|
||||
"foo\n"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((foo (string-append directory "/foo.txt"))
|
||||
(env (make-environment '())))
|
||||
(sh:with-redirects env `((> 1 ,foo))
|
||||
(lambda ()
|
||||
(display "foo")
|
||||
(newline)))
|
||||
(call-with-input-file foo get-string-all)))))
|
||||
|
||||
(test-equal "Redirects built-in standard error to file"
|
||||
"foo\n"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((foo (string-append directory "/foo.txt"))
|
||||
(env (make-environment '())))
|
||||
(sh:with-redirects env `((> 2 ,foo))
|
||||
(lambda ()
|
||||
(display "foo" (current-error-port))
|
||||
(newline (current-error-port))))
|
||||
(call-with-input-file foo get-string-all)))))
|
||||
|
||||
(test-equal "Redirects external standard output to file"
|
||||
"foo\n"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((utility (string-append directory "/utility"))
|
||||
(foo (string-append directory "/foo.txt"))
|
||||
(env (make-environment '())))
|
||||
(make-script utility
|
||||
(display "foo")
|
||||
(newline))
|
||||
(sh:with-redirects env `((> 1 ,foo))
|
||||
(lambda ()
|
||||
(sh:exec env utility)))
|
||||
(call-with-input-file foo get-string-all)))))
|
||||
|
||||
(test-equal "Redirects external standard error to file"
|
||||
"foo\n"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((utility (string-append directory "/utility"))
|
||||
(foo (string-append directory "/foo.txt"))
|
||||
(env (make-environment '())))
|
||||
(make-script utility
|
||||
(display "foo" (current-error-port))
|
||||
(newline (current-error-port)))
|
||||
(sh:with-redirects env `((> 2 ,foo))
|
||||
(lambda ()
|
||||
(sh:exec env utility)))
|
||||
(call-with-input-file foo get-string-all)))))
|
||||
|
||||
(test-equal "Redirects built-in standard input from file"
|
||||
"foo\n"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((foo (string-append directory "/foo.txt"))
|
||||
(output (string-append directory "/output.txt"))
|
||||
(env (make-environment '())))
|
||||
(with-output-to-file foo
|
||||
(lambda ()
|
||||
(display "foo")
|
||||
(newline)))
|
||||
(sh:with-redirects env `((< 0 ,foo))
|
||||
(lambda ()
|
||||
(with-output-to-file output
|
||||
(lambda ()
|
||||
(display (get-string-all (current-input-port)))))))
|
||||
(call-with-input-file output get-string-all)))))
|
||||
|
||||
(test-equal "Redirects external standard input from file"
|
||||
"foo\n"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((utility (string-append directory "/utility"))
|
||||
(foo (string-append directory "/foo.txt"))
|
||||
(output (string-append directory "/output.txt"))
|
||||
(env (make-environment '())))
|
||||
(with-output-to-file foo
|
||||
(lambda ()
|
||||
(display "foo")
|
||||
(newline)))
|
||||
(make-script utility
|
||||
(use-modules (ice-9 textual-ports))
|
||||
(with-output-to-file ,output
|
||||
(lambda ()
|
||||
(display (get-string-all (current-input-port))))))
|
||||
(sh:with-redirects env `((< 0 ,foo))
|
||||
(lambda ()
|
||||
(sh:exec env utility)))
|
||||
(call-with-input-file output get-string-all)))))
|
||||
|
||||
;; These next two tests are non-deterministic, so we need to allow
|
||||
;; multiple right answers. (This is preferred to using 'force-output'
|
||||
;; because we want to be sure that 'sh:with-redirects' handles
|
||||
;; left-over buffered output.)
|
||||
|
||||
(test-assert "Redirects built-in standard error to standard output"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((foo (string-append directory "/foo.txt"))
|
||||
(env (make-environment '())))
|
||||
(sh:with-redirects env `((> 1 ,foo) (>& 2 1))
|
||||
(lambda ()
|
||||
(display "foo")
|
||||
(newline)
|
||||
(display "bar" (current-error-port))
|
||||
(newline (current-error-port))))
|
||||
(let ((result (call-with-input-file foo get-string-all)))
|
||||
(or (string=? result "foo\nbar\n")
|
||||
(string=? result "bar\nfoo\n")))))))
|
||||
|
||||
(test-assert "Redirects external standard error to standard output"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((utility (string-append directory "/utility"))
|
||||
(foo (string-append directory "/foo.txt"))
|
||||
(env (make-environment '())))
|
||||
(make-script utility
|
||||
(display "foo")
|
||||
(newline)
|
||||
(display "bar" (current-error-port))
|
||||
(newline (current-error-port)))
|
||||
(sh:with-redirects env `((> 1 ,foo) (>& 2 1))
|
||||
(lambda ()
|
||||
(sh:exec env utility)))
|
||||
(let ((result (call-with-input-file foo get-string-all)))
|
||||
(or (string=? result "foo\nbar\n")
|
||||
(string=? result "bar\nfoo\n")))))))
|
||||
|
||||
(test-equal "Appends standard output to file"
|
||||
"foo\nbar\n"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((foo (string-append directory "/foo.txt"))
|
||||
(env (make-environment '())))
|
||||
(with-output-to-file foo
|
||||
(lambda ()
|
||||
(display "foo")
|
||||
(newline)))
|
||||
(sh:with-redirects env `((>> 1 ,foo))
|
||||
(lambda ()
|
||||
(display "bar")
|
||||
(newline)))
|
||||
(call-with-input-file foo get-string-all)))))
|
||||
|
||||
(test-equal "Redirects here-document to standard input"
|
||||
"foo\n"
|
||||
(let ((env (make-environment '())))
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(sh:with-redirects env '((<< 0 "foo\n"))
|
||||
(lambda ()
|
||||
(display (get-string-all (current-input-port)))))))))
|
||||
|
||||
(test-equal "Allows here-document and file redirect"
|
||||
"foo\n"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(let ((foo (string-append directory "/foo.txt"))
|
||||
(env (make-environment '())))
|
||||
(sh:with-redirects env `((> 1 ,foo) (<< 0 "foo\n"))
|
||||
(lambda ()
|
||||
(display (get-string-all (current-input-port)))))
|
||||
(call-with-input-file foo get-string-all)))))
|
||||
|
||||
(test-equal "Uses last here-document specified"
|
||||
"foo\n"
|
||||
(let ((env (make-environment '())))
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(sh:with-redirects env '((<< 0 "bar\n") (<< 0 "foo\n"))
|
||||
(lambda ()
|
||||
(display (get-string-all (current-input-port)))))))))
|
||||
|
||||
;; TODO: Read-write tests, closing tests, clobbering tests.
|
||||
|
||||
(test-end)
|
||||
|
|
|
|||
Loading…
Reference in New Issue