test-suite/guile-test

   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 \f
  91 ;;; User configurable settings:
  92 (define default-test-suite
  93   (string-append (getenv "HOME") "/bogus-path/test-suite"))
  94
  95 \f
  96 ;;; Variables that will receive their actual values later.
  97 (define test-suite default-test-suite)
  98
  99 (define tmp-dir #f)
 100
 101 \f
 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 \f
 139 ;;; The test driver.
 140
 141 \f
 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 \f
 239 ;;; Local Variables:
 240 ;;; mode: scheme
 241 ;;; End: