467 lines
14 KiB
Scheme
467 lines
14 KiB
Scheme
;;; Gash -- Guile As SHell
|
||
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
|
||
;;;
|
||
;;; This file is part of Gash.
|
||
;;;
|
||
;;; Gash is free software: you can redistribute it and/or modify
|
||
;;; it under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation, either version 3 of the License, or
|
||
;;; (at your option) any later version.
|
||
;;;
|
||
;;; Gash is distributed in the hope that it will be useful,
|
||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (test-shell)
|
||
#:use-module (gash compat)
|
||
#:use-module (gash compat textual-ports)
|
||
#:use-module (gash environment)
|
||
#:use-module (gash shell)
|
||
#:use-module (ice-9 ftw)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (srfi srfi-64)
|
||
#:use-module (tests unit automake)
|
||
#:use-module (tests unit config))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; Tests for the shell module.
|
||
;;;
|
||
;;; Code:
|
||
|
||
(define (make-temporary-directory)
|
||
(let loop ((name (tmpnam)))
|
||
(catch 'system-error
|
||
(lambda ()
|
||
(mkdir name #o700)
|
||
name)
|
||
(lambda args
|
||
(unless (= (system-error-errno args) EEXIST)
|
||
(apply throw args))
|
||
(loop (tmpnam))))))
|
||
|
||
(define (delete-recursively path)
|
||
(define enter? (const #t))
|
||
(define (leaf path stat acc) (delete-file path) #f)
|
||
(define down (const #f))
|
||
(define (up path stat acc) (rmdir path) #f)
|
||
(define skip (const #f))
|
||
(define (error path stat errno result)
|
||
(scm-error 'system-error
|
||
"delete-recursively"
|
||
"~A" `(,strerror errno)
|
||
`(,errno)))
|
||
(file-system-fold enter? leaf down up skip error #f path))
|
||
|
||
(define (call-with-temporary-directory proc)
|
||
(let* ((directory (make-temporary-directory)))
|
||
(dynamic-wind
|
||
(lambda () #t)
|
||
(lambda ()
|
||
(proc directory))
|
||
(lambda ()
|
||
(delete-recursively directory)))))
|
||
|
||
(define (%make-script object . forms)
|
||
(define (write-script port)
|
||
(chmod port #o755)
|
||
(format port "#!~a --no-auto-compile~%!#~%~%" *guile-path*)
|
||
(for-each (lambda (form)
|
||
(write form port)
|
||
(newline port))
|
||
forms))
|
||
(match object
|
||
((? port?) (write-script object))
|
||
((? string?) (call-with-output-file object write-script))))
|
||
|
||
(define-syntax-rule (make-script path form form1 ...)
|
||
(%make-script path `form `form1 ...))
|
||
|
||
(test-begin "shell")
|
||
|
||
(test-assert "Executes a utility by absolute path"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((utility (string-append directory "/utility"))
|
||
(sentinal (string-append directory "/sentinal.txt")))
|
||
(make-script utility
|
||
(with-output-to-file ,sentinal
|
||
(lambda ()
|
||
(display "x"))))
|
||
(sh:exec utility)
|
||
(file-exists? sentinal)))))
|
||
|
||
(test-assert "Executes a utility by searching PATH"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((utility (string-append directory "/utility"))
|
||
(sentinal (string-append directory "/sentinal.txt")))
|
||
(make-script utility
|
||
(with-output-to-file ,sentinal
|
||
(lambda ()
|
||
(display "x"))))
|
||
(with-variables `(("PATH" . ,directory))
|
||
(lambda () (sh:exec "utility")))
|
||
(file-exists? sentinal)))))
|
||
|
||
(test-equal "Sets status to 127 if a utility cannot be found"
|
||
127
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(with-variables `(("PATH" . ,directory))
|
||
(lambda ()
|
||
(sh:exec "utility")
|
||
(get-status))))))
|
||
|
||
(test-equal "Executes regular built-ins"
|
||
"foo bar\n"
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(sh:exec "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")))
|
||
(sh:with-redirects `((> 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")))
|
||
(sh:with-redirects `((> 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")))
|
||
(make-script utility
|
||
(display "foo")
|
||
(newline))
|
||
(sh:with-redirects `((> 1 ,foo))
|
||
(lambda ()
|
||
(sh:exec 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")))
|
||
(make-script utility
|
||
(display "foo" (current-error-port))
|
||
(newline (current-error-port)))
|
||
(sh:with-redirects `((> 2 ,foo))
|
||
(lambda ()
|
||
(sh:exec 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")))
|
||
(with-output-to-file foo
|
||
(lambda ()
|
||
(display "foo")
|
||
(newline)))
|
||
(sh:with-redirects `((< 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")))
|
||
(with-output-to-file foo
|
||
(lambda ()
|
||
(display "foo")
|
||
(newline)))
|
||
(make-script utility
|
||
(use-modules (rnrs io ports))
|
||
(with-output-to-file ,output
|
||
(lambda ()
|
||
(display (get-string-all (current-input-port))))))
|
||
(sh:with-redirects `((< 0 ,foo))
|
||
(lambda ()
|
||
(sh:exec 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")))
|
||
(sh:with-redirects `((> 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")))
|
||
(make-script utility
|
||
(display "foo")
|
||
(newline)
|
||
(display "bar" (current-error-port))
|
||
(newline (current-error-port)))
|
||
(sh:with-redirects `((> 1 ,foo) (>& 2 1))
|
||
(lambda ()
|
||
(sh:exec 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")))
|
||
(with-output-to-file foo
|
||
(lambda ()
|
||
(display "foo")
|
||
(newline)))
|
||
(sh:with-redirects `((>> 1 ,foo))
|
||
(lambda ()
|
||
(display "bar")
|
||
(newline)))
|
||
(call-with-input-file foo get-string-all)))))
|
||
|
||
(test-equal "Redirects here-document to standard input"
|
||
"foo\n"
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(sh:with-redirects '((<< 0 "foo\n"))
|
||
(lambda ()
|
||
(display (get-string-all (current-input-port))))))))
|
||
|
||
(test-equal "Redirects work with string ports"
|
||
"foo\n"
|
||
(with-input-from-string "bar\n"
|
||
(lambda ()
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(sh:with-redirects '((<< 0 "foo\n"))
|
||
(lambda ()
|
||
(display (get-string-all (current-input-port))))))))))
|
||
|
||
(test-equal "Does not use buffered input from current-input-port"
|
||
"foo\n"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((bar-baz (string-append directory "/bar-baz.txt")))
|
||
(with-output-to-file bar-baz
|
||
(lambda ()
|
||
(display "bar\nbaz\n")))
|
||
(with-input-from-file bar-baz
|
||
(lambda ()
|
||
(setvbuf (current-input-port) 'block 8)
|
||
(get-line (current-input-port))
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(sh:with-redirects '((<< 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")))
|
||
(sh:with-redirects `((> 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"
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(sh:with-redirects '((<< 0 "bar\n") (<< 0 "foo\n"))
|
||
(lambda ()
|
||
(display (get-string-all (current-input-port))))))))
|
||
|
||
;; TODO: Read-write tests, closing tests, clobbering tests.
|
||
|
||
|
||
;;; Subshells.
|
||
|
||
(test-equal "Subshells cannot change variables"
|
||
"foo"
|
||
(with-variables '(("x" . "foo"))
|
||
(lambda ()
|
||
(sh:subshell
|
||
(lambda ()
|
||
(setvar! "x" "bar")))
|
||
(getvar "x"))))
|
||
|
||
;; TODO: Test other means of manipulating the environment and exit
|
||
;; statuses.
|
||
|
||
|
||
;;; Command substitutions.
|
||
|
||
(test-equal "Substitutes output from built-in"
|
||
"foo"
|
||
(sh:substitute-command
|
||
(lambda ()
|
||
(display "foo"))))
|
||
|
||
(test-equal "Substitutes output from external utilities"
|
||
"foo"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((utility (string-append directory "/utility")))
|
||
(make-script utility
|
||
(display "foo"))
|
||
(sh:substitute-command
|
||
(lambda ()
|
||
(sh:exec utility)))))))
|
||
|
||
(test-equal "Trailing newlines are trimmed from substitutions"
|
||
"foo"
|
||
(sh:substitute-command
|
||
(lambda ()
|
||
(display "foo")
|
||
(newline))))
|
||
|
||
(test-equal "Non-trailing newlines are preserved in substitutions"
|
||
"\nfoo\nbar"
|
||
(sh:substitute-command
|
||
(lambda ()
|
||
(newline)
|
||
(display "foo")
|
||
(newline)
|
||
(display "bar"))))
|
||
|
||
(test-equal "Empty substitutions produce empty strings"
|
||
""
|
||
(sh:substitute-command noop))
|
||
|
||
|
||
;; Pipelines.
|
||
|
||
(test-equal "Built-ins are connected by pipelines"
|
||
"foo"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((foo (string-append directory "/foo.txt")))
|
||
(sh:pipeline (lambda ()
|
||
(display "foo\n"))
|
||
(lambda ()
|
||
(with-output-to-file foo
|
||
(lambda ()
|
||
(display (get-line (current-input-port)))))))
|
||
(call-with-input-file foo get-string-all)))))
|
||
|
||
(test-equal "External utilities are connected by pipelines"
|
||
"foo"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((utility1 (string-append directory "utility1"))
|
||
(utility2 (string-append directory "utility2"))
|
||
(foo (string-append directory "/foo.txt")))
|
||
(make-script utility1
|
||
(display "foo\n"))
|
||
(make-script utility2
|
||
(use-modules (rnrs io ports))
|
||
(with-output-to-file ,foo
|
||
(lambda ()
|
||
(display (get-line (current-input-port))))))
|
||
(sh:pipeline (lambda ()
|
||
(sh:exec utility1))
|
||
(lambda ()
|
||
(sh:exec utility2)))
|
||
(call-with-input-file foo get-string-all)))))
|
||
|
||
(test-equal "Externals and built-ins are connected by pipelines"
|
||
"foo"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((utility (string-append directory "/utility"))
|
||
(foo (string-append directory "/foo.txt")))
|
||
(make-script utility
|
||
(display "foo\n"))
|
||
(sh:pipeline (lambda ()
|
||
(sh:exec utility))
|
||
(lambda ()
|
||
(with-output-to-file foo
|
||
(lambda ()
|
||
(display (get-line (current-input-port)))))))
|
||
(call-with-input-file foo get-string-all)))))
|
||
|
||
(test-equal "Built-ins and externals are connected by pipelines"
|
||
"foo"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((utility (string-append directory "/utility"))
|
||
(foo (string-append directory "/foo.txt")))
|
||
(make-script utility
|
||
(use-modules (rnrs io ports))
|
||
(with-output-to-file ,foo
|
||
(lambda ()
|
||
(display (get-line (current-input-port))))))
|
||
(sh:pipeline (lambda ()
|
||
(display "foo\n"))
|
||
(lambda ()
|
||
(sh:exec utility)))
|
||
(call-with-input-file foo get-string-all)))))
|
||
|
||
|
||
;;; Errexit.
|
||
|
||
(test-assert "Exit traps are still called on errexit"
|
||
(call-with-prompt default-prompt-tag
|
||
(lambda ()
|
||
(set-atexit! (lambda () (abort-to-prompt default-prompt-tag)))
|
||
(setopt! 'errexit #t)
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((utility (string-append directory "/false")))
|
||
(make-script utility
|
||
(exit EXIT_FAILURE))
|
||
(sh:exec utility)))))
|
||
(lambda (k) #t)))
|
||
|
||
(test-end)
|