/[guile]/guile/guile-core/test-suite/guile-test
ViewVC logotype

Diff of /guile/guile-core/test-suite/guile-test

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by dirk, Mon May 8 17:42:03 2000 UTC revision 1.2.4.1 by ttn, Sat Feb 9 23:15:28 2002 UTC
# Line 1  Line 1 
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  ;;;;  ;;;;
# Line 59  Line 76 
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))
# Line 84  Line 120 
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")
# Line 112  Line 153 
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
# Line 122  Line 163 
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)
# Line 153  Line 227 
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:

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.2.4.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26