1 |
#!/usr/local/bin/guile \ |
#!../libguile/guile \ |
2 |
-e main -s |
-e main -s |
3 |
!# |
!# |
4 |
|
|
5 |
;;;; guile-test --- run the Guile test suite |
;;;; guile-test --- run the Guile test suite |
6 |
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 |
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 |
7 |
;;;; |
;;;; |
8 |
;;;; Copyright (C) 1999 Free Software Foundation, Inc. |
;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. |
9 |
;;;; |
;;;; |
10 |
;;;; This program is free software; you can redistribute it and/or modify |
;;;; 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 |
;;;; 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) |
;;;; the Free Software Foundation; either version 2, or (at your option) |
13 |
;;;; any later version. |
;;;; any later version. |
14 |
;;;; |
;;;; |
15 |
;;;; This program is distributed in the hope that it will be useful, |
;;;; This program is distributed in the hope that it will be useful, |
16 |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
17 |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
18 |
;;;; GNU General Public License for more details. |
;;;; GNU General Public License for more details. |
19 |
;;;; |
;;;; |
20 |
;;;; You should have received a copy of the GNU General Public License |
;;;; 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 |
;;;; along with this software; see the file COPYING. If not, write to |
22 |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
23 |
;;;; Boston, MA 02111-1307 USA |
;;;; Boston, MA 02111-1307 USA |
24 |
|
|
25 |
|
|
26 |
|
;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...] |
|
;;;; Usage: guile-test [--log-file LOG] [TEST ...] |
|
27 |
;;;; |
;;;; |
28 |
;;;; Run tests from the Guile test suite. Report failures and |
;;;; Run tests from the Guile test suite. Report failures and |
29 |
;;;; unexpected passes to the standard output, along with a summary of |
;;;; unexpected passes to the standard output, along with a summary of |
30 |
;;;; all the results. Record each reported test outcome in the log |
;;;; all the results. Record each reported test outcome in the log |
31 |
;;;; file, `guile.log'. |
;;;; file, `guile.log'. The exit status is #f if any of the tests |
32 |
|
;;;; fail or pass unexpectedly. |
33 |
;;;; |
;;;; |
34 |
;;;; Normally, guile-test scans the test directory, and executes all |
;;;; Normally, guile-test scans the test directory, and executes all |
35 |
;;;; files whose names end in `.test'. (It assumes they contain |
;;;; files whose names end in `.test'. (It assumes they contain |
36 |
;;;; Scheme code.) However, you can have it execute specific tests by |
;;;; Scheme code.) However, you can have it execute specific tests by |
37 |
;;;; listing their filenames on the command line. |
;;;; listing their filenames on the command line. |
38 |
;;;; |
;;;; |
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). |
44 |
|
;;;; |
45 |
;;;; If present, the `--log-file LOG' option tells `guile-test' to put |
;;;; If present, the `--log-file LOG' option tells `guile-test' to put |
46 |
;;;; the log output in a file named LOG. |
;;;; the log output in a file named LOG. |
47 |
;;;; |
;;;; |
48 |
|
;;;; If present, the `--debug' option will enable a debugging mode. |
49 |
|
;;;; |
50 |
|
;;;; If present, the `--flag-unresolved' option will cause guile-test |
51 |
|
;;;; to exit with failure status if any tests are UNRESOLVED. |
52 |
|
;;;; |
53 |
|
;;;; |
54 |
;;;; Installation: |
;;;; Installation: |
55 |
;;;; |
;;;; |
56 |
;;;; Change the #! line at the top of this script to point at the |
;;;; If you change the #! line at the top of this script to point at |
57 |
;;;; Guile interpreter you want to test. Edit `test-suite/paths.scm' |
;;;; the Guile interpreter you want to test, you can call this script |
58 |
;;;; so that datadir points to the parent directory of the `tests' tree. |
;;;; 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'. |
63 |
|
;;;; |
64 |
;;;; |
;;;; |
65 |
;;;; Shortcomings: |
;;;; Shortcomings: |
66 |
;;;; |
;;;; |
67 |
;;;; At the moment, due to a simple-minded implementation, test files |
;;;; At the moment, due to a simple-minded implementation, test files |
68 |
;;;; must live in the test directory, and you must specify their names |
;;;; 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 |
;;;; relative to the top of the test directory. If you want to send |
70 |
;;;; me a patche that fixes this, but still leaves sane test names in |
;;;; 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 |
;;;; the log file, that would be great. At the moment, all the tests |
72 |
;;;; I care about are in the test directory, though. |
;;;; I care about are in the test directory, though. |
73 |
;;;; |
;;;; |
76 |
;;;; change which Guile interpreter you're testing, you need to edit |
;;;; change which Guile interpreter you're testing, you need to edit |
77 |
;;;; the #! line at the top of this file, which is stupid. |
;;;; the #! line at the top of this file, which is stupid. |
78 |
|
|
79 |
|
|
80 |
|
;;; User configurable settings: |
81 |
|
(define default-test-suite |
82 |
|
(string-append (getenv "HOME") "/bogus-path/test-suite")) |
83 |
|
|
84 |
|
|
85 |
(use-modules (test-suite lib) |
(use-modules (test-suite lib) |
|
(test-suite paths) |
|
86 |
(ice-9 getopt-long) |
(ice-9 getopt-long) |
87 |
(ice-9 and-let*)) |
;;(ice-9 and-let-star) |
88 |
|
;;(ice-9 rdelim) |
89 |
|
) |
90 |
|
|
91 |
|
|
92 |
|
;;; Variables that will receive their actual values later. |
93 |
|
(define test-suite default-test-suite) |
94 |
|
|
95 |
|
(define tmp-dir #f) |
96 |
|
|
97 |
|
|
98 |
;;; General utilities, that probably should be in a library somewhere. |
;;; General utilities, that probably should be in a library somewhere. |
99 |
|
|
100 |
|
;;; Enable debugging |
101 |
|
(define (enable-debug-mode) |
102 |
|
(write-line %load-path) |
103 |
|
(set! %load-verbosely #t) |
104 |
|
(debug-enable 'backtrace 'debug)) |
105 |
|
|
106 |
;;; Traverse the directory tree at ROOT, applying F to the name of |
;;; Traverse the directory tree at ROOT, applying F to the name of |
107 |
;;; each file in the tree, including ROOT itself. For a subdirectory |
;;; each file in the tree, including ROOT itself. For a subdirectory |
108 |
;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow |
;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow |
109 |
;;; symlinks. |
;;; symlinks. |
110 |
(define (for-each-file f root) |
(define (for-each-file f root) |
111 |
|
|
112 |
;; A "hard directory" is a path that denotes a directory and is not a |
;; A "hard directory" is a path that denotes a directory and is not a |
113 |
;; symlink. |
;; symlink. |
114 |
(define (file-is-hard-directory? filename) |
(define (file-is-hard-directory? filename) |
115 |
(eq? (stat:type (lstat filename)) 'directory)) |
(eq? (stat:type (lstat filename)) 'directory)) |
120 |
(let ((dir (opendir root))) |
(let ((dir (opendir root))) |
121 |
(let loop () |
(let loop () |
122 |
(let ((entry (readdir dir))) |
(let ((entry (readdir dir))) |
123 |
(cond |
(cond |
124 |
((eof-object? entry) #f) |
((eof-object? entry) #f) |
125 |
((or (string=? entry ".") |
((or (string=? entry ".") |
126 |
(string=? entry "..")) |
(string=? entry "..") |
127 |
|
(string=? entry "CVS") |
128 |
|
(string=? entry "RCS")) |
129 |
(loop)) |
(loop)) |
130 |
(else |
(else |
131 |
(visit (string-append root "/" entry)) |
(visit (string-append root "/" entry)) |
132 |
(loop)))))))))) |
(loop)))))))))) |
133 |
|
|
|
|
|
134 |
|
|
135 |
;;; The test driver. |
;;; The test driver. |
136 |
|
|
137 |
(define test-root (in-vicinity datadir "tests")) |
|
138 |
|
;;; Localizing test files and temporary data files. |
139 |
|
|
140 |
|
(define (data-file-name filename) |
141 |
|
(in-vicinity tmp-dir filename)) |
142 |
|
|
143 |
(define (test-file-name test) |
(define (test-file-name test) |
144 |
(in-vicinity test-root test)) |
(in-vicinity test-suite test)) |
145 |
|
|
146 |
;;; Return a list of all the test files in the test tree. |
;;; Return a list of all the test files in the test tree. |
147 |
(define (enumerate-tests) |
(define (enumerate-tests test-dir) |
148 |
(let ((root-len (+ 1 (string-length test-root))) |
(let ((root-len (+ 1 (string-length test-dir))) |
149 |
(tests '())) |
(tests '())) |
150 |
(for-each-file (lambda (file) |
(for-each-file (lambda (file) |
151 |
(if (has-suffix? file ".test") |
(if (has-suffix? file ".test") |
153 |
(substring file root-len))) |
(substring file root-len))) |
154 |
(set! tests (cons short-name tests)))) |
(set! tests (cons short-name tests)))) |
155 |
#t) |
#t) |
156 |
test-root) |
test-dir) |
157 |
|
|
158 |
;; for-each-file presents the files in whatever order it finds |
;; for-each-file presents the files in whatever order it finds |
159 |
;; them in the directory. We sort them here, so they'll always |
;; them in the directory. We sort them here, so they'll always |
163 |
|
|
164 |
(define (main args) |
(define (main args) |
165 |
(let ((options (getopt-long args |
(let ((options (getopt-long args |
166 |
`((log-file (single-char #\l) |
`((test-suite |
167 |
(value #t)))))) |
(single-char #\t) |
168 |
|
(value #t)) |
169 |
|
(flag-unresolved |
170 |
|
(single-char #\u)) |
171 |
|
(log-file |
172 |
|
(single-char #\l) |
173 |
|
(value #t)) |
174 |
|
(debug |
175 |
|
(single-char #\d)))))) |
176 |
(define (opt tag default) |
(define (opt tag default) |
177 |
(let ((pair (assq tag options))) |
(let ((pair (assq tag options))) |
178 |
(if pair (cdr pair) default))) |
(if pair (cdr pair) default))) |
179 |
(let ((log-file (opt 'log-file "guile.log")) |
|
180 |
(tests (let ((foo (opt '() '()))) |
(if (opt 'debug #f) |
181 |
(if (null? foo) (enumerate-tests) |
(enable-debug-mode)) |
182 |
foo)))) |
|
183 |
|
(set! test-suite |
184 |
|
(or (opt 'test-suite #f) |
185 |
|
(getenv "TEST_SUITE_DIR") |
186 |
|
default-test-suite)) |
187 |
|
|
188 |
|
;; directory where temporary files are created. |
189 |
|
;; when run from "make check", this must be under the build-dir, |
190 |
|
;; not the src-dir. |
191 |
|
(set! tmp-dir (getcwd)) |
192 |
|
|
193 |
|
(let* ((tests |
194 |
|
(let ((foo (opt '() '()))) |
195 |
|
(if (null? foo) |
196 |
|
(enumerate-tests test-suite) |
197 |
|
foo))) |
198 |
|
(log-file |
199 |
|
(opt 'log-file "guile.log"))) |
200 |
|
|
201 |
;; Open the log file. |
;; Open the log file. |
202 |
(let ((log-port (open-output-file log-file))) |
(let ((log-port (open-output-file log-file))) |
203 |
|
|
204 |
;; Register some reporters. |
;; Register some reporters. |
205 |
(let ((counter (make-count-reporter))) |
(let ((global-pass #t) |
206 |
|
(counter (make-count-reporter))) |
207 |
(register-reporter (car counter)) |
(register-reporter (car counter)) |
208 |
(register-reporter (make-log-reporter log-port)) |
(register-reporter (make-log-reporter log-port)) |
209 |
(register-reporter user-reporter) |
(register-reporter user-reporter) |
210 |
|
(register-reporter (lambda results |
211 |
|
(case (car results) |
212 |
|
((unresolved) |
213 |
|
(and (opt 'flag-unresolved #f) |
214 |
|
(set! global-pass #f))) |
215 |
|
((fail upass error) |
216 |
|
(set! global-pass #f))))) |
217 |
|
|
218 |
;; Run the tests. |
;; Run the tests. |
219 |
(for-each (lambda (test) |
(for-each (lambda (test) |
227 |
(print-counts counts) |
(print-counts counts) |
228 |
(print-counts counts log-port)) |
(print-counts counts log-port)) |
229 |
|
|
230 |
(close-port log-port)))))) |
(close-port log-port) |
231 |
|
(quit global-pass)))))) |
232 |
|
|
233 |
|
|
234 |
;;; Local Variables: |
;;; Local Variables: |