315 lines
10 KiB
Scheme
315 lines
10 KiB
Scheme
;;; The Geesh Shell Interpreter
|
||
;;; Copyright 2018 Timothy Sample <samplet@ngyro.com>
|
||
;;;
|
||
;;; This file is part of Geesh.
|
||
;;;
|
||
;;; Geesh 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.
|
||
;;;
|
||
;;; Geesh 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 Geesh. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (test-shell)
|
||
#:use-module (geesh environment)
|
||
#:use-module (geesh shell)
|
||
#:use-module (ice-9 ftw)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 textual-ports)
|
||
#:use-module (srfi srfi-64)
|
||
#:use-module (tests automake)
|
||
#:use-module (tests 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))
|
||
(result (with-continuation-barrier
|
||
(lambda ()
|
||
(proc directory)))))
|
||
(delete-recursively directory)
|
||
result))
|
||
|
||
(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"))
|
||
(env (make-environment '())))
|
||
(make-script utility
|
||
(with-output-to-file ,sentinal
|
||
(lambda ()
|
||
(display "x"))))
|
||
(sh:exec env 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"))
|
||
(env (make-environment `(("PATH" . ,directory)))))
|
||
(make-script utility
|
||
(with-output-to-file ,sentinal
|
||
(lambda ()
|
||
(display "x"))))
|
||
(sh:exec env "utility")
|
||
(file-exists? sentinal)))))
|
||
|
||
(test-assert "Throws error if a utility cannot be found"
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(let ((env (make-environment `(("PATH" . ,directory)))))
|
||
(catch #t
|
||
(lambda ()
|
||
(sh:exec env "utility")
|
||
#f)
|
||
(lambda args
|
||
(match args
|
||
(('misc-error _ _ ("Command not found.") _) #t)
|
||
(_ #f))))))))
|
||
|
||
(test-equal "Executes regular built-ins"
|
||
"foo bar\n"
|
||
(let ((env (make-environment '())))
|
||
(with-output-to-string
|
||
(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)
|