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