1#!../libguile/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, 2001, 2006 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., 51 Franklin Street, Fifth Floor,
23;;;; Boston, MA 02110-1301 USA
24
25
26;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...]
27;;;;
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.
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;;;; 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
46;;;; 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:
55;;;;
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'.
63;;;;
64;;;;
65;;;; Shortcomings:
66;;;;
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.
73;;;;
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.
78
79(define (main . args)
80  (let ((module (resolve-module '(test-suite guile-test))))
81    (apply (module-ref module 'main) args)))
82
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))
89
90
91;;; User configurable settings:
92(define default-test-suite
93  (string-append (getenv "HOME") "/bogus-path/test-suite"))
94
95
96;;; Variables that will receive their actual values later.
97(define test-suite default-test-suite)
98
99(define tmp-dir #f)
100
101
102;;; General utilities, that probably should be in a library somewhere.
103
104;;; Enable debugging
105(define (enable-debug-mode)
106  (write-line %load-path)
107  (set! %load-verbosely #t)
108  (debug-enable 'backtrace 'debug))
109
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
113;;; symlinks.
114(define (for-each-file f root)
115
116  ;; A "hard directory" is a path that denotes a directory and is not a
117  ;; symlink.
118  (define (file-is-hard-directory? filename)
119    (eq? (stat:type (lstat filename)) 'directory))
120
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)))
125	    (let loop ()
126	      (let ((entry (readdir dir)))
127		(cond
128		 ((eof-object? entry) #f)
129		 ((or (string=? entry ".")
130		      (string=? entry "..")
131                      (string=? entry "CVS")
132                      (string=? entry "RCS"))
133		  (loop))
134		 (else
135		  (visit (string-append root "/" entry))
136		  (loop))))))))))
137
138
139;;; The test driver.
140
141
142;;; Localizing test files and temporary data files.
143
144(define (data-file-name filename)
145  (in-vicinity tmp-dir filename))
146
147(define (test-file-name test)
148  (in-vicinity test-suite test))
149
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)))
153	(tests '()))
154    (for-each-file (lambda (file)
155		     (if (has-suffix? file ".test")
156			 (let ((short-name
157				(substring file root-len)))
158			   (set! tests (cons short-name tests))))
159		     #t)
160		   test-dir)
161
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<?)))
167
168(define (main args)
169  (let ((options (getopt-long args
170			      `((test-suite
171				 (single-char #\t)
172				 (value #t))
173                                (flag-unresolved
174                                 (single-char #\u))
175				(log-file
176				 (single-char #\l)
177				 (value #t))
178				(debug
179				 (single-char #\d))))))
180    (define (opt tag default)
181      (let ((pair (assq tag options)))
182	(if pair (cdr pair) default)))
183
184    (if (opt 'debug #f)
185	(enable-debug-mode))
186
187    (set! test-suite
188	  (or (opt 'test-suite #f)
189	      (getenv "TEST_SUITE_DIR")
190	      default-test-suite))
191
192    ;; directory where temporary files are created.
193    ;; when run from "make check", this must be under the build-dir,
194    ;; not the src-dir.
195    (set! tmp-dir (getcwd))
196
197    (let* ((tests
198	    (let ((foo (opt '() '())))
199	      (if (null? foo)
200		  (enumerate-tests test-suite)
201		  foo)))
202	   (log-file
203	    (opt 'log-file "guile.log")))
204
205      ;; Open the log file.
206      (let ((log-port (open-output-file log-file)))
207
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
215			       (case (car results)
216                                 ((unresolved)
217                                  (and (opt 'flag-unresolved #f)
218                                       (set! global-pass #f)))
219				 ((fail upass error)
220				  (set! global-pass #f)))))
221
222	  ;; Run the tests.
223	  (for-each (lambda (test)
224                      (display (string-append "Running " test "\n"))
225		      (with-test-prefix test
226			(load (test-file-name test))))
227		    tests)
228
229	  ;; Display the final counts, both to the user and in the log
230	  ;; file.
231	  (let ((counts ((cadr counter))))
232	    (print-counts counts)
233	    (print-counts counts log-port))
234
235	  (close-port log-port)
236	  (quit global-pass))))))
237
238
239;;; Local Variables:
240;;; mode: scheme
241;;; End:
242