ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 13:58:15 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

build: test-driver.scm: Make output redirection optional.

Browse source 
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:
Maxim Cournoyer 2021-01-16 14:54:27 -05:00
parent 85243d0d63
commit 13f299b2c9
No known key found for this signature in database
GPG key ID: 1260E46482E63562
1 changed files with 21 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
build-aux/test-driver.scm
View file

@ -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?)
"") ;no color "") ;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"))
(redirect-port log (current-output-port)) (test-name (option 'test-name #f)))
(redirect-port log (current-warning-port)) (when log
(redirect-port log (current-error-port)) (redirect-port log (current-output-port))
(redirect-port log (current-warning-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)))