cgit.sxemacs.org Git - riece/blob - lisp/test/lunit.el

   1 ;;; lunit.el --- simple testing framework for luna
   2
   3 ;; Copyright (C) 2000-2004 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-2 case (integerp "a")))
  36 ;;
  37 ;; (luna-define-method test-2 ((case silly-test-case))
  38 ;;   (lunit-assert-2 case (stringp "b")))
  39 ;;
  40 ;; (with-output-to-temp-buffer "*Lunit Results*"
  41 ;;   (lunit (lunit-make-test-suite-from-class 'silly-test-case)))
  42 ;; ______________________________________________________________________
  43 ;; Running `silly-test-case#test-1'... failure: (integerp "a")
  44 ;; Running `silly-test-case#test-2'...
  45 ;; 2 runs, 2 assertions, 1 failures, 0 errors
  46
  47 ;;; Code:
  48
  49 (require 'luna)
  50
  51 (eval-when-compile (require 'cl))
  52
  53 (require 'pp)
  54
  55 ;;; @ test
  56 ;;;
  57
  58 (eval-and-compile
  59   (luna-define-class lunit-test ()
  60                      (name))
  61
  62   (luna-define-internal-accessors 'lunit-test))
  63
  64 (luna-define-generic lunit-test-number-of-tests (test)
  65   "Count the number of test cases that will be run by the test.")
  66
  67 (luna-define-generic lunit-test-run (test result)
  68   "Run the test and collects its result in result.")
  69
  70 (luna-define-generic lunit-test-suite-add-test (suite test)
  71   "Add the test to the suite.")
  72
  73 ;;; @ test listener
  74 ;;;
  75
  76 (luna-define-class lunit-test-listener)
  77
  78 ;;; @ test result
  79 ;;;
  80
  81 (put 'lunit-error 'error-message "test error")
  82 (put 'lunit-error 'error-conditions '(lunit-error error))
  83
  84 (put 'lunit-failure 'error-message "test failure")
  85 (put 'lunit-failure 'error-conditions '(lunit-failure lunit-error error))
  86
  87 (eval-and-compile
  88   (luna-define-class lunit-test-result ()
  89                      (errors
  90                       failures
  91                       listeners
  92                       assert-count))
  93
  94   (luna-define-internal-accessors 'lunit-test-result))
  95
  96 (luna-define-generic lunit-test-result-run (result case)
  97   "Run the test case.")
  98
  99 (luna-define-generic lunit-test-result-notify (result message &rest args)
 100   "Report the current state of execution.")
 101
 102 (luna-define-generic lunit-test-result-add-listener (result listener)
 103   "Add listener to the list of listeners.")
 104
 105 (defun lunit-make-test-result (&rest listeners)
 106   "Return a newly allocated `lunit-test-result' instance with LISTENERS."
 107   (luna-make-entity 'lunit-test-result :listeners listeners :assert-count 0))
 108
 109 (luna-define-method lunit-test-result-notify ((result lunit-test-result)
 110                                               message args)
 111   (let ((listeners
 112          (lunit-test-result-listeners-internal result)))
 113     (dolist (listener listeners)
 114       (apply #'luna-send listener message listener args))))
 115
 116 (luna-define-method lunit-test-result-run ((result lunit-test-result) case)
 117   (lunit-test-result-notify result 'lunit-test-listener-start case)
 118   (condition-case error
 119       (lunit-test-case-run case)
 120     (lunit-failure
 121      (lunit-test-result-set-failures-internal
 122       result
 123       (nconc (lunit-test-result-failures-internal result)
 124              (list (cons case (cdr error)))))
 125      (lunit-test-result-notify
 126       result 'lunit-test-listener-failure case (cdr error)))
 127     (lunit-error
 128      (lunit-test-result-set-errors-internal
 129       result
 130       (nconc (lunit-test-result-errors-internal result)
 131              (list (cons case (cdr error)))))
 132      (lunit-test-result-notify
 133       result 'lunit-test-listener-error case (cdr error))))
 134   (lunit-test-result-set-assert-count-internal
 135    result
 136    (+ (lunit-test-result-assert-count-internal result)
 137       (lunit-test-case-assert-count-internal case)))
 138   (lunit-test-result-notify result 'lunit-test-listener-end case))
 139
 140 (luna-define-method lunit-test-result-add-listener ((result lunit-test-result)
 141                                                     listener)
 142   (let ((listeners
 143          (lunit-test-result-listeners-internal result)))
 144     (setq listeners (nconc listeners (list listener)))
 145     (lunit-test-result-set-listeners-internal result listeners)))
 146
 147 ;;; @ test case
 148 ;;;
 149
 150 (eval-and-compile
 151   (luna-define-class lunit-test-case (lunit-test)
 152                      (assert-count))
 153
 154   (luna-define-internal-accessors 'lunit-test-case))
 155
 156 (luna-define-generic lunit-test-case-run (case)
 157   "Run the test case.")
 158
 159 (luna-define-generic lunit-test-case-setup (case)
 160   "Setup the test case.")
 161
 162 (luna-define-generic lunit-test-case-teardown (case)
 163   "Clear the test case.")
 164
 165 (defun lunit-make-test-case (class name)
 166   "Return a newly allocated `lunit-test-case'.
 167 CLASS is a symbol for class derived from `lunit-test-case'.
 168 NAME is name of the method to be tested."
 169   (luna-make-entity class :name name :assert-count 0))
 170
 171 (luna-define-method lunit-test-number-of-tests ((case lunit-test-case))
 172   1)
 173
 174 (luna-define-method lunit-test-run ((case lunit-test-case) result)
 175   (lunit-test-result-run result case))
 176
 177 (luna-define-method lunit-test-case-setup ((case lunit-test-case)))
 178 (luna-define-method lunit-test-case-teardown ((case lunit-test-case)))
 179
 180 (luna-define-method lunit-test-case-run ((case lunit-test-case))
 181   (lunit-test-case-setup case)
 182   (unwind-protect
 183       (let* ((name
 184               (lunit-test-name-internal case))
 185              (functions
 186               (luna-find-functions case name)))
 187         (unless functions
 188           (error "Method \"%S\" not found" name))
 189         (condition-case error
 190             (funcall (car functions) case)
 191           (lunit-failure
 192            (signal (car error)(cdr error)))
 193           (error
 194            (signal 'lunit-error error))))
 195     (lunit-test-case-teardown case)))
 196
 197 ;;; @ test suite
 198 ;;;
 199
 200 (eval-and-compile
 201   (luna-define-class lunit-test-suite (lunit-test)
 202                      (tests))
 203
 204   (luna-define-internal-accessors 'lunit-test-suite))
 205
 206 (defun lunit-make-test-suite (&rest tests)
 207   "Return a newly allocated `lunit-test-suite' instance.
 208 TESTS holds a number of instances of `lunit-test'."
 209   (luna-make-entity 'lunit-test-suite :tests tests))
 210
 211 (luna-define-method lunit-test-suite-add-test ((suite lunit-test-suite) test)
 212   (let ((tests (lunit-test-suite-tests-internal suite)))
 213     (lunit-test-suite-set-tests-internal suite (nconc tests (list test)))))
 214
 215 (luna-define-method lunit-test-number-of-tests ((suite lunit-test-suite))
 216   (let ((tests (lunit-test-suite-tests-internal suite))
 217         (accu 0))
 218     (dolist (test tests)
 219       (setq accu (+ accu (lunit-test-number-of-tests test))))
 220     accu))
 221
 222 (luna-define-method lunit-test-run ((suite lunit-test-suite) result)
 223   (let ((tests (lunit-test-suite-tests-internal suite)))
 224     (dolist (test tests)
 225       (lunit-test-run test result))))
 226
 227 ;;; @ test runner
 228 ;;;
 229
 230 (defmacro lunit-assert (condition-expr)
 231   "Verify that CONDITION-EXPR returns non-nil; signal an error if not."
 232   `(unless ,condition-expr
 233      (signal 'lunit-failure (list ',condition-expr))))
 234
 235 (defmacro lunit-assert-2 (case condition-expr)
 236   "In regard to CASE, verify that CONDITION-EXPR returns non-nil;
 237 signal an error if not."
 238   `(let ((case ,case))
 239      (lunit-test-case-set-assert-count-internal
 240       case
 241       (1+ (lunit-test-case-assert-count-internal case)))
 242      (unless ,condition-expr
 243        (signal 'lunit-failure (list ',condition-expr)))))
 244
 245 (luna-define-class lunit-test-printer (lunit-test-listener))
 246
 247 (luna-define-method lunit-test-listener-error ((printer lunit-test-printer)
 248                                                case error)
 249   (princ (format " error: %S" error)))
 250
 251 (luna-define-method lunit-test-listener-failure ((printer lunit-test-printer)
 252                                                  case failure)
 253   (princ (format " failure: %S" failure)))
 254
 255 (luna-define-method lunit-test-listener-start ((printer lunit-test-printer)
 256                                                case)
 257   (princ (format "Running `%S#%S'..."
 258                  (luna-class-name case)
 259                  (lunit-test-name-internal case))))
 260
 261 (luna-define-method lunit-test-listener-end ((printer lunit-test-printer) case)
 262   (princ "\n"))
 263
 264 (defun lunit-make-test-suite-from-class (class)
 265   "Make a test suite from all test methods of the CLASS."
 266   (let (tests)
 267     (mapatoms
 268      (lambda (symbol)
 269        (if (and (fboundp symbol)
 270                 (string-match "^test" (symbol-name symbol))
 271                 (null (get symbol 'luna-method-qualifier)))
 272            (push (lunit-make-test-case class symbol) tests)))
 273      (luna-class-obarray (luna-find-class class)))
 274     (apply #'lunit-make-test-suite tests)))
 275
 276 (defun lunit (test)
 277   "Run TEST and display the result."
 278   (let* ((printer
 279           (luna-make-entity 'lunit-test-printer))
 280          (result
 281           (lunit-make-test-result printer)))
 282     (lunit-test-run test result)
 283     (let ((assert-count
 284            (lunit-test-result-assert-count-internal result))
 285           (failures
 286            (lunit-test-result-failures-internal result))
 287           (errors
 288            (lunit-test-result-errors-internal result)))
 289       (princ (format "%d runs, %d assertions, %d failures, %d errors\n"
 290                      (lunit-test-number-of-tests test)
 291                      assert-count
 292                      (length failures)
 293                      (length errors))))))
 294
 295 (defvar imenu-create-index-function)
 296 (defun lunit-create-index-function ()
 297   (require 'imenu)
 298   (save-excursion
 299     (unwind-protect
 300         (progn
 301           (goto-char (point-min))
 302           (setq imenu-generic-expression
 303                 '((nil "^\\s-*(def\\(un\\|subst\\|macro\\)\\s-+\\([-A-Za-z0-9+*|:]+\\)" 2)))
 304           (funcall imenu-create-index-function))
 305       (setq imenu-create-index-function lisp-imenu-generic-expression))))
 306
 307 (defun lunit-generate-template (file)
 308   (interactive "fGenerate lunit template for: ")
 309   (save-excursion
 310     (set-buffer (find-file-noselect file))
 311     (let ((index-alist
 312            (lunit-create-index-function)))
 313       (with-output-to-temp-buffer "*Lunit template*"
 314         (let* ((feature
 315                 (file-name-sans-extension
 316                  (file-name-nondirectory file)))
 317                (class
 318                 (concat "test-" feature)))
 319           (set-buffer standard-output)
 320           (insert "\
 321 \(require 'lunit)
 322 \(require '" feature ")
 323
 324 \(luna-define-class " class " (lunit-test-case))
 325
 326 ")
 327           (dolist (index index-alist)
 328             (insert "\
 329 \(luna-define-method " class "-" (car index) " ((case " class "))
 330   (lunit-assert nil))
 331
 332 ")))))))
 333
 334 (provide 'lunit)
 335
 336 ;;; lunit.el ends here