254 lines
8.7 KiB
Plaintext
254 lines
8.7 KiB
Plaintext
|
#! @GUILE@ \
|
|||
|
--no-auto-compile -e main -s
|
|||
|
!#
|
|||
|
|
|||
|
;;; Gash -- Guile As SHell
|
|||
|
;;; Copyright © 2019 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/>.
|
|||
|
|
|||
|
(use-modules (ice-9 match)
|
|||
|
(ice-9 popen)
|
|||
|
(ice-9 rdelim)
|
|||
|
(ice-9 receive)
|
|||
|
(ice-9 textual-ports)
|
|||
|
(srfi srfi-9))
|
|||
|
|
|||
|
|
|||
|
;;; Test record
|
|||
|
|
|||
|
(define-record-type <test>
|
|||
|
(%make-test name script args status stdout stderr xfail?)
|
|||
|
test?
|
|||
|
(name test-name)
|
|||
|
(script test-script)
|
|||
|
(args test-args)
|
|||
|
(status test-status)
|
|||
|
(stdout test-stdout)
|
|||
|
(stderr test-stderr)
|
|||
|
(xfail? test-xfail?))
|
|||
|
|
|||
|
(define* (make-test name script #:key (args '()) (status 0)
|
|||
|
stdout stderr xfail?)
|
|||
|
(unless (string? name)
|
|||
|
(error (format #f "invalid test name: ~s" name)))
|
|||
|
(unless (string? script)
|
|||
|
(error (format #f "invalid test script: ~s" script)))
|
|||
|
(match args
|
|||
|
((or () ((? string?) ...)) #t)
|
|||
|
(_ (error (format #f "invalid test args: ~s" args))))
|
|||
|
(%make-test name script args status stdout stderr xfail?))
|
|||
|
|
|||
|
|
|||
|
;;; Org-style input
|
|||
|
|
|||
|
(define (read-org-block ex-chr port)
|
|||
|
(define block-name
|
|||
|
(let ((name (read-delimited " \t\n" port 'peek)))
|
|||
|
;; Consume the rest of the line.
|
|||
|
(read-line port)
|
|||
|
(unless (string-prefix-ci? "begin_" name)
|
|||
|
(error "Org blocks must start with \"begin_\""))
|
|||
|
(substring name 6)))
|
|||
|
|
|||
|
(define delim
|
|||
|
(string-append "#+end_" block-name "\n"))
|
|||
|
|
|||
|
(let loop ((line (read-line port 'concat)) (acc '()))
|
|||
|
(cond
|
|||
|
((eof-object? line) (error "end of file in Org block"))
|
|||
|
((string-ci=? line delim) (string-concatenate-reverse acc))
|
|||
|
(else
|
|||
|
(unless (string-prefix? " " line)
|
|||
|
(error "All Org block lines must indented with two spaces"))
|
|||
|
(loop (read-line port 'concat) (cons (substring line 2) acc))))))
|
|||
|
|
|||
|
(read-hash-extend #\+ read-org-block)
|
|||
|
|
|||
|
(define (read-tests port)
|
|||
|
(let loop ((token (read port)) (test '()) (tests '()))
|
|||
|
(match token
|
|||
|
((? eof-object?)
|
|||
|
(reverse! (match test
|
|||
|
(() tests)
|
|||
|
(_ (cons test tests)))))
|
|||
|
('*
|
|||
|
(let ((name (read-line port)))
|
|||
|
(when (eof-object? name)
|
|||
|
(error "end of file while expecting a value"))
|
|||
|
(loop (read port) `((:name: . ,(string-trim name)))
|
|||
|
(match test
|
|||
|
(() tests)
|
|||
|
(_ (cons test tests))))))
|
|||
|
(key
|
|||
|
(let ((value (read port)))
|
|||
|
(when (eof-object? value)
|
|||
|
(error "end of file while expecting a value"))
|
|||
|
(loop (read port) (acons key value test) tests))))))
|
|||
|
|
|||
|
(define (test-alist->test alist)
|
|||
|
(make-test (assq-ref alist ':name:)
|
|||
|
(assq-ref alist ':script:)
|
|||
|
#:args (or (assq-ref alist ':args:) '())
|
|||
|
#:status (or (assq-ref alist ':status:) 0)
|
|||
|
#:stdout (assq-ref alist ':stdout:)
|
|||
|
#:stderr (assq-ref alist ':stderr:)
|
|||
|
#:xfail? (assq-ref alist ':xfail?:)))
|
|||
|
|
|||
|
|
|||
|
;;; Invocation helpers
|
|||
|
|
|||
|
;; XXX: This is probably the slowest way possible to do this. I hope
|
|||
|
;; it is correct, at least.
|
|||
|
(define (get-strings-all . ports)
|
|||
|
(define accs (make-hash-table (length ports)))
|
|||
|
|
|||
|
(define (accs-cons! x port)
|
|||
|
(hashq-set! accs port (cons x (hashq-ref accs port '()))))
|
|||
|
|
|||
|
(let loop ((ps ports))
|
|||
|
(match ps
|
|||
|
(() (map (lambda (port)
|
|||
|
(reverse-list->string (hashq-ref accs port '())))
|
|||
|
ports))
|
|||
|
(_ (match (select ps '() '())
|
|||
|
(((ready-port . _) _ _)
|
|||
|
(match (read-char ready-port)
|
|||
|
((? eof-object?)
|
|||
|
(loop (filter (lambda (port)
|
|||
|
(not (eq? port ready-port)))
|
|||
|
ps)))
|
|||
|
(chr (accs-cons! chr ready-port)
|
|||
|
(loop ps)))))))))
|
|||
|
|
|||
|
(define (observe shell script filename args)
|
|||
|
"Use SHELL to interpret SCRIPT, returning the exit status, standard
|
|||
|
output, and standard error as three values."
|
|||
|
(match-let (((stdout-input . stdout-output) (pipe))
|
|||
|
((stderr-input . stderr-output) (pipe))
|
|||
|
((ex-input . ex-output) (pipe)))
|
|||
|
(match (primitive-fork)
|
|||
|
(0 (catch #t
|
|||
|
(lambda ()
|
|||
|
(close-port stdout-input)
|
|||
|
(close-port stderr-input)
|
|||
|
(close-port ex-input)
|
|||
|
(dup stdout-output 1)
|
|||
|
(dup stderr-output 2)
|
|||
|
(setenv "TEST_TMP" (getcwd))
|
|||
|
(chdir "@abs_top_srcdir@")
|
|||
|
(apply execlp shell shell "-e" "-c" script filename args))
|
|||
|
(lambda args
|
|||
|
(write args ex-output)
|
|||
|
(force-output ex-output)
|
|||
|
(primitive-_exit EXIT_FAILURE))))
|
|||
|
(pid (close-port stdout-output)
|
|||
|
(close-port stderr-output)
|
|||
|
(close-port ex-output)
|
|||
|
(match (get-strings-all stdout-input stderr-input ex-input)
|
|||
|
((stdout stderr "")
|
|||
|
(match-let (((pid . status) (waitpid pid)))
|
|||
|
(values (status:exit-val status) stdout stderr)))
|
|||
|
((_ _ ex)
|
|||
|
(apply throw (call-with-input-string ex read))))))))
|
|||
|
|
|||
|
|
|||
|
;;; Runner
|
|||
|
|
|||
|
(define (display-output output)
|
|||
|
(format #t "---~%~a~a---~%"
|
|||
|
output (if (string-suffix? "\n" output) "" "\n")))
|
|||
|
|
|||
|
(define (run-test test shell)
|
|||
|
(match-let ((($ <test> name script args
|
|||
|
xstatus xstdout xstderr xfail?) test))
|
|||
|
(format #t "Start test: ~a~%" name)
|
|||
|
(display "Script: ")
|
|||
|
(display-output script)
|
|||
|
(format #t "Arguments: ~s~%" args)
|
|||
|
(catch #t
|
|||
|
(lambda ()
|
|||
|
(receive (status stdout stderr) (observe shell script "test" args)
|
|||
|
(let* ((status-ok? (= status xstatus))
|
|||
|
(stdout-ok? (or (not xstdout) (string=? stdout xstdout)))
|
|||
|
(stderr-ok? (or (not xstderr) (string=? stderr xstderr)))
|
|||
|
(ok? (and status-ok? stdout-ok? stderr-ok?))
|
|||
|
(result (if ok?
|
|||
|
(if xfail? 'xpass 'pass)
|
|||
|
(if xfail? 'xfail 'fail))))
|
|||
|
(unless status-ok?
|
|||
|
(format #t "Expected status: ~a~%" xstatus)
|
|||
|
(format #t "Actual status: ~a~%" status))
|
|||
|
(unless stdout-ok?
|
|||
|
(display "Expected stdout: ")
|
|||
|
(display-output xstdout)
|
|||
|
(display "Actual stdout: " )
|
|||
|
(display-output stdout))
|
|||
|
(unless stderr-ok?
|
|||
|
(display "Expected stderr: ")
|
|||
|
(display-output xstderr)
|
|||
|
(display "Actual stderr: " )
|
|||
|
(display-output stderr))
|
|||
|
(format #t "Result: ~a~%" result)
|
|||
|
(format #t "End test: ~a~%" name)
|
|||
|
result)))
|
|||
|
(lambda args
|
|||
|
(format #t "Test error: ~s~%" args)
|
|||
|
(format #t "End test: ~a~%" name)
|
|||
|
'error))))
|
|||
|
|
|||
|
(define (run-tests tests shell)
|
|||
|
(let loop ((tests tests) (pass 0) (fail 0) (xpass 0) (xfail 0) (error 0))
|
|||
|
(match tests
|
|||
|
(()
|
|||
|
(format #t "== Summary ==~%")
|
|||
|
(for-each (match-lambda
|
|||
|
((label . count)
|
|||
|
(when (> count 0)
|
|||
|
(format #t "~a~a~%" label count))))
|
|||
|
`(("Expected passes: " . ,pass)
|
|||
|
("Expected failures: " . ,xfail)
|
|||
|
("Unexpected passes: " . ,xpass)
|
|||
|
("Unexpected failures: " . ,fail)
|
|||
|
("Errors: " . ,error)))
|
|||
|
(let ((pass? (and (= xpass 0) (= fail 0) (= error 0))))
|
|||
|
(format #t "Result: ~a~%" (if pass? "pass" "fail"))
|
|||
|
pass?))
|
|||
|
((test . rest)
|
|||
|
(match (let ((result (run-test test shell)))
|
|||
|
(newline)
|
|||
|
result)
|
|||
|
('pass (loop rest (1+ pass) fail xpass xfail error))
|
|||
|
('fail (loop rest pass (1+ fail) xpass xfail error))
|
|||
|
('xpass (loop rest pass fail (1+ xpass) xfail error))
|
|||
|
('xfail (loop rest pass fail xpass (1+ xfail) error))
|
|||
|
('error (loop rest pass fail xpass xfail (1+ error))))))))
|
|||
|
|
|||
|
|
|||
|
;;; Main
|
|||
|
|
|||
|
(define (main args)
|
|||
|
(match args
|
|||
|
((_ filename)
|
|||
|
(exit (run-tests (map test-alist->test
|
|||
|
(call-with-input-file filename read-tests))
|
|||
|
"gash")))
|
|||
|
(_ (error "invalid arguments"))))
|
|||
|
|
|||
|
;;; Local Variables:
|
|||
|
;;; mode: scheme
|
|||
|
;;; End:
|