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