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 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., 59 Temple Place, Suite 330,
  23 ;;;; Boston, MA 02111-1307 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 ;;;;
  51 ;;;; Installation:
  52 ;;;;
  53 ;;;; If you change the #! line at the top of this script to point at
  54 ;;;; the Guile interpreter you want to test, you can call this script
  55 ;;;; as an executable instead of having to pass it as a parameter to
  56 ;;;; guile via "guile -e main -s guile-test".  Further, you can edit
  57 ;;;; the definition of default-test-suite to point to the parent
  58 ;;;; directory of the `tests' tree, which makes it unnecessary to set
  59 ;;;; the environment variable `TEST_SUITE_DIR'.
  60 ;;;;
  61 ;;;;
  62 ;;;; Shortcomings:
  63 ;;;;
  64 ;;;; At the moment, due to a simple-minded implementation, test files
  65 ;;;; must live in the test directory, and you must specify their names
  66 ;;;; relative to the top of the test directory.  If you want to send
  67 ;;;; me a patch that fixes this, but still leaves sane test names in
  68 ;;;; the log file, that would be great.  At the moment, all the tests
  69 ;;;; I care about are in the test directory, though.
  70 ;;;;
  71 ;;;; It would be nice if you could specify the Guile interpreter you
  72 ;;;; want to test on the command line.  As it stands, if you want to
  73 ;;;; change which Guile interpreter you're testing, you need to edit
  74 ;;;; the #! line at the top of this file, which is stupid.
  75
  76 \f
  77 ;;; User configurable settings:
  78 (define default-test-suite
  79   (string-append (getenv "HOME") "/bogus-path/test-suite"))
  80
  81 \f
  82 (use-modules (test-suite lib)
  83              (ice-9 getopt-long)
  84              (ice-9 and-let-star))
  85
  86 \f
  87 ;;; Variables that will receive their actual values later.
  88 (define test-suite default-test-suite)
  89
  90 (define tmp-dir #f)
  91
  92 \f
  93 ;;; General utilities, that probably should be in a library somewhere.
  94
  95 ;;; Enable debugging
  96 (define (enable-debug-mode)
  97   (write-line %load-path)
  98   (set! %load-verbosely #t)
  99   (debug-enable 'backtrace 'debug))
 100
 101 ;;; Traverse the directory tree at ROOT, applying F to the name of
 102 ;;; each file in the tree, including ROOT itself.  For a subdirectory
 103 ;;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
 104 ;;; symlinks.
 105 (define (for-each-file f root)
 106
 107   ;; A "hard directory" is a path that denotes a directory and is not a
 108   ;; symlink.
 109   (define (file-is-hard-directory? filename)
 110     (eq? (stat:type (lstat filename)) 'directory))
 111
 112   (let visit ((root root))
 113     (let ((should-recur (f root)))
 114       (if (and should-recur (file-is-hard-directory? root))
 115           (let ((dir (opendir root)))
 116             (let loop ()
 117               (let ((entry (readdir dir)))
 118                 (cond
 119                  ((eof-object? entry) #f)
 120                  ((or (string=? entry ".")
 121                       (string=? entry ".."))
 122                   (loop))
 123                  (else
 124                   (visit (string-append root "/" entry))
 125                   (loop))))))))))
 126
 127 \f
 128 ;;; The test driver.
 129
 130 \f
 131 ;;; Localizing test files and temporary data files.
 132
 133 (define (data-file-name filename)
 134   (in-vicinity tmp-dir filename))
 135
 136 (define (test-file-name test)
 137   (in-vicinity test-suite test))
 138
 139 ;;; Return a list of all the test files in the test tree.
 140 (define (enumerate-tests test-dir)
 141   (let ((root-len (+ 1 (string-length test-dir)))
 142         (tests '()))
 143     (for-each-file (lambda (file)
 144                      (if (has-suffix? file ".test")
 145                          (let ((short-name
 146                                 (substring file root-len)))
 147                            (set! tests (cons short-name tests))))
 148                      #t)
 149                    test-dir)
 150
 151     ;; for-each-file presents the files in whatever order it finds
 152     ;; them in the directory.  We sort them here, so they'll always
 153     ;; appear in the same order.  This makes it easier to compare test
 154     ;; log files mechanically.
 155     (sort tests string<?)))
 156
 157 (define (main args)
 158   (let ((options (getopt-long args
 159                               `((test-suite
 160                                  (single-char #\t)
 161                                  (value #t))
 162                                 (log-file
 163                                  (single-char #\l)
 164                                  (value #t))
 165                                 (debug
 166                                  (single-char #\d))))))
 167     (define (opt tag default)
 168       (let ((pair (assq tag options)))
 169         (if pair (cdr pair) default)))
 170
 171     (if (opt 'debug #f)
 172         (enable-debug-mode))
 173
 174     (set! test-suite
 175           (or (opt 'test-suite #f)
 176               (getenv "TEST_SUITE_DIR")
 177               default-test-suite))
 178
 179     ;; directory where temporary files are created.
 180     ;; when run from "make check", this must be under the build-dir,
 181     ;; not the src-dir.
 182     (set! tmp-dir (getcwd))
 183
 184     (let* ((tests
 185             (let ((foo (opt '() '())))
 186               (if (null? foo)
 187                   (enumerate-tests test-suite)
 188                   foo)))
 189            (log-file
 190             (opt 'log-file "guile.log")))
 191
 192       ;; Open the log file.
 193       (let ((log-port (open-output-file log-file)))
 194
 195         ;; Register some reporters.
 196         (let ((global-pass #t)
 197               (counter (make-count-reporter)))
 198           (register-reporter (car counter))
 199           (register-reporter (make-log-reporter log-port))
 200           (register-reporter user-reporter)
 201           (register-reporter (lambda results
 202                                (case (car results)
 203                                  ((fail upass unresolved error)
 204                                   (set! global-pass #f)))))
 205
 206           ;; Run the tests.
 207           (for-each (lambda (test)
 208                       (with-test-prefix test
 209                         (load (test-file-name test))))
 210                     tests)
 211
 212           ;; Display the final counts, both to the user and in the log
 213           ;; file.
 214           (let ((counts ((cadr counter))))
 215             (print-counts counts)
 216             (print-counts counts log-port))
 217
 218           (close-port log-port)
 219           (quit global-pass))))))
 220
 221 \f
 222 ;;; Local Variables:
 223 ;;; mode: scheme
 224 ;;; End: