From: Daiki Ueno Date: Fri, 5 Nov 2004 06:25:42 +0000 (+0000) Subject: Added test cases. X-Git-Url: https://cgit.sxemacs.org/?p=riece;a=commitdiff_plain;h=e5cab94cba73b8f6fe03a309ecafb962092e1c1f;hp=117f0f29b6ad99dd268d88c274d347a200001079 Added test cases. --- diff --git a/configure.ac b/configure.ac index 1c100eb..c8651c2 100644 --- a/configure.ac +++ b/configure.ac @@ -14,4 +14,5 @@ AM_CONDITIONAL(XEMACS, test ${EMACS_FLAVOR} = xemacs) AC_OUTPUT(Makefile \ lisp/Makefile +lisp/test/Makefile doc/Makefile) diff --git a/lisp/COMPILE b/lisp/COMPILE index 9e87444..518ab57 100644 --- a/lisp/COMPILE +++ b/lisp/COMPILE @@ -136,3 +136,19 @@ (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 diff --git a/lisp/Makefile.am b/lisp/Makefile.am index d4d6eaa..c65f321 100644 --- a/lisp/Makefile.am +++ b/lisp/Makefile.am @@ -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 index 0000000..625b3ff --- /dev/null +++ b/lisp/test/Makefile.am @@ -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 index 0000000..f33b83f --- /dev/null +++ b/lisp/test/luna.el @@ -0,0 +1,434 @@ +;;; luna.el --- tiny OOP system kernel + +;; Copyright (C) 1999,2000,2002 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 index 0000000..dbe1f74 --- /dev/null +++ b/lisp/test/lunit.el @@ -0,0 +1,331 @@ +;;; lunit.el --- simple testing framework for luna + +;; Copyright (C) 2000 Daiki Ueno. + +;; Author: Daiki Ueno +;; 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". +;; + +;; (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 index 0000000..9ee22ea --- /dev/null +++ b/lisp/test/test-riece-alias.el @@ -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