1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
#!/usr/local/bin/guile \
-e main -s
!#
;;;; guile-test --- run the Guile test suite
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
;;;; Copyright (C) 1999 Free Software Foundation, Inc.
;;;;
;;;; 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
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;; Usage: guile-test [--log-file LOG] [TEST ...]
;;;;
;;;; Run tests from the Guile test suite. Report failures and
;;;; unexpected passes to the standard output, along with a summary of
;;;; all the results. Record each reported test outcome in the log
;;;; file, `guile.log'.
;;;;
;;;; Normally, guile-test scans the test directory, and executes all
;;;; files whose names end in `.test'. (It assumes they contain
;;;; Scheme code.) However, you can have it execute specific tests by
;;;; listing their filenames on the command line.
;;;;
;;;; If present, the `--log-file LOG' option tells `guile-test' to put
;;;; the log output in a file named LOG.
;;;;
;;;; Installation:
;;;;
;;;; Change the #! line at the top of this script to point at the
;;;; Guile interpreter you want to test. Edit `test-suite/paths.scm'
;;;; so that datadir points to the parent directory of the `tests' tree.
;;;;
;;;; Shortcomings:
;;;;
;;;; At the moment, due to a simple-minded implementation, test files
;;;; must live in the test directory, and you must specify their names
;;;; relative to the top of the test directory. If you want to send
;;;; me a patche that fixes this, but still leaves sane test names in
;;;; the log file, that would be great. At the moment, all the tests
;;;; I care about are in the test directory, though.
;;;;
;;;; It would be nice if you could specify the Guile interpreter you
;;;; want to test on the command line. As it stands, if you want to
;;;; change which Guile interpreter you're testing, you need to edit
;;;; the #! line at the top of this file, which is stupid.
(use-modules (test-suite lib)
(test-suite paths)
(ice-9 getopt-long)
(ice-9 and-let*))
;;; General utilities, that probably should be in a library somewhere.
;;; Traverse the directory tree at ROOT, applying F to the name of
;;; each file in the tree, including ROOT itself. For a subdirectory
;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow
;;; symlinks.
(define (for-each-file f root)
;; A "hard directory" is a path that denotes a directory and is not a
;; symlink.
(define (file-is-hard-directory? filename)
(eq? (stat:type (lstat filename)) 'directory))
(let visit ((root root))
(let ((should-recur (f root)))
(if (and should-recur (file-is-hard-directory? root))
(let ((dir (opendir root)))
(let loop ()
(let ((entry (readdir dir)))
(cond
((eof-object? entry) #f)
((or (string=? entry ".")
(string=? entry ".."))
(loop))
(else
(visit (string-append root "/" entry))
(loop))))))))))
;;; The test driver.
(define test-root (in-vicinity datadir "tests"))
(define (test-file-name test)
(in-vicinity test-root test))
;;; Return a list of all the test files in the test tree.
(define (enumerate-tests)
(let ((root-len (+ 1 (string-length test-root)))
(tests '()))
(for-each-file (lambda (file)
(if (has-suffix? file ".test")
(let ((short-name
(substring file root-len)))
(set! tests (cons short-name tests))))
#t)
test-root)
;; for-each-file presents the files in whatever order it finds
;; them in the directory. We sort them here, so they'll always
;; appear in the same order. This makes it easier to compare test
;; log files mechanically.
(sort tests string<?)))
(define (main args)
(let ((options (getopt-long args
`((log-file (single-char #\l)
(value #t))))))
(define (opt tag default)
(let ((pair (assq tag options)))
(if pair (cdr pair) default)))
(let ((log-file (opt 'log-file "guile.log"))
(tests (let ((foo (opt '() '())))
(if (null? foo) (enumerate-tests)
foo))))
;; Open the log file.
(let ((log-port (open-output-file log-file)))
;; Register some reporters.
(let ((counter (make-count-reporter)))
(register-reporter (car counter))
(register-reporter (make-log-reporter log-port))
(register-reporter user-reporter)
;; Run the tests.
(for-each (lambda (test)
(with-test-prefix test
(catch-test-errors
(load (test-file-name test)))))
tests)
;; Display the final counts, both to the user and in the log
;; file.
(let ((counts ((cadr counter))))
(print-counts counts)
(print-counts counts log-port))
(close-port log-port))))))
;;; Local Variables:
;;; mode: scheme
;;; End:
|