2 exec guile
--no-auto-compile -e main
-s "$0" "$@"
4 ;;;; test-driver.scm
- Guile
test driver
for Automake testsuite harness
6 (define script-version
"2021-02-02.05") ;UTC
8 ;;; Copyright ©
2015, 2016 Mathieu Lirzin
<mthl@gnu.org
>
9 ;;; Copyright ©
2021 Maxim Cournoyer
<maxim.cournoyer@gmail.com
>
11 ;;; This program is free software
; you can redistribute it and
/or modify it
12 ;;; under the terms of the GNU General Public License as published by
13 ;;; the Free Software Foundation
; either version
3 of the License
, or
(at
14 ;;; your option
) any later version.
16 ;;; This program is distributed
in the hope that it will be useful
, but
17 ;;; WITHOUT ANY WARRANTY
; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;;; GNU General Public License
for more details.
21 ;;; You should have received a copy of the GNU General Public License
22 ;;; along with this program. If not
, see
<http
://www.gnu.org
/licenses
/>.
26 ;;; This
script provides a Guile
test driver using the SRFI-64 Scheme API
for
27 ;;; test suites. SRFI-64 is distributed with Guile since version
2.0.9.
31 (use-modules
(ice-9 format
)
42 test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
43 [--expect-failure={yes|no}] [--color-tests={yes|no}]
44 [--select=REGEXP] [--exclude=REGEXP] [--errors-only={yes|no}]
45 [--enable-hard-errors={yes|no}] [--brief={yes|no}}]
46 [--show-duration={yes|no}] [--]
47 TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
48 The '--test-name' option is mandatory. The '--select' and '--exclude' options
49 allow selecting or excluding individual test cases via a regexp, respectively.
50 The '--errors-only' option can be set to \"yes\" to limit the logged test case
51 metadata to only those test cases that failed. When set to \"yes\", the
52 '--brief' option disables printing the individual test case result to the
53 console. When '--show-duration' is set to \"yes\", the time elapsed per test
57 '((test-name (value #t))
62 (errors-only (value #t))
63 (color-tests (value #t))
64 (expect-failure (value #t)) ;XXX: not implemented yet
65 (enable-hard-errors (value #t)) ;not implemented in SRFI-64
67 (show-duration (value #t))
68 (help (single-char #\h) (value #f))
69 (version (single-char #\V) (value #f))))
71 (define (option->boolean options key)
72 "Return #t if the value associated with KEY in OPTIONS is \"yes\"."
73 (and=> (option-ref options key #f) (cut string=? <> "yes")))
75 (define* (test-display field value #:optional (port (current-output-port))
77 "Display \"FIELD: VALUE\\n\" on PORT."
80 (format port "~A:~%" field)
81 (pretty-print value port #:per-line-prefix "+ "))
82 (format port "~A: ~S~%" field value)))
84 (define* (result->string symbol #:key colorize?)
85 "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t."
86 (let ((result (string-upcase (symbol->string symbol))))
88 (string-append (case symbol
89 ((pass) "\e[0;32m") ;green
90 ((xfail) "\e[1;32m") ;light green
91 ((skip) "\e[1;34m") ;blue
92 ((fail xpass) "\e[0;31m") ;red
93 ((error) "\e[0;35m")) ;magenta
100 ;;; SRFI 64 custom test runner.
103 (define* (test-runner-gnu test-name #:key color? brief? errors-only?
105 (out-port (current-output-port))
106 (trs-port (%make-void-port "w"))
108 "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the
109 file name of the current the test. COLOR? specifies whether to use colors.
110 When BRIEF? is true, the individual test cases results are masked and only the
111 summary is shown. ERRORS-ONLY? reduces the amount of test case metadata
112 logged to only that of the failed test cases. OUT-PORT and TRS-PORT must be
113 output ports. OUT-PORT defaults to the current output port, while TRS-PORT
114 defaults to a void port, which means no TRS output is logged. SELECT and
115 EXCLUDE may take a regular expression to select or exclude individual test
116 cases based on their names."
118 (define test-cases-start-time (make-hash-table))
120 (define (test-on-test-begin-gnu runner)
121 ;; Procedure called at the start of an individual test case, before the
122 ;; test expression (and expected value) are evaluated.
123 (let ((test-case-name (test-runner-test-name runner))
124 (start-time (current-time time-monotonic)))
125 (hash-set! test-cases-start-time test-case-name start-time)))
127 (define (test-skipped? runner)
128 (eq? 'skip
(test-result-kind runner
)))
130 (define
(test-failed? runner
)
131 (not
(or
(test-passed? runner
)
132 (test-skipped? runner
))))
134 (define
(test-on-test-end-gnu runner
)
135 ;; Procedure called
at the end of an individual
test case, when the result
136 ;; of the
test is available.
137 (let* ((results
(test-result-alist runner
))
138 (result?
(cut assq
<> results
))
139 (result
(cut assq-ref results
<>))
140 (test-case-name
(test-runner-test-name runner
))
141 (start
(hash-ref test-cases-start-time test-case-name
))
142 (end
(current-time time-monotonic
))
143 (time-elapsed
(time-difference end start
))
144 (time-elapsed-seconds
(+ (time-second time-elapsed
)
145 (* 1e-9 (time-nanosecond time-elapsed
)))))
146 (unless
(or brief?
(and errors-only?
(test-skipped? runner
)))
147 ;; Display the result of each
test case on the console.
148 (format out-port
"~a: ~a - ~a ~@[[~,3fs]~]~%"
149 (result-
>string
(test-result-kind runner
) #:colorize? color?)
150 test-name test-case-name
151 (and show-duration? time-elapsed-seconds
)))
153 (unless
(and errors-only?
(not
(test-failed? runner
)))
154 (format
#t "test-name: ~A~%" (result 'test-name))
155 (format
#t "location: ~A~%"
156 (string-append
(result
'source-file) ":"
157 (number->string (result 'source-line
))))
158 (test-display
"source" (result
'source-form) #:pretty? #t)
159 (when (result? 'expected-value
)
160 (test-display
"expected-value" (result
'expected-value)))
161 (when (result? 'expected-error
)
162 (test-display
"expected-error" (result
'expected-error) #:pretty? #t))
163 (when (result? 'actual-value
)
164 (test-display
"actual-value" (result
'actual-value)))
165 (when (result? 'actual-error
)
166 (test-display
"actual-error" (result
'actual-error) #:pretty? #t))
167 (format #t "result: ~a~%" (result->string (result 'result-kind
)))
170 (format trs-port
":test-result: ~A ~A [~,3fs]~%"
171 (result-
>string
(test-result-kind runner
))
172 (test-runner-test-name runner
) time-elapsed-seconds
)))
174 (define
(test-on-group-end-gnu runner
)
175 ;; Procedure called by a
'test-end', including
at the end of a test-group.
176 (let ((fail
(or
(positive?
(test-runner-fail-count runner
))
177 (positive?
(test-runner-xpass-count runner
))))
178 (skip
(or
(positive?
(test-runner-skip-count runner
))
179 (positive?
(test-runner-xfail-count runner
)))))
180 ;; XXX
: The global results need some refinements
for XPASS.
181 (format trs-port
":global-test-result: ~A~%"
182 (if fail
"FAIL" (if skip
"SKIP" "PASS")))
183 (format trs-port
":recheck: ~A~%"
184 (if fail
"yes" "no"))
185 (format trs-port
":copy-in-global-log: ~A~%"
186 (if (or fail skip
) "yes" "no"))
188 ;; Display the global
test group result on the console.
189 (format out-port
"~A: ~A~%"
190 (result-
>string
(if fail
'fail (if skip 'skip
'pass))
195 (let ((runner (test-runner-null)))
196 (test-runner-on-test-begin! runner test-on-test-begin-gnu)
197 (test-runner-on-test-end! runner test-on-test-end-gnu)
198 (test-runner-on-group-end! runner test-on-group-end-gnu)
199 (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
204 ;;; SRFI 64 test specifiers.
206 (define (test-match-name* regexp)
207 "Return a test specifier that matches a test name against REGEXP."
209 (string-match regexp (test-runner-test-name runner))))
211 (define (test-match-name*/negated regexp)
212 "Return a negated test specifier version of test-match-name*."
214 (not (string-match regexp (test-runner-test-name runner)))))
216 ;;; XXX: test-match-all is a syntax, which isn't convenient to use with a list
217 ;;; of
test specifiers computed
at run
time. Copy this SRFI
64 internal
218 ;;; definition here
, which is the procedural equivalent of
'test-match-all'.
219 (define
(%test-match-all . pred-list
)
222 (let loop
((l pred-list
))
226 (if (not
((car l
) runner
))
235 (define
(main . args
)
236 (let* ((opts
(getopt-long
(command-line
) %options
))
237 (option
(cut option-ref opts
<> <>)))
239 ((option
'help #f) (show-help))
240 ((option 'version
#f) (format #t "test-driver.scm ~A~%" script-version))
242 (let* ((log
(and
=> (option
'log-file #f) (cut open-file <> "w0")))
243 (trs (and=> (option 'trs-file
#f) (cut open-file <> "wl")))
244 (out
(duplicate-port
(current-output-port
) "wl"))
245 (test-name
(option
'test-name #f))
246 (select (option 'select #f))
247 (exclude
(option
'exclude #f))
248 (test-specifiers (filter-map
250 (list (and=> select test-match-name*)
251 (and=> exclude test-match-name*/negated))))
252 (test-specifier (apply %test-match-all test-specifiers))
253 (color-tests (if (assoc 'color-tests opts
)
254 (option-
>boolean opts
'color-tests)
257 (redirect-port log (current-output-port))
258 (redirect-port log (current-warning-port))
259 (redirect-port log (current-error-port)))
261 (test-runner-gnu test-name
263 #:brief? (option->boolean opts 'brief
)
264 #:errors-only? (option->boolean opts 'errors-only)
265 #:show-duration? (option->boolean
267 #:out-port out #:trs-port trs)
268 (test-apply test-specifier
270 (load-from-path test-name))))
271 (and=> log close-port)
272 (and=> trs close-port)
277 ;;; eval: (add-hook 'write-file-functions
'time-stamp)
278 ;;; time-stamp-start: "(define script-version \""
279 ;;; time-stamp-format: "%:y-%02m-%02d.%02H"
280 ;;; time-stamp-time-zone: "UTC"
281 ;;; time-stamp-end: "\") ;UTC"
284 ;;;; test-driver.scm ends here.