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