lisp-unit.lisp

   1 ;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 #|
   4 Copyright (c) 2004-2005 Christopher K. Riesbeck
   5
   6 Permission is hereby granted, free of charge, to any person obtaining
   7 a copy of this software and associated documentation files (the "Software"),
   8 to deal in the Software without restriction, including without limitation
   9 the rights to use, copy, modify, merge, publish, distribute, sublicense,
  10 and/or sell copies of the Software, and to permit persons to whom the
  11 Software is furnished to do so, subject to the following conditions:
  12
  13 The above copyright notice and this permission notice shall be included
  14 in all copies or substantial portions of the Software.
  15
  16 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  17 OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  18 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  19 THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
  20 OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
  21 ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  22 OTHER DEALINGS IN THE SOFTWARE.
  23
  24
  25 How to use
  26 ----------
  27
  28 1. Read the documentation at:
  29    https://github.com/OdonataResearchLLC/lisp-unit/wiki
  30
  31 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
  32 examples. If you want, start your test file with (REMOVE-TESTS :ALL)
  33 to clear any previously defined tests.
  34
  35 3. Load this file.
  36
  37 4. (use-package :lisp-unit)
  38
  39 5. Load your code file and your file of tests.
  40
  41 6. Test your code with (RUN-TESTS '(test-name1 test-name2 ...)) or
  42 simply (RUN-TESTS :ALL) to run all defined tests.
  43
  44 A summary of how many tests passed and failed will be printed.
  45
  46 NOTE: Nothing is compiled until RUN-TESTS is expanded. Redefining
  47 functions or even macros does not require reloading any tests.
  48
  49 |#
  50
  51 ;;; Packages
  52
  53 (in-package :cl-user)
  54
  55 (defpackage :lisp-unit
  56   (:use :common-lisp)
  57   ;; Print parameters
  58   (:export :*print-summary*
  59            :*print-failures*
  60            :*print-errors*
  61            :*summarize-results*)
  62   ;; Forms for assertions
  63   (:export :assert-eq
  64            :assert-eql
  65            :assert-equal
  66            :assert-equalp
  67            :assert-equality
  68            :assert-prints
  69            :assert-expands
  70            :assert-true
  71            :assert-test
  72            :assert-false
  73            :assert-error)
  74   ;; Functions for managing tests
  75   (:export :define-test
  76            :list-tests
  77            :test-code
  78            :test-documentation
  79            :remove-tests
  80            :run-tests
  81            :use-debugger)
  82   ;; Functions for managing tags
  83   (:export :list-tags
  84            :tagged-tests
  85            :remove-tags
  86            :run-tags)
  87   ;; Functions for reporting test results
  88   (:export :test-names
  89            :failed-tests
  90            :error-tests
  91            :missing-tests
  92            :print-failures
  93            :print-errors
  94            :summarize-results)
  95   ;; Functions for test results
  96   (:export :reduce-test-results-dbs)
  97   ;; Functions for extensibility via signals
  98   (:export :signal-results
  99            :test-run-complete
 100            :results)
 101   ;; Utility predicates
 102   (:export :logically-equal :set-equal))
 103
 104 (in-package :lisp-unit)
 105
 106 ;;; Global counters
 107
 108 (defparameter *pass* 0
 109   "The passed assertion results.")
 110
 111 (defparameter *fail* ()
 112   "The failed assertion results.")
 113
 114 (defun reset-counters ()
 115   "Reset the counters to empty lists."
 116   (setf *pass* 0 *fail* ()))
 117
 118 ;;; Global options
 119
 120 (defparameter *print-summary* nil
 121   "Print a summary of the pass, fail, and error count if non-nil.")
 122
 123 (defparameter *print-failures* nil
 124   "Print failure messages if non-NIL.")
 125
 126 (defparameter *print-errors* nil
 127   "Print error messages if non-NIL.")
 128
 129 (defparameter *summarize-results* t
 130   "Summarize all of the unit test results.")
 131
 132 (defparameter *use-debugger* nil
 133   "If not NIL, enter the debugger when an error is encountered in an
 134 assertion.")
 135
 136 (defun use-debugger (&optional (flag t))
 137   "Use the debugger when testing, or not."
 138   (setq *use-debugger* flag))
 139
 140 (defun use-debugger-p (condition)
 141   "Debug or ignore errors."
 142   (cond
 143    ((eq :ask *use-debugger*)
 144     (y-or-n-p "~A -- debug?" condition))
 145    (*use-debugger*)))
 146
 147 (defparameter *signal-results* nil
 148   "Signal the result if non NIL.")
 149
 150 (defun signal-results (&optional (flag t))
 151   "Signal the results for extensibility."
 152   (setq *signal-results* flag))
 153
 154 ;;; Global unit test database
 155
 156 (defparameter *test-db* (make-hash-table :test #'eq)
 157   "The unit test database is simply a hash table.")
 158
 159 (defun null-tests-warning-report (null-tests-warning stream)
 160   "Write the null-tests-warning to the stream."
 161   (format stream "No tests defined for package ~A."
 162           (tests-package-name null-tests-warning)))
 163
 164 (define-condition null-tests-warning (simple-warning)
 165   ((name
 166     :type string
 167     :initarg :name
 168     :reader tests-package-name))
 169   (:report null-tests-warning-report))
 170
 171 (defun package-table (package &optional create)
 172   (let ((packobj (find-package package)))
 173     (cond
 174      ((gethash packobj *test-db*))
 175      (create
 176       (setf (gethash packobj *test-db*) (make-hash-table)))
 177      (t (warn 'null-tests-warning :name (package-name package))))))
 178
 179 (defmacro with-package-table ((table
 180                                &optional (package *package*) create)
 181                               &body body)
 182   "Execute the body only if the package table exists."
 183   (let ((gtable (gensym "TABLE-")))
 184     `(let* ((,gtable (package-table ,package ,create))
 185             (,table ,gtable))
 186        (when (hash-table-p ,gtable) ,@body))))
 187
 188 ;;; Global tags database
 189
 190 (defparameter *tag-db* (make-hash-table :test #'eq)
 191   "The tag database is simply a hash table.")
 192
 193 (defun null-tags-warning-report (null-tags-warning stream)
 194   "Write the null-tags-warning to the stream."
 195   (format stream "No tags defined for package ~A."
 196           (tags-package-name null-tags-warning)))
 197
 198 (define-condition null-tags-warning (simple-warning)
 199   ((name
 200     :type string
 201     :initarg :name
 202     :reader tags-package-name))
 203   (:report null-tags-warning-report))
 204
 205 (defun package-tags (package &optional create)
 206   "Return the tags DB for the package."
 207   (let ((packobj (find-package package)))
 208     (cond
 209      ((gethash packobj *tag-db*))
 210      (create
 211       (setf (gethash packobj *tag-db*) (make-hash-table)))
 212      (t (warn 'null-tags-warning :name (package-name package))))))
 213
 214 (defmacro with-package-tags ((table
 215                               &optional (package *package*) create)
 216                              &body body)
 217   "Execute the body only if the package tags exists."
 218   (let ((gtable (gensym "TABLE-")))
 219     `(let* ((,gtable (package-tags ,package ,create))
 220             (,table ,gtable))
 221        (when (hash-table-p ,gtable) ,@body))))
 222
 223 ;;; Unit test definition
 224
 225 (defclass unit-test ()
 226   ((doc
 227     :type string
 228     :initarg :doc
 229     :reader doc)
 230    (thunk
 231     :type (function () t)
 232     :initarg :thunk)
 233    (code
 234     :type list
 235     :initarg :code
 236     :reader code))
 237   (:default-initargs :doc "" :code ())
 238   (:documentation
 239    "Organize the unit test documentation and code."))
 240
 241 ;;; NOTE: Shamelessly taken from PG's analyze-body
 242 (defun parse-body (body &optional doc tag)
 243   "Separate the components of the body."
 244   (let ((item (first body)))
 245     (cond
 246      ((and (listp item) (eq :tag (first item)))
 247       (parse-body (rest body) doc (nconc (rest item) tag)))
 248      ((and (stringp item) (not doc) (rest body))
 249       (if tag
 250           (values doc tag (rest body))
 251           (parse-body (rest body) item tag)))
 252      (t (values doc tag body)))))
 253
 254 (defun test-name-error-report (test-name-error stream)
 255   "Write the test-name-error to the stream."
 256   (format stream "Test name ~S is not of type ~A."
 257           (type-error-datum test-name-error)
 258           (type-error-expected-type test-name-error)))
 259
 260 (define-condition test-name-error (type-error)
 261   ()
 262   (:default-initargs :expected-type 'symbol)
 263   (:report test-name-error-report)
 264   (:documentation
 265    "The test name error is a type error."))
 266
 267 (defun valid-test-name (name)
 268   "Signal a type-error if the test name is not a symbol."
 269   (if (symbolp name)
 270       name
 271       (error 'test-name-error :datum name)))
 272
 273 (defun test-package (name)
 274   "Return the package for storing the test."
 275   (multiple-value-bind (symbol status)
 276       (find-symbol (symbol-name name))
 277     (declare (ignore symbol))
 278     (ecase status
 279       ((:internal :external nil)
 280        (symbol-package name))
 281       (:inherited *package*))))
 282
 283 (defmacro define-test (name &body body)
 284   "Store the test in the test database."
 285   (let ((qname (gensym "NAME-")))
 286     (multiple-value-bind (doc tag code) (parse-body body)
 287       `(let* ((,qname (valid-test-name ',name))
 288               (doc (or ,doc (symbol-name ,qname)))
 289               (package (test-package ,qname)))
 290          (setf
 291           ;; Unit test
 292           (gethash ,qname (package-table package t))
 293           (make-instance 'unit-test :doc doc :code ',code :thunk (lambda () ,@body)))
 294          ;; Tags
 295          (loop
 296           for tag in ',tag do
 297           (pushnew ,qname (gethash tag (package-tags package t))))
 298          ;; Return the name of the test
 299          ,qname))))
 300
 301 ;;; Manage tests
 302
 303 (defun list-tests (&optional (package *package*))
 304   "Return a list of the tests in package."
 305   (with-package-table (table package)
 306     (loop for test-name being each hash-key in table
 307           collect test-name)))
 308
 309 (defun test-documentation (name &optional (package *package*))
 310   "Return the documentation for the test."
 311   (with-package-table (table package)
 312     (let ((unit-test (gethash name table)))
 313       (if (null unit-test)
 314           (warn "No test ~A in package ~A."
 315                 name (package-name package))
 316           (doc unit-test)))))
 317
 318 (defun test-code (name &optional (package *package*))
 319   "Returns the code stored for the test name."
 320   (with-package-table (table package)
 321     (let ((unit-test (gethash name table)))
 322       (if (null unit-test)
 323           (warn "No test ~A in package ~A."
 324                 name (package-name package))
 325           (code unit-test)))))
 326
 327 (defun remove-tests (&optional (names :all) (package *package*))
 328   "Remove individual tests or entire sets."
 329   (if (eq :all names)
 330       (if (null package)
 331           (clrhash *test-db*)
 332           (progn
 333             (remhash (find-package package) *test-db*)
 334             (remhash (find-package package) *tag-db*)))
 335       (progn
 336         ;; Remove tests
 337         (with-package-table (table package)
 338           (loop for name in names
 339                 unless (remhash name table) do
 340                 (warn "No test ~A in package ~A to remove."
 341                       name (package-name package))))
 342         ;; Remove tests from tags
 343         (with-package-tags (tags package)
 344           (loop for tag being each hash-key in tags
 345                 using (hash-value tagged-tests)
 346                 do
 347                 (setf
 348                  (gethash tag tags)
 349                  (set-difference tagged-tests names)))))))
 350
 351 ;;; Manage tags
 352
 353 (defun %tests-from-all-tags (&optional (package *package*))
 354   "Return all of the tests that have been tagged."
 355   (with-package-tags (table package)
 356     (loop for tests being each hash-value in table
 357           nconc (copy-list tests) into all-tests
 358           finally (return (delete-duplicates all-tests)))))
 359
 360 (defun %tests-from-tags (tags &optional (package *package*))
 361   "Return the tests associated with the tags."
 362   (with-package-tags (table package)
 363     (loop for tag in tags
 364           as tests = (gethash tag table)
 365           if (null tests) do (warn "No tests tagged with ~S." tag)
 366           else nconc (copy-list tests) into all-tests
 367           finally (return (delete-duplicates all-tests)))))
 368
 369 (defun list-tags (&optional (package *package*))
 370   "Return a list of the tags in package."
 371   (with-package-tags (table package)
 372     (loop for tag being each hash-key in table collect tag)))
 373
 374 (defun tagged-tests (&optional (tags :all) (package *package*))
 375   "Return a list of the tests associated with the tags."
 376   (if (eq :all tags)
 377       (%tests-from-all-tags package)
 378       (%tests-from-tags tags package)))
 379
 380 (defun remove-tags (&optional (tags :all) (package *package*))
 381   "Remove individual tags or entire sets."
 382   (if (eq :all tags)
 383       (if (null package)
 384           (clrhash *tag-db*)
 385           (remhash (find-package package) *tag-db*))
 386       (with-package-tags (tag-table package)
 387         (loop for tag in tags
 388               unless (remhash tag tag-table) do
 389               (warn "No tag ~A in package ~A to remove."
 390                     tag (package-name package))))))
 391
 392 ;;; Assert macros
 393
 394 (defmacro assert-eq (expected form &rest extras)
 395   "Assert whether expected and form are EQ."
 396   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 397
 398 (defmacro assert-eql (expected form &rest extras)
 399   "Assert whether expected and form are EQL."
 400   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 401
 402 (defmacro assert-equal (expected form &rest extras)
 403   "Assert whether expected and form are EQUAL."
 404   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 405
 406 (defmacro assert-equalp (expected form &rest extras)
 407   "Assert whether expected and form are EQUALP."
 408   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 409
 410 (defmacro assert-error (condition form &rest extras)
 411   "Assert whether form signals condition."
 412   `(expand-assert :error ,form (expand-error-form ,form)
 413                   ,condition ,extras))
 414
 415 (defmacro assert-expands (expansion form &rest extras)
 416   "Assert whether form expands to expansion."
 417   `(expand-assert :macro ,form
 418                   (expand-macro-form ,form nil)
 419                   ',expansion ,extras))
 420
 421 (defmacro assert-equality (test expected form &rest extras)
 422   "Assert whether expected and form are equal according to test."
 423   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 424
 425 (defmacro assert-prints (output form &rest extras)
 426   "Assert whether printing the form generates the output."
 427   `(expand-assert :output ,form (expand-output-form ,form)
 428                   ,output ,extras))
 429
 430 (defmacro assert-nil (form &rest extras)
 431   "Assert whether the form is false."
 432   (if (atom form)
 433       `(expand-assert :result ,form ,form nil ,extras)
 434       `(expand-t-or-f nil ,form ,extras)))
 435
 436 (defmacro assert-false (form &rest extras)
 437   "Assert whether the form is false."
 438   (if (atom form)
 439       `(expand-assert :result ,form ,form nil ,extras)
 440       `(expand-t-or-f nil ,form ,extras)))
 441
 442 (defmacro assert-true (form &rest extras)
 443   "Assert whether the form is true."
 444   (if (atom form)
 445       `(expand-assert :result ,form ,form t ,extras)
 446       `(expand-t-or-f t ,form ,extras)))
 447
 448 (defmacro expand-t-or-f (t-or-f form extras)
 449   "Expand the true/false assertions to report the arguments."
 450   (let ((fname (gensym))
 451         (args (gensym)))
 452     `(let ((,fname #',(car form))
 453            (,args (list ,@(cdr form))))
 454        (internal-assert
 455         :result ',form
 456         (lambda () (apply ,fname ,args)) ; Evaluate the form
 457         (lambda () ,t-or-f)
 458         ;; Concatenate the args with the extras
 459         (lambda ()
 460           (nconc
 461            (mapcan #'list ',(cdr form) ,args)
 462            (funcall (expand-extras ,extras))))
 463         #'eql))))
 464
 465 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 466   "Expand the assertion to the internal format."
 467   `(internal-assert ,type ',form
 468                     (lambda () ,body)
 469                     (lambda () ,expected)
 470                     (expand-extras ,extras)
 471                     ,test))
 472
 473 (defmacro expand-error-form (form)
 474   "Wrap the error assertion in HANDLER-CASE."
 475   `(handler-case ,form
 476      (condition (error) error)))
 477
 478 (defmacro expand-output-form (form)
 479   "Capture the output of the form in a string."
 480   (let ((out (gensym)))
 481     `(let* ((,out (make-string-output-stream))
 482             (*standard-output*
 483              (make-broadcast-stream *standard-output* ,out)))
 484        ,form
 485        (get-output-stream-string ,out))))
 486
 487 (defmacro expand-macro-form (form env)
 488   "Expand the macro form once."
 489   `(let ((*gensym-counter* 1))
 490      (macroexpand-1 ',form ,env)))
 491
 492 (defmacro expand-extras (extras)
 493   "Expand extra forms."
 494   `(lambda ()
 495      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 496
 497 (defgeneric assert-result (type test expected actual)
 498   (:documentation
 499    "Return the result of the assertion."))
 500
 501 (defgeneric record-failure (type form actual expected extras test)
 502   (:documentation
 503    "Record the details of the failure."))
 504
 505 (defclass failure-result ()
 506   ((form
 507     :initarg :form
 508     :reader form)
 509    (actual
 510     :type list
 511     :initarg :actual
 512     :reader actual)
 513    (expected
 514     :type list
 515     :initarg :expected
 516     :reader expected)
 517    (extras
 518     :type list
 519     :initarg :extras
 520     :reader extras)
 521    (test
 522     :type function
 523     :initarg :test
 524     :reader test))
 525   (:documentation
 526    "Failure details of the assertion."))
 527
 528 (defun %record-failure (class form actual expected extras test)
 529   "Return an instance of the failure result."
 530   (make-instance class
 531                  :form form
 532                  :actual actual
 533                  :expected expected
 534                  :extras extras
 535                  :test test))
 536
 537 (defclass equal-result (failure-result)
 538   ()
 539   (:documentation
 540    "Result of a failed equal assertion."))
 541
 542 (defmethod assert-result ((type (eql :equal)) test expected actual)
 543   "Return the result of an equal assertion."
 544   (and
 545    (<= (length expected) (length actual))
 546    (every test expected actual)))
 547
 548 (defmethod record-failure ((type (eql :equal))
 549                            form actual expected extras test)
 550   "Return an instance of an equal failure result."
 551   (%record-failure 'equal-result form actual expected extras test))
 552
 553 (defclass error-result (failure-result)
 554   ()
 555   (:documentation
 556    "Result of a failed error assertion."))
 557
 558 (defmethod assert-result ((type (eql :error)) test expected actual)
 559   "Return the result of an error assertion."
 560   (declare (ignore test))
 561   (or
 562    (eql (car actual) (car expected))
 563    (typep (car actual) (car expected))))
 564
 565 (defmethod record-failure ((type (eql :error))
 566                            form actual expected extras test)
 567   "Return an instance of an error failure result."
 568   (%record-failure 'error-result form actual expected extras test))
 569
 570 (defclass macro-result (failure-result)
 571   ()
 572   (:documentation
 573    "Result of a failed macro expansion assertion."))
 574
 575 (defun %expansion-equal (form1 form2)
 576   "Descend into the forms checking for equality."
 577   (let ((item1 (first form1))
 578         (item2 (first form2)))
 579     (cond
 580      ((and (null item1) (null item2)))
 581      ((and (listp item1) (listp item2))
 582       (and
 583        (%expansion-equal item1 item2)
 584        (%expansion-equal (rest form1) (rest form2))))
 585      ((and (symbolp item1) (symbolp item2))
 586       (and
 587        (string= (symbol-name item1) (symbol-name item2))
 588        (%expansion-equal (rest form1) (rest form2))))
 589      (t (and
 590          (equal item1 item2)
 591          (%expansion-equal (rest form1) (rest form2)))))))
 592
 593 (defmethod assert-result ((type (eql  :macro)) test expected actual)
 594   "Return the result of a macro assertion."
 595   (declare (ignore test))
 596   (%expansion-equal (first expected) (first actual)))
 597
 598 (defmethod record-failure ((type (eql :macro))
 599                            form actual expected extras test)
 600   "Return an instance of a macro failure result."
 601   (%record-failure 'macro-result form actual expected extras test))
 602
 603 (defclass boolean-result (failure-result)
 604   ()
 605   (:documentation
 606    "Result of a failed boolean assertion."))
 607
 608 (defmethod assert-result ((type (eql :result)) test expected actual)
 609   "Return the result of a result assertion."
 610   (declare (ignore test))
 611   (logically-equal (car actual) (car expected)))
 612
 613 (defmethod record-failure ((type (eql :result))
 614                            form actual expected extras test)
 615   "Return an instance of a boolean failure result."
 616   (%record-failure 'boolean-result form actual expected extras test))
 617
 618 (defclass output-result (failure-result)
 619   ()
 620   (:documentation
 621    "Result of a failed output assertion."))
 622
 623 (defmethod assert-result ((type (eql :output)) test expected actual)
 624   "Return the result of an output assertion."
 625   (declare (ignore test))
 626   (string=
 627    (string-trim '(#\newline #\return #\space) (car actual))
 628    (car expected)))
 629
 630 (defmethod record-failure ((type (eql :output))
 631                            form actual expected extras test)
 632   "Return an instance of an output failure result."
 633   (%record-failure 'output-result form actual expected extras test))
 634
 635 (defun internal-assert
 636        (type form code-thunk expected-thunk extras test)
 637   "Perform the assertion and record the results."
 638   (let* ((actual (multiple-value-list (funcall code-thunk)))
 639          (expected (multiple-value-list (funcall expected-thunk)))
 640          (result (assert-result type test expected actual)))
 641     (if result
 642         (incf *pass*)
 643         (push
 644          (record-failure
 645           type form actual expected
 646           (when extras (funcall extras)) test)
 647          *fail*))
 648     ;; Return the result
 649     result))
 650
 651 ;;; Unit test results
 652
 653 (defclass test-result ()
 654   ((name
 655     :type symbol
 656     :initarg :name
 657     :reader name)
 658    (pass
 659     :type fixnum
 660     :initarg :pass
 661     :reader pass)
 662    (fail
 663     :type list
 664     :initarg :fail
 665     :reader fail)
 666    (exerr
 667     :initarg :exerr
 668     :reader exerr)
 669    (run-time
 670     :initarg :run-time
 671     :reader run-time
 672     :documentation
 673     "Test run time measured in internal time units"))
 674   (:default-initargs :exerr nil)
 675   (:documentation
 676    "Store the results of the unit test."))
 677
 678 (defun print-summary (test-result &optional
 679                       (stream *standard-output*))
 680   "Print a summary of the test result."
 681   (format stream "~&~A: ~S assertions passed, ~S failed"
 682           (name test-result)
 683           (pass test-result)
 684           (length (fail test-result)))
 685   (if (exerr test-result)
 686       (format stream ", and an execution error.")
 687       (write-char #\. stream))
 688   (terpri stream)
 689   (terpri stream))
 690
 691 (defun run-code (code)
 692   "Run the code to test the assertions."
 693   (funcall (coerce `(lambda () ,@code) 'function)))
 694
 695 (defun run-test-thunk (name code)
 696   (let ((*pass* 0)
 697         (*fail* ())
 698         (start (get-internal-run-time)))
 699     (handler-bind
 700         ((error
 701           (lambda (condition)
 702             (if (use-debugger-p condition)
 703                 condition
 704                 (return-from run-test-thunk
 705                   (make-instance
 706                    'test-result
 707                    :name name
 708                    :pass *pass*
 709                    :fail *fail*
 710                    :run-time (- (get-internal-run-time) start)
 711                    :exerr condition))))))
 712       (run-code code))
 713     ;; Return the result count
 714     (make-instance
 715      'test-result
 716      :name name
 717      :pass *pass*
 718      :fail *fail*
 719      :run-time (- (get-internal-run-time) start))))
 720
 721 ;;; Test results database
 722
 723 (defclass test-results-db ()
 724   ((database
 725     :type hash-table
 726     :initform (make-hash-table :test #'eq)
 727     :reader database)
 728    (pass
 729     :type fixnum
 730     :initform 0
 731     :accessor pass)
 732    (fail
 733     :type fixnum
 734     :initform 0
 735     :accessor fail)
 736    (exerr
 737     :type fixnum
 738     :initform 0
 739     :accessor exerr)
 740    (failed-tests
 741     :type list
 742     :initform ()
 743     :accessor failed-tests)
 744    (error-tests
 745     :type list
 746     :initform ()
 747     :accessor error-tests)
 748    (missing-tests
 749     :type list
 750     :initform ()
 751     :accessor missing-tests))
 752   (:documentation
 753    "Store the results of the tests for further evaluation."))
 754
 755 (defmethod print-object ((object test-results-db) stream)
 756   "Print the summary counts with the object."
 757   (let ((pass (pass object))
 758         (fail (fail object))
 759         (exerr (exerr object)))
 760     (format
 761      stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 762      (class-name (class-of object))
 763      (+ pass fail) pass fail exerr)))
 764
 765 (defun test-names (test-results-db)
 766   "Return a list of the test names in the database."
 767   (loop for name being each hash-key in (database test-results-db)
 768         collect name))
 769
 770 (defun record-result (test-name code results)
 771   "Run the test code and record the result."
 772   (let ((result (run-test-thunk test-name code)))
 773     ;; Store the result
 774     (setf (gethash test-name (database results)) result)
 775     ;; Count passed tests
 776     (when (plusp (pass result))
 777       (incf (pass results) (pass result)))
 778     ;; Count failed tests and record the name
 779     (when (fail result)
 780       (incf (fail results) (length (fail result)))
 781       (push test-name (failed-tests results)))
 782     ;; Count errors and record the name
 783     (when (exerr result)
 784       (incf (exerr results))
 785       (push test-name (error-tests results)))
 786     ;; Running output
 787     (when *print-failures* (print-failures result))
 788     (when *print-errors* (print-errors result))
 789     (when (or *print-summary* *print-failures* *print-errors*)
 790       (print-summary result))))
 791
 792 (defun summarize-results (results &optional
 793                           (stream *standard-output*))
 794   "Print a summary of all results to the stream."
 795   (let ((pass (pass results))
 796         (fail (fail results)))
 797     (format stream "~&Unit Test Summary~%")
 798     (format stream " | ~D assertions total~%" (+ pass fail))
 799     (format stream " | ~D passed~%" pass)
 800     (format stream " | ~D failed~%" fail)
 801     (format stream " | ~D execution errors~%" (exerr results))
 802     (format stream " | ~D missing tests~2%"
 803             (length (missing-tests results)))))
 804
 805 (defun default-db-merge-function (results new-results)
 806   "Signal an error by default if a merge is required."
 807   (lambda (key value1 value2)
 808     (error
 809      "Cannot merge TEST-RESULTS-DB instances ~A and ~A as key ~A has
 810 two values, ~A and ~A"
 811      results new-results key value1 value2)))
 812
 813 (defun nappend-test-results-db (results new-results &key merge)
 814   "Merge the results of NEW-RESULTS in to RESULTS. Any conflicts
 815 between RESULTS and NEW-RESULTS are handled by the function MERGE.
 816
 817 The lambda list for the MERGE functions is
 818
 819   (key results-value new-results-value)
 820
 821 where:
 822   KEY is the key which appears in RESULTS and NEW-RESULTS.
 823   RESULTS-VALUE is the value appearing RESULTS.
 824   NEW-RESULTS-VALUE is the value appearing in NEW-RESULTS.
 825
 826 If MERGE is NIL, then an error is signalled when a conflict occurs.
 827 "
 828   (check-type results test-results-db)
 829   (check-type new-results test-results-db)
 830   (check-type merge (or null function))
 831   (loop
 832    with results-db = (database results)
 833    with new-results-db = (database new-results)
 834    with merge =
 835    (or merge (default-db-merge-function results new-results))
 836    ;; Merge test databases
 837    for key being each hash-key in new-results-db
 838    using (hash-value new-results-value)
 839    do
 840    (multiple-value-bind (results-value presentp)
 841        (gethash key results-db)
 842      (setf
 843       (gethash key results-db)
 844       (if presentp
 845           (funcall merge key results-value new-results-value)
 846           new-results-value)))
 847    finally
 848    ;; Update counters
 849    (incf (pass results) (pass new-results))
 850    (incf (fail results) (fail new-results))
 851    (incf (exerr results) (exerr new-results))
 852    ;; Merge failures, errors, and missing test details
 853    (setf
 854     ;; Failures
 855     (failed-tests results)
 856     (append (failed-tests results) (failed-tests new-results))
 857     ;; Errors
 858     (error-tests results)
 859     (append (error-tests results) (error-tests new-results))
 860     ;; Missing tests
 861     (missing-tests results)
 862     (append (missing-tests results) (missing-tests new-results))))
 863    ;; Return the merged results
 864    results)
 865
 866 (defun reduce-test-results-dbs (all-results &key merge)
 867   "Return a new instance of TEST-RESULTS-DB which contains all of the
 868 results in the sequence RESULTS. Any conflicts are handled by the
 869 function MERGE.
 870
 871 The lambda list for the MERGE function is
 872
 873   (key value-1 value-2)
 874
 875 where:
 876   KEY is the key which appears at least twice in the sequence RESULTS.
 877   VALUE-1 and VALUE-2 are the conflicting values for the given KEY.
 878
 879 If MERGE is NIL, then an error is signalled when a conflict occurs."
 880   (loop
 881    with accumulated-test-results-db = (make-instance 'test-results-db)
 882    for new-results in all-results do
 883    (nappend-test-results-db
 884     accumulated-test-results-db new-results :merge merge)
 885    finally (return accumulated-test-results-db)))
 886
 887 ;;; Run the tests
 888
 889 (define-condition test-run-complete ()
 890   ((results
 891     :type 'test-results-db
 892     :initarg :results
 893     :reader results))
 894   (:documentation
 895    "Signaled when a test run is finished."))
 896
 897 (defun %run-all-thunks (&optional (package *package*))
 898   "Run all of the test thunks in the package."
 899   (with-package-table (table package)
 900     (loop
 901      with results = (make-instance 'test-results-db)
 902      for test-name being each hash-key in table
 903      using (hash-value unit-test)
 904      if unit-test do
 905      (record-result test-name (code unit-test) results)
 906      else do
 907      (push test-name (missing-tests results))
 908      ;; Summarize and return the test results
 909      finally
 910      (when *signal-results*
 911        (signal 'test-run-complete :results results))
 912      (when *summarize-results*
 913        (summarize-results results))
 914      (return results))))
 915
 916 (defun %run-thunks (test-names &optional (package *package*))
 917   "Run the list of test thunks in the package."
 918   (with-package-table (table package)
 919     (loop
 920      with results = (make-instance 'test-results-db)
 921      for test-name in test-names
 922      as unit-test = (gethash test-name table)
 923      if unit-test do
 924      (record-result test-name (code unit-test) results)
 925      else do
 926      (push test-name (missing-tests results))
 927      finally
 928      (when *signal-results*
 929        (signal 'test-run-complete :results results))
 930      (when *summarize-results*
 931        (summarize-results results))
 932      (return results))))
 933
 934 (defun run-tests (&optional (test-names :all) (package *package*))
 935   "Run the specified tests in package."
 936   (reset-counters)
 937   (if (eq :all test-names)
 938       (%run-all-thunks package)
 939       (%run-thunks test-names package)))
 940
 941 (defun run-tags (&optional (tags :all) (package *package*))
 942   "Run the tests associated with the specified tags in package."
 943   (reset-counters)
 944   (%run-thunks (tagged-tests tags package) package))
 945
 946 ;;; Print failures
 947
 948 (defgeneric print-failures (result &optional stream)
 949   (:documentation
 950    "Report the results of the failed assertion."))
 951
 952 (defmethod print-failures :around ((result failure-result) &optional
 953                                    (stream *standard-output*))
 954   "Failure header and footer output."
 955   (format stream "~& | Failed Form: ~S" (form result))
 956   (call-next-method)
 957   (when (extras result)
 958     (format stream "~{~& | ~S => ~S~}~%" (extras result)))
 959   (format stream "~& |~%"))
 960
 961 (defmethod print-failures ((result failure-result) &optional
 962                            (stream *standard-output*))
 963   (format stream "~& | Expected ~{~S~^; ~} " (expected result))
 964   (format stream "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))
 965
 966 (defmethod print-failures ((result error-result) &optional
 967                            (stream *standard-output*))
 968   (format stream "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
 969           (expected result))
 970   (format stream " ~{~S~^; ~}" (actual result)))
 971
 972 (defmethod print-failures ((result macro-result) &optional
 973                            (stream *standard-output*))
 974   (format stream "~& | Should have expanded to ~{~S~^; ~} "
 975           (expected result))
 976   (format stream "~<~%~:;but saw ~{~S~^; ~}~>" (actual result)))
 977
 978 (defmethod print-failures ((result output-result) &optional
 979                            (stream *standard-output*))
 980   (format stream "~& | Should have printed ~{~S~^; ~} "
 981           (expected result))
 982   (format stream "~<~%~:;but saw ~{~S~^; ~}~>"
 983           (actual result)))
 984
 985 (defmethod print-failures ((result test-result) &optional
 986                            (stream *standard-output*))
 987   "Print the failed assertions in the unit test."
 988   (loop for fail in (fail result) do
 989         (print-failures fail stream)))
 990
 991 (defmethod print-failures ((results test-results-db) &optional
 992                            (stream *standard-output*))
 993   "Print all of the failure tests."
 994   (loop with db = (database results)
 995         for test in (failed-tests results)
 996         as result = (gethash test db)
 997         do
 998         (print-failures result stream)
 999         (print-summary result stream)))
1000
1001 ;;; Print errors
1002
1003 (defgeneric print-errors (result &optional stream)
1004   (:documentation
1005    "Print the error condition."))
1006
1007 (defmethod print-errors ((result test-result) &optional
1008                          (stream *standard-output*))
1009   "Print the error condition."
1010   (let ((exerr (exerr result))
1011         (*print-escape* nil))
1012     (when exerr
1013       (format stream "~& | Execution error:~% | ~W" exerr)
1014       (format stream "~& |~%"))))
1015
1016 (defmethod print-errors ((results test-results-db) &optional
1017                          (stream *standard-output*))
1018   "Print all of the error tests."
1019   (loop with db = (database results)
1020         for test in (error-tests results)
1021         as result = (gethash test db)
1022         do
1023         (print-errors result stream)
1024         (print-summary result stream)))
1025
1026 ;;; Useful equality predicates for tests
1027
1028 (defun logically-equal (x y)
1029   "Return true if x and y are both false or both true."
1030   (eql (not x) (not y)))
1031
1032 (defun set-equal (list1 list2 &rest initargs &key key (test #'equal))
1033   "Return true if every element of list1 is an element of list2 and
1034 vice versa."
1035   (declare (ignore key test))
1036   (and
1037    (listp list1)
1038    (listp list2)
1039    (apply #'subsetp list1 list2 initargs)
1040    (apply #'subsetp list2 list1 initargs)))
1041
1042 (pushnew :lisp-unit common-lisp:*features*)