mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
b3b7477128
* test-suite/guile-test: add call-with-temp-dir and exception-errno. * test-suite/tests/filesys.test: add further copy-file tests.
307 lines
11 KiB
Scheme
Executable file
307 lines
11 KiB
Scheme
Executable file
#!../meta/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, 2014, 2022 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 -L `pwd`/test-suite -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' and don't begin with `.'. (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)
|
||
:declarative? #f
|
||
: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)
|
||
#:declarative? #f
|
||
:use-module ((test-suite lib automake) :prefix automake/)
|
||
:export (call-with-temp-dir
|
||
data-file-name
|
||
exception-errno
|
||
main
|
||
test-file-name))
|
||
|
||
|
||
;;; User configurable settings:
|
||
(define (default-test-suite)
|
||
(let ((argv0 (car (program-arguments))))
|
||
(if (string=? (basename argv0) "guile-test")
|
||
(dirname argv0)
|
||
(error "Cannot find default test suite."))))
|
||
|
||
|
||
;;; Variables that will receive their actual values later.
|
||
(define test-suite)
|
||
|
||
(define tmp-dir #f)
|
||
|
||
|
||
;;; General utilities, that probably should be in a library somewhere.
|
||
|
||
(define-syntax-rule (call-with-temp-dir template f)
|
||
"Call (f tempdir) with a temporary directory created by (mkdtemp
|
||
template) that is always removed on exit from f."
|
||
(let ((tmpdir (mkdtemp template)))
|
||
(dynamic-wind
|
||
(const #f)
|
||
(λ () (f tmpdir))
|
||
(λ ()
|
||
(unless (zero? (status:exit-val (system* "rm" "-rf" tmpdir)))
|
||
(error "Unable to remove temporary directory: " tmpdir))))))
|
||
|
||
(define (exception-errno ex)
|
||
"Return the errno value from the system-error derived &exception ex."
|
||
(car (list-ref (exception-args ex) 3)))
|
||
|
||
;;; Enable debugging
|
||
(define (enable-debug-mode)
|
||
(write-line %load-path)
|
||
(set! %load-verbosely #t))
|
||
|
||
;;; 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))))))))))
|
||
|
||
|
||
;;; The test driver.
|
||
|
||
|
||
;;; 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)
|
||
(when (string-suffix? ".test" file)
|
||
(let ((short-name (substring file root-len)))
|
||
(unless (eqv? #\. (string-ref short-name 0))
|
||
(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))
|
||
(trs-file
|
||
(value #t))))))
|
||
(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"))
|
||
(trs-file (opt 'trs-file #f)))
|
||
|
||
;; Open the log file.
|
||
(let ((log-port (open-output-file log-file))
|
||
(trs-port (and trs-file
|
||
(let ((p (open-output-file trs-file)))
|
||
(set-port-encoding! p "UTF-8")
|
||
(display ":copy-in-global-log: no\n" p)
|
||
p))))
|
||
|
||
;; 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)))
|
||
(when trs-port
|
||
(register-reporter (automake/reporter trs-port)))
|
||
(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"))
|
||
(when (defined? 'setlocale)
|
||
(setlocale LC_ALL "C"))
|
||
(with-test-prefix test
|
||
(load (test-file-name test))))
|
||
tests))))
|
||
(if (opt 'coverage #f)
|
||
(let-values (((coverage-data _)
|
||
(with-code-coverage 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))))
|
||
(unless trs-port
|
||
(print-counts counts))
|
||
(print-counts counts log-port)
|
||
|
||
(close-port log-port)
|
||
|
||
(when trs-port
|
||
(when global-pass (display ":recheck: no\n" trs-port))
|
||
(display ":test-global-result: " trs-port)
|
||
(display (count-summary-line counts) trs-port)
|
||
(newline trs-port)
|
||
(close-port trs-port)))
|
||
|
||
(quit global-pass))))))
|
||
|
||
|
||
;;; Local Variables:
|
||
;;; mode: scheme
|
||
;;; End:
|