mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
build: test-driver.scm: Make output redirection optional.
This makes it easier (and less surprising) for users to experiment with the custom Scheme test driver directly. The behavior is unchanged from Automake's point of view. * build-aux/test-driver.scm (main): Make the --log-file and --trs-file arguments optional and update doc. Only open, redirect and close a port to a log file when the --log-file option is provided. Only open and close a port to a trs file when the --trs-file option is provided. (test-runner-gnu): Set OUT-PORT parameter default value to the current output port. Set the TRS-PORT parameter default value to a void port. Update doc.
This commit is contained in:
parent
85243d0d63
commit
13f299b2c9
1 changed files with 21 additions and 15 deletions
|
@ -1,8 +1,9 @@
|
||||||
;;;; test-driver.scm - Guile test driver for Automake testsuite harness
|
;;;; test-driver.scm - Guile test driver for Automake testsuite harness
|
||||||
|
|
||||||
(define script-version "2017-03-22.13") ;UTC
|
(define script-version "2021-01-26.20") ;UTC
|
||||||
|
|
||||||
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
|
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
|
||||||
|
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||||
;;;
|
;;;
|
||||||
;;; This program is free software; you can redistribute it and/or modify it
|
;;; This program is free software; you can redistribute it and/or modify it
|
||||||
;;; under the terms of the GNU General Public License as published by
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
@ -35,7 +36,7 @@ (define (show-help)
|
||||||
[--expect-failure={yes|no}] [--color-tests={yes|no}]
|
[--expect-failure={yes|no}] [--color-tests={yes|no}]
|
||||||
[--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
|
[--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
|
||||||
TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
|
TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
|
||||||
The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))
|
The '--test-name' option is mandatory.\n"))
|
||||||
|
|
||||||
(define %options
|
(define %options
|
||||||
'((test-name (value #t))
|
'((test-name (value #t))
|
||||||
|
@ -75,11 +76,14 @@ (define* (result->string symbol #:key colorize?)
|
||||||
"[m") ;no color
|
"[m") ;no color
|
||||||
result)))
|
result)))
|
||||||
|
|
||||||
(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
|
(define* (test-runner-gnu test-name #:key color? brief?
|
||||||
|
(out-port (current-output-port))
|
||||||
|
(trs-port (%make-void-port "w")))
|
||||||
"Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the
|
"Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the
|
||||||
file name of the current the test. COLOR? specifies whether to use colors,
|
file name of the current the test. COLOR? specifies whether to use colors,
|
||||||
and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The
|
and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports.
|
||||||
current output port is supposed to be redirected to a '.log' file."
|
OUT-PORT defaults to the current output port, while TRS-PORT defaults to a
|
||||||
|
void port, which means no TRS output is logged."
|
||||||
|
|
||||||
(define (test-on-test-begin-gnu runner)
|
(define (test-on-test-begin-gnu runner)
|
||||||
;; Procedure called at the start of an individual test case, before the
|
;; Procedure called at the start of an individual test case, before the
|
||||||
|
@ -156,20 +160,22 @@ (define (main . args)
|
||||||
((option 'help #f) (show-help))
|
((option 'help #f) (show-help))
|
||||||
((option 'version #f) (format #t "test-driver.scm ~A" script-version))
|
((option 'version #f) (format #t "test-driver.scm ~A" script-version))
|
||||||
(else
|
(else
|
||||||
(let ((log (open-file (option 'log-file "") "w0"))
|
(let ((log (and=> (option 'log-file #f) (cut open-file <> "w0")))
|
||||||
(trs (open-file (option 'trs-file "") "wl"))
|
(trs (and=> (option 'trs-file #f) (cut open-file <> "wl")))
|
||||||
(out (duplicate-port (current-output-port) "wl")))
|
(out (duplicate-port (current-output-port) "wl"))
|
||||||
|
(test-name (option 'test-name #f)))
|
||||||
|
(when log
|
||||||
(redirect-port log (current-output-port))
|
(redirect-port log (current-output-port))
|
||||||
(redirect-port log (current-warning-port))
|
(redirect-port log (current-warning-port))
|
||||||
(redirect-port log (current-error-port))
|
(redirect-port log (current-error-port)))
|
||||||
(test-with-runner
|
(test-with-runner
|
||||||
(test-runner-gnu (option 'test-name #f)
|
(test-runner-gnu test-name
|
||||||
#:color? (option->boolean opts 'color-tests)
|
#:color? (option->boolean opts 'color-tests)
|
||||||
#:brief? (option->boolean opts 'brief)
|
#:brief? (option->boolean opts 'brief)
|
||||||
#:out-port out #:trs-port trs)
|
#:out-port out #:trs-port trs)
|
||||||
(load-from-path (option 'test-name #f)))
|
(load-from-path test-name))
|
||||||
(close-port log)
|
(and=> log close-port)
|
||||||
(close-port trs)
|
(and=> trs close-port)
|
||||||
(close-port out))))
|
(close-port out))))
|
||||||
(exit 0)))
|
(exit 0)))
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue