6 |
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 |
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 |
7 |
;;;; |
;;;; |
8 |
;;;; Copyright (C) 1999, 2001 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, |
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 |
;;;; The option `--test-suite' can be given to specify the test |
40 |
;;;; directory. If no such option is given, the test directory is |
;;;; directory. If no such option is given, the test directory is |
41 |
;;;; taken from the environment variable TEST_SUITE_DIR (if defined), |
;;;; taken from the environment variable TEST_SUITE_DIR (if defined), |
42 |
;;;; otherwise a default directory that is hardcoded in this file is |
;;;; otherwise a default directory that is hardcoded in this file is |
43 |
;;;; used (see "Installation" below). |
;;;; 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. |
;;;; 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: |
108 |
;;; symlinks. |
;;; symlinks. |
109 |
(define (for-each-file f root) |
(define (for-each-file f root) |
110 |
|
|
111 |
;; 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 |
112 |
;; symlink. |
;; symlink. |
113 |
(define (file-is-hard-directory? filename) |
(define (file-is-hard-directory? filename) |
114 |
(eq? (stat:type (lstat filename)) 'directory)) |
(eq? (stat:type (lstat filename)) 'directory)) |
119 |
(let ((dir (opendir root))) |
(let ((dir (opendir root))) |
120 |
(let loop () |
(let loop () |
121 |
(let ((entry (readdir dir))) |
(let ((entry (readdir dir))) |
122 |
(cond |
(cond |
123 |
((eof-object? entry) #f) |
((eof-object? entry) #f) |
124 |
((or (string=? entry ".") |
((or (string=? entry ".") |
125 |
(string=? entry "..")) |
(string=? entry "..")) |
160 |
|
|
161 |
(define (main args) |
(define (main args) |
162 |
(let ((options (getopt-long args |
(let ((options (getopt-long args |
163 |
`((test-suite |
`((test-suite |
164 |
(single-char #\t) |
(single-char #\t) |
165 |
(value #t)) |
(value #t)) |
166 |
(log-file |
(flag-unresolved |
167 |
|
(single-char #\u)) |
168 |
|
(log-file |
169 |
(single-char #\l) |
(single-char #\l) |
170 |
(value #t)) |
(value #t)) |
171 |
(debug |
(debug |
172 |
(single-char #\d)))))) |
(single-char #\d)))))) |
173 |
(define (opt tag default) |
(define (opt tag default) |
174 |
(let ((pair (assq tag options))) |
(let ((pair (assq tag options))) |
189 |
|
|
190 |
(let* ((tests |
(let* ((tests |
191 |
(let ((foo (opt '() '()))) |
(let ((foo (opt '() '()))) |
192 |
(if (null? foo) |
(if (null? foo) |
193 |
(enumerate-tests test-suite) |
(enumerate-tests test-suite) |
194 |
foo))) |
foo))) |
195 |
(log-file |
(log-file |
196 |
(opt 'log-file "guile.log"))) |
(opt 'log-file "guile.log"))) |
197 |
|
|
198 |
;; Open the log file. |
;; Open the log file. |
206 |
(register-reporter user-reporter) |
(register-reporter user-reporter) |
207 |
(register-reporter (lambda results |
(register-reporter (lambda results |
208 |
(case (car results) |
(case (car results) |
209 |
((fail upass unresolved error) |
((unresolved) |
210 |
|
(and (opt 'flag-unresolved #f) |
211 |
|
(set! global-pass #f))) |
212 |
|
((fail upass error) |
213 |
(set! global-pass #f))))) |
(set! global-pass #f))))) |
214 |
|
|
215 |
;; Run the tests. |
;; Run the tests. |