lunit.el

   1 ;;; lunit.el --- simple testing framework for luna
   2
   3 ;; Copyright (C) 2000 Daiki Ueno.
   4
   5 ;; Author: Daiki Ueno <ueno@unixuser.org>
   6 ;; Keywords: OOP, XP
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This module is inspired by "JUnit A Cook's Tour".
  28 ;; <URL:http://www.junit.org/junit/doc/cookstour/cookstour.htm>
  29
  30 ;; (require 'lunit)
  31 ;;
  32 ;; (luna-define-class silly-test-case (lunit-test-case))
  33 ;;
  34 ;; (luna-define-method test-1 ((case silly-test-case))
  35 ;;   (lunit-assert (integerp "a")))
  36 ;;
  37 ;; (luna-define-method test-2 ((case silly-test-case))
  38 ;;   (lunit-assert (stringp "b")))
  39 ;;
  40 ;; (with-output-to-temp-buffer "*Lunit Results*"
  41 ;;   (lunit (lunit-make-test-suite-from-class 'silly-test-case)))
  42 ;; ______________________________________________________________________
  43 ;; Starting test `silly-test-case#test-1'
  44 ;; failure: (integerp "a")
  45 ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  46 ;; ______________________________________________________________________
  47 ;; Starting test `silly-test-case#test-2'
  48 ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  49 ;; 2 runs, 1 failures, 0 errors
  50
  51 ;;; Code:
  52
  53 (require 'luna)
  54
  55 (eval-when-compile (require 'cl))
  56
  57 ;;; @ test
  58 ;;;
  59
  60 (eval-and-compile
  61   (luna-define-class lunit-test ()
  62                      (name))
  63
  64   (luna-define-internal-accessors 'lunit-test))
  65
  66 (luna-define-generic lunit-test-number-of-tests (test)
  67   "Count the number of test cases that will be run by the test.")
  68
  69 (luna-define-generic lunit-test-run (test result)
  70   "Run the test and collects its result in result.")
  71
  72 (luna-define-generic lunit-test-suite-add-test (suite test)
  73   "Add the test to the suite.")
  74
  75 ;;; @ test listener
  76 ;;;
  77
  78 (luna-define-class lunit-test-listener ())
  79
  80 (luna-define-generic lunit-test-listener-error (listener case error)
  81   "An error occurred.")
  82
  83 (luna-define-generic lunit-test-listener-failure (listener case failure)
  84   "A failure occurred.")
  85
  86 (luna-define-generic lunit-test-listener-start (listener case)
  87   "A test started.")
  88
  89 (luna-define-generic lunit-test-listener-end (listener case)
  90   "A test ended.")
  91
  92 ;;; @ test result
  93 ;;;
  94
  95 (put 'lunit-error 'error-message "test error")
  96 (put 'lunit-error 'error-conditions '(lunit-error error))
  97
  98 (put 'lunit-failure 'error-message "test failure")
  99 (put 'lunit-failure 'error-conditions '(lunit-failure lunit-error error))
 100
 101 (eval-and-compile
 102   (luna-define-class lunit-test-result ()
 103                      (errors
 104                       failures
 105                       listeners))
 106
 107   (luna-define-internal-accessors 'lunit-test-result))
 108
 109 (luna-define-generic lunit-test-result-run (result case)
 110   "Run the test case.")
 111
 112 (luna-define-generic lunit-test-result-error (result case error)
 113   "Add error to the list of errors.
 114 The passed in exception caused the error.")
 115
 116 (luna-define-generic lunit-test-result-failure (result case failure)
 117   "Add failure to the list of failures.
 118 The passed in exception caused the failure.")
 119
 120 (luna-define-generic lunit-test-result-add-listener (result listener)
 121   "Add listener to the list of listeners.")
 122
 123 (defun lunit-make-test-result (&rest listeners)
 124   "Return a newly allocated `lunit-test-result' instance with LISTENERS."
 125   (luna-make-entity 'lunit-test-result :listeners listeners))
 126
 127 (luna-define-method lunit-test-result-run ((result lunit-test-result) case)
 128   (let ((listeners (lunit-test-result-listeners-internal result)))
 129     (dolist (listener listeners)
 130       (lunit-test-listener-start listener case))
 131     (condition-case error
 132         (lunit-test-case-run case)
 133       (lunit-failure
 134        (lunit-test-result-failure result case (nth 1 error)))
 135       (lunit-error
 136        (lunit-test-result-error result case (cdr error))))
 137     (dolist (listener listeners)
 138       (lunit-test-listener-end listener case))))
 139
 140 (luna-define-method lunit-test-result-error ((result lunit-test-result)
 141                                              case error)
 142   (let ((listeners (lunit-test-result-listeners-internal result))
 143         (errors (lunit-test-result-errors-internal result)))
 144     (if errors
 145         (nconc errors (list (cons case error)))
 146       (lunit-test-result-set-errors-internal result (list (cons case error))))
 147     (dolist (listener listeners)
 148       (lunit-test-listener-error listener case error))))
 149
 150 (luna-define-method lunit-test-result-failure ((result lunit-test-result)
 151                                                case failure)
 152   (let ((listeners (lunit-test-result-listeners-internal result))
 153         (failures (lunit-test-result-failures-internal result)))
 154     (if failures
 155         (nconc failures (list (cons case failure)))
 156       (lunit-test-result-set-failures-internal result (list (cons case failure))))
 157     (dolist (listener listeners)
 158       (lunit-test-listener-failure listener case failure))))
 159
 160 (luna-define-method lunit-test-result-add-listener ((result lunit-test-result)
 161                                                     listener)
 162   (let ((listeners (lunit-test-result-listeners-internal result)))
 163     (if listeners
 164         (nconc listeners (list listener))
 165       (lunit-test-result-set-listeners-internal result (list listener)))))
 166
 167 ;;; @ test case
 168 ;;;
 169
 170 (luna-define-class lunit-test-case (lunit-test))
 171
 172 (luna-define-generic lunit-test-case-run (case)
 173   "Run the test case.")
 174
 175 (luna-define-generic lunit-test-case-setup (case)
 176   "Setup the test case.")
 177
 178 (luna-define-generic lunit-test-case-teardown (case)
 179   "Clear the test case.")
 180
 181 (defun lunit-make-test-case (class name)
 182   "Return a newly allocated `lunit-test-case'.
 183 CLASS is a symbol for class derived from `lunit-test-case'.
 184 NAME is name of the method to be tested."
 185   (luna-make-entity class :name name))
 186
 187 (luna-define-method lunit-test-number-of-tests ((case lunit-test-case))
 188   1)
 189
 190 (luna-define-method lunit-test-run ((case lunit-test-case) result)
 191   (lunit-test-result-run result case))
 192
 193 (luna-define-method lunit-test-case-setup ((case lunit-test-case)))
 194 (luna-define-method lunit-test-case-teardown ((case lunit-test-case)))
 195
 196 (luna-define-method lunit-test-case-run ((case lunit-test-case))
 197   (lunit-test-case-setup case)
 198   (unwind-protect
 199       (let* ((name
 200               (lunit-test-name-internal case))
 201              (functions
 202               (luna-find-functions case name)))
 203         (unless functions
 204           (error "Method \"%S\" not found" name))
 205         (condition-case error
 206             (funcall (car functions) case)
 207           (lunit-failure
 208            (signal (car error)(cdr error)))
 209           (error
 210            (signal 'lunit-error error))))
 211     (lunit-test-case-teardown case)))
 212
 213 ;;; @ test suite
 214 ;;;
 215
 216 (eval-and-compile
 217   (luna-define-class lunit-test-suite (lunit-test)
 218                      (tests))
 219
 220   (luna-define-internal-accessors 'lunit-test-suite))
 221
 222 (defun lunit-make-test-suite (&rest tests)
 223   "Return a newly allocated `lunit-test-suite' instance.
 224 TESTS holds a number of instances of `lunit-test'."
 225   (luna-make-entity 'lunit-test-suite :tests tests))
 226
 227 (luna-define-method lunit-test-suite-add-test ((suite lunit-test-suite) test)
 228   (let ((tests (lunit-test-suite-tests-internal suite)))
 229     (if tests
 230         (nconc tests (list test))
 231       (lunit-test-suite-set-tests-internal suite (list test)))))
 232
 233 (luna-define-method lunit-test-number-of-tests ((suite lunit-test-suite))
 234   (let ((tests (lunit-test-suite-tests-internal suite))
 235         (accu 0))
 236     (dolist (test tests)
 237       (setq accu (+ accu (lunit-test-number-of-tests test))))
 238     accu))
 239
 240 (luna-define-method lunit-test-run ((suite lunit-test-suite) result)
 241   (let ((tests (lunit-test-suite-tests-internal suite)))
 242     (dolist (test tests)
 243       (lunit-test-run test result))))
 244
 245 ;;; @ test runner
 246 ;;;
 247
 248 (defmacro lunit-assert (condition-expr)
 249   "Verify that CONDITION-EXPR returns non-nil; signal an error if not."
 250   (let ((condition (eval condition-expr)))
 251     `(unless ,condition
 252        (signal 'lunit-failure (list ',condition-expr)))))
 253
 254 (luna-define-class lunit-test-printer (lunit-test-listener))
 255
 256 (luna-define-method lunit-test-listener-error ((printer lunit-test-printer)
 257                                                case error)
 258   (princ (format " error: %S" error)))
 259
 260 (luna-define-method lunit-test-listener-failure ((printer lunit-test-printer)
 261                                                  case failure)
 262   (princ (format " failure: %S" failure)))
 263
 264 (luna-define-method lunit-test-listener-start ((printer lunit-test-printer) case)
 265   (princ (format "Running `%S#%S'..."
 266                  (luna-class-name case)
 267                  (lunit-test-name-internal case))))
 268
 269 (luna-define-method lunit-test-listener-end ((printer lunit-test-printer) case)
 270   (princ "\n"))
 271
 272 (defun lunit-make-test-suite-from-class (class)
 273   "Make a test suite from all test methods of the CLASS."
 274   (let (tests)
 275     (mapatoms
 276      (lambda (symbol)
 277        (if (and (fboundp symbol)
 278                 (null (get symbol 'luna-method-qualifier)))
 279            (push (lunit-make-test-case class symbol) tests)))
 280      (luna-class-obarray (luna-find-class class)))
 281     (apply #'lunit-make-test-suite tests)))
 282
 283 (defun lunit (test)
 284   "Run TEST and display the result."
 285   (let* ((printer
 286           (luna-make-entity 'lunit-test-printer))
 287          (result
 288           (lunit-make-test-result printer))
 289          failures
 290          errors)
 291     (lunit-test-run test result)
 292     (setq failures (lunit-test-result-failures-internal result)
 293           errors (lunit-test-result-errors-internal result))
 294     (princ (format "%d runs, %d failures, %d errors\n"
 295                    (lunit-test-number-of-tests test)
 296                    (length failures)
 297                    (length errors)))))
 298
 299 (provide 'lunit)
 300
 301 ;;; lunit.el ends here