test-suite/guile-test

   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, 2014 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                                (when (defined? 'setlocale)
 243                                  (setlocale LC_ALL "C"))
 244                                (with-test-prefix test
 245                                  (load (test-file-name test))))
 246                              tests))))
 247             (if (opt 'coverage #f)
 248                 (let-values (((coverage-data _)
 249                               (with-code-coverage (the-vm) run-tests)))
 250                   (let ((out (open-output-file "guile.info")))
 251                     (coverage-data->lcov coverage-data out)
 252                     (close out)))
 253                 (run-tests)))
 254
 255           ;; Display the final counts, both to the user and in the log
 256           ;; file.
 257           (let ((counts ((cadr counter))))
 258             (print-counts counts)
 259             (print-counts counts log-port))
 260
 261           (close-port log-port)
 262           (quit global-pass))))))
 263
 264 \f
 265 ;;; Local Variables:
 266 ;;; mode: scheme
 267 ;;; End: