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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, 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 ;;; @ test result
  81 ;;;
  82
  83 (put 'lunit-error 'error-message "test error")
  84 (put 'lunit-error 'error-conditions '(lunit-error error))
  85
  86 (put 'lunit-failure 'error-message "test failure")
  87 (put 'lunit-failure 'error-conditions '(lunit-failure lunit-error error))
  88
  89 (eval-and-compile
  90   (luna-define-class lunit-test-result ()
  91                      (errors
  92                       failures
  93                       listeners))
  94
  95   (luna-define-internal-accessors 'lunit-test-result))
  96
  97 (luna-define-generic lunit-test-result-run (result case)
  98   "Run the test case.")
  99
 100 (luna-define-generic lunit-test-result-notify (result message &rest args)
 101   "Report the current state of execution.")
 102
 103 (luna-define-generic lunit-test-result-error (result case error)
 104   "Add error to the list of errors.
 105 The passed in exception caused the error.")
 106
 107 (luna-define-generic lunit-test-result-failure (result case failure)
 108   "Add failure to the list of failures.
 109 The passed in exception caused the failure.")
 110
 111 (luna-define-generic lunit-test-result-add-listener (result listener)
 112   "Add listener to the list of listeners.")
 113
 114 (defun lunit-make-test-result (&rest listeners)
 115   "Return a newly allocated `lunit-test-result' instance with LISTENERS."
 116   (luna-make-entity 'lunit-test-result :listeners listeners))
 117
 118 (luna-define-method lunit-test-result-notify ((result lunit-test-result)
 119                                               message args)
 120   (let ((listeners
 121          (lunit-test-result-listeners-internal result)))
 122     (dolist (listener listeners)
 123       (apply #'luna-send listener message listener args))))
 124
 125 (luna-define-method lunit-test-result-run ((result lunit-test-result) case)
 126   (lunit-test-result-notify result 'lunit-test-listener-start case)
 127   (condition-case error
 128       (lunit-test-case-run case)
 129     (lunit-failure
 130      (lunit-test-result-failure result case (nth 1 error)))
 131     (lunit-error
 132      (lunit-test-result-error result case (cdr error))))
 133   (lunit-test-result-notify result 'lunit-test-listener-end case))
 134
 135 (luna-define-method lunit-test-result-error ((result lunit-test-result)
 136                                              case error)
 137   (let ((errors
 138          (lunit-test-result-errors-internal result)))
 139     (setq errors (nconc errors (list (cons case error))))
 140     (lunit-test-result-set-errors-internal result errors))
 141   (lunit-test-result-notify result 'lunit-test-listener-error case error))
 142
 143 (luna-define-method lunit-test-result-failure ((result lunit-test-result)
 144                                                case failure)
 145   (let ((failures
 146          (lunit-test-result-failures-internal result)))
 147     (setq failures (nconc failures (list (cons case failure))))
 148     (lunit-test-result-set-failures-internal result failures))
 149   (lunit-test-result-notify result 'lunit-test-listener-failure case failure))
 150
 151 (luna-define-method lunit-test-result-add-listener ((result lunit-test-result)
 152                                                     listener)
 153   (let ((listeners
 154          (lunit-test-result-listeners-internal result)))
 155     (setq listeners (nconc listeners (list listener)))
 156     (lunit-test-result-set-listeners-internal result listeners)))
 157
 158 ;;; @ test case
 159 ;;;
 160
 161 (luna-define-class lunit-test-case (lunit-test))
 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))
 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           (lunit-failure
 199            (signal (car error)(cdr error)))
 200           (error
 201            (signal 'lunit-error error))))
 202     (lunit-test-case-teardown case)))
 203
 204 ;;; @ test suite
 205 ;;;
 206
 207 (eval-and-compile
 208   (luna-define-class lunit-test-suite (lunit-test)
 209                      (tests))
 210
 211   (luna-define-internal-accessors 'lunit-test-suite))
 212
 213 (defun lunit-make-test-suite (&rest tests)
 214   "Return a newly allocated `lunit-test-suite' instance.
 215 TESTS holds a number of instances of `lunit-test'."
 216   (luna-make-entity 'lunit-test-suite :tests tests))
 217
 218 (luna-define-method lunit-test-suite-add-test ((suite lunit-test-suite) test)
 219   (let ((tests (lunit-test-suite-tests-internal suite)))
 220     (lunit-test-suite-set-tests-internal suite (nconc tests (list test)))))
 221
 222 (luna-define-method lunit-test-number-of-tests ((suite lunit-test-suite))
 223   (let ((tests (lunit-test-suite-tests-internal suite))
 224         (accu 0))
 225     (dolist (test tests)
 226       (setq accu (+ accu (lunit-test-number-of-tests test))))
 227     accu))
 228
 229 (luna-define-method lunit-test-run ((suite lunit-test-suite) result)
 230   (let ((tests (lunit-test-suite-tests-internal suite)))
 231     (dolist (test tests)
 232       (lunit-test-run test result))))
 233
 234 ;;; @ test runner
 235 ;;;
 236
 237 (defmacro lunit-assert (condition-expr)
 238   "Verify that CONDITION-EXPR returns non-nil; signal an error if not."
 239   (let ((condition (eval condition-expr)))
 240     `(when ,(not condition)
 241        (signal 'lunit-failure (list ',condition-expr)))))
 242
 243 (luna-define-class lunit-test-printer (lunit-test-listener))
 244
 245 (luna-define-method lunit-test-listener-error ((printer lunit-test-printer)
 246                                                case error)
 247   (princ (format " error: %S" error)))
 248
 249 (luna-define-method lunit-test-listener-failure ((printer lunit-test-printer)
 250                                                  case failure)
 251   (princ (format " failure: %S" failure)))
 252
 253 (luna-define-method lunit-test-listener-start ((printer lunit-test-printer)
 254                                                case)
 255   (princ (format "Running `%S#%S'..."
 256                  (luna-class-name case)
 257                  (lunit-test-name-internal case))))
 258
 259 (luna-define-method lunit-test-listener-end ((printer lunit-test-printer) case)
 260   (princ "\n"))
 261
 262 (defun lunit-make-test-suite-from-class (class)
 263   "Make a test suite from all test methods of the CLASS."
 264   (let (tests)
 265     (mapatoms
 266      (lambda (symbol)
 267        (if (and (fboundp symbol)
 268                 (string-match "^test" (symbol-name symbol))
 269                 (null (get symbol 'luna-method-qualifier)))
 270            (push (lunit-make-test-case class symbol) tests)))
 271      (luna-class-obarray (luna-find-class class)))
 272     (apply #'lunit-make-test-suite tests)))
 273
 274 (defun lunit (test)
 275   "Run TEST and display the result."
 276   (let* ((printer
 277           (luna-make-entity 'lunit-test-printer))
 278          (result
 279           (lunit-make-test-result printer)))
 280     (lunit-test-run test result)
 281     (let ((failures
 282            (lunit-test-result-failures-internal result))
 283           (errors
 284            (lunit-test-result-errors-internal result)))
 285       (princ (format "%d runs, %d failures, %d errors\n"
 286                      (lunit-test-number-of-tests test)
 287                      (length failures)
 288                      (length errors))))))
 289
 290 (defvar imenu-create-index-function)
 291 (defun lunit-create-index-function ()
 292   (require 'imenu)
 293   (save-excursion
 294     (unwind-protect
 295         (progn
 296           (goto-char (point-min))
 297           (setq imenu-generic-expression
 298                 '((nil "^\\s-*(def\\(un\\|subst\\|macro\\)\\s-+\\([-A-Za-z0-9+*|:]+\\)" 2)))
 299           (funcall imenu-create-index-function))
 300       (setq imenu-create-index-function lisp-imenu-generic-expression))))
 301
 302 (defun lunit-generate-template (file)
 303   (interactive "fGenerate lunit template for: ")
 304   (save-excursion
 305     (set-buffer (find-file-noselect file))
 306     (let ((index-alist
 307            (lunit-create-index-function)))
 308       (with-output-to-temp-buffer "*Lunit template*"
 309         (let* ((feature
 310                 (file-name-sans-extension
 311                  (file-name-nondirectory file)))
 312                (class
 313                 (concat "test-" feature)))
 314           (set-buffer standard-output)
 315           (insert "\
 316 \(require 'lunit)
 317 \(require '" feature ")
 318
 319 \(luna-define-class " class " (lunit-test-case))
 320
 321 ")
 322           (dolist (index index-alist)
 323             (insert "\
 324 \(luna-define-method " class "-" (car index) " ((case " class "))
 325   (lunit-assert nil))
 326
 327 ")))))))
 328
 329 (provide 'lunit)
 330
 331 ;;; lunit.el ends here