"\\("
eword-encoded-text-regexp
"\\)"
- (regexp-quote "?="))))
- )
+ (regexp-quote "?=")))))
;;; @ for string
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
(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
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))))
(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
(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)
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.
(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)
(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
;; 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))
'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
`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
(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)
(concat "^\\(" (regexp-quote (or separator "")) "\\)?$")
nil t)
(match-beginning 0)
- (point-max)
- ))
+ (point-max)))
code-conversion))
(define-obsolete-function-alias 'eword-decode-header
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))
(lambda (chr)
(cond ((eq chr ?\n) "")
((eq chr ?\t) " ")
- (t (char-to-string chr)))
- ))
+ (t (char-to-string chr)))))
(std11-unfold-string dest)
"")
dest))))))
(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))
(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)))
(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
(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))
(= (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
(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)
(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))
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.
(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)
(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
;;;
(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
(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)
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))
(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)
&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)
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)
(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
(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
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)))
;;; @ 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
(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)
;;;
(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
(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)
--- /dev/null
+;;; 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
--- /dev/null
+(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")))
--- /dev/null
+(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")))
--- /dev/null
+(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"))))
projects / elisp / flim.git / commitdiff