5
;;;; guile-test --- run the Guile test suite
6
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
8
;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
10
;;;; This program is free software; you can redistribute it and/or modify
11
;;;; it under the terms of the GNU General Public License as published by
12
;;;; the Free Software Foundation; either version 2, or (at your option)
13
;;;; any later version.
15
;;;; This program is distributed in the hope that it will be useful,
16
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18
;;;; GNU General Public License for more details.
20
;;;; You should have received a copy of the GNU General Public License
21
;;;; along with this software; see the file COPYING. If not, write to
22
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23
;;;; Boston, MA 02110-1301 USA
26
;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...]
28
;;;; Run tests from the Guile test suite. Report failures and
29
;;;; unexpected passes to the standard output, along with a summary of
30
;;;; all the results. Record each reported test outcome in the log
31
;;;; file, `guile.log'. The exit status is #f if any of the tests
32
;;;; fail or pass unexpectedly.
34
;;;; Normally, guile-test scans the test directory, and executes all
35
;;;; files whose names end in `.test'. (It assumes they contain
36
;;;; Scheme code.) However, you can have it execute specific tests by
37
;;;; listing their filenames on the command line.
39
;;;; The option `--test-suite' can be given to specify the test
40
;;;; directory. If no such option is given, the test directory is
41
;;;; taken from the environment variable TEST_SUITE_DIR (if defined),
42
;;;; otherwise a default directory that is hardcoded in this file is
43
;;;; used (see "Installation" below).
45
;;;; If present, the `--log-file LOG' option tells `guile-test' to put
46
;;;; the log output in a file named LOG.
48
;;;; If present, the `--debug' option will enable a debugging mode.
50
;;;; If present, the `--flag-unresolved' option will cause guile-test
51
;;;; to exit with failure status if any tests are UNRESOLVED.
56
;;;; If you change the #! line at the top of this script to point at
57
;;;; the Guile interpreter you want to test, you can call this script
58
;;;; as an executable instead of having to pass it as a parameter to
59
;;;; guile via "guile -e main -s guile-test". Further, you can edit
60
;;;; the definition of default-test-suite to point to the parent
61
;;;; directory of the `tests' tree, which makes it unnecessary to set
62
;;;; the environment variable `TEST_SUITE_DIR'.
67
;;;; At the moment, due to a simple-minded implementation, test files
68
;;;; must live in the test directory, and you must specify their names
69
;;;; relative to the top of the test directory. If you want to send
70
;;;; me a patch that fixes this, but still leaves sane test names in
71
;;;; the log file, that would be great. At the moment, all the tests
72
;;;; I care about are in the test directory, though.
74
;;;; It would be nice if you could specify the Guile interpreter you
75
;;;; want to test on the command line. As it stands, if you want to
76
;;;; change which Guile interpreter you're testing, you need to edit
77
;;;; the #! line at the top of this file, which is stupid.
80
(let ((module (resolve-module '(test-suite guile-test))))
81
(apply (module-ref module 'main) args)))
83
(define-module (test-suite guile-test)
84
:use-module (test-suite lib)
85
:use-module (ice-9 getopt-long)
86
:use-module (ice-9 and-let-star)
87
:use-module (ice-9 rdelim)
88
:export (main data-file-name test-file-name))
91
;;; User configurable settings:
92
(define default-test-suite
93
(string-append (getenv "HOME") "/bogus-path/test-suite"))
96
;;; Variables that will receive their actual values later.
97
(define test-suite default-test-suite)
102
;;; General utilities, that probably should be in a library somewhere.
105
(define (enable-debug-mode)
106
(write-line %load-path)
107
(set! %load-verbosely #t)
108
(debug-enable 'backtrace 'debug))
110
;;; Traverse the directory tree at ROOT, applying F to the name of
111
;;; each file in the tree, including ROOT itself. For a subdirectory
112
;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow
114
(define (for-each-file f root)
116
;; A "hard directory" is a path that denotes a directory and is not a
118
(define (file-is-hard-directory? filename)
119
(eq? (stat:type (lstat filename)) 'directory))
121
(let visit ((root root))
122
(let ((should-recur (f root)))
123
(if (and should-recur (file-is-hard-directory? root))
124
(let ((dir (opendir root)))
126
(let ((entry (readdir dir)))
128
((eof-object? entry) #f)
129
((or (string=? entry ".")
130
(string=? entry "..")
131
(string=? entry "CVS")
132
(string=? entry "RCS"))
135
(visit (string-append root "/" entry))
142
;;; Localizing test files and temporary data files.
144
(define (data-file-name filename)
145
(in-vicinity tmp-dir filename))
147
(define (test-file-name test)
148
(in-vicinity test-suite test))
150
;;; Return a list of all the test files in the test tree.
151
(define (enumerate-tests test-dir)
152
(let ((root-len (+ 1 (string-length test-dir)))
154
(for-each-file (lambda (file)
155
(if (has-suffix? file ".test")
157
(substring file root-len)))
158
(set! tests (cons short-name tests))))
162
;; for-each-file presents the files in whatever order it finds
163
;; them in the directory. We sort them here, so they'll always
164
;; appear in the same order. This makes it easier to compare test
165
;; log files mechanically.
166
(sort tests string<?)))
169
(let ((options (getopt-long args
179
(single-char #\d))))))
180
(define (opt tag default)
181
(let ((pair (assq tag options)))
182
(if pair (cdr pair) default)))
188
(or (opt 'test-suite #f)
189
(getenv "TEST_SUITE_DIR")
192
;; directory where temporary files are created.
193
;; when run from "make check", this must be under the build-dir,
195
(set! tmp-dir (getcwd))
198
(let ((foo (opt '() '())))
200
(enumerate-tests test-suite)
203
(opt 'log-file "guile.log")))
205
;; Open the log file.
206
(let ((log-port (open-output-file log-file)))
208
;; Register some reporters.
209
(let ((global-pass #t)
210
(counter (make-count-reporter)))
211
(register-reporter (car counter))
212
(register-reporter (make-log-reporter log-port))
213
(register-reporter user-reporter)
214
(register-reporter (lambda results
217
(and (opt 'flag-unresolved #f)
218
(set! global-pass #f)))
220
(set! global-pass #f)))))
223
(for-each (lambda (test)
224
(display (string-append "Running " test "\n"))
225
(with-test-prefix test
226
(load (test-file-name test))))
229
;; Display the final counts, both to the user and in the log
231
(let ((counts ((cadr counter))))
232
(print-counts counts)
233
(print-counts counts log-port))
235
(close-port log-port)
236
(quit global-pass))))))
added
removed
test-suite/guile-test
