| 1 | #!../meta/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, 2010 Free Software Foundation, Inc. |
| 9 | ;;;; |
| 10 | ;;;; This program is free software; you can redistribute it and/or |
| 11 | ;;;; modify it under the terms of the GNU Lesser General Public |
| 12 | ;;;; License as published by the Free Software Foundation; either |
| 13 | ;;;; version 3, or (at your option) 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 Lesser General Public License for more details. |
| 19 | ;;;; |
| 20 | ;;;; You should have received a copy of the GNU Lesser General Public |
| 21 | ;;;; License along with this software; see the file COPYING.LESSER. |
| 22 | ;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin |
| 23 | ;;;; Street, Fifth Floor, 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 | :use-module (system vm coverage) |
| 89 | :use-module (srfi srfi-11) |
| 90 | :use-module (system vm vm) |
| 91 | :export (main data-file-name test-file-name)) |
| 92 | |
| 93 | \f |
| 94 | ;;; User configurable settings: |
| 95 | (define (default-test-suite) |
| 96 | (let ((argv0 (car (program-arguments)))) |
| 97 | (if (string=? (basename argv0) "guile-test") |
| 98 | (dirname argv0) |
| 99 | (error "Cannot find default test suite.")))) |
| 100 | |
| 101 | \f |
| 102 | ;;; Variables that will receive their actual values later. |
| 103 | (define test-suite) |
| 104 | |
| 105 | (define tmp-dir #f) |
| 106 | |
| 107 | \f |
| 108 | ;;; General utilities, that probably should be in a library somewhere. |
| 109 | |
| 110 | ;;; Enable debugging |
| 111 | (define (enable-debug-mode) |
| 112 | (write-line %load-path) |
| 113 | (set! %load-verbosely #t) |
| 114 | (debug-enable 'backtrace 'debug)) |
| 115 | |
| 116 | ;;; Traverse the directory tree at ROOT, applying F to the name of |
| 117 | ;;; each file in the tree, including ROOT itself. For a subdirectory |
| 118 | ;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow |
| 119 | ;;; symlinks. |
| 120 | (define (for-each-file f root) |
| 121 | |
| 122 | ;; A "hard directory" is a path that denotes a directory and is not a |
| 123 | ;; symlink. |
| 124 | (define (file-is-hard-directory? filename) |
| 125 | (eq? (stat:type (lstat filename)) 'directory)) |
| 126 | |
| 127 | (let visit ((root root)) |
| 128 | (let ((should-recur (f root))) |
| 129 | (if (and should-recur (file-is-hard-directory? root)) |
| 130 | (let ((dir (opendir root))) |
| 131 | (let loop () |
| 132 | (let ((entry (readdir dir))) |
| 133 | (cond |
| 134 | ((eof-object? entry) #f) |
| 135 | ((or (string=? entry ".") |
| 136 | (string=? entry "..") |
| 137 | (string=? entry "CVS") |
| 138 | (string=? entry "RCS")) |
| 139 | (loop)) |
| 140 | (else |
| 141 | (visit (string-append root "/" entry)) |
| 142 | (loop)))))))))) |
| 143 | |
| 144 | \f |
| 145 | ;;; The test driver. |
| 146 | |
| 147 | \f |
| 148 | ;;; Localizing test files and temporary data files. |
| 149 | |
| 150 | (define (data-file-name filename) |
| 151 | (in-vicinity tmp-dir filename)) |
| 152 | |
| 153 | (define (test-file-name test) |
| 154 | (in-vicinity test-suite test)) |
| 155 | |
| 156 | ;;; Return a list of all the test files in the test tree. |
| 157 | (define (enumerate-tests test-dir) |
| 158 | (let ((root-len (+ 1 (string-length test-dir))) |
| 159 | (tests '())) |
| 160 | (for-each-file (lambda (file) |
| 161 | (if (string-suffix? ".test" file) |
| 162 | (let ((short-name |
| 163 | (substring file root-len))) |
| 164 | (set! tests (cons short-name tests)))) |
| 165 | #t) |
| 166 | test-dir) |
| 167 | |
| 168 | ;; for-each-file presents the files in whatever order it finds |
| 169 | ;; them in the directory. We sort them here, so they'll always |
| 170 | ;; appear in the same order. This makes it easier to compare test |
| 171 | ;; log files mechanically. |
| 172 | (sort tests string<?))) |
| 173 | |
| 174 | (define (main args) |
| 175 | (let ((options (getopt-long args |
| 176 | `((test-suite |
| 177 | (single-char #\t) |
| 178 | (value #t)) |
| 179 | (flag-unresolved |
| 180 | (single-char #\u)) |
| 181 | (log-file |
| 182 | (single-char #\l) |
| 183 | (value #t)) |
| 184 | (coverage |
| 185 | (single-char #\c)) |
| 186 | (debug |
| 187 | (single-char #\d)))))) |
| 188 | (define (opt tag default) |
| 189 | (let ((pair (assq tag options))) |
| 190 | (if pair (cdr pair) default))) |
| 191 | |
| 192 | (if (opt 'debug #f) |
| 193 | (enable-debug-mode)) |
| 194 | |
| 195 | (set! test-suite |
| 196 | (or (opt 'test-suite #f) |
| 197 | (getenv "TEST_SUITE_DIR") |
| 198 | (default-test-suite))) |
| 199 | |
| 200 | ;; directory where temporary files are created. |
| 201 | ;; when run from "make check", this must be under the build-dir, |
| 202 | ;; not the src-dir. |
| 203 | (set! tmp-dir (getcwd)) |
| 204 | |
| 205 | (let* ((tests |
| 206 | (let ((foo (opt '() '()))) |
| 207 | (if (null? foo) |
| 208 | (enumerate-tests test-suite) |
| 209 | foo))) |
| 210 | (log-file |
| 211 | (opt 'log-file "guile.log"))) |
| 212 | |
| 213 | ;; Open the log file. |
| 214 | (let ((log-port (open-output-file log-file))) |
| 215 | |
| 216 | ;; Allow for arbitrary Unicode characters in the log file. |
| 217 | (set-port-encoding! log-port "UTF-8") |
| 218 | |
| 219 | ;; Don't fail if we can't display a test name to stdout/stderr. |
| 220 | (set-port-conversion-strategy! (current-output-port) 'escape) |
| 221 | (set-port-conversion-strategy! (current-error-port) 'escape) |
| 222 | |
| 223 | ;; Register some reporters. |
| 224 | (let ((global-pass #t) |
| 225 | (counter (make-count-reporter))) |
| 226 | (register-reporter (car counter)) |
| 227 | (register-reporter (make-log-reporter log-port)) |
| 228 | (register-reporter user-reporter) |
| 229 | (register-reporter (lambda results |
| 230 | (case (car results) |
| 231 | ((unresolved) |
| 232 | (and (opt 'flag-unresolved #f) |
| 233 | (set! global-pass #f))) |
| 234 | ((fail upass error) |
| 235 | (set! global-pass #f))))) |
| 236 | |
| 237 | ;; Run the tests. |
| 238 | (let ((run-tests |
| 239 | (lambda () |
| 240 | (for-each (lambda (test) |
| 241 | (display (string-append "Running " test "\n")) |
| 242 | (with-test-prefix test |
| 243 | (load (test-file-name test)))) |
| 244 | tests)))) |
| 245 | (if (opt 'coverage #f) |
| 246 | (let-values (((coverage-data _) |
| 247 | (with-code-coverage (the-vm) run-tests))) |
| 248 | (let ((out (open-output-file "guile.info"))) |
| 249 | (coverage-data->lcov coverage-data out) |
| 250 | (close out))) |
| 251 | (run-tests))) |
| 252 | |
| 253 | ;; Display the final counts, both to the user and in the log |
| 254 | ;; file. |
| 255 | (let ((counts ((cadr counter)))) |
| 256 | (print-counts counts) |
| 257 | (print-counts counts log-port)) |
| 258 | |
| 259 | (close-port log-port) |
| 260 | (quit global-pass)))))) |
| 261 | |
| 262 | \f |
| 263 | ;;; Local Variables: |
| 264 | ;;; mode: scheme |
| 265 | ;;; End: |