test-suite/guile-test

   1 #!/usr/local/bin/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
  27 ;;;; Usage: guile-test [--log-file LOG] [TEST ...]
  28 ;;;;
  29 ;;;; Run tests from the Guile test suite.  Report failures and
  30 ;;;; unexpected passes to the standard output, along with a summary of
  31 ;;;; all the results.  Record each reported test outcome in the log
  32 ;;;; file, `guile.log'.
  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 ;;;; If present, the `--log-file LOG' option tells `guile-test' to put
  40 ;;;; the log output in a file named LOG.
  41 ;;;;
  42 ;;;; Installation:
  43 ;;;;
  44 ;;;; Change the #! line at the top of this script to point at the
  45 ;;;; Guile interpreter you want to test.  Edit `test-suite/paths.scm'
  46 ;;;; so that datadir points to the parent directory of the `tests' tree.
  47 ;;;;
  48 ;;;; Shortcomings:
  49 ;;;;
  50 ;;;; At the moment, due to a simple-minded implementation, test files
  51 ;;;; must live in the test directory, and you must specify their names
  52 ;;;; relative to the top of the test directory.  If you want to send
  53 ;;;; me a patche that fixes this, but still leaves sane test names in
  54 ;;;; the log file, that would be great.  At the moment, all the tests
  55 ;;;; I care about are in the test directory, though.
  56 ;;;;
  57 ;;;; It would be nice if you could specify the Guile interpreter you
  58 ;;;; want to test on the command line.  As it stands, if you want to
  59 ;;;; change which Guile interpreter you're testing, you need to edit
  60 ;;;; the #! line at the top of this file, which is stupid.
  61
  62 (use-modules (test-suite lib)
  63              (test-suite paths)
  64              (ice-9 getopt-long)
  65              (ice-9 and-let*))
  66
  67 \f
  68 ;;; General utilities, that probably should be in a library somewhere.
  69
  70 ;;; Traverse the directory tree at ROOT, applying F to the name of
  71 ;;; each file in the tree, including ROOT itself.  For a subdirectory
  72 ;;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
  73 ;;; symlinks.
  74 (define (for-each-file f root)
  75
  76   ;; A "hard directory" is a path that denotes a directory and is not a
  77   ;; symlink.
  78   (define (file-is-hard-directory? filename)
  79     (eq? (stat:type (lstat filename)) 'directory))
  80
  81   (let visit ((root root))
  82     (let ((should-recur (f root)))
  83       (if (and should-recur (file-is-hard-directory? root))
  84           (let ((dir (opendir root)))
  85             (let loop ()
  86               (let ((entry (readdir dir)))
  87                 (cond
  88                  ((eof-object? entry) #f)
  89                  ((or (string=? entry ".")
  90                       (string=? entry ".."))
  91                   (loop))
  92                  (else
  93                   (visit (string-append root "/" entry))
  94                   (loop))))))))))
  95
  96
  97 \f
  98 ;;; The test driver.
  99
 100 (define test-root (in-vicinity datadir "tests"))
 101
 102 (define (test-file-name test)
 103   (in-vicinity test-root test))
 104
 105 ;;; Return a list of all the test files in the test tree.
 106 (define (enumerate-tests)
 107   (let ((root-len (+ 1 (string-length test-root)))
 108         (tests '()))
 109     (for-each-file (lambda (file)
 110                      (if (has-suffix? file ".test")
 111                          (let ((short-name
 112                                 (substring file root-len)))
 113                            (set! tests (cons short-name tests))))
 114                      #t)
 115                    test-root)
 116
 117     ;; for-each-file presents the files in whatever order it finds
 118     ;; them in the directory.  We sort them here, so they'll always
 119     ;; appear in the same order.  This makes it easier to compare test
 120     ;; log files mechanically.
 121     (sort tests string<?)))
 122
 123 (define (main args)
 124   (let ((options (getopt-long args
 125                               `((log-file (single-char #\l)
 126                                           (value #t))))))
 127     (define (opt tag default)
 128       (let ((pair (assq tag options)))
 129         (if pair (cdr pair) default)))
 130     (let ((log-file (opt 'log-file "guile.log"))
 131           (tests (let ((foo (opt '() '())))
 132                    (if (null? foo) (enumerate-tests)
 133                        foo))))
 134
 135       ;; Open the log file.
 136       (let ((log-port (open-output-file log-file)))
 137
 138         ;; Register some reporters.
 139         (let ((counter (make-count-reporter)))
 140           (register-reporter (car counter))
 141           (register-reporter (make-log-reporter log-port))
 142           (register-reporter user-reporter)
 143
 144           ;; Run the tests.
 145           (for-each (lambda (test)
 146                       (with-test-prefix test
 147                         (catch-test-errors
 148                          (load (test-file-name test)))))
 149                     tests)
 150
 151           ;; Display the final counts, both to the user and in the log
 152           ;; file.
 153           (let ((counts ((cadr counter))))
 154             (print-counts counts)
 155             (print-counts counts log-port))
 156
 157           (close-port log-port))))))
 158
 159 \f
 160 ;;; Local Variables:
 161 ;;; mode: scheme
 162 ;;; End: