123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516 |
- ;;;; test-suite/lib.scm --- generic support for testing
- ;;;; Copyright (C) 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
- ;;;;
- ;;;; This program is free software; you can redistribute it and/or modify
- ;;;; it under the terms of the GNU General Public License as published by
- ;;;; the Free Software Foundation; either version 2, 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 General Public License for more details.
- ;;;;
- ;;;; You should have received a copy of the GNU General Public License
- ;;;; along with this software; see the file COPYING. If not, write to
- ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- ;;;; Boston, MA 02111-1307 USA
- (define-module (test-suite lib)
- ;;:use-module (ice-9 stack-catch)
- :use-module (ice-9 regex))
- (export
- ;; Exceptions which are commonly being tested for.
- exception:out-of-range exception:unbound-var
- exception:wrong-num-args exception:wrong-type-arg
- ;; Reporting passes and failures.
- run-test
- pass-if expect-fail
- pass-if-exception expect-fail-exception
- ;; Naming groups of tests in a regular fashion.
- with-test-prefix with-test-prefix* current-test-prefix
- ;; Reporting results in various ways.
- register-reporter unregister-reporter reporter-registered?
- make-count-reporter print-counts
- make-log-reporter
- full-reporter
- user-reporter
- format-test-name
- ;; The more modern way to check exceptions is to use `run-test-exception',
- ;; but that uses (ice-9 stack-catch), which is not available yet, so we use
- ;; these two. We also prevent `run-test-exception' definition below.
- signals-error? signals-error?*)
- ;;;; If you're using Emacs's Scheme mode:
- ;;;; (put 'with-test-prefix 'scheme-indent-function 1)
- ;;;; CORE FUNCTIONS
- ;;;;
- ;;;; The function (run-test name expected-result thunk) is the heart of the
- ;;;; testing environment. The first parameter NAME is a unique name for the
- ;;;; test to be executed (for an explanation of this parameter see below under
- ;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
- ;;;; that indicates whether the corresponding test is expected to pass. If
- ;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
- ;;;; #f the test is expected to fail. Finally, THUNK is the function that
- ;;;; actually performs the test. For example:
- ;;;;
- ;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
- ;;;;
- ;;;; To report success, THUNK should either return #t or throw 'pass. To
- ;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
- ;;;; returns a non boolean value or throws 'unresolved, this indicates that
- ;;;; the test did not perform as expected. For example the property that was
- ;;;; to be tested could not be tested because something else went wrong.
- ;;;; THUNK may also throw 'untested to indicate that the test was deliberately
- ;;;; not performed, for example because the test case is not complete yet.
- ;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
- ;;;; requires some feature that is not available in the configured testing
- ;;;; environment. All other exceptions thrown by THUNK are considered as
- ;;;; errors.
- ;;;;
- ;;;;
- ;;;; Convenience macros for tests expected to pass or fail
- ;;;;
- ;;;; * (pass-if name body) is a short form for
- ;;;; (run-test name #t (lambda () body))
- ;;;; * (expect-fail name body) is a short form for
- ;;;; (run-test name #f (lambda () body))
- ;;;;
- ;;;; For example:
- ;;;;
- ;;;; (pass-if "integer addition" (= 2 (+ 1 1)))
- ;;;;
- ;;;;
- ;;;; Convenience macros to test for exceptions
- ;;;;
- ;;;; The following macros take exception parameters which are pairs
- ;;;; (type . message), where type is a symbol that denotes an exception type
- ;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
- ;;;; regular expression that describes the error message for the exception
- ;;;; like "Argument .* out of range".
- ;;;;
- ;;;; * (pass-if-exception name exception body) will pass if the execution of
- ;;;; body causes the given exception to be thrown. If no exception is
- ;;;; thrown, the test fails. If some other exception is thrown, is is an
- ;;;; error.
- ;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
- ;;;; the execution of body causes the given exception to be thrown. If no
- ;;;; exception is thrown, the test fails expectedly. If some other
- ;;;; exception is thrown, it is an error.
- ;;;; TEST NAMES
- ;;;;
- ;;;; Every test in the test suite has a unique name, to help
- ;;;; developers find tests that are failing (or unexpectedly passing),
- ;;;; and to help gather statistics.
- ;;;;
- ;;;; A test name is a list of printable objects. For example:
- ;;;; ("ports.scm" "file" "read and write back list of strings")
- ;;;; ("ports.scm" "pipe" "read")
- ;;;;
- ;;;; Test names may contain arbitrary objects, but they always have
- ;;;; the following properties:
- ;;;; - Test names can be compared with EQUAL?.
- ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
- ;;;; and READ procedures; doing so preserves their identity.
- ;;;;
- ;;;; For example:
- ;;;;
- ;;;; (pass-if "simple addition" (= 4 (+ 2 2)))
- ;;;;
- ;;;; In that case, the test name is the list ("simple addition").
- ;;;;
- ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
- ;;;; a prefix for the names of all tests whose results are reported
- ;;;; within their dynamic scope. For example:
- ;;;;
- ;;;; (begin
- ;;;; (with-test-prefix "basic arithmetic"
- ;;;; (pass-if "addition" (= (+ 2 2) 4))
- ;;;; (pass-if "subtraction" (= (- 4 2) 2)))
- ;;;; (pass-if "multiplication" (= (* 2 2) 4)))
- ;;;;
- ;;;; In that example, the three test names are:
- ;;;; ("basic arithmetic" "addition"),
- ;;;; ("basic arithmetic" "subtraction"), and
- ;;;; ("multiplication").
- ;;;;
- ;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends
- ;;;; a new element to the current prefix:
- ;;;;
- ;;;; (with-test-prefix "arithmetic"
- ;;;; (with-test-prefix "addition"
- ;;;; (pass-if "integer" (= (+ 2 2) 4))
- ;;;; (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
- ;;;; (with-test-prefix "subtraction"
- ;;;; (pass-if "integer" (= (- 2 2) 0))
- ;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
- ;;;;
- ;;;; The four test names here are:
- ;;;; ("arithmetic" "addition" "integer")
- ;;;; ("arithmetic" "addition" "complex")
- ;;;; ("arithmetic" "subtraction" "integer")
- ;;;; ("arithmetic" "subtraction" "complex")
- ;;;;
- ;;;; To print a name for a human reader, we DISPLAY its elements,
- ;;;; separated by ": ". So, the last set of test names would be
- ;;;; reported as:
- ;;;;
- ;;;; arithmetic: addition: integer
- ;;;; arithmetic: addition: complex
- ;;;; arithmetic: subtraction: integer
- ;;;; arithmetic: subtraction: complex
- ;;;;
- ;;;; The Guile benchmarks use with-test-prefix to include the name of
- ;;;; the source file containing the test in the test name, to help
- ;;;; developers to find failing tests, and to provide each file with its
- ;;;; own namespace.
- ;;;; REPORTERS
- ;;;;
- ;;;; A reporter is a function which we apply to each test outcome.
- ;;;; Reporters can log results, print interesting results to the
- ;;;; standard output, collect statistics, etc.
- ;;;;
- ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
- ;;;; possibly additional arguments depending on RESULT; its return value
- ;;;; is ignored. RESULT has one of the following forms:
- ;;;;
- ;;;; pass - The test named TEST passed.
- ;;;; Additional arguments are ignored.
- ;;;; upass - The test named TEST passed unexpectedly.
- ;;;; Additional arguments are ignored.
- ;;;; fail - The test named TEST failed.
- ;;;; Additional arguments are ignored.
- ;;;; xfail - The test named TEST failed, as expected.
- ;;;; Additional arguments are ignored.
- ;;;; unresolved - The test named TEST did not perform as expected, for
- ;;;; example the property that was to be tested could not be
- ;;;; tested because something else went wrong.
- ;;;; Additional arguments are ignored.
- ;;;; untested - The test named TEST was not actually performed, for
- ;;;; example because the test case is not complete yet.
- ;;;; Additional arguments are ignored.
- ;;;; unsupported - The test named TEST requires some feature that is not
- ;;;; available in the configured testing environment.
- ;;;; Additional arguments are ignored.
- ;;;; error - An error occurred while the test named TEST was
- ;;;; performed. Since this result means that the system caught
- ;;;; an exception it could not handle, the exception arguments
- ;;;; are passed as additional arguments.
- ;;;;
- ;;;; This library provides some standard reporters for logging results
- ;;;; to a file, reporting interesting results to the user, and
- ;;;; collecting totals.
- ;;;;
- ;;;; You can use the REGISTER-REPORTER function and friends to add
- ;;;; whatever reporting functions you like. If you don't register any
- ;;;; reporters, the library uses FULL-REPORTER, which simply writes
- ;;;; all results to the standard output.
- ;;;; MISCELLANEOUS
- ;;;;
- ;;; Define some exceptions which are commonly being tested for.
- (define exception:out-of-range
- (cons 'out-of-range "^Argument .*out of range"))
- (define exception:unbound-var
- (cons 'unbound-variable "^Unbound variable"))
- (define exception:wrong-num-args
- (cons 'wrong-number-of-args "^Wrong number of arguments"))
- (define exception:wrong-type-arg
- (cons 'wrong-type-arg "^Wrong type argument"))
- ;;; Display all parameters to the default output port, followed by a newline.
- (define (display-line . objs)
- (for-each display objs)
- (newline))
- ;;; Display all parameters to the given output port, followed by a newline.
- (define (display-line-port port . objs)
- (for-each (lambda (obj) (display obj port)) objs)
- (newline port))
- ;;;; CORE FUNCTIONS
- ;;;;
- ;;; The central testing routine.
- ;;; The idea is taken from Greg, the GNUstep regression test environment.
- (define run-test #f)
- (let ((test-running #f))
- (define (local-run-test name expect-pass thunk)
- (if test-running
- (error "Nested calls to run-test are not permitted.")
- (let ((test-name (full-name name)))
- (set! test-running #t)
- (catch #t
- (lambda ()
- (let ((result (thunk)))
- (if (eq? result #t) (throw 'pass))
- (if (eq? result #f) (throw 'fail))
- (throw 'unresolved)))
- (lambda (key . args)
- (case key
- ((pass)
- (report (if expect-pass 'pass 'upass) test-name))
- ((fail)
- (report (if expect-pass 'fail 'xfail) test-name))
- ((unresolved untested unsupported)
- (report key test-name))
- ((quit)
- (report 'unresolved test-name)
- (quit))
- (else
- (report 'error test-name (cons key args))))))
- (set! test-running #f))))
- (set! run-test local-run-test))
- ;;; A short form for tests that are expected to pass, taken from Greg.
- (defmacro pass-if (name body . rest)
- `(run-test ,name #t (lambda () ,body ,@rest)))
- ;;; A short form for tests that are expected to fail, taken from Greg.
- (defmacro expect-fail (name body . rest)
- `(run-test ,name #f (lambda () ,body ,@rest)))
- ;;; A helper function to implement the macros that test for exceptions.
- '(define (run-test-exception name exception expect-pass thunk)
- (run-test name expect-pass
- (lambda ()
- (stack-catch (car exception)
- (lambda () (thunk) #f)
- (lambda (key proc message . rest)
- (cond
- ;; handle explicit key
- ((string-match (cdr exception) message)
- #t)
- ;; handle `(error ...)' which uses `misc-error' for key and doesn't
- ;; yet format the message and args (we have to do it here).
- ((and (eq? 'misc-error (car exception))
- (list? rest)
- (string-match (cdr exception)
- (apply simple-format #f message (car rest))))
- #t)
- ;; unhandled; throw again
- (else
- (apply throw key proc message rest))))))))
- ;;; A short form for tests that expect a certain exception to be thrown.
- (defmacro pass-if-exception (name exception body . rest)
- `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
- ;;; A short form for tests expected to fail to throw a certain exception.
- (defmacro expect-fail-exception (name exception body . rest)
- `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
- ;;;; TEST NAMES
- ;;;;
- ;;;; Turn a test name into a nice human-readable string.
- (define (format-test-name name)
- (call-with-output-string
- (lambda (port)
- (let loop ((name name)
- (separator ""))
- (if (pair? name)
- (begin
- (display separator port)
- (display (car name) port)
- (loop (cdr name) ": ")))))))
- ;;;; For a given test-name, deliver the full name including all prefixes.
- (define (full-name name)
- (append (current-test-prefix) (list name)))
- ;;; A fluid containing the current test prefix, as a list.
- (define prefix-fluid (make-fluid))
- (fluid-set! prefix-fluid '())
- (define (current-test-prefix)
- (fluid-ref prefix-fluid))
- ;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
- ;;; The name prefix is only changed within the dynamic scope of the
- ;;; call to with-test-prefix*. Return the value returned by THUNK.
- (define (with-test-prefix* prefix thunk)
- (with-fluids ((prefix-fluid
- (append (fluid-ref prefix-fluid) (list prefix))))
- (thunk)))
- ;;; (with-test-prefix PREFIX BODY ...)
- ;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
- ;;; The name prefix is only changed within the dynamic scope of the
- ;;; with-test-prefix expression. Return the value returned by the last
- ;;; BODY expression.
- (defmacro with-test-prefix (prefix . body)
- `(with-test-prefix* ,prefix (lambda () ,@body)))
- ;;;; REPORTERS
- ;;;;
- ;;; The global list of reporters.
- (define reporters '())
- ;;; The default reporter, to be used only if no others exist.
- (define default-reporter #f)
- ;;; Add the procedure REPORTER to the current set of reporter functions.
- ;;; Signal an error if that reporter procedure object is already registered.
- (define (register-reporter reporter)
- (if (memq reporter reporters)
- (error "register-reporter: reporter already registered: " reporter))
- (set! reporters (cons reporter reporters)))
- ;;; Remove the procedure REPORTER from the current set of reporter
- ;;; functions. Signal an error if REPORTER is not currently registered.
- (define (unregister-reporter reporter)
- (if (memq reporter reporters)
- (set! reporters (delq! reporter reporters))
- (error "unregister-reporter: reporter not registered: " reporter)))
- ;;; Return true iff REPORTER is in the current set of reporter functions.
- (define (reporter-registered? reporter)
- (if (memq reporter reporters) #t #f))
- ;;; Send RESULT to all currently registered reporter functions.
- (define (report . args)
- (if (pair? reporters)
- (for-each (lambda (reporter) (apply reporter args))
- reporters)
- (apply default-reporter args)))
- ;;;; Some useful standard reporters:
- ;;;; Count reporters count the occurrence of each test result type.
- ;;;; Log reporters write all test results to a given log file.
- ;;;; Full reporters write all test results to the standard output.
- ;;;; User reporters write interesting test results to the standard output.
- ;;; The complete list of possible test results.
- (define result-tags
- '((pass "PASS" "passes: ")
- (fail "FAIL" "failures: ")
- (upass "UPASS" "unexpected passes: ")
- (xfail "XFAIL" "expected failures: ")
- (unresolved "UNRESOLVED" "unresolved test cases: ")
- (untested "UNTESTED" "untested test cases: ")
- (unsupported "UNSUPPORTED" "unsupported test cases: ")
- (error "ERROR" "errors: ")))
- ;;; The list of important test results.
- (define important-result-tags
- '(fail upass unresolved error))
- ;;; Display a single test result in formatted form to the given port
- (define (print-result port result name . args)
- (let* ((tag (assq result result-tags))
- (label (if tag (cadr tag) #f)))
- (if label
- (begin
- (display label port)
- (display ": " port)
- (display (format-test-name name) port)
- (if (pair? args)
- (begin
- (display " - arguments: " port)
- (write args port)))
- (newline port))
- (error "(test-suite lib) FULL-REPORTER: unrecognized result: "
- result))))
- ;;; Return a list of the form (COUNTER RESULTS), where:
- ;;; - COUNTER is a reporter procedure, and
- ;;; - RESULTS is a procedure taking no arguments which returns the
- ;;; results seen so far by COUNTER. The return value is an alist
- ;;; mapping outcome symbols (`pass', `fail', etc.) onto counts.
- (define (make-count-reporter)
- (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
- (list
- (lambda (result name . args)
- (let ((pair (assq result counts)))
- (if pair
- (set-cdr! pair (+ 1 (cdr pair)))
- (error "count-reporter: unexpected test result: "
- (cons result (cons name args))))))
- (lambda ()
- (append counts '())))))
- ;;; Print a count reporter's results nicely. Pass this function the value
- ;;; returned by a count reporter's RESULTS procedure.
- (define (print-counts results . port?)
- (let ((port (if (pair? port?)
- (car port?)
- (current-output-port))))
- (newline port)
- (display-line-port port "Totals for this test run:")
- (for-each
- (lambda (tag)
- (let ((result (assq (car tag) results)))
- (if result
- (display-line-port port (caddr tag) (cdr result))
- (display-line-port port
- "Test suite bug: "
- "no total available for `" (car tag) "'"))))
- result-tags)
- (newline port)))
- ;;; Return a reporter procedure which prints all results to the file
- ;;; FILE, in human-readable form. FILE may be a filename, or a port.
- (define (make-log-reporter file)
- (let ((port (if (output-port? file) file
- (open-output-file file))))
- (lambda args
- (apply print-result port args)
- (force-output port))))
- ;;; A reporter that reports all results to the user.
- (define (full-reporter . args)
- (apply print-result (current-output-port) args))
- ;;; A reporter procedure which shows interesting results (failures,
- ;;; unexpected passes etc.) to the user.
- (define (user-reporter result name . args)
- (if (memq result important-result-tags)
- (apply full-reporter result name args)))
- (set! default-reporter full-reporter)
- ;;;; Detecting whether errors occur
- ;;; (signals-error? KEY BODY ...)
- ;;; Evaluate the expressions BODY ... . If any errors occur, return #t;
- ;;; otherwise, return #f.
- ;;;
- ;;; KEY indicates the sort of errors to look for; it can be a symbol,
- ;;; indicating that only errors with that name should be caught, or
- ;;; #t, meaning that any kind of error should be caught.
- (defmacro signals-error? key-and-body
- `(signals-error?* ,(car key-and-body)
- (lambda () ,@(cdr key-and-body))))
- ;;; (signals-error?* KEY THUNK)
- ;;; Apply THUNK, catching errors. If any errors occur, return #t;
- ;;; otherwise, return #f.
- ;;;
- ;;; KEY indicates the sort of errors to look for; it can be a symbol,
- ;;; indicating that only errors with that name should be caught, or
- ;;; #t, meaning that any kind of error should be caught.
- (define (signals-error?* key thunk)
- (catch key
- (lambda () (thunk) #f)
- (lambda args #t)))
|