Added test cases.
authorDaiki Ueno <ueno@unixuser.org>
Fri, 5 Nov 2004 06:25:42 +0000 (06:25 +0000)
committerDaiki Ueno <ueno@unixuser.org>
Fri, 5 Nov 2004 06:25:42 +0000 (06:25 +0000)
configure.ac
lisp/COMPILE
lisp/Makefile.am
lisp/test/Makefile.am [new file with mode: 0644]
lisp/test/luna.el [new file with mode: 0644]
lisp/test/lunit.el [new file with mode: 0644]
lisp/test/test-riece-alias.el [new file with mode: 0644]

index 1c100eb..c8651c2 100644 (file)
@@ -14,4 +14,5 @@ AM_CONDITIONAL(XEMACS, test ${EMACS_FLAVOR} = xemacs)
 
 AC_OUTPUT(Makefile \
 lisp/Makefile
+lisp/test/Makefile
 doc/Makefile)
index 9e87444..518ab57 100644 (file)
    (expand-file-name "riece"
                     (expand-file-name "lisp" (car command-line-args-left)))
    (riece-install-just-print-p)))
+
+(defun riece-test ()
+  (require 'lunit)
+  (let ((load-path (cons (expand-file-name "test") (cons nil load-path)))
+       (files (directory-files "test" t "^test-.*\\.el$"))
+        (suite (lunit-make-test-suite)))
+    (while files
+      (when (file-regular-p (car files))
+       (load-file (car files))
+       (lunit-test-suite-add-test
+        suite
+        (lunit-make-test-suite-from-class
+         (intern (file-name-sans-extension
+                  (file-name-nondirectory (car files)))))))
+      (setq files (cdr files)))
+    (lunit suite)))
\ No newline at end of file
index d4d6eaa..c65f321 100644 (file)
@@ -1,3 +1,5 @@
+SUBDIRS = test
+
 EXTRA_DIST = COMPILE ChangeLog ChangeLog.Liece \
        riece-000.el riece-200.el riece-300.el riece-400.el riece-500.el \
        riece-addon.el riece-channel.el riece-coding.el riece-commands.el \
@@ -31,3 +33,6 @@ package:
 install-package: package
        $(XEMACS) $(FLAGS) -l COMPILE -f riece-install-package \
                $(PACKAGEDIR) # $(MAKE)
+
+check-local:
+       $(EMACS) $(FLAGS) -l COMPILE -f riece-test
\ No newline at end of file
diff --git a/lisp/test/Makefile.am b/lisp/test/Makefile.am
new file mode 100644 (file)
index 0000000..625b3ff
--- /dev/null
@@ -0,0 +1,2 @@
+EXTRA_DIST = luna.el lunit.el \
+       test-riece-alias.el
\ No newline at end of file
diff --git a/lisp/test/luna.el b/lisp/test/luna.el
new file mode 100644 (file)
index 0000000..f33b83f
--- /dev/null
@@ -0,0 +1,434 @@
+;;; luna.el --- tiny OOP system kernel
+
+;; Copyright (C) 1999,2000,2002 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: OOP
+
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+
+;;; @ class
+;;;
+
+(defmacro luna-find-class (name)
+  "Return a luna-class that has NAME."
+  `(get ,name 'luna-class))
+
+;; Give NAME (symbol) the luna-class CLASS.
+(defmacro luna-set-class (name class)
+  `(put ,name 'luna-class ,class))
+
+;; Return the obarray of luna-class CLASS.
+(defmacro luna-class-obarray (class)
+  `(aref ,class 1))
+
+;; Return the parents of luna-class CLASS.
+(defmacro luna-class-parents (class)
+  `(aref ,class 2))
+
+;; Return the number of slots of luna-class CLASS.
+(defmacro luna-class-number-of-slots (class)
+  `(aref ,class 3))
+
+(defmacro luna-define-class (class &optional parents slots)
+  "Define CLASS as a luna-class.
+CLASS always inherits the luna-class `standard-object'.
+
+The optional 1st arg PARENTS is a list luna-class names.  These
+luna-classes are also inheritted by CLASS.
+
+The optional 2nd arg SLOTS is a list of slots CLASS will have."
+  `(luna-define-class-function ',class ',(append parents '(standard-object))
+                              ',slots))
+
+
+;; Define CLASS as a luna-class.  PARENTS, if non-nil, is a list of
+;; luna-class names inherited by CLASS.  SLOTS, if non-nil, is a list
+;; of slots belonging to CLASS.
+
+(defun luna-define-class-function (class &optional parents slots)
+  (let ((oa (make-vector 31 0))
+       (rest parents)
+       parent name
+       (i 2)
+       b j)
+    (while rest
+      (setq parent (pop rest)
+           b (- i 2))
+      (mapatoms (lambda (sym)
+                 (when (setq j (get sym 'luna-slot-index))
+                   (setq name (symbol-name sym))
+                   (unless (intern-soft name oa)
+                     (put (intern name oa) 'luna-slot-index (+ j b))
+                     (setq i (1+ i)))))
+               (luna-class-obarray (luna-find-class parent))))
+    (setq rest slots)
+    (while rest
+      (setq name (symbol-name (pop rest)))
+      (unless (intern-soft name oa)
+       (put (intern name oa) 'luna-slot-index i)
+       (setq i (1+ i))))
+    (luna-set-class class (vector 'class oa parents i))))
+
+
+;; Return a member (slot or method) of CLASS that has name
+;; MEMBER-NAME.
+
+(defun luna-class-find-member (class member-name)
+  (or (stringp member-name)
+      (setq member-name (symbol-name member-name)))
+  (intern-soft member-name (luna-class-obarray class)))
+
+
+;; Return a member (slot or method) of CLASS that has name
+;; MEMBER-NAME.  If CLASS doesnt' have such a member, make it in
+;; CLASS.
+
+(defsubst luna-class-find-or-make-member (class member-name)
+  (or (stringp member-name)
+      (setq member-name (symbol-name member-name)))
+  (intern member-name (luna-class-obarray class)))
+
+
+;; Return the index number of SLOT-NAME in CLASS.
+
+(defmacro luna-class-slot-index (class slot-name)
+  `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
+
+(defmacro luna-define-method (name &rest definition)
+  "Define NAME as a method of a luna class.
+
+Usage of this macro follows:
+
+  (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
+
+The optional 1st argument METHOD-QUALIFIER specifies when and how the
+method is called.
+
+If it is :before, call the method before calling the parents' methods.
+
+If it is :after, call the method after calling the parents' methods.
+
+If it is :around, call the method only.  The parents' methods can be
+executed by calling the function `luna-call-next-method' in BODY.
+
+Otherwize, call the method only, and the parents' methods are never
+executed.  In this case, METHOD-QUALIFIER is treated as ARGLIST.
+
+ARGLIST has the form ((VAR CLASS) METHOD-ARG ...), where VAR is a
+variable name that should be bound to an entity that receives the
+message NAME, CLASS is a class name.  The first argument to the method
+is VAR, and the remaining arguments are METHOD-ARGs.
+
+If VAR is nil, arguments to the method are METHOD-ARGs.  This kind of
+methods can't be called from generic-function (see
+`luna-define-generic').
+
+The optional 4th argument DOCSTRING is the documentation of the
+method.  If it is not string, it is treated as BODY.
+
+The optional 5th BODY is the body of the method."
+  (let ((method-qualifier (pop definition))
+       args specializer class self)
+    (if (memq method-qualifier '(:before :after :around))
+       (setq args (pop definition))
+      (setq args method-qualifier
+           method-qualifier nil))
+    (setq specializer (car args)
+         class (nth 1 specializer)
+         self (car specializer))
+    `(let ((func (lambda ,(if self
+                             (cons self (cdr args))
+                           (cdr args))
+                  ,@definition))
+          (sym (luna-class-find-or-make-member
+                (luna-find-class ',class) ',name))
+          (cache (get ',name 'luna-method-cache)))
+       (and cache
+           (fboundp sym)
+           (mapatoms
+            (lambda (s)
+              (if (memq (symbol-function sym) (symbol-value s))
+                  (unintern s cache)))
+            cache))
+       (fset sym func)
+       (put sym 'luna-method-qualifier ,method-qualifier))))
+
+(put 'luna-define-method 'lisp-indent-function 'defun)
+
+(def-edebug-spec luna-define-method
+  (&define name [&optional &or ":before" ":after" ":around"]
+          ((arg symbolp)
+           [&rest arg]
+           [&optional ["&optional" arg &rest arg]]
+           &optional ["&rest" arg])
+          def-body))
+
+
+;; Return a list of method functions named SERVICE registered in the
+;; parents of CLASS.
+
+(defun luna-class-find-parents-functions (class service)
+  (let ((parents (luna-class-parents class))
+       ret)
+    (while (and parents
+               (null
+                (setq ret (luna-class-find-functions
+                           (luna-find-class (pop parents))
+                           service)))))
+    ret))
+
+;; Return a list of method functions named SERVICE registered in CLASS
+;; and the parents..
+
+(defun luna-class-find-functions (class service)
+  (let ((sym (luna-class-find-member class service)))
+    (if (fboundp sym)
+       (cond ((eq (get sym 'luna-method-qualifier) :before)
+              (cons (symbol-function sym)
+                    (luna-class-find-parents-functions class service)))
+             ((eq (get sym 'luna-method-qualifier) :after)
+              (nconc (luna-class-find-parents-functions class service)
+                     (list (symbol-function sym))))
+             ((eq (get sym 'luna-method-qualifier) :around)
+              (cons sym (luna-class-find-parents-functions class service)))
+             (t
+              (list (symbol-function sym))))
+      (luna-class-find-parents-functions class service))))
+
+
+;;; @ instance (entity)
+;;;
+
+(defmacro luna-class-name (entity)
+  "Return class-name of the ENTITY."
+  `(aref ,entity 0))
+
+(defmacro luna-set-class-name (entity name)
+  `(aset ,entity 0 ,name))
+
+(defmacro luna-get-obarray (entity)
+  `(aref ,entity 1))
+
+(defmacro luna-set-obarray (entity obarray)
+  `(aset ,entity 1 ,obarray))
+
+(defmacro luna-slot-index (entity slot-name)
+  `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
+                         ,slot-name))
+
+(defsubst luna-slot-value (entity slot)
+  "Return the value of SLOT of ENTITY."
+  (aref entity (luna-slot-index entity slot)))
+
+(defsubst luna-set-slot-value (entity slot value)
+  "Store VALUE into SLOT of ENTITY."
+  (aset entity (luna-slot-index entity slot) value))
+
+(defmacro luna-find-functions (entity service)
+  `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
+                             ,service))
+
+(defsubst luna-send (entity message &rest luna-current-method-arguments)
+  "Send MESSAGE to ENTITY, and return the result.
+ENTITY is an instance of a luna class, and MESSAGE is a method name of
+the luna class.
+LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
+  (let ((luna-next-methods (luna-find-functions entity message))
+       luna-current-method
+       luna-previous-return-value)
+    (while (and luna-next-methods
+               (progn
+                 (setq luna-current-method (pop luna-next-methods)
+                       luna-previous-return-value
+                       (apply luna-current-method
+                              luna-current-method-arguments))
+                 (if (symbolp luna-current-method)
+                     (not (eq (get luna-current-method
+                                   'luna-method-qualifier) :around))
+                   t))))
+    luna-previous-return-value))
+
+(eval-when-compile
+  (defvar luna-next-methods nil)
+  (defvar luna-current-method-arguments nil))
+
+(defun luna-call-next-method ()
+  "Call the next method in the current method function.
+A method function that has :around qualifier should call this function
+to execute the parents' methods."
+  (let (luna-current-method
+       luna-previous-return-value)
+    (while (and luna-next-methods
+               (progn
+                 (setq luna-current-method (pop luna-next-methods)
+                       luna-previous-return-value
+                       (apply luna-current-method
+                              luna-current-method-arguments))
+                 (if (symbolp luna-current-method)
+                     (not (eq (get luna-current-method
+                                   'luna-method-qualifier) :around))
+                   t))))
+    luna-previous-return-value))
+
+(defun luna-make-entity (class &rest init-args)
+  "Make an entity (instance) of luna-class CLASS and return it.
+INIT-ARGS is a plist of the form (:SLOT1 VAL1 :SLOT2 VAL2 ...),
+where SLOTs are slots of CLASS and the VALs are initial values of
+the corresponding SLOTs."
+  (let* ((c (get class 'luna-class))
+        (v (make-vector (luna-class-number-of-slots c) nil)))
+    (luna-set-class-name v class)
+    (luna-set-obarray v (make-vector 7 0))
+    (apply #'luna-send v 'initialize-instance v init-args)))
+
+
+;;; @ interface (generic function)
+;;;
+
+;; Find a method of ENTITY that handles MESSAGE, and call it with
+;; arguments LUNA-CURRENT-METHOD-ARGUMENTS.
+
+(defun luna-apply-generic (entity message &rest luna-current-method-arguments)
+  (let* ((class (luna-class-name entity))
+        (cache (get message 'luna-method-cache))
+        (sym (intern-soft (symbol-name class) cache))
+        luna-next-methods)
+    (if sym
+       (setq luna-next-methods (symbol-value sym))
+      (setq luna-next-methods
+           (luna-find-functions entity message))
+      (set (intern (symbol-name class) cache)
+          luna-next-methods))
+    (luna-call-next-method)))
+
+
+;; Convert ARGLIST (argument list spec for a method function) to the
+;; actual list of arguments.
+
+(defsubst luna-arglist-to-arguments (arglist)
+  (let (dest)
+    (while arglist
+      (let ((arg (car arglist)))
+       (or (memq arg '(&optional &rest))
+           (setq dest (cons arg dest))))
+      (setq arglist (cdr arglist)))
+    (nreverse dest)))
+
+
+(defmacro luna-define-generic (name args &optional doc)
+  "Define a function NAME that provides a generic interface to the method NAME.
+ARGS is the argument list for NAME.  The first element of ARGS is an
+entity.
+
+The function handles a message sent to the entity by calling the
+method with proper arguments.
+
+The optional 3rd argument DOC is the documentation string for NAME."
+  (if doc
+      `(progn
+        (defun ,(intern (symbol-name name)) ,args
+          ,doc
+          (luna-apply-generic ,(car args) ',name
+                              ,@(luna-arglist-to-arguments args)))
+        (put ',name 'luna-method-cache (make-vector 31 0)))
+    `(progn
+       (defun ,(intern (symbol-name name)) ,args
+        (luna-apply-generic ,(car args) ',name
+                            ,@(luna-arglist-to-arguments args)))
+       (put ',name 'luna-method-cache (make-vector 31 0)))))
+
+(put 'luna-define-generic 'lisp-indent-function 'defun)
+
+
+;;; @ accessor
+;;;
+
+(defun luna-define-internal-accessors (class-name)
+  "Define internal accessors for instances of the luna class CLASS-NAME.
+
+Internal accessors are macros to refer and set a slot value of the
+instances.  For instance, if the class has SLOT, macros
+CLASS-NAME-SLOT-internal and CLASS-NAME-set-SLOT-internal are defined.
+
+CLASS-NAME-SLOT-internal accepts one argument INSTANCE, and returns
+the value of SLOT.
+
+CLASS-NAME-set-SLOT-internal accepts two arguemnt INSTANCE and VALUE,
+and sets SLOT to VALUE."
+  (let ((entity-class (luna-find-class class-name))
+       parents parent-class)
+    (mapatoms
+     (lambda (slot)
+       (if (luna-class-slot-index entity-class slot)
+          (catch 'derived
+            (setq parents (luna-class-parents entity-class))
+            (while parents
+              (setq parent-class (luna-find-class (car parents)))
+              (if (luna-class-slot-index parent-class slot)
+                  (throw 'derived nil))
+              (setq parents (cdr parents)))
+            (eval
+             `(progn
+                (defmacro ,(intern (format "%s-%s-internal"
+                                           class-name slot))
+                  (entity)
+                  (list 'aref entity
+                        ,(luna-class-slot-index entity-class
+                                                (intern (symbol-name slot)))))
+                (defmacro ,(intern (format "%s-set-%s-internal"
+                                           class-name slot))
+                  (entity value)
+                  (list 'aset entity
+                        ,(luna-class-slot-index
+                          entity-class (intern (symbol-name slot)))
+                        value)))))))
+     (luna-class-obarray entity-class))))
+
+
+;;; @ standard object
+;;;
+
+;; Define super class of all luna classes.
+(luna-define-class-function 'standard-object)
+
+(luna-define-method initialize-instance ((entity standard-object)
+                                        &rest init-args)
+  "Initialize slots of ENTITY by INIT-ARGS."
+  (let* ((c (luna-find-class (luna-class-name entity)))
+        (oa (luna-class-obarray c))
+        s i)
+    (while init-args
+      (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
+           i (pop init-args))
+      (if s
+         (aset entity (get s 'luna-slot-index) i)))
+    entity))
+
+
+;;; @ end
+;;;
+
+(provide 'luna)
+
+;; luna.el ends here
diff --git a/lisp/test/lunit.el b/lisp/test/lunit.el
new file mode 100644 (file)
index 0000000..dbe1f74
--- /dev/null
@@ -0,0 +1,331 @@
+;;; lunit.el --- simple testing framework for luna
+
+;; Copyright (C) 2000 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, 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 (integerp "a")))
+;;
+;; (luna-define-method test-2 ((case silly-test-case))
+;;   (lunit-assert (stringp "b")))
+;;
+;; (with-output-to-temp-buffer "*Lunit Results*"
+;;   (lunit (lunit-make-test-suite-from-class 'silly-test-case)))
+;; ______________________________________________________________________
+;; Starting test `silly-test-case#test-1'
+;; failure: (integerp "a")
+;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+;; ______________________________________________________________________
+;; Starting test `silly-test-case#test-2'
+;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+;; 2 runs, 1 failures, 0 errors
+
+;;; Code:
+
+(require 'luna)
+
+(eval-when-compile (require 'cl))
+
+;;; @ 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))
+
+  (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-error (result case error)
+  "Add error to the list of errors.
+The passed in exception caused the error.")
+
+(luna-define-generic lunit-test-result-failure (result case failure)
+  "Add failure to the list of failures.
+The passed in exception caused the failure.")
+
+(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))
+
+(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-failure result case (nth 1 error)))
+    (lunit-error
+     (lunit-test-result-error result case (cdr error))))
+  (lunit-test-result-notify result 'lunit-test-listener-end case))
+
+(luna-define-method lunit-test-result-error ((result lunit-test-result)
+                                            case error)
+  (let ((errors
+        (lunit-test-result-errors-internal result)))
+    (setq errors (nconc errors (list (cons case error))))
+    (lunit-test-result-set-errors-internal result errors))
+  (lunit-test-result-notify result 'lunit-test-listener-error case error))
+
+(luna-define-method lunit-test-result-failure ((result lunit-test-result)
+                                              case failure)
+  (let ((failures
+        (lunit-test-result-failures-internal result)))
+    (setq failures (nconc failures (list (cons case failure))))
+    (lunit-test-result-set-failures-internal result failures))
+  (lunit-test-result-notify result 'lunit-test-listener-failure case failure))
+
+(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
+;;;
+
+(luna-define-class lunit-test-case (lunit-test))
+
+(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))
+
+(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."
+  (let ((condition (eval condition-expr)))
+    `(when ,(not condition)
+       (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 ((failures
+          (lunit-test-result-failures-internal result))
+         (errors
+          (lunit-test-result-errors-internal result)))
+      (princ (format "%d runs, %d failures, %d errors\n"
+                    (lunit-test-number-of-tests test)
+                    (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
diff --git a/lisp/test/test-riece-alias.el b/lisp/test/test-riece-alias.el
new file mode 100644 (file)
index 0000000..9ee22ea
--- /dev/null
@@ -0,0 +1,79 @@
+(require 'riece-alias)
+
+(luna-define-class test-riece-alias (lunit-test-case))
+
+(luna-define-method test-riece-alias-altsep-1 ((case test-riece-alias))
+  (let ((riece-alias-alternate-separator "@"))
+    (lunit-assert
+     (equal
+      (riece-alias-abbrev-alternate-separator "#riece")
+      "#riece"))
+    (lunit-assert
+     (equal
+      (riece-alias-abbrev-alternate-separator "#riece localhost")
+      "#riece@localhost"))
+    (lunit-assert
+     (equal
+      (riece-alias-abbrev-alternate-separator "#ch@nnel")
+      "#ch@@nnel"))
+    (lunit-assert
+     (equal
+      (riece-alias-abbrev-alternate-separator "#ch@nnel localhost")
+      "#ch@@nnel@localhost"))))
+
+(luna-define-method test-riece-alias-altsep-2 ((case test-riece-alias))
+  (let ((riece-alias-alternate-separator "@@"))
+    (lunit-assert
+     (equal
+      (riece-alias-abbrev-alternate-separator "#riece")
+      "#riece"))
+    (lunit-assert
+     (equal
+      (riece-alias-abbrev-alternate-separator "#riece localhost")
+      "#riece@@localhost"))
+    (lunit-assert
+     (equal
+      (riece-alias-abbrev-alternate-separator "#ch@@nnel")
+      "#ch@@@@nnel"))
+    (lunit-assert
+     (equal
+      (riece-alias-abbrev-alternate-separator "#ch@@nnel localhost")
+      "#ch@@@@nnel@@localhost"))))
+
+(luna-define-method test-riece-alias-altsep-3 ((case test-riece-alias))
+  (let ((riece-alias-alternate-separator "@"))
+    (lunit-assert
+     (equal
+      (riece-alias-expand-alternate-separator "#riece")
+      "#riece"))
+    (lunit-assert
+     (equal
+      (riece-alias-expand-alternate-separator "#riece@localhost")
+      "#riece localhost"))
+    (lunit-assert
+     (equal
+      (riece-alias-expand-alternate-separator "#ch@@nnel")
+      "#ch@nnel"))
+    (lunit-assert
+     (equal
+      (riece-alias-expand-alternate-separator "#ch@@nnel@localhost")
+      "#ch@nnel localhost"))))
+
+(luna-define-method test-riece-alias-altsep-4 ((case test-riece-alias))
+  (let ((riece-alias-alternate-separator "@@"))
+    (lunit-assert
+     (equal
+      (riece-alias-expand-alternate-separator "#riece")
+      "#riece"))
+    (lunit-assert
+     (equal
+      (riece-alias-expand-alternate-separator "#riece@@localhost")
+      "#riece localhost"))
+    (lunit-assert
+     (equal
+      (riece-alias-expand-alternate-separator "#ch@@@@nnel")
+      "#ch@@nnel"))
+    (lunit-assert
+     (equal
+      (riece-alias-expand-alternate-separator "#ch@@@@nnel@@localhost")
+      "#ch@@nnel localhost"))))
\ No newline at end of file