diff options
Diffstat (limited to 'build-aux')
| -rw-r--r-- | build-aux/build-self.scm | 3 | ||||
| -rwxr-xr-x[-rw-r--r--] | build-aux/test-driver.scm | 184 |
2 files changed, 145 insertions, 42 deletions
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index 4b6e2bfae5..d5bc5fb46e 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -245,8 +245,11 @@ interface (FFI) of Guile.") "Return a program that computes the derivation to build Guix from SOURCE." (define select? ;; Select every module but (guix config) and non-Guix modules. + ;; Also exclude (guix channels): it is autoloaded by (guix describe), but + ;; only for peripheral functionality. (match-lambda (('guix 'config) #f) + (('guix 'channels) #f) (('guix _ ...) #t) (('gnu _ ...) #t) (_ #f))) diff --git a/build-aux/test-driver.scm b/build-aux/test-driver.scm index 52af1e9be7..1cdd4ff8f7 100644..100755 --- a/build-aux/test-driver.scm +++ b/build-aux/test-driver.scm @@ -1,8 +1,12 @@ +#!/bin/sh +exec guile --no-auto-compile -e main -s "$0" "$@" +!# ;;;; test-driver.scm - Guile test driver for Automake testsuite harness -(define script-version "2017-03-22.13") ;UTC +(define script-version "2021-02-02.05") ;UTC ;;; 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 ;;; under the terms of the GNU General Public License as published by @@ -24,8 +28,12 @@ ;;; ;;;; Code: -(use-modules (ice-9 getopt-long) +(use-modules (ice-9 format) + (ice-9 getopt-long) (ice-9 pretty-print) + (ice-9 regex) + (srfi srfi-1) + (srfi srfi-19) (srfi srfi-26) (srfi srfi-64)) @@ -33,18 +41,30 @@ (display "Usage: test-driver --test-name=NAME --log-file=PATH --trs-file=PATH [--expect-failure={yes|no}] [--color-tests={yes|no}] - [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--] + [--select=REGEXP] [--exclude=REGEXP] [--errors-only={yes|no}] + [--enable-hard-errors={yes|no}] [--brief={yes|no}}] + [--show-duration={yes|no}] [--] TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] -The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n")) +The '--test-name' option is mandatory. The '--select' and '--exclude' options +allow selecting or excluding individual test cases via a regexp, respectively. +The '--errors-only' option can be set to \"yes\" to limit the logged test case +metadata to only those test cases that failed. When set to \"yes\", the +'--brief' option disables printing the individual test case result to the +console. When '--show-duration' is set to \"yes\", the time elapsed per test +case is shown.\n")) (define %options '((test-name (value #t)) (log-file (value #t)) (trs-file (value #t)) + (select (value #t)) + (exclude (value #t)) + (errors-only (value #t)) (color-tests (value #t)) (expect-failure (value #t)) ;XXX: not implemented yet (enable-hard-errors (value #t)) ;not implemented in SRFI-64 (brief (value #t)) + (show-duration (value #t)) (help (single-char #\h) (value #f)) (version (single-char #\V) (value #f)))) @@ -75,46 +95,81 @@ The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n")) "[m") ;no color result))) -(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port) + +;;; +;;; SRFI 64 custom test runner. +;;; + +(define* (test-runner-gnu test-name #:key color? brief? errors-only? + show-duration? + (out-port (current-output-port)) + (trs-port (%make-void-port "w")) + select exclude) "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, -and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The -current output port is supposed to be redirected to a '.log' file." +file name of the current the test. COLOR? specifies whether to use colors. +When BRIEF? is true, the individual test cases results are masked and only the +summary is shown. ERRORS-ONLY? reduces the amount of test case metadata +logged to only that of the failed test cases. OUT-PORT and TRS-PORT must be +output ports. OUT-PORT defaults to the current output port, while TRS-PORT +defaults to a void port, which means no TRS output is logged. SELECT and +EXCLUDE may take a regular expression to select or exclude individual test +cases based on their names." + + (define test-cases-start-time (make-hash-table)) (define (test-on-test-begin-gnu runner) ;; 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) <>))) - (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))) + (let ((test-case-name (test-runner-test-name runner)) + (start-time (current-time time-monotonic))) + (hash-set! test-cases-start-time test-case-name start-time))) + + (define (test-skipped? runner) + (eq? 'skip (test-result-kind runner))) + + (define (test-failed? runner) + (not (or (test-passed? runner) + (test-skipped? runner)))) (define (test-on-test-end-gnu runner) ;; Procedure called at the end of an individual test case, when the result ;; of the test is available. (let* ((results (test-result-alist runner)) (result? (cut assq <> results)) - (result (cut assq-ref results <>))) - (unless brief? + (result (cut assq-ref results <>)) + (test-case-name (test-runner-test-name runner)) + (start (hash-ref test-cases-start-time test-case-name)) + (end (current-time time-monotonic)) + (time-elapsed (time-difference end start)) + (time-elapsed-seconds (+ (time-second time-elapsed) + (* 1e-9 (time-nanosecond time-elapsed))))) + (unless (or brief? (and errors-only? (test-skipped? runner))) ;; Display the result of each test case on the console. - (format out-port "~A: ~A - ~A~%" + (format out-port "~a: ~a - ~a ~@[[~,3fs]~]~%" (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) - (test-display "expected-error" (result 'expected-error) #:pretty? #t)) - (when (result? 'actual-value) - (test-display "actual-value" (result 'actual-value))) - (when (result? 'actual-error) - (test-display "actual-error" (result 'actual-error) #:pretty? #t)) - (format #t "result: ~a~%" (result->string (result 'result-kind))) - (newline) - (format trs-port ":test-result: ~A ~A~%" + test-name test-case-name + (and show-duration? time-elapsed-seconds))) + + (unless (and errors-only? (not (test-failed? runner))) + (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) + (when (result? 'expected-value) + (test-display "expected-value" (result 'expected-value))) + (when (result? 'expected-error) + (test-display "expected-error" (result 'expected-error) #:pretty? #t)) + (when (result? 'actual-value) + (test-display "actual-value" (result 'actual-value))) + (when (result? 'actual-error) + (test-display "actual-error" (result 'actual-error) #:pretty? #t)) + (format #t "result: ~a~%" (result->string (result 'result-kind))) + (newline)) + + (format trs-port ":test-result: ~A ~A [~,3fs]~%" (result->string (test-result-kind runner)) - (test-runner-test-name runner)))) + (test-runner-test-name runner) time-elapsed-seconds))) (define (test-on-group-end-gnu runner) ;; Procedure called by a 'test-end', including at the end of a test-group. @@ -146,6 +201,34 @@ current output port is supposed to be redirected to a '.log' file." ;;; +;;; SRFI 64 test specifiers. +;;; +(define (test-match-name* regexp) + "Return a test specifier that matches a test name against REGEXP." + (lambda (runner) + (string-match regexp (test-runner-test-name runner)))) + +(define (test-match-name*/negated regexp) + "Return a negated test specifier version of test-match-name*." + (lambda (runner) + (not (string-match regexp (test-runner-test-name runner))))) + +;;; XXX: test-match-all is a syntax, which isn't convenient to use with a list +;;; of test specifiers computed at run time. Copy this SRFI 64 internal +;;; definition here, which is the procedural equivalent of 'test-match-all'. +(define (%test-match-all . pred-list) + (lambda (runner) + (let ((result #t)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if (not ((car l) runner)) + (set! result #f)) + (loop (cdr l)))))))) + + +;;; ;;; Entry point. ;;; @@ -154,22 +237,39 @@ current output port is supposed to be redirected to a '.log' file." (option (cut option-ref opts <> <>))) (cond ((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 - (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)) + (let* ((log (and=> (option 'log-file #f) (cut open-file <> "w0"))) + (trs (and=> (option 'trs-file #f) (cut open-file <> "wl"))) + (out (duplicate-port (current-output-port) "wl")) + (test-name (option 'test-name #f)) + (select (option 'select #f)) + (exclude (option 'exclude #f)) + (test-specifiers (filter-map + identity + (list (and=> select test-match-name*) + (and=> exclude test-match-name*/negated)))) + (test-specifier (apply %test-match-all test-specifiers)) + (color-tests (if (assoc 'color-tests opts) + (option->boolean opts 'color-tests) + #t))) + (when log + (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) + (test-runner-gnu test-name + #:color? color-tests #:brief? (option->boolean opts 'brief) + #:errors-only? (option->boolean opts 'errors-only) + #:show-duration? (option->boolean + opts 'show-duration) #:out-port out #:trs-port trs) - (load-from-path (option 'test-name #f))) - (close-port log) - (close-port trs) + (test-apply test-specifier + (lambda _ + (load-from-path test-name)))) + (and=> log close-port) + (and=> trs close-port) (close-port out)))) (exit 0))) |