From: yamaoka <yamaoka>
Date: Fri, 15 Dec 2000 07:00:10 +0000 (+0000)
Subject: Synch with `flim-1_14' (to be continued).
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=56ba87de744707422ee57924d75d15fb904b40ad;p=elisp%2Fflim.git

Synch with `flim-1_14' (to be continued).
---

diff --git a/eword-decode.el b/eword-decode.el
index d374d3f..1dd428a 100644
--- a/eword-decode.el
+++ b/eword-decode.el
@@ -67,8 +67,7 @@
 	      "\\("
 	      eword-encoded-text-regexp
 	      "\\)"
-	      (regexp-quote "?="))))
-  )
+	      (regexp-quote "?=")))))
 
 
 ;;; @ for string
@@ -90,26 +89,19 @@ such as a version of Net$cape)."
 	beg end)
     (while (and (string-match eword-encoded-word-regexp string)
 		(setq beg (match-beginning 0)
-		      end (match-end 0))
-		)
+		      end (match-end 0)))
       (if (> beg 0)
 	  (if (not
 	       (and (eq ew t)
-		    (string-match "^[ \t]+$" (substring string 0 beg))
-		    ))
-	      (setq dest (concat dest (substring string 0 beg)))
-	    )
-	)
+		    (string-match "^[ \t]+$" (substring string 0 beg))))
+	      (setq dest (concat dest (substring string 0 beg)))))
       (setq dest
 	    (concat dest
 		    (eword-decode-encoded-word
-		     (substring string beg end) must-unfold)
-		    ))
+		     (substring string beg end) must-unfold)))
       (setq string (substring string end))
-      (setq ew t)
-      )
-    (concat dest string)
-    ))
+      (setq ew t))
+    (concat dest string)))
 
 (defun eword-decode-structured-field-body (string
 					   &optional start-column max-column
@@ -144,8 +136,7 @@ decode the charset included in it, it is not decoded."
 	(setq result
 	      (if (eq type 'spaces)
 		  (concat result " ")
-		(concat result (eword-decode-token token))
-		))))
+		(concat result (eword-decode-token token))))))
     result))
 
 (defun eword-decode-and-fold-structured-field-body (string
@@ -174,12 +165,10 @@ decode the charset included in it, it is not decoded."
 			  c next-c)
 		  (setq result (concat result "\n " next-str)
 			c (1+ next-len)))
-		(setq tokens (cdr tokens))
-		)
+		(setq tokens (cdr tokens)))
 	    (let* ((str (eword-decode-token token)))
 	      (setq result (concat result str)
-		    c (+ c (string-width str)))
-	      ))))
+		    c (+ c (string-width str)))))))
       (if token
 	  (concat result (eword-decode-token token))
 	result))))
@@ -221,41 +210,34 @@ such as a version of Net$cape)."
     (save-restriction
       (narrow-to-region start end)
       (if unfolding
-	  (eword-decode-unfold)
-	)
+	  (eword-decode-unfold))
       (goto-char (point-min))
       (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)"
-                                        "\\(\n?[ \t]\\)+"
-                                        "\\(" eword-encoded-word-regexp "\\)")
-                                nil t)
+					"\\(\n?[ \t]\\)+"
+					"\\(" eword-encoded-word-regexp "\\)")
+				nil t)
 	(replace-match "\\1\\6")
-        (goto-char (point-min))
-	)
+	(goto-char (point-min)))
       (while (re-search-forward eword-encoded-word-regexp nil t)
 	(insert (eword-decode-encoded-word
 		 (prog1
 		     (buffer-substring (match-beginning 0) (match-end 0))
-		   (delete-region (match-beginning 0) (match-end 0))
-		   ) must-unfold))
-	)
-      )))
+		   (delete-region (match-beginning 0) (match-end 0)))
+		 must-unfold))))))
 
 (defun eword-decode-unfold ()
   (goto-char (point-min))
   (let (field beg end)
     (while (re-search-forward std11-field-head-regexp nil t)
       (setq beg (match-beginning 0)
-            end (std11-field-end))
+	    end (std11-field-end))
       (setq field (buffer-substring beg end))
       (if (string-match eword-encoded-word-regexp field)
-          (save-restriction
-            (narrow-to-region (goto-char beg) end)
-            (while (re-search-forward "\n\\([ \t]\\)" nil t)
-              (replace-match (match-string 1))
-              )
-	    (goto-char (point-max))
-	    ))
-      )))
+	  (save-restriction
+	    (narrow-to-region (goto-char beg) end)
+	    (while (re-search-forward "\n\\([ \t]\\)" nil t)
+	      (replace-match (match-string 1)))
+	    (goto-char (point-max)))))))
 
 
 ;;; @ for message header
@@ -284,16 +266,13 @@ If mode is `nil', corresponding decoder is set up for every modes."
 		  (setcdr cell (put-alist field function (cdr cell)))
 		(setq mime-field-decoder-alist
 		      (cons (cons mode (list (cons field function)))
-			    mime-field-decoder-alist))
-		))
-	    (apply (function mime-set-field-decoder) field specs)
-	    )
+			    mime-field-decoder-alist))))
+	    (apply (function mime-set-field-decoder) field specs))
 	(mime-set-field-decoder field
 				'plain function
 				'wide function
 				'summary function
-				'nov function)
-	))))
+				'nov function)))))
 
 ;;;###autoload
 (defmacro mime-find-field-presentation-method (name)
@@ -301,20 +280,17 @@ If mode is `nil', corresponding decoder is set up for every modes."
 NAME must be `plain', `wide', `summary' or `nov'."
   (cond ((eq name nil)
 	 (` (or (assq 'summary mime-field-decoder-cache)
-		'(summary))
-	    ))
+		'(summary))))
 	((and (consp name)
 	      (car name)
 	      (consp (cdr name))
 	      (symbolp (car (cdr name)))
 	      (null (cdr (cdr name))))
 	 (` (or (assq (, name) mime-field-decoder-cache)
-		(cons (, name) nil))
-	    ))
+		(cons (, name) nil))))
 	(t
 	 (` (or (assq (or (, name) 'summary) mime-field-decoder-cache)
-		(cons (or (, name) 'summary) nil)))
-	 )))
+		(cons (or (, name) 'summary) nil))))))
 
 (defun mime-find-field-decoder-internal (field &optional mode)
   "Return function to decode field-body of FIELD in MODE.
@@ -324,8 +300,7 @@ Optional argument MODE must be object of field-presentation-method."
 	       (funcall mime-update-field-decoder-cache
 			field (car mode))
 	     (setcdr mode
-		     (cdr (assq (car mode) mime-field-decoder-cache)))
-	     ))))
+		     (cdr (assq (car mode) mime-field-decoder-cache)))))))
 
 ;;;###autoload
 (defun mime-find-field-decoder (field &optional mode)
@@ -340,30 +315,27 @@ Default value of MODE is `summary'."
 	    (cdr p)
 	  (cdr (funcall mime-update-field-decoder-cache
 			field (or mode 'summary)))))
-    (inline (mime-find-field-decoder-internal field mode))
-    ))
+    (inline (mime-find-field-decoder-internal field mode))))
 
 ;;;###autoload
 (defun mime-update-field-decoder-cache (field mode &optional function)
   "Update field decoder cache `mime-field-decoder-cache'."
   (cond ((eq function 'identity)
-	 (setq function nil)
-	 )
+	 (setq function nil))
 	((null function)
 	 (let ((decoder-alist
 		(cdr (assq (or mode 'summary) mime-field-decoder-alist))))
 	   (setq function (cdr (or (assq field decoder-alist)
-				   (assq t decoder-alist)))))
-	 ))
+				   (assq t decoder-alist)))))))
   (let ((cell (assq mode mime-field-decoder-cache))
-        ret)
+	ret)
     (if cell
-        (if (setq ret (assq field (cdr cell)))
-            (setcdr ret function)
-          (setcdr cell (cons (setq ret (cons field function)) (cdr cell))))
+	(if (setq ret (assq field (cdr cell)))
+	    (setcdr ret function)
+	  (setcdr cell (cons (setq ret (cons field function)) (cdr cell))))
       (setq mime-field-decoder-cache
-            (cons (cons mode (list (setq ret (cons field function))))
-                  mime-field-decoder-cache)))
+	    (cons (cons mode (list (setq ret (cons field function))))
+		  mime-field-decoder-cache)))
     ret))
 
 ;; ignored fields
@@ -393,10 +365,10 @@ Default value of MODE is `summary'."
 ;; structured fields
 (let ((fields
        '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
-	 To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
-	 Mail-Followup-To
-	 Mime-Version Content-Type Content-Transfer-Encoding
-	 Content-Disposition User-Agent))
+		  To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
+		  Mail-Followup-To
+		  Mime-Version Content-Type Content-Transfer-Encoding
+		  Content-Disposition User-Agent))
       field)
   (while fields
     (setq field (pop fields))
@@ -405,8 +377,7 @@ Default value of MODE is `summary'."
      'plain	(function eword-decode-structured-field-body)
      'wide	(function eword-decode-and-fold-structured-field-body)
      'summary	(function eword-decode-and-unfold-structured-field-body)
-     'nov	(function eword-decode-and-unfold-structured-field-body)
-     )))
+     'nov	(function eword-decode-and-unfold-structured-field-body))))
 
 ;; unstructured fields (default)
 (mime-set-field-decoder
@@ -430,18 +401,17 @@ Non MIME encoded-word part in FILED-BODY is decoded with
 `default-mime-charset'."
   (let (field-name-symbol len decoder)
     (if (symbolp field-name)
-        (setq field-name-symbol field-name
-              len (1+ (string-width (symbol-name field-name))))
+	(setq field-name-symbol field-name
+	      len (1+ (string-width (symbol-name field-name))))
       (setq field-name-symbol (intern (capitalize field-name))
-            len (1+ (string-width field-name))))
+	    len (1+ (string-width field-name))))
     (setq decoder (mime-find-field-decoder field-name-symbol mode))
     (if decoder
 	(funcall decoder field-body len max-column)
       ;; Don't decode
       (if (eq mode 'summary)
 	  (std11-unfold-string field-body)
-	field-body)
-      )))
+	field-body))))
 
 ;;;###autoload
 (defun mime-decode-header-in-region (start end
@@ -478,11 +448,8 @@ default-mime-charset."
 		  (let ((body (buffer-substring p end))
 			(default-mime-charset default-charset))
 		    (delete-region p end)
-		    (insert (funcall field-decoder body (1+ len)))
-		    ))
-		))
-	  (eword-decode-region (point-min) (point-max) t)
-	  )))))
+		    (insert (funcall field-decoder body (1+ len)))))))
+	  (eword-decode-region (point-min) (point-max) t))))))
 
 ;;;###autoload
 (defun mime-decode-header-in-buffer (&optional code-conversion separator)
@@ -501,8 +468,7 @@ If SEPARATOR is not nil, it is used as header separator."
 	  (concat "^\\(" (regexp-quote (or separator "")) "\\)?$")
 	  nil t)
 	 (match-beginning 0)
-       (point-max)
-       ))
+       (point-max)))
    code-conversion))
 
 (define-obsolete-function-alias 'eword-decode-header
@@ -536,21 +502,16 @@ if there are in decoded encoded-word (generated by bad manner MUA such
 as a version of Net$cape)."
   (or (if (string-match eword-encoded-word-regexp word)
 	  (let ((charset
-		 (substring word (match-beginning 1) (match-end 1))
-		 )
+		 (substring word (match-beginning 1) (match-end 1)))
 		(encoding
 		 (upcase
-		  (substring word (match-beginning 2) (match-end 2))
-		  ))
+		  (substring word (match-beginning 2) (match-end 2))))
 		(text
-		 (substring word (match-beginning 3) (match-end 3))
-		 ))
-            (condition-case err
-                (eword-decode-encoded-text charset encoding text must-unfold)
-              (error
-	       (funcall eword-decode-encoded-word-error-handler word err)
-               ))
-            ))
+		 (substring word (match-beginning 3) (match-end 3))))
+	    (condition-case err
+		(eword-decode-encoded-text charset encoding text must-unfold)
+	      (error
+	       (funcall eword-decode-encoded-word-error-handler word err)))))
       word))
 
 
@@ -579,8 +540,7 @@ as a version of Net$cape)."
 			    (lambda (chr)
 			      (cond ((eq chr ?\n) "")
 				    ((eq chr ?\t) " ")
-				    (t (char-to-string chr)))
-			      ))
+				    (t (char-to-string chr)))))
 			   (std11-unfold-string dest)
 			   "")
 	      dest))))))
@@ -627,8 +587,7 @@ be the result."
 		      (substring string (1+ start) (1- p)))
 		     default-mime-charset))
 	      ;;(substring string p))
-	      p)
-      )))
+	      p))))
 
 (defun eword-analyze-domain-literal (string start &optional must-unfold)
   (std11-analyze-domain-literal string start))
@@ -648,14 +607,12 @@ be the result."
 	  (cond ((eq chr ?\\)
 		 (setq i (1+ i))
 		 (if (>= i len)
-		     (throw 'tag nil)
-		   )
+		     (throw 'tag nil))
 		 (setq last-str (concat last-str
 					(substring string from (1- i))
 					(char-to-string (aref string i)))
 		       i (1+ i)
-		       from i)
-		 )
+		       from i))
 		((eq chr ?\))
 		 (setq ret (concat last-str
 				   (substring string from i)))
@@ -669,10 +626,8 @@ be the result."
 					 (decode-mime-charset-string
 					  ret default-mime-charset)
 					 must-unfold)
-					dest)
-				       )))
-			      (1+ i)))
-		 )
+					dest))))
+			      (1+ i))))
 		((eq chr ?\()
 		 (if (setq ret (eword-analyze-comment string i must-unfold))
 		     (setq last-str
@@ -686,17 +641,13 @@ be the result."
 				     (decode-mime-charset-string
 				      last-str default-mime-charset)
 				     must-unfold)
-				    dest)
-			     )
+				    dest))
 			   i (cdr ret)
 			   from i
 			   last-str "")
-		   (throw 'tag nil)
-		   ))
+		   (throw 'tag nil)))
 		(t
-		 (setq i (1+ i))
-		 ))
-	  )))))
+		 (setq i (1+ i)))))))))
 
 (defun eword-analyze-spaces (string start &optional must-unfold)
   (std11-analyze-spaces string start))
@@ -709,8 +660,7 @@ be the result."
 	   (= (match-beginning 0) start))
       (let ((end (match-end 0))
 	    (dest (eword-decode-encoded-word (match-string 0 string)
-					     must-unfold))
-	    )
+					     must-unfold)))
 	;;(setq string (substring string end))
 	(setq start end)
 	(while (and (string-match (eval-when-compile
@@ -725,11 +675,9 @@ be the result."
 			(eword-decode-encoded-word (match-string 1 string)
 						   must-unfold))
 		;;string (substring string end))
-		start end)
-	  )
+		start end))
 	(cons (cons 'atom dest) ;;string)
-	      end)
-	)))
+	      end))))
 
 (defun eword-analyze-atom (string start &optional must-unfold)
   (if (and (string-match std11-atom-regexp string start)
@@ -739,8 +687,7 @@ be the result."
 			   (substring string start end)
 			   default-mime-charset))
 	      ;;(substring string end)
-	      end)
-	)))
+	      end))))
 
 (defun eword-lexical-analyze-internal (string start must-unfold)
   (let ((len (length string))
@@ -751,17 +698,13 @@ be the result."
 		  func r)
 	      (while (and (setq func (car rest))
 			  (null
-			   (setq r (funcall func string start must-unfold)))
-			  )
+			   (setq r (funcall func string start must-unfold))))
 		(setq rest (cdr rest)))
 	      (or r
-		  (list (cons 'error (substring string start)) (1+ len)))
-	      ))
+		  (list (cons 'error (substring string start)) (1+ len)))))
       (setq dest (cons (car ret) dest)
-	    start (cdr ret))
-      )
-    (nreverse dest)
-    ))
+	    start (cdr ret)))
+    (nreverse dest)))
 
 (defun eword-lexical-analyze (string &optional start must-unfold)
   "Return lexical analyzed list corresponding STRING.
@@ -795,12 +738,9 @@ characters encoded as encoded-words or invalid \"raw\" format.
 				  (if (stringp (car value))
 				      (std11-wrap-as-quoted-pairs
 				       (car value) '(?( ?)))
-				    (eword-decode-token (car value))
-				    ))
-		     value (cdr value))
-	       )
-	     (concat "(" dest ")")
-	     ))
+				    (eword-decode-token (car value))))
+		     value (cdr value)))
+	     (concat "(" dest ")")))
 	  (t value))))
 
 (defun eword-extract-address-components (string &optional start)
@@ -814,11 +754,9 @@ characters are regarded as variable `default-mime-charset'."
 			  (eword-lexical-analyze
 			   (std11-unfold-string string) start
 			   'must-unfold))))
-         (phrase  (std11-full-name-string structure))
-         (address (std11-address-string structure))
-         )
-    (list phrase address)
-    ))
+	 (phrase  (std11-full-name-string structure))
+	 (address (std11-address-string structure)))
+    (list phrase address)))
 
 
 ;;; @ end
diff --git a/luna.el b/luna.el
index f7390b0..3481bad 100644
--- a/luna.el
+++ b/luna.el
@@ -40,31 +40,43 @@
 ;;;
 
 (defmacro luna-find-class (name)
-  "Return the luna-class of the given 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 (type &optional parents slots)
-  "Define TYPE as a luna-class.
-If PARENTS is specified, TYPE inherits PARENTS.
-Each parent must be name of luna-class (symbol).
-If SLOTS is specified, TYPE will be defined to have them."
-  (` (luna-define-class-function '(, type)
+(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))))
 
-(defun luna-define-class-function (type &optional parents 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)
   (static-condition-case nil
       :symbol-for-testing-whether-colon-keyword-is-available-or-not
     (void-variable
@@ -86,17 +98,19 @@ If SLOTS is specified, TYPE will be defined to have them."
 		     (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 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 type (vector 'class oa parents 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)
@@ -111,33 +125,55 @@ If SLOTS is specified, TYPE will be defined to have them."
 				member-name)))))
 	ret)))
 
+
+;; 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 function of a class.
+  "Define NAME as a method of a luna class.
 
 Usage of this macro follows:
 
-  (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...) 
+  (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.
 
-NAME is the name of method.
+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.
 
-Optional argument METHOD-QUALIFIER must be :before, :after or :around.
-If it is :before / :after, the method is called before / after a
-method of parent class is finished.  ARGLIST is like an argument list
-of lambda, but (car ARGLIST) must be specialized parameter.  (car (car
-ARGLIST)) is name of variable and \(nth 1 (car ARGLIST)) is name of
-class.
+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').
 
-Optional argument DOCSTRING is the documentation of method.
+The optional 4th argument DOCSTRING is the documentation of the
+method.  If it is not string, it is treated as BODY.
 
-BODY is the body of method."
+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))
@@ -153,11 +189,12 @@ BODY is the body of method."
 				 (cdr args)))
 		      (,@ definition))))
 	     (sym (luna-class-find-or-make-member
-		   (luna-find-class '(, class)) '(, name))))
+		   (luna-find-class '(, class)) '(, name)))
+	     (cache (get '(, name) 'luna-method-cache)))
+	 (if cache
+	     (unintern '(, class) cache))
 	 (fset sym func)
-	 (put sym 'luna-method-qualifier (, method-qualifier))
-	 ))
-    ))
+	 (put sym 'luna-method-qualifier (, method-qualifier))))))
 
 (put 'luna-define-method 'lisp-indent-function 'defun)
 
@@ -169,6 +206,10 @@ BODY is the body of method."
 	    &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)
@@ -179,6 +220,9 @@ BODY is the body of method."
 			    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)
@@ -229,6 +273,8 @@ BODY is the body of method."
 
 (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
@@ -250,7 +296,9 @@ LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
   (defvar luna-current-method-arguments nil))
 
 (defun luna-call-next-method ()
-  "Call the next method in a method with :around qualifier."
+  "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
@@ -265,13 +313,14 @@ LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
 		    t))))
     luna-previous-return-value))
 
-(defun luna-make-entity (type &rest init-args)
-  "Make instance of luna-class TYPE and return it.
-If INIT-ARGS is specified, it is used as initial values of the slots.
-It must be plist and each slot name must have prefix `:'."
-  (let* ((c (get type 'luna-class))
+(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 type)
+    (luna-set-class-name v class)
     (luna-set-obarray v (make-vector 7 0))
     (apply (function luna-send) v 'initialize-instance v init-args)))
 
@@ -279,6 +328,26 @@ It must be plist and each slot name must have prefix `:'."
 ;;; @ 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
@@ -288,19 +357,28 @@ It must be plist and each slot name must have prefix `:'."
       (setq arglist (cdr arglist)))
     (nreverse dest)))
 
+
 (defmacro luna-define-generic (name args &optional doc)
-  "Define generic-function NAME.
-ARGS is argument of and DOC is DOC-string."
+  "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
-      (` (defun (, (intern (symbol-name name))) (, args)
-	   (, doc)
-	   (luna-send (, (car args)) '(, name)
-		      (,@ (luna-arglist-to-arguments args)))
-	   ))
-    (` (defun (, (intern (symbol-name name))) (, args)
-	 (luna-send (, (car args)) '(, name)
-		    (,@ (luna-arglist-to-arguments args)))
-	 ))))
+      (` (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)
 
@@ -309,7 +387,17 @@ ARGS is argument of and DOC is DOC-string."
 ;;;
 
 (defun luna-define-internal-accessors (class-name)
-  "Define internal accessors for an entity of 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
@@ -322,36 +410,35 @@ ARGS is argument of and DOC is DOC-string."
 		(setq parent-class (luna-find-class (car parents)))
 		(if (luna-class-slot-index parent-class slot)
 		    (throw 'derived nil))
-		(setq parents (cdr parents))
-		)
+		(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))))
-			    ))
+			    (, (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))
-		    )))
-	      ))))
+			    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)
diff --git a/lunit.el b/lunit.el
new file mode 100644
index 0000000..7debb2a
--- /dev/null
+++ b/lunit.el
@@ -0,0 +1,301 @@
+;;; 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 ())
+
+(luna-define-generic lunit-test-listener-error (listener case error)
+  "An error occurred.")
+
+(luna-define-generic lunit-test-listener-failure (listener case failure)
+  "A failure occurred.")
+
+(luna-define-generic lunit-test-listener-start (listener case)
+  "A test started.")
+
+(luna-define-generic lunit-test-listener-end (listener case)
+  "A test ended.")
+
+;;; @ 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-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-run ((result lunit-test-result) case)
+  (let ((listeners (lunit-test-result-listeners-internal result)))
+    (dolist (listener listeners)
+      (lunit-test-listener-start listener 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))))
+    (dolist (listener listeners)
+      (lunit-test-listener-end listener case))))
+
+(luna-define-method lunit-test-result-error ((result lunit-test-result)
+					     case error)
+  (let ((listeners (lunit-test-result-listeners-internal result))
+	(errors (lunit-test-result-errors-internal result)))
+    (if errors
+	(nconc errors (list (cons case error)))
+      (lunit-test-result-set-errors-internal result (list (cons case error))))
+    (dolist (listener listeners)
+      (lunit-test-listener-error listener case error))))
+
+(luna-define-method lunit-test-result-failure ((result lunit-test-result)
+					       case failure)
+  (let ((listeners (lunit-test-result-listeners-internal result))
+	(failures (lunit-test-result-failures-internal result)))
+    (if failures
+	(nconc failures (list (cons case failure)))
+      (lunit-test-result-set-failures-internal result (list (cons case failure))))
+    (dolist (listener listeners)
+      (lunit-test-listener-failure listener case failure))))
+
+(luna-define-method lunit-test-result-add-listener ((result lunit-test-result)
+						    listener)
+  (let ((listeners (lunit-test-result-listeners-internal result)))
+    (if listeners
+	(nconc listeners (list listener))
+      (lunit-test-result-set-listeners-internal result (list listener)))))
+
+;;; @ 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)))
+    (if tests
+	(nconc tests (list test))
+      (lunit-test-suite-set-tests-internal suite (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)))
+    (` (unless (, 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)
+		(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))
+	 failures
+	 errors)
+    (lunit-test-run test result)
+    (setq 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)))))
+
+(provide 'lunit)
+
+;;; lunit.el ends here
diff --git a/tests/test-hmac-md5.el b/tests/test-hmac-md5.el
new file mode 100644
index 0000000..a93a423
--- /dev/null
+++ b/tests/test-hmac-md5.el
@@ -0,0 +1,63 @@
+(require 'lunit)
+(require 'hmac-md5)
+
+(luna-define-class test-hmac-md5 (lunit-test-case))
+
+(luna-define-method test-hmac-md5-1 ((case test-hmac-md5))
+  (lunit-assert
+   (string=
+    (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b)))
+    "9294727a3638bb1c13f48ef8158bfc9d")))
+
+(luna-define-method test-hmac-md5-2 ((case test-hmac-md5))
+  (lunit-assert
+   (string=
+    (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe"))
+    "750c783e6ab0b503eaa86e310a5db738")))
+
+(luna-define-method test-hmac-md5-3 ((case test-hmac-md5))
+  (lunit-assert
+   (string=
+    (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa)))
+    "56be34521d144c88dbb8c733f0e8b3f6")))
+
+(luna-define-method test-hmac-md5-4 ((case test-hmac-md5))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-md5
+      (make-string 50 ?\xcd)
+      (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
+    "697eaf0aca3a3aea3a75164746ffaa79")))
+
+(luna-define-method test-hmac-md5-5 ((case test-hmac-md5))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c)))
+    "56461ef2342edc00f9bab995690efd4c")))
+
+(luna-define-method test-hmac-md5-6 ((case test-hmac-md5))
+  (lunit-assert
+   (string=
+     (encode-hex-string
+      (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c)))
+     "56461ef2342edc00f9bab995")))
+
+(luna-define-method test-hmac-md5-7 ((case test-hmac-md5))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-md5
+      "Test Using Larger Than Block-Size Key - Hash Key First"
+      (make-string 80 ?\xaa)))
+    "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd")))
+
+(luna-define-method test-hmac-md5-8 ((case test-hmac-md5))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-md5
+      "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
+      (make-string 80 ?\xaa)))
+    "6f630fad67cda0ee1fb1f562db3aa53e")))
diff --git a/tests/test-hmac-sha1.el b/tests/test-hmac-sha1.el
new file mode 100644
index 0000000..e329e80
--- /dev/null
+++ b/tests/test-hmac-sha1.el
@@ -0,0 +1,63 @@
+(require 'lunit)
+(require 'hmac-sha1)
+
+(luna-define-class test-hmac-sha1 (lunit-test-case))
+
+(luna-define-method test-hmac-sha1-1 ((case test-hmac-sha1))
+  (lunit-assert
+   (string=
+    (encode-hex-string (hmac-sha1 "Hi There" (make-string 20 ?\x0b)))
+    "b617318655057264e28bc0b6fb378c8ef146be00")))
+
+(luna-define-method test-hmac-sha1-2 ((case test-hmac-sha1))
+  (lunit-assert
+   (string=
+    (encode-hex-string (hmac-sha1 "what do ya want for nothing?" "Jefe"))
+    "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79")))
+
+(luna-define-method test-hmac-sha1-3 ((case test-hmac-sha1))
+  (lunit-assert
+   (string=
+    (encode-hex-string (hmac-sha1 (make-string 50 ?\xdd) (make-string 20 ?\xaa)))
+    "125d7342b9ac11cd91a39af48aa17b4f63f175d3")))
+
+(luna-define-method test-hmac-sha1-4 ((case test-hmac-sha1))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-sha1
+      (make-string 50 ?\xcd)
+      (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
+    "4c9007f4026250c6bc8414f9bf50c86c2d7235da")))
+
+(luna-define-method test-hmac-sha1-5 ((case test-hmac-sha1))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-sha1 "Test With Truncation" (make-string 20 ?\x0c)))
+    "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04")))
+
+(luna-define-method test-hmac-sha1-6 ((case test-hmac-sha1))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-sha1-96 "Test With Truncation" (make-string 20 ?\x0c)))
+    "4c1a03424b55e07fe7f27be1")))
+
+(luna-define-method test-hmac-sha1-7 ((case test-hmac-sha1))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-sha1
+      "Test Using Larger Than Block-Size Key - Hash Key First"
+      (make-string 80 ?\xaa)))
+    "aa4ae5e15272d00e95705637ce8a3b55ed402112")))
+
+(luna-define-method test-hmac-sha1-8 ((case test-hmac-sha1))
+  (lunit-assert
+   (string=
+    (encode-hex-string
+     (hmac-sha1
+      "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
+      (make-string 80 ?\xaa)))
+    "e8e99d0f45237d786d6bbaa7965c7808bbff1a91")))
diff --git a/tests/test-sasl.el b/tests/test-sasl.el
new file mode 100644
index 0000000..07bcaa1
--- /dev/null
+++ b/tests/test-sasl.el
@@ -0,0 +1,60 @@
+(require 'lunit)
+(require 'sasl)
+
+(luna-define-class test-sasl (lunit-test-case))
+
+(luna-define-method test-sasl-find-mechanism ((case test-sasl))
+  (let ((mechanisms sasl-mechanisms))
+    (while mechanisms
+      (let* ((sasl-mechanisms (list (car mechanisms))))
+	(lunit-assert
+	 (sasl-find-mechanism (list (car mechanisms)))))
+      (setq mechanisms (cdr mechanisms)))))
+
+(luna-define-method test-sasl-digest-md5-imap ((case test-sasl))
+  (let* ((sasl-mechanisms '("DIGEST-MD5"))
+	 (mechanism
+	  (sasl-find-mechanism '("DIGEST-MD5")))
+	 (client
+	  (sasl-make-client mechanism "chris" "imap" "elwood.innosoft.com"))
+	 (sasl-read-passphrase
+	  #'(lambda (prompt)
+	      "secret"))
+	 step
+	 response)
+    (sasl-client-set-property client 'realm "elwood.innosoft.com")
+    (sasl-client-set-property client 'cnonce "OA6MHXh6VqTrRk")
+    (setq step (sasl-next-step client nil))
+    (sasl-step-set-data
+     step "realm=\"elwood.innosoft.com\",nonce=\"OA6MG9tEQGm2hh\",\
+qop=\"auth\",algorithm=md5-sess,charset=utf-8")
+    (setq step (sasl-next-step client step))
+    (sasl-step-data step)
+    (setq response (sasl-digest-md5-parse-string (sasl-step-data step)))
+    (lunit-assert
+     (string=
+      (plist-get response 'response) "d388dad90d4bbd760a152321f2143af7"))))
+
+(luna-define-method test-sasl-digest-md5-acap ((case test-sasl))
+  (let* ((sasl-mechanisms '("DIGEST-MD5"))
+	 (mechanism
+	  (sasl-find-mechanism '("DIGEST-MD5")))
+	 (client
+	  (sasl-make-client mechanism "chris" "acap" "elwood.innosoft.com"))
+	 (sasl-read-passphrase
+	  #'(lambda (prompt)
+	      "secret"))
+	 step
+	 response)
+    (sasl-client-set-property client 'realm "elwood.innosoft.com")
+    (sasl-client-set-property client 'cnonce "OA9BSuZWMSpW8m")
+    (setq step (sasl-next-step client nil))
+    (sasl-step-set-data
+     step "realm=\"elwood.innosoft.com\",nonce=\"OA9BSXrbuRhWay\",qop=\"auth\",\
+algorithm=md5-sess,charset=utf-8")
+    (setq step (sasl-next-step client step))
+    (sasl-step-data step)
+    (setq response (sasl-digest-md5-parse-string (sasl-step-data step)))
+    (lunit-assert
+     (string=
+      (plist-get response 'response) "6084c6db3fede7352c551284490fd0fc"))))