--- /dev/null
+;;; lunit.el --- simple testing framework for luna
+
+;; Copyright (C) 2000-2004 Daiki Ueno.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: OOP, XP
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; This module is inspired by "JUnit A Cook's Tour".
+;; <URL:http://www.junit.org/junit/doc/cookstour/cookstour.htm>
+
+;; (require 'lunit)
+;;
+;; (luna-define-class silly-test-case (lunit-test-case))
+;;
+;; (luna-define-method test-1 ((case silly-test-case))
+;; (lunit-assert-2 case (integerp "a")))
+;;
+;; (luna-define-method test-2 ((case silly-test-case))
+;; (lunit-assert-2 case (stringp "b")))
+;;
+;; (with-output-to-temp-buffer "*Lunit Results*"
+;; (lunit (lunit-make-test-suite-from-class 'silly-test-case)))
+;; ______________________________________________________________________
+;; Running `silly-test-case#test-1'... failure: (integerp "a")
+;; Running `silly-test-case#test-2'...
+;; 2 runs, 2 assertions, 1 failures, 0 errors
+
+;;; Code:
+
+(require 'luna)
+
+(eval-when-compile (require 'cl))
+
+(require 'pp)
+
+;;; @ test
+;;;
+
+(eval-and-compile
+ (luna-define-class lunit-test ()
+ (name))
+
+ (luna-define-internal-accessors 'lunit-test))
+
+(luna-define-generic lunit-test-number-of-tests (test)
+ "Count the number of test cases that will be run by the test.")
+
+(luna-define-generic lunit-test-run (test result)
+ "Run the test and collects its result in result.")
+
+(luna-define-generic lunit-test-suite-add-test (suite test)
+ "Add the test to the suite.")
+
+;;; @ test listener
+;;;
+
+(luna-define-class lunit-test-listener)
+
+;;; @ test result
+;;;
+
+(put 'lunit-error 'error-message "test error")
+(put 'lunit-error 'error-conditions '(lunit-error error))
+
+(put 'lunit-failure 'error-message "test failure")
+(put 'lunit-failure 'error-conditions '(lunit-failure lunit-error error))
+
+(eval-and-compile
+ (luna-define-class lunit-test-result ()
+ (errors
+ failures
+ listeners
+ assert-count))
+
+ (luna-define-internal-accessors 'lunit-test-result))
+
+(luna-define-generic lunit-test-result-run (result case)
+ "Run the test case.")
+
+(luna-define-generic lunit-test-result-notify (result message &rest args)
+ "Report the current state of execution.")
+
+(luna-define-generic lunit-test-result-add-listener (result listener)
+ "Add listener to the list of listeners.")
+
+(defun lunit-make-test-result (&rest listeners)
+ "Return a newly allocated `lunit-test-result' instance with LISTENERS."
+ (luna-make-entity 'lunit-test-result :listeners listeners :assert-count 0))
+
+(luna-define-method lunit-test-result-notify ((result lunit-test-result)
+ message args)
+ (let ((listeners
+ (lunit-test-result-listeners-internal result)))
+ (dolist (listener listeners)
+ (apply #'luna-send listener message listener args))))
+
+(luna-define-method lunit-test-result-run ((result lunit-test-result) case)
+ (lunit-test-result-notify result 'lunit-test-listener-start case)
+ (condition-case error
+ (lunit-test-case-run case)
+ (lunit-failure
+ (lunit-test-result-set-failures-internal
+ result
+ (nconc (lunit-test-result-failures-internal result)
+ (list (cons case (cdr error)))))
+ (lunit-test-result-notify
+ result 'lunit-test-listener-failure case (cdr error)))
+ (lunit-error
+ (lunit-test-result-set-errors-internal
+ result
+ (nconc (lunit-test-result-errors-internal result)
+ (list (cons case (cdr error)))))
+ (lunit-test-result-notify
+ result 'lunit-test-listener-error case (cdr error))))
+ (lunit-test-result-set-assert-count-internal
+ result
+ (+ (lunit-test-result-assert-count-internal result)
+ (lunit-test-case-assert-count-internal case)))
+ (lunit-test-result-notify result 'lunit-test-listener-end case))
+
+(luna-define-method lunit-test-result-add-listener ((result lunit-test-result)
+ listener)
+ (let ((listeners
+ (lunit-test-result-listeners-internal result)))
+ (setq listeners (nconc listeners (list listener)))
+ (lunit-test-result-set-listeners-internal result listeners)))
+
+;;; @ test case
+;;;
+
+(eval-and-compile
+ (luna-define-class lunit-test-case (lunit-test)
+ (assert-count))
+
+ (luna-define-internal-accessors 'lunit-test-case))
+
+(luna-define-generic lunit-test-case-run (case)
+ "Run the test case.")
+
+(luna-define-generic lunit-test-case-setup (case)
+ "Setup the test case.")
+
+(luna-define-generic lunit-test-case-teardown (case)
+ "Clear the test case.")
+
+(defun lunit-make-test-case (class name)
+ "Return a newly allocated `lunit-test-case'.
+CLASS is a symbol for class derived from `lunit-test-case'.
+NAME is name of the method to be tested."
+ (luna-make-entity class :name name :assert-count 0))
+
+(luna-define-method lunit-test-number-of-tests ((case lunit-test-case))
+ 1)
+
+(luna-define-method lunit-test-run ((case lunit-test-case) result)
+ (lunit-test-result-run result case))
+
+(luna-define-method lunit-test-case-setup ((case lunit-test-case)))
+(luna-define-method lunit-test-case-teardown ((case lunit-test-case)))
+
+(luna-define-method lunit-test-case-run ((case lunit-test-case))
+ (lunit-test-case-setup case)
+ (unwind-protect
+ (let* ((name
+ (lunit-test-name-internal case))
+ (functions
+ (luna-find-functions case name)))
+ (unless functions
+ (error "Method \"%S\" not found" name))
+ (condition-case error
+ (funcall (car functions) case)
+ (lunit-failure
+ (signal (car error)(cdr error)))
+ (error
+ (signal 'lunit-error error))))
+ (lunit-test-case-teardown case)))
+
+;;; @ test suite
+;;;
+
+(eval-and-compile
+ (luna-define-class lunit-test-suite (lunit-test)
+ (tests))
+
+ (luna-define-internal-accessors 'lunit-test-suite))
+
+(defun lunit-make-test-suite (&rest tests)
+ "Return a newly allocated `lunit-test-suite' instance.
+TESTS holds a number of instances of `lunit-test'."
+ (luna-make-entity 'lunit-test-suite :tests tests))
+
+(luna-define-method lunit-test-suite-add-test ((suite lunit-test-suite) test)
+ (let ((tests (lunit-test-suite-tests-internal suite)))
+ (lunit-test-suite-set-tests-internal suite (nconc tests (list test)))))
+
+(luna-define-method lunit-test-number-of-tests ((suite lunit-test-suite))
+ (let ((tests (lunit-test-suite-tests-internal suite))
+ (accu 0))
+ (dolist (test tests)
+ (setq accu (+ accu (lunit-test-number-of-tests test))))
+ accu))
+
+(luna-define-method lunit-test-run ((suite lunit-test-suite) result)
+ (let ((tests (lunit-test-suite-tests-internal suite)))
+ (dolist (test tests)
+ (lunit-test-run test result))))
+
+;;; @ test runner
+;;;
+
+(defmacro lunit-assert (condition-expr)
+ "Verify that CONDITION-EXPR returns non-nil; signal an error if not."
+ `(unless ,condition-expr
+ (signal 'lunit-failure (list ',condition-expr))))
+
+(defmacro lunit-assert-2 (case condition-expr)
+ "In regard to CASE, verify that CONDITION-EXPR returns non-nil;
+signal an error if not."
+ `(let ((case ,case))
+ (lunit-test-case-set-assert-count-internal
+ case
+ (1+ (lunit-test-case-assert-count-internal case)))
+ (unless ,condition-expr
+ (signal 'lunit-failure (list ',condition-expr)))))
+
+(luna-define-class lunit-test-printer (lunit-test-listener))
+
+(luna-define-method lunit-test-listener-error ((printer lunit-test-printer)
+ case error)
+ (princ (format " error: %S" error)))
+
+(luna-define-method lunit-test-listener-failure ((printer lunit-test-printer)
+ case failure)
+ (princ (format " failure: %S" failure)))
+
+(luna-define-method lunit-test-listener-start ((printer lunit-test-printer)
+ case)
+ (princ (format "Running `%S#%S'..."
+ (luna-class-name case)
+ (lunit-test-name-internal case))))
+
+(luna-define-method lunit-test-listener-end ((printer lunit-test-printer) case)
+ (princ "\n"))
+
+(defun lunit-make-test-suite-from-class (class)
+ "Make a test suite from all test methods of the CLASS."
+ (let (tests)
+ (mapatoms
+ (lambda (symbol)
+ (if (and (fboundp symbol)
+ (string-match "^test" (symbol-name symbol))
+ (null (get symbol 'luna-method-qualifier)))
+ (push (lunit-make-test-case class symbol) tests)))
+ (luna-class-obarray (luna-find-class class)))
+ (apply #'lunit-make-test-suite tests)))
+
+(defun lunit (test)
+ "Run TEST and display the result."
+ (let* ((printer
+ (luna-make-entity 'lunit-test-printer))
+ (result
+ (lunit-make-test-result printer)))
+ (lunit-test-run test result)
+ (let ((assert-count
+ (lunit-test-result-assert-count-internal result))
+ (failures
+ (lunit-test-result-failures-internal result))
+ (errors
+ (lunit-test-result-errors-internal result)))
+ (princ (format "%d runs, %d assertions, %d failures, %d errors\n"
+ (lunit-test-number-of-tests test)
+ assert-count
+ (length failures)
+ (length errors))))))
+
+(defvar imenu-create-index-function)
+(defun lunit-create-index-function ()
+ (require 'imenu)
+ (save-excursion
+ (unwind-protect
+ (progn
+ (goto-char (point-min))
+ (setq imenu-generic-expression
+ '((nil "^\\s-*(def\\(un\\|subst\\|macro\\)\\s-+\\([-A-Za-z0-9+*|:]+\\)" 2)))
+ (funcall imenu-create-index-function))
+ (setq imenu-create-index-function lisp-imenu-generic-expression))))
+
+(defun lunit-generate-template (file)
+ (interactive "fGenerate lunit template for: ")
+ (save-excursion
+ (set-buffer (find-file-noselect file))
+ (let ((index-alist
+ (lunit-create-index-function)))
+ (with-output-to-temp-buffer "*Lunit template*"
+ (let* ((feature
+ (file-name-sans-extension
+ (file-name-nondirectory file)))
+ (class
+ (concat "test-" feature)))
+ (set-buffer standard-output)
+ (insert "\
+\(require 'lunit)
+\(require '" feature ")
+
+\(luna-define-class " class " (lunit-test-case))
+
+")
+ (dolist (index index-alist)
+ (insert "\
+\(luna-define-method " class "-" (car index) " ((case " class "))
+ (lunit-assert nil))
+
+")))))))
+
+(provide 'lunit)
+
+;;; lunit.el ends here
projects / packages / blobdiff