Skip to content

Commit e546c22

Browse files
wedesoftwedesoft
committed
Readd test-driver.scm
1 parent cb0816f commit e546c22

File tree

3 files changed

+201
-4
lines changed

3 files changed

+201
-4
lines changed

‎autogen.sh

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,9 @@
11
#!/bin/sh
22
git log > ChangeLog
3-
mkdir -p build-aux
4-
touch build-aux/config.rpath
5-
autoreconf -i
3+
# mkdir -p build-aux
4+
# touch build-aux/config.rpath
5+
aclocal -I m4
6+
autoheader
7+
libtoolize --force
8+
automake -a --foreign
9+
autoconf

‎build-aux/test-driver.scm

Lines changed: 194 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,194 @@
1+
2+
;;;; test-driver.scm - Guile test driver for Automake testsuite harness
3+
4+
(define script-version "2016-05-11.14") ;UTC
5+
6+
;;; Copyright (C) 2015, 2016 Mathieu Lirzin <[email protected]>
7+
;;;
8+
;;; This program is free software; you can redistribute it and/or modify it
9+
;;; under the terms of the GNU General Public License as published by
10+
;;; the Free Software Foundation; either version 3 of the License, or (at
11+
;;; your option) any later version.
12+
;;;
13+
;;; This program is distributed in the hope that it will be useful, but
14+
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15+
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16+
;;; GNU General Public License for more details.
17+
;;;
18+
;;; You should have received a copy of the GNU General Public License
19+
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
20+
;;;
21+
;;; As a special exception to the GNU General Public License, if you
22+
;;; distribute this file as part of a program that contains a configuration
23+
;;; script generated by Autoconf, you may include it under the same
24+
;;; distribution terms that you use for the rest of that program.
25+
26+
;;;; Commentary:
27+
;;;
28+
;;; This script provides a Guile test driver using the SRFI-64 Scheme API for
29+
;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9.
30+
;;;
31+
;;;; Code:
32+
33+
(use-modules (ice-9 getopt-long)
34+
(ice-9 pretty-print)
35+
(srfi srfi-26)
36+
(srfi srfi-64))
37+
38+
(define (show-help)
39+
(display "Usage:
40+
test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
41+
[--expect-failure={yes|no}] [--color-tests={yes|no}]
42+
[--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
43+
TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
44+
The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))
45+
46+
(define %options
47+
'((test-name (value #t))
48+
(log-file (value #t))
49+
(trs-file (value #t))
50+
(color-tests (value #t))
51+
(expect-failure (value #t)) ;XXX: not implemented yet
52+
(enable-hard-errors (value #t)) ;not implemented in SRFI-64
53+
(brief (value #t))
54+
(help (single-char #\h) (value #f))
55+
(version (single-char #\V) (value #f))))
56+
57+
(define (option->boolean options key)
58+
"Return #t if the value associated with KEY in OPTIONS is \"yes\"."
59+
(and=> (option-ref options key #f) (cut string=? <> "yes")))
60+
61+
(define* (test-display field value #:optional (port (current-output-port))
62+
#:key pretty?)
63+
"Display \"FIELD: VALUE\\n\" on PORT."
64+
(if pretty?
65+
(begin
66+
(format port "~A:~%" field)
67+
(pretty-print value port #:per-line-prefix "+ "))
68+
(format port "~A: ~A~%" field value)))
69+
70+
(define* (result->string symbol #:key colorize?)
71+
"Return SYMBOL as an upper case string. Use colors when COLORIZE is #t."
72+
(let ((result (string-upcase (symbol->string symbol))))
73+
(if colorize?
74+
(string-append (case symbol
75+
((pass) "") ;green
76+
((xfail) "") ;light green
77+
((skip) "") ;blue
78+
((fail xpass) "") ;red
79+
((error) "")) ;magenta
80+
result
81+
"") ;no color
82+
result)))
83+
84+
(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
85+
"Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the
86+
file name of the current the test. COLOR? specifies whether to use colors,
87+
and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The
88+
current output port is supposed to be redirected to a '.log' file."
89+
90+
(define (test-on-test-begin-gnu runner)
91+
;; Procedure called at the start of an individual test case, before the
92+
;; test expression (and expected value) are evaluated.
93+
(let ((result (cute assq-ref (test-result-alist runner) <>)))
94+
(test-display "test-name" (result 'test-name))
95+
(test-display "location"
96+
(string-append (result 'source-file) ":"
97+
(number->string (result 'source-line))))
98+
(test-display "source" (result 'source-form) #:pretty? #t)))
99+
100+
(define (test-on-test-end-gnu runner)
101+
;; Procedure called at the end of an individual test case, when the result
102+
;; of the test is available.
103+
(let* ((results (test-result-alist runner))
104+
(result? (cut assq <> results))
105+
(result (cut assq-ref results <>)))
106+
(unless brief?
107+
;; Display the result of each test case on the console.
108+
(test-display
109+
(result->string (test-result-kind runner) #:colorize? color?)
110+
(string-append test-name " - " (test-runner-test-name runner))
111+
out-port))
112+
(when (result? 'expected-value)
113+
(test-display "expected-value" (result 'expected-value)))
114+
(when (result? 'expected-error)
115+
(test-display "expected-error" (result 'expected-error) #:pretty? #t))
116+
(when (result? 'actual-value)
117+
(test-display "actual-value" (result 'actual-value)))
118+
(when (result? 'actual-error)
119+
(test-display "actual-error" (result 'actual-error) #:pretty? #t))
120+
(test-display "result" (result->string (result 'result-kind)))
121+
(newline)
122+
(test-display ":test-result"
123+
(string-append (result->string (test-result-kind runner))
124+
" " (test-runner-test-name runner))
125+
trs-port)))
126+
127+
(define (test-on-group-end-gnu runner)
128+
;; Procedure called by a 'test-end', including at the end of a test-group.
129+
(let ((fail (or (positive? (test-runner-fail-count runner))
130+
(positive? (test-runner-xpass-count runner))))
131+
(skip (or (positive? (test-runner-skip-count runner))
132+
(positive? (test-runner-xfail-count runner)))))
133+
;; XXX: The global results need some refinements for XPASS.
134+
(test-display ":global-test-result"
135+
(if fail "FAIL" (if skip "SKIP" "PASS"))
136+
trs-port)
137+
(test-display ":recheck"
138+
(if fail "yes" "no")
139+
trs-port)
140+
(test-display ":copy-in-global-log"
141+
(if (or fail skip) "yes" "no")
142+
trs-port)
143+
(when brief?
144+
;; Display the global test group result on the console.
145+
(test-display (result->string (if fail 'fail (if skip 'skip 'pass))
146+
#:colorize? color?)
147+
test-name
148+
out-port))
149+
#f))
150+
151+
(let ((runner (test-runner-null)))
152+
(test-runner-on-test-begin! runner test-on-test-begin-gnu)
153+
(test-runner-on-test-end! runner test-on-test-end-gnu)
154+
(test-runner-on-group-end! runner test-on-group-end-gnu)
155+
(test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
156+
runner))
157+
158+
159+
;;;
160+
;;; Entry point.
161+
;;;
162+
163+
(let* ((opts (getopt-long (command-line) %options))
164+
(option (cut option-ref opts <> <>)))
165+
(cond
166+
((option 'help #f) (show-help))
167+
((option 'version #f) (format #t "test-driver.scm ~A~%" script-version))
168+
(else
169+
(let ((log (open-file (option 'log-file "") "w0"))
170+
(trs (open-file (option 'trs-file "") "wl"))
171+
(out (duplicate-port (current-output-port) "wl")))
172+
(redirect-port log (current-output-port))
173+
(redirect-port log (current-warning-port))
174+
(redirect-port log (current-error-port))
175+
(test-with-runner
176+
(test-runner-gnu (option 'test-name #f)
177+
#:color? (option->boolean opts 'color-tests)
178+
#:brief? (option->boolean opts 'brief)
179+
#:out-port out #:trs-port trs)
180+
(load (string-append (getcwd) "/" (car (option '() '(""))))))
181+
(close-port log)
182+
(close-port trs)
183+
(close-port out))))
184+
(exit 0))
185+
186+
;;; Local Variables:
187+
;;; eval: (add-hook 'write-file-functions 'time-stamp)
188+
;;; time-stamp-start: "(define script-version \""
189+
;;; time-stamp-format: "%:y-%02m-%02d.%02H"
190+
;;; time-stamp-time-zone: "UTC"
191+
;;; time-stamp-end: "\") ;UTC"
192+
;;; End:
193+
194+
;;;; test-driver.scm ends here.

‎configure.ac

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,6 @@ AC_PREREQ([2.69])
55
AC_INIT([aiscm], [0.26.1], [[email protected]])
66
DATE=2023-02-14
77
AC_SUBST(DATE)
8-
AM_CONFIG_AUX_DIR([build-aux])
98
AM_INIT_AUTOMAKE([--warnings=no-portability foreign])
109
AC_CONFIG_MACRO_DIR([m4])
1110
AC_REQUIRE_AUX_FILE([test-driver.scm])

0 commit comments

Comments
 (0)