deprecate has-suffix?

[bpt/guile.git] / test-suite / guile-test

#!../libguile/guile \
-e main -s
!#

;;;; guile-test --- run the Guile test suite
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
;;;; 	Copyright (C) 1999, 2001, 2006, 2010 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this software; see the file COPYING.LESSER.
;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA


;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...]
;;;;
;;;; Run tests from the Guile test suite.  Report failures and
;;;; unexpected passes to the standard output, along with a summary of
;;;; all the results.  Record each reported test outcome in the log
;;;; file, `guile.log'.  The exit status is #f if any of the tests
;;;; fail or pass unexpectedly.
;;;;
;;;; Normally, guile-test scans the test directory, and executes all
;;;; files whose names end in `.test'.  (It assumes they contain
;;;; Scheme code.)  However, you can have it execute specific tests by
;;;; listing their filenames on the command line.
;;;;
;;;; The option `--test-suite' can be given to specify the test
;;;; directory.  If no such option is given, the test directory is
;;;; taken from the environment variable TEST_SUITE_DIR (if defined),
;;;; otherwise a default directory that is hardcoded in this file is
;;;; used (see "Installation" below).
;;;;
;;;; If present, the `--log-file LOG' option tells `guile-test' to put
;;;; the log output in a file named LOG.
;;;;
;;;; If present, the `--debug' option will enable a debugging mode.
;;;;
;;;; If present, the `--flag-unresolved' option will cause guile-test
;;;; to exit with failure status if any tests are UNRESOLVED.
;;;;
;;;;
;;;; Installation:
;;;;
;;;; If you change the #! line at the top of this script to point at
;;;; the Guile interpreter you want to test, you can call this script
;;;; as an executable instead of having to pass it as a parameter to
;;;; guile via "guile -e main -s guile-test".  Further, you can edit
;;;; the definition of default-test-suite to point to the parent
;;;; directory of the `tests' tree, which makes it unnecessary to set
;;;; the environment variable `TEST_SUITE_DIR'.
;;;;
;;;;
;;;; Shortcomings:
;;;;
;;;; At the moment, due to a simple-minded implementation, test files
;;;; must live in the test directory, and you must specify their names
;;;; relative to the top of the test directory.  If you want to send
;;;; me a patch that fixes this, but still leaves sane test names in
;;;; the log file, that would be great.  At the moment, all the tests
;;;; I care about are in the test directory, though.
;;;;
;;;; It would be nice if you could specify the Guile interpreter you
;;;; want to test on the command line.  As it stands, if you want to
;;;; change which Guile interpreter you're testing, you need to edit
;;;; the #! line at the top of this file, which is stupid.

(define (main . args)
  (let ((module (resolve-module '(test-suite guile-test))))
    (apply (module-ref module 'main) args)))

(define-module (test-suite guile-test)
  :use-module (test-suite lib)
  :use-module (ice-9 getopt-long)
  :use-module (ice-9 and-let-star)
  :use-module (ice-9 rdelim)
  :use-module (system vm coverage)
  :use-module (srfi srfi-11)
  :use-module (system vm vm)
  :export (main data-file-name test-file-name))

\f
;;; User configurable settings:
(define default-test-suite
  (string-append (getenv "HOME") "/bogus-path/test-suite"))

\f
;;; Variables that will receive their actual values later.
(define test-suite default-test-suite)

(define tmp-dir #f)

\f
;;; General utilities, that probably should be in a library somewhere.

;;; Enable debugging
(define (enable-debug-mode)
  (write-line %load-path)
  (set! %load-verbosely #t)
  (debug-enable 'backtrace 'debug))

;;; Traverse the directory tree at ROOT, applying F to the name of
;;; each file in the tree, including ROOT itself.  For a subdirectory
;;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
;;; symlinks.
(define (for-each-file f root)

  ;; A "hard directory" is a path that denotes a directory and is not a
  ;; symlink.
  (define (file-is-hard-directory? filename)
    (eq? (stat:type (lstat filename)) 'directory))

  (let visit ((root root))
    (let ((should-recur (f root)))
      (if (and should-recur (file-is-hard-directory? root))
	  (let ((dir (opendir root)))
	    (let loop ()
	      (let ((entry (readdir dir)))
		(cond
		 ((eof-object? entry) #f)
		 ((or (string=? entry ".")
		      (string=? entry "..")
                      (string=? entry "CVS")
                      (string=? entry "RCS"))
		  (loop))
		 (else
		  (visit (string-append root "/" entry))
		  (loop))))))))))

\f
;;; The test driver.

\f
;;; Localizing test files and temporary data files.

(define (data-file-name filename)
  (in-vicinity tmp-dir filename))

(define (test-file-name test)
  (in-vicinity test-suite test))

;;; Return a list of all the test files in the test tree.
(define (enumerate-tests test-dir)
  (let ((root-len (+ 1 (string-length test-dir)))
	(tests '()))
    (for-each-file (lambda (file)
		     (if (string-suffix? ".test" file)
			 (let ((short-name
				(substring file root-len)))
			   (set! tests (cons short-name tests))))
		     #t)
		   test-dir)

    ;; for-each-file presents the files in whatever order it finds
    ;; them in the directory.  We sort them here, so they'll always
    ;; appear in the same order.  This makes it easier to compare test
    ;; log files mechanically.
    (sort tests string<?)))

(define (main args)
  (let ((options (getopt-long args
			      `((test-suite
				 (single-char #\t)
				 (value #t))
                                (flag-unresolved
                                 (single-char #\u))
				(log-file
				 (single-char #\l)
				 (value #t))
                                (coverage
                                 (single-char #\c))
				(debug
				 (single-char #\d))))))
    (define (opt tag default)
      (let ((pair (assq tag options)))
	(if pair (cdr pair) default)))

    (if (opt 'debug #f)
	(enable-debug-mode))

    (set! test-suite
	  (or (opt 'test-suite #f)
	      (getenv "TEST_SUITE_DIR")
	      default-test-suite))

    ;; directory where temporary files are created.
    ;; when run from "make check", this must be under the build-dir,
    ;; not the src-dir.
    (set! tmp-dir (getcwd))

    (let* ((tests
	    (let ((foo (opt '() '())))
	      (if (null? foo)
		  (enumerate-tests test-suite)
		  foo)))
	   (log-file
	    (opt 'log-file "guile.log")))

      ;; Open the log file.
      (let ((log-port (open-output-file log-file)))

        ;; Allow for arbitrary Unicode characters in the log file.
        (set-port-encoding! log-port "UTF-8")

        ;; Don't fail if we can't display a test name to stdout/stderr.
        (set-port-conversion-strategy! (current-output-port) 'escape)
        (set-port-conversion-strategy! (current-error-port) 'escape)

	;; Register some reporters.
	(let ((global-pass #t)
	      (counter (make-count-reporter)))
	  (register-reporter (car counter))
	  (register-reporter (make-log-reporter log-port))
	  (register-reporter user-reporter)
	  (register-reporter (lambda results
			       (case (car results)
                                 ((unresolved)
                                  (and (opt 'flag-unresolved #f)
                                       (set! global-pass #f)))
				 ((fail upass error)
				  (set! global-pass #f)))))

	  ;; Run the tests.
          (let ((run-tests
                 (lambda ()
                   (for-each (lambda (test)
                               (display (string-append "Running " test "\n"))
                               (with-test-prefix test
                                                 (load (test-file-name test))))
                             tests))))
            (if (opt 'coverage #f)
                (let-values (((coverage-data _)
                              (with-code-coverage (the-vm) run-tests)))
                  (let ((out (open-output-file "guile.info")))
                    (coverage-data->lcov coverage-data out)
                    (close out)))
                (run-tests)))

	  ;; Display the final counts, both to the user and in the log
	  ;; file.
	  (let ((counts ((cadr counter))))
	    (print-counts counts)
	    (print-counts counts log-port))

	  (close-port log-port)
	  (quit global-pass))))))

\f
;;; Local Variables:
;;; mode: scheme
;;; End: