[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Ludovic Courtès |
|
Date: |
Sun, 7 Jan 2018 17:59:54 -0500 (EST) |
branch: master
commit 6c163e491617d431149bbe54aa4ba9bef9530c83
Author: Ludovic Courtès <address@hidden>
Date: Sun Jan 7 10:45:06 2018 +0100
build: Update 'test-driver.scm' from Guix.
* build-aux/test-driver.scm: Update from current Guix.
* Makefile.am (SCM_LOG_DRIVER): Add -L and -e flags.
---
Makefile.am | 7 ++--
build-aux/test-driver.scm | 103 +++++++++++++++++++++-------------------------
2 files changed, 51 insertions(+), 59 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 0fff919..3a3740f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -52,9 +52,10 @@ AM_TESTS_ENVIRONMENT = \
testsrcdir='$(abs_top_srcdir)/tests' \
testbuilddir='$(abs_top_builddir)/tests'
-SCM_LOG_DRIVER = \
- $(builddir)/pre-inst-env $(GUILE) \
- $(srcdir)/build-aux/test-driver.scm
+SCM_LOG_DRIVER = \
+ $(top_builddir)/pre-inst-env $(GUILE) \
+ -L "$(abs_top_srcdir)" -e main \
+ $(top_srcdir)/build-aux/test-driver.scm
SH_LOG_COMPILER = $(top_builddir)/pre-inst-env $(SHELL)
AM_SH_LOG_FLAGS = -x -e
diff --git a/build-aux/test-driver.scm b/build-aux/test-driver.scm
index b5529a1..52af1e9 100644
--- a/build-aux/test-driver.scm
+++ b/build-aux/test-driver.scm
@@ -1,8 +1,8 @@
;;;; test-driver.scm - Guile test driver for Automake testsuite harness
-(define script-version "2016-05-11.14") ;UTC
+(define script-version "2017-03-22.13") ;UTC
-;;; Copyright (C) 2015, 2016 Mathieu Lirzin <address@hidden>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <address@hidden>
;;;
;;; 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
@@ -16,11 +16,6 @@
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-;;;
-;;; As a special exception to the GNU General Public License, if you
-;;; distribute this file as part of a program that contains a configuration
-;;; script generated by Autoconf, you may include it under the same
-;;; distribution terms that you use for the rest of that program.
;;;; Commentary:
;;;
@@ -64,7 +59,7 @@ The '--test-name', '--log-file' and '--trs-file' options are
mandatory.\n"))
(begin
(format port "~A:~%" field)
(pretty-print value port #:per-line-prefix "+ "))
- (format port "~A: ~A~%" field value)))
+ (format port "~A: ~S~%" field value)))
(define* (result->string symbol #:key colorize?)
"Return SYMBOL as an upper case string. Use colors when COLORIZE is #t."
@@ -90,10 +85,10 @@ current output port is supposed to be redirected to a
'.log' file."
;; Procedure called at the start of an individual test case, before the
;; test expression (and expected value) are evaluated.
(let ((result (cute assq-ref (test-result-alist runner) <>)))
- (test-display "test-name" (result 'test-name))
- (test-display "location"
- (string-append (result 'source-file) ":"
- (number->string (result 'source-line))))
+ (format #t "test-name: ~A~%" (result 'test-name))
+ (format #t "location: ~A~%"
+ (string-append (result 'source-file) ":"
+ (number->string (result 'source-line))))
(test-display "source" (result 'source-form) #:pretty? #t)))
(define (test-on-test-end-gnu runner)
@@ -104,10 +99,9 @@ current output port is supposed to be redirected to a
'.log' file."
(result (cut assq-ref results <>)))
(unless brief?
;; Display the result of each test case on the console.
- (test-display
- (result->string (test-result-kind runner) #:colorize? color?)
- (string-append test-name " - " (test-runner-test-name runner))
- out-port))
+ (format out-port "~A: ~A - ~A~%"
+ (result->string (test-result-kind runner) #:colorize? color?)
+ test-name (test-runner-test-name runner)))
(when (result? 'expected-value)
(test-display "expected-value" (result 'expected-value)))
(when (result? 'expected-error)
@@ -116,12 +110,11 @@ current output port is supposed to be redirected to a
'.log' file."
(test-display "actual-value" (result 'actual-value)))
(when (result? 'actual-error)
(test-display "actual-error" (result 'actual-error) #:pretty? #t))
- (test-display "result" (result->string (result 'result-kind)))
+ (format #t "result: ~a~%" (result->string (result 'result-kind)))
(newline)
- (test-display ":test-result"
- (string-append (result->string (test-result-kind runner))
- " " (test-runner-test-name runner))
- trs-port)))
+ (format trs-port ":test-result: ~A ~A~%"
+ (result->string (test-result-kind runner))
+ (test-runner-test-name runner))))
(define (test-on-group-end-gnu runner)
;; Procedure called by a 'test-end', including at the end of a test-group.
@@ -130,21 +123,18 @@ current output port is supposed to be redirected to a
'.log' file."
(skip (or (positive? (test-runner-skip-count runner))
(positive? (test-runner-xfail-count runner)))))
;; XXX: The global results need some refinements for XPASS.
- (test-display ":global-test-result"
- (if fail "FAIL" (if skip "SKIP" "PASS"))
- trs-port)
- (test-display ":recheck"
- (if fail "yes" "no")
- trs-port)
- (test-display ":copy-in-global-log"
- (if (or fail skip) "yes" "no")
- trs-port)
+ (format trs-port ":global-test-result: ~A~%"
+ (if fail "FAIL" (if skip "SKIP" "PASS")))
+ (format trs-port ":recheck: ~A~%"
+ (if fail "yes" "no"))
+ (format trs-port ":copy-in-global-log: ~A~%"
+ (if (or fail skip) "yes" "no"))
(when brief?
;; Display the global test group result on the console.
- (test-display (result->string (if fail 'fail (if skip 'skip 'pass))
- #:colorize? color?)
- test-name
- out-port))
+ (format out-port "~A: ~A~%"
+ (result->string (if fail 'fail (if skip 'skip 'pass))
+ #:colorize? color?)
+ test-name))
#f))
(let ((runner (test-runner-null)))
@@ -159,28 +149,29 @@ current output port is supposed to be redirected to a
'.log' file."
;;; Entry point.
;;;
-(let* ((opts (getopt-long (command-line) %options))
- (option (cut option-ref opts <> <>)))
- (cond
- ((option 'help #f) (show-help))
- ((option 'version #f) (format #t "test-driver.scm ~A~%" script-version))
- (else
- (let ((log (open-file (option 'log-file "") "w0"))
- (trs (open-file (option 'trs-file "") "wl"))
- (out (duplicate-port (current-output-port) "wl")))
- (redirect-port log (current-output-port))
- (redirect-port log (current-warning-port))
- (redirect-port log (current-error-port))
- (test-with-runner
- (test-runner-gnu (option 'test-name #f)
- #:color? (option->boolean opts 'color-tests)
- #:brief? (option->boolean opts 'brief)
- #:out-port out #:trs-port trs)
- (load (string-append (getcwd) "/" (car (option '() '(""))))))
- (close-port log)
- (close-port trs)
- (close-port out))))
- (exit 0))
+(define (main . args)
+ (let* ((opts (getopt-long (command-line) %options))
+ (option (cut option-ref opts <> <>)))
+ (cond
+ ((option 'help #f) (show-help))
+ ((option 'version #f) (format #t "test-driver.scm ~A" script-version))
+ (else
+ (let ((log (open-file (option 'log-file "") "w0"))
+ (trs (open-file (option 'trs-file "") "wl"))
+ (out (duplicate-port (current-output-port) "wl")))
+ (redirect-port log (current-output-port))
+ (redirect-port log (current-warning-port))
+ (redirect-port log (current-error-port))
+ (test-with-runner
+ (test-runner-gnu (option 'test-name #f)
+ #:color? (option->boolean opts 'color-tests)
+ #:brief? (option->boolean opts 'brief)
+ #:out-port out #:trs-port trs)
+ (load-from-path (option 'test-name #f)))
+ (close-port log)
+ (close-port trs)
+ (close-port out))))
+ (exit 0)))
;;; Local Variables:
;;; eval: (add-hook 'write-file-functions 'time-stamp)