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 ;; (lunit-class 'silly-test-case)
  41 ;; ______________________________________________________________________
  42 ;; Starting test `silly-test-case#test-1'
  43 ;; failure: (integerp "a")
  44 ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  45 ;; ______________________________________________________________________
  46 ;; Starting test `silly-test-case#test-2'
  47 ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  48 ;; 2 runs, 1 failures, 0 errors
  49
  50 ;;; Code:
  51
  52 (require 'luna)
  53
  54 (eval-when-compile (require 'cl))
  55
  56 ;;; @ test
  57 ;;;
  58
  59 (eval-and-compile
  60   (luna-define-class lunit-test ()
  61                      (name))
  62
  63   (luna-define-internal-accessors 'lunit-test))
  64
  65 (luna-define-generic lunit-test-number-of-tests (test)
  66   "Count the number of test cases that will be run by the test.")
  67
  68 (luna-define-generic lunit-test-run (test result)
  69   "Run the test and collects its result in result.")
  70
  71 (luna-define-generic lunit-test-suite-add-test (suite test)
  72   "Add the test to the suite.")
  73
  74 ;;; @ test listener
  75 ;;;
  76
  77 (luna-define-class lunit-test-listener ())
  78
  79 (luna-define-generic lunit-test-listener-error (listener case error)
  80   "An error occurred.")
  81
  82 (luna-define-generic lunit-test-listener-failure (listener case failure)
  83   "An failure occurred.")
  84
  85 (luna-define-generic lunit-test-listener-start (listener case)
  86   "A test started.")
  87
  88 (luna-define-generic lunit-test-listener-end (listener case)
  89   "A test ended.")
  90
  91 ;;; @ test result
  92 ;;;
  93
  94 (put 'lunit-error 'error-message "test error")
  95 (put 'lunit-error 'error-conditions '(lunit-error error))
  96
  97 (put 'lunit-failure 'error-message "test failure")
  98 (put 'lunit-failure 'error-conditions '(lunit-failure lunit-error error))
  99
 100 (eval-and-compile
 101   (luna-define-class lunit-test-result ()
 102                      (errors
 103                       failures
 104                       listeners))
 105
 106   (luna-define-internal-accessors 'lunit-test-result))
 107
 108 (luna-define-generic lunit-test-result-run (result case)
 109   "Run the test case.")
 110
 111 (luna-define-generic lunit-test-result-error (result case error)
 112   "Add error to the list of errors.
 113 The passed in exception caused the error.")
 114
 115 (luna-define-generic lunit-test-result-failure (result case failure)
 116   "Add failure to the list of failures.
 117 The passed in exception caused the failure.")
 118
 119 (luna-define-generic lunit-test-result-add-listener (result listener)
 120   "Add listener to the list of listeners.")
 121
 122 (defun lunit-make-test-result (&rest listeners)
 123   "Return a newly allocated `lunit-test-result' instance with LISTENERS."
 124   (luna-make-entity 'lunit-test-result :listeners listeners))
 125
 126 (luna-define-method lunit-test-result-run ((result lunit-test-result) case)
 127   (let ((listeners (lunit-test-result-listeners-internal result)))
 128     (dolist (listener listeners)
 129       (lunit-test-listener-start listener case))
 130     (condition-case error
 131         (lunit-test-case-run case)
 132       (lunit-failure
 133        (lunit-test-result-failure result case (nth 1 error)))
 134       (lunit-error
 135        (lunit-test-result-error result case (cdr error))))
 136     (dolist (listener listeners)
 137       (lunit-test-listener-end listener case))))
 138
 139 (luna-define-method lunit-test-result-error ((result lunit-test-result)
 140                                              case error)
 141   (let ((listeners (lunit-test-result-listeners-internal result))
 142         (errors (lunit-test-result-errors-internal result)))
 143     (if errors
 144         (nconc errors (list (cons case error)))
 145       (lunit-test-result-set-errors-internal result (list (cons case error))))
 146     (dolist (listener listeners)
 147       (lunit-test-listener-error listener case error))))
 148
 149 (luna-define-method lunit-test-result-failure ((result lunit-test-result)
 150                                                case failure)
 151   (let ((listeners (lunit-test-result-listeners-internal result))
 152         (failures (lunit-test-result-failures-internal result)))
 153     (if failures
 154         (nconc failures (list (cons case failure)))
 155       (lunit-test-result-set-failures-internal result (list (cons case failure))))
 156     (dolist (listener listeners)
 157       (lunit-test-listener-failure listener case failure))))
 158
 159 (luna-define-method lunit-test-result-add-listener ((result lunit-test-result)
 160                                                     listener)
 161   (let ((listeners (lunit-test-result-listeners-internal result)))
 162     (if listeners
 163         (nconc listeners (list listener))
 164       (lunit-test-result-set-listeners-internal result (list listener)))))
 165
 166 ;;; @ test case
 167 ;;;
 168
 169 (luna-define-class lunit-test-case (lunit-test))
 170
 171 (luna-define-generic lunit-test-case-run (case)
 172   "Run the test case.")
 173
 174 (luna-define-generic lunit-test-case-setup (case)
 175   "Setup the test case.")
 176
 177 (luna-define-generic lunit-test-case-teardown (case)
 178   "Clear the test case.")
 179
 180 (defun lunit-make-test-case (class name)
 181   "Return a newly allocated `lunit-test-case'.
 182 CLASS is a symbol for class derived from `lunit-test-case'.
 183 NAME is name of the method to be tested."
 184   (luna-make-entity class :name name))
 185
 186 (luna-define-method lunit-test-number-of-tests ((case lunit-test-case))
 187   1)
 188
 189 (luna-define-method lunit-test-run ((case lunit-test-case) result)
 190   (lunit-test-result-run result case))
 191
 192 (luna-define-method lunit-test-case-setup ((case lunit-test-case)))
 193 (luna-define-method lunit-test-case-teardown ((case lunit-test-case)))
 194
 195 (luna-define-method lunit-test-case-run ((case lunit-test-case))
 196   (lunit-test-case-setup case)
 197   (unwind-protect
 198       (let* ((name
 199               (lunit-test-name-internal case))
 200              (functions
 201               (luna-find-functions case name)))
 202         (unless functions
 203           (error "Method \"%S\" not found" name))
 204         (condition-case error
 205             (funcall (car functions) case)
 206           (lunit-failure
 207            (signal (car error)(cdr error)))
 208           (error
 209            (signal 'lunit-error (cdr error)))))
 210     (lunit-test-case-teardown case)))
 211
 212 ;;; @ test suite
 213 ;;;
 214
 215 (eval-and-compile
 216   (luna-define-class lunit-test-suite (lunit-test)
 217                      (tests))
 218
 219   (luna-define-internal-accessors 'lunit-test-suite))
 220
 221 (defun lunit-make-test-suite (&rest tests)
 222   "Return a newly allocated `lunit-test-suite' instance.
 223 TESTS holds a number of instances of `lunit-test'."
 224   (luna-make-entity 'lunit-test-suite :tests tests))
 225
 226 (luna-define-method lunit-test-suite-add-test ((suite lunit-test-suite) test)
 227   (let ((tests (lunit-test-suite-tests-internal suite)))
 228     (if tests
 229         (nconc tests (list test))
 230       (lunit-test-suite-set-tests-internal suite (list test)))))
 231
 232 (luna-define-method lunit-test-number-of-tests ((suite lunit-test-suite))
 233   (let ((tests (lunit-test-suite-tests-internal suite))
 234         (accu 0))
 235     (dolist (test tests)
 236       (setq accu (+ accu (lunit-test-number-of-tests test))))
 237     accu))
 238
 239 (luna-define-method lunit-test-run ((suite lunit-test-suite) result)
 240   (let ((tests (lunit-test-suite-tests-internal suite)))
 241     (dolist (test tests)
 242       (lunit-test-run test result))))
 243
 244 ;;; @ test runner
 245 ;;;
 246
 247 (defmacro lunit-assert (condition-expr)
 248   "Verify that CONDITION-EXPR returns non-nil; signal an error if not."
 249   (let ((condition (eval condition-expr)))
 250     `(unless ,condition
 251        (signal 'lunit-failure (list ',condition-expr)))))
 252
 253 (defvar lunit-test-results-buffer "*Lunit Results*")
 254
 255 (luna-define-class lunit-test-printer (lunit-test-listener))
 256
 257 (luna-define-method lunit-test-listener-error ((printer lunit-test-printer)
 258                                                case error)
 259   (princ (format "error: %S\n" error)))
 260
 261 (luna-define-method lunit-test-listener-failure ((printer lunit-test-printer)
 262                                                  case failure)
 263   (princ (format "failure: %S\n" failure)))
 264
 265 (luna-define-method lunit-test-listener-start ((printer lunit-test-printer) case)
 266   (princ (format "\
 267 ______________________________________________________________________
 268 Starting test `%S#%S'\n"
 269                  (luna-class-name case)
 270                  (lunit-test-name-internal case))))
 271
 272 (luna-define-method lunit-test-listener-end ((printer lunit-test-printer) case)
 273   (princ "\
 274 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 275 "))
 276
 277 (defun lunit-class (class)
 278   "Run all test methods of the CLASS and display the result."
 279   (let (tests)
 280     (mapatoms
 281      (lambda (symbol)
 282        (if (and (fboundp symbol)
 283                 (null (get symbol 'luna-method-qualifier)))
 284            (push (lunit-make-test-case class symbol) tests)))
 285      (luna-class-obarray (luna-find-class class)))
 286     (lunit
 287      (apply #'lunit-make-test-suite tests))))
 288
 289 (defun lunit (test)
 290   "Run TEST and display the result."
 291   (let* ((printer
 292           (luna-make-entity 'lunit-test-printer))
 293          (result
 294           (lunit-make-test-result printer))
 295          failures
 296          errors)
 297     (with-output-to-temp-buffer lunit-test-results-buffer
 298       (lunit-test-run test result)
 299       (setq failures (lunit-test-result-failures-internal result)
 300             errors (lunit-test-result-errors-internal result))
 301       (princ (format "%d runs, %d failures, %d errors"
 302                      (lunit-test-number-of-tests test)
 303                      (length failures)
 304                      (length errors))))
 305     nil))
 306
 307 (provide 'lunit)
 308
 309 ;;; lunit.el ends here