+2000-12-12 Daiki Ueno <ueno@unixuser.org>
+
+ * sasl.el: Rewrite with luna.
+
+2000-12-06 Daiki Ueno <ueno@unixuser.org>
+
+ * FLIM-ELS: Don't install md5-dl.el, md5-el.el, sha1-dl.el and
+ sha1-el.el if the running emacs has builtin message digest
+ functions.
+
+ * md5-dl.el, sha1-dl.el: Don't bind `dynamic-link' and
+ `dynamic-call'.
+
+ * md5.el (md5-dl-module): Moved from md5-dl.el.
+ * sha1.el: Don't bind `sha1-string'.
+
+2000-12-04 Daiki Ueno <ueno@unixuser.org>
+
+ * README.ja, README.en (load-path): Remove section.
+ (What's FLIM): Specify prerequisite version of Emacsen.
+
+2000-11-21 Daiki Ueno <ueno@unixuser.org>
+
+ * sasl.el (sasl-client-set-encoder): New function.
+ (sasl-client-set-decoder): New function.
+ (sasl-client-encoder): New function.
+ (sasl-client-decoder): New function.
+
+ * sasl-digest.el: Require 'cl' when compiling.
+ (sasl-digest-md5-signing-encode-magic): New constant.
+ (sasl-digest-md5-signing-decode-magic): New constant.
+ (sasl-digest-md5-htonl-string): New function.
+ (sasl-digest-md5-make-integrity-encoder): New function.
+ (sasl-digest-md5-make-integrity-decoder): New function.
+ (sasl-digest-md5-ha1): New function.
+ (sasl-digest-md5-response-value): Accept the 1st argument `ha1'.
+ (sasl-digest-md5-response): Use `sasl-digest-md5-ha1'.
+ - Set integrity encoder and decoder of the client.
+
+ * smtp.el: Require `luna'.
+ (smtp-read-response): Accept `smtp-connection' object rather than
+ process-object.
+ (smtp-send-command): Likewise.
+ (smtp-send-data): Likewise.
+
+2000-11-10 Daiki Ueno <ueno@unixuser.org>
+
+ * tests/test-sasl.el (test-sasl-digest-md5-imap): New testcase.
+ (test-sasl-digest-md5-acap): New testcase.
+
+2000-11-10 Daiki Ueno <ueno@unixuser.org>
+
+ * lunit.el (lunit-make-test-suite-from-class): New function.
+ (lunit-class): Abolish.
+ (lunit-test-results-buffer): Abolish.
+
+ * FLIM-ELS (check-flim): New function.
+
+ * Makefile (check): New target.
+
+ * tests: New directory.
+
+2000-11-09 Daiki Ueno <ueno@unixuser.org>
+
+ * lunit.el (lunit-test-method-regexp): New variable.
+ (lunit-class): New function.
+
+2000-11-09 Daiki Ueno <ueno@unixuser.org>
+
+ * lunit.el: New file.
+
2000-12-13 Kenichi Handa <handa@etl.go.jp>
* luna.el: Fix and add DOCs and comments; fix coding style.
(sasl-digest-md5-syntax-table): Rename from
`sasl-digest-md5-parse-digest-challenge-syntax-table'.
(sasl-digest-md5-parse-string): Rename from
- `sasl-digest-md5-parse-digest-challenge'; only return a property list.
+ `sasl-digest-md5-parse-digest-challenge'; only return a property
+ list.
(sasl-digest-md5-challenge): Abolish.
(sasl-digest-md5-build-response-value-1): Abolish.
(sasl-digest-md5-response-value): Define as function.
2000-10-31 Daiki Ueno <ueno@unixuser.org>
- * smtp.el: New implementation; don't use `tram.el' and `luna.el'.
+ * smtp.el: New implementation.
+
+2000-08-16 Daiki Ueno <ueno@unixuser.org>
+
+ * FLIM-ELS (flim-modules): Add `qmtp'.
+
+ * qmtp.el: New file.
2000-08-28 Yuuichi Teranishi <teranisi@gohome.org>
(progn
(add-to-list 'default-load-path LISPDIR)
(add-to-list 'load-path LISPDIR)
- (add-to-list 'load-path (expand-file-name "apel" LISPDIR))
- ))
+ (add-to-list 'load-path (expand-file-name "apel" LISPDIR))))
(if (boundp 'VERSION_SPECIFIC_LISPDIR)
(add-to-list 'load-path VERSION_SPECIFIC_LISPDIR))
;;; Code:
(setq flim-modules '(std11
- luna mime-def
+ luna lunit mime-def
mel mel-q mel-u mel-g
eword-decode eword-encode
mime mime-parse mmgeneric
(setq flim-version-specific-modules '(mailcap))
(setq hmac-modules '(hex-util
- hmac-def
- md5 md5-el md5-dl
- sha1 sha1-el sha1-dl
+ hmac-def md5 sha1
hmac-md5 hmac-sha1))
-(setq flim-modules (nconc hmac-modules flim-modules))
-
(if (and (fboundp 'base64-encode-string)
(subrp (symbol-function 'base64-encode-string)))
nil
(unless-broken ccl-usable
(setq flim-modules (cons 'mel-b-ccl (cons 'mel-q-ccl flim-modules))))
+(if (and (fboundp 'md5)
+ (subrp (symbol-function 'md5)))
+ nil
+ (if (fboundp 'dynamic-link)
+ (setq hmac-modules (cons 'md5-dl hmac-modules))
+ (setq hmac-modules (cons 'md5-el hmac-modules))))
+
+(if (fboundp 'dynamic-link)
+ (setq hmac-modules (cons 'sha1-dl hmac-modules))
+ (setq hmac-modules (cons 'sha1-el hmac-modules)))
+
+(setq flim-modules (nconc hmac-modules flim-modules))
+
;;; FLIM-ELS ends here
(let (prefix lisp-dir version-specific-lisp-dir)
(and (setq prefix (car command-line-args-left))
(or (string-equal "NONE" prefix)
- (defvar PREFIX prefix)
- ))
+ (defvar PREFIX prefix)))
(setq command-line-args-left (cdr command-line-args-left))
(and (setq lisp-dir (car command-line-args-left))
(or (string-equal "NONE" lisp-dir)
- (defvar LISPDIR lisp-dir)
- ))
+ (defvar LISPDIR lisp-dir)))
(setq command-line-args-left (cdr command-line-args-left))
(and (setq version-specific-lisp-dir (car command-line-args-left))
(or (string-equal "NONE" version-specific-lisp-dir)
(progn
(defvar VERSION_SPECIFIC_LISPDIR version-specific-lisp-dir)
(princ (format "VERSION_SPECIFIC_LISPDIR=%s\n"
- VERSION_SPECIFIC_LISPDIR)))
- ))
+ VERSION_SPECIFIC_LISPDIR)))))
(setq command-line-args-left (cdr command-line-args-left))
(load-file "FLIM-CFG")
(load-file "FLIM-ELS")
(princ (format "PREFIX=%s
-LISPDIR=%s\n" PREFIX LISPDIR))
- ))
+LISPDIR=%s\n" PREFIX LISPDIR))))
(defun compile-flim ()
(config-flim)
(compile-elisp-modules flim-version-specific-modules ".")
- (compile-elisp-modules flim-modules ".")
- )
+ (compile-elisp-modules flim-modules "."))
(defun install-flim ()
(config-flim)
(install-elisp-modules flim-version-specific-modules "./"
FLIM_VERSION_SPECIFIC_DIR)
- (install-elisp-modules flim-modules "./" FLIM_DIR)
- )
+ (install-elisp-modules flim-modules "./" FLIM_DIR))
+
+(defun check-flim ()
+ (config-flim)
+ (require 'lunit)
+ (let ((files (directory-files "tests" t))
+ (suite (lunit-make-test-suite)))
+ (while files
+ (if (file-regular-p (car files))
+ (progn
+ (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)))
(defun config-flim-package ()
(let (package-dir)
(and (setq package-dir (car command-line-args-left))
(or (string= "NONE" package-dir)
- (defvar PACKAGEDIR package-dir)
- ))
+ (defvar PACKAGEDIR package-dir)))
(setq command-line-args-left (cdr command-line-args-left))
(load-file "FLIM-CFG")
(load-file "FLIM-ELS")
(setq flim-modules (append flim-modules
'(auto-autoloads custom-load)))
- (princ (format "PACKAGEDIR=%s\n" PACKAGEDIR))
- ))
+ (princ (format "PACKAGEDIR=%s\n" PACKAGEDIR))))
(defun compile-flim-package ()
(config-flim-package)
(Custom-make-dependencies)
(compile-elisp-modules flim-version-specific-modules ".")
- (compile-elisp-modules flim-modules ".")
- )
+ (compile-elisp-modules flim-modules "."))
(defun install-flim-package ()
(config-flim-package)
(expand-file-name "lisp"
PACKAGEDIR)))
(delete-file "./auto-autoloads.el")
- (delete-file "./custom-load.el")
- )
+ (delete-file "./custom-load.el"))
;;; FLIM-MK ends here
$(EMACS) $(FLAGS) -f compile-flim $(PREFIX) $(LISPDIR) \
$(VERSION_SPECIFIC_LISPDIR)
+check:
+ $(EMACS) $(FLAGS) -f check-flim $(PREFIX) $(LISPDIR) \
+ $(VERSION_SPECIFIC_LISPDIR)
+
install: elc
$(EMACS) $(FLAGS) -f install-flim $(PREFIX) $(LISPDIR) \
$(VERSION_SPECIFIC_LISPDIR)
mailcap.el --- mailcap parser and utility
+ This library should work on:
+
+ Emacs 20.4 and up
+ XEmacs 21.1 and up
+
Installation
============
Notice that XEmacs package system requires XEmacs 21.0 or later.
-load-path (for Emacs or MULE)
-=============================
-
- If you are using Emacs or Mule, please add directory of FLIM to
- load-path. If you install by default setting, you can write
- subdirs.el for example:
-
- --------------------------------------------------------------------
- (normal-top-level-add-to-load-path '("apel" "flim"))
- --------------------------------------------------------------------
-
- If you are using XEmacs, there are no need of setting about
- load-path.
-
-
Bug reports
===========
mailcap.el --- mailcap \e$B$N2r@O=hM}Ey\e(B
+ \e$B0J2<$N4D6-$GF0:n$7$^$9!'\e(B
+
+ Emacs 20.4 \e$B0J9_\e(B
+ XEmacs 21.1 \e$B0J9_\e(B
+
\e$BF3F~\e(B (install)
==============
`PREFIX=...' \e$B$,>JN,$5$l$k$H!";XDj$5$l$?\e(B emacs \e$B%3%^%s%I$N%G%#%l%/%H%j!<\e(B
\e$BLZ$N@\F,<-$,;HMQ$5$l$^$9\e(B (\e$B$*$=$i$/\e(B /usr/local \e$B$G$9\e(B)\e$B!#\e(B
- \e$BNc$($P!"\e(BPREFIX=/usr/local \e$B$H\e(B Emacs 19.34 \e$B$,;XDj$5$l$l$P!"0J2<$N%G%#%l\e(B
+ \e$BNc$($P!"\e(BPREFIX=/usr/local \e$B$H\e(B Emacs 20.7 \e$B$,;XDj$5$l$l$P!"0J2<$N%G%#%l\e(B
\e$B%/%H%j!<LZ$,:n@.$5$l$^$9!#\e(B
/usr/local/share/emacs/site-lisp/flim/ --- FLIM
+ /usr/local/share/emacs/20.7/site-lisp/flim/ --- FLIM
Emacs Lisp \e$B%W%m%0%i%`$N$?$a$N\e(B lisp \e$B%G%#%l%/%H%j!<$r;XDj$9$k$3$H$,$G\e(B
\e$B$-$^$9!#Nc$($P!"\e(B:
\e$B$G$9!#\e(B
-load-path (Emacs \e$B$H\e(B MULE \e$BMQ\e(B)
-=============================
-
- Emacs \e$B$+\e(B Mule \e$B$r;H$C$F$$$k$J$i!"\e(BFLIM \e$B$N%G%#%l%/%H%j!<$r\e(B load-path \e$B$K\e(B
- \e$BDI2C$7$F$/$@$5$$!#=i4|@_Dj$N$^$^F3F~$7$?$J$i!"<!$N$h$&$K\e(B subdirs.el
- \e$B$r=q$/$3$H$,$G$-$^$9!#Nc\e(B:
-
- --------------------------------------------------------------------
- (normal-top-level-add-to-load-path '("apel" "flim"))
- --------------------------------------------------------------------
-
- XEmacs \e$B$r;H$C$F$$$k$J$i!"\e(Bload-path \e$B$r@_Dj$9$kI,MW$O$"$j$^$;$s!#\e(B
-
-
\e$B%P%0Js9p\e(B
========
--- /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
(require 'pcustom)
(require 'mail-utils) ; mail-strip-quoted-names
(require 'sasl)
+(require 'luna)
(defgroup smtp nil
"SMTP protocol for sending mail."
(defvar smtp-submit-package-function #'smtp-submit-package)
-;;; @ SMTP package structure
+;;; @ SMTP package
;;; A package contains a mail message, an envelope sender address,
;;; and one or more envelope recipient addresses. In ESMTP model
;;; the current sending package should be guaranteed to be accessible
;;; anywhere from the hook methods (or SMTP commands).
-(defmacro smtp-package-sender (package)
- "Return the sender of PACKAGE, a string."
- `(aref ,package 0))
-
-(defmacro smtp-package-recipients (package)
- "Return the recipients of PACKAGE, a list of strings."
- `(aref ,package 1))
+(eval-and-compile
+ (luna-define-class smtp-package ()
+ (sender
+ recipients
+ buffer))
-(defmacro smtp-package-buffer (package)
- "Return the data of PACKAGE, a buffer."
- `(aref ,package 2))
+ (luna-define-internal-accessors 'smtp-package))
-(defmacro smtp-make-package (sender recipients buffer)
+(defun smtp-make-package (sender recipients buffer)
"Create a new package structure.
A package is a unit of SMTP message
SENDER specifies the package sender, a string.
RECIPIENTS is a list of recipients.
BUFFER may be a buffer or a buffer name which contains mail message."
- `(vector ,sender ,recipients ,buffer))
+ (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer))
-(defun smtp-package-buffer-size (package)
+(defun smtp-package-buffer-internal-size (package)
"Return the size of PACKAGE, an integer."
(save-excursion
- (set-buffer (smtp-package-buffer package))
+ (set-buffer (smtp-package-buffer-internal package))
(let ((size
(+ (buffer-size)
;; Add one byte for each change-of-line
(setq size (1+ size)))
size)))
-;;; @ SMTP connection structure
+;;; @ SMTP connection
;;; We should consider the function `open-network-stream' is a emulation
;;; for another network stream. They are likely to be implemented with an
;;; external program and the function `process-contact' returns the
;;; process id instead of `(HOST SERVICE)' pair.
-(defmacro smtp-connection-process (connection)
- "Return the subprocess-object of CONNECTION."
- `(aref ,connection 0))
-
-(defmacro smtp-connection-server (connection)
- "Return the server of CONNECTION, a string."
- `(aref ,connection 1))
-
-(defmacro smtp-connection-service (connection)
- "Return the service of CONNECTION, a string or an integer."
- `(aref ,connection 2))
-
-(defmacro smtp-connection-extensions (connection)
- "Return the SMTP extensions of CONNECTION, a list of strings."
- `(aref ,connection 3))
+(eval-and-compile
+ (luna-define-class smtp-connection ()
+ (process
+ server
+ service
+ extensions
+ encoder
+ decoder))
-(defmacro smtp-connection-set-extensions (connection extensions)
- "Set the SMTP extensions of CONNECTION.
-EXTENSIONS is a list of cons cells of the form \(EXTENSION . PARAMETERS).
-Where EXTENSION is a symbol and PARAMETERS is a list of strings."
- `(aset ,connection 3 ,extensions))
+ (luna-define-internal-accessors 'smtp-connection))
-(defmacro smtp-make-connection (process server service)
+(defun smtp-make-connection (process server service)
"Create a new connection structure.
PROCESS is an internal subprocess-object. SERVER is name of the host
to connect to. SERVICE is name of the service desired."
- `(vector ,process ,server ,service nil))
+ (luna-make-entity 'smtp-connection :process process :server server :service service))
-(defun smtp-connection-opened (connection)
- "Say whether the CONNECTION to server has been opened."
- (let ((process (smtp-connection-process connection)))
+(luna-define-generic smtp-connection-opened (connection)
+ "Say whether the CONNECTION to server has been opened.")
+
+(luna-define-generic smtp-close-connection (connection)
+ "Close the CONNECTION to server.")
+
+(luna-define-method smtp-connection-opened ((connection smtp-connection))
+ (let ((process (smtp-connection-process-internal connection)))
(if (memq (process-status process) '(open run))
t)))
-(defun smtp-close-connection (connection)
- "Close the CONNECTION to server."
- (let ((process (smtp-connection-process connection)))
+(luna-define-method smtp-close-connection ((connection smtp-connection))
+ (let ((process (smtp-connection-process-internal connection)))
(delete-process process)))
(defun smtp-make-fqdn ()
(let* ((connection
(smtp-find-connection (current-buffer)))
(response
- (smtp-read-response
- (smtp-connection-process connection))))
+ (smtp-read-response connection)))
(if (/= (car response) 220)
(smtp-response-error response))))
(defun smtp-primitive-ehlo (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
- (smtp-send-command process (format "EHLO %s" (smtp-make-fqdn)))
- (setq response (smtp-read-response process))
+ (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
+ (setq response (smtp-read-response connection))
(if (/= (car response) 250)
(smtp-response-error response))
- (smtp-connection-set-extensions
+ (smtp-connection-set-extensions-internal
connection (mapcar
(lambda (extension)
(let ((extensions
(defun smtp-primitive-helo (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
- (smtp-send-command process (format "HELO %s" (smtp-make-fqdn)))
- (setq response (smtp-read-response process))
+ (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
+ (setq response (smtp-read-response connection))
(if (/= (car response) 250)
(smtp-response-error response))))
(defun smtp-primitive-auth (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
(mechanisms
- (cdr (assq 'auth (smtp-connection-extensions connection))))
+ (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
(sasl-mechanisms
(or smtp-sasl-mechanisms sasl-mechanisms))
(mechanism
(unless mechanism
(error "No authentication mechanism available"))
(setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
- (smtp-connection-server connection)))
+ (smtp-connection-server-internal connection)))
(if smtp-sasl-properties
(sasl-client-set-properties client smtp-sasl-properties))
(setq name (sasl-mechanism-name mechanism)
;; Retrieve the initial response
step (sasl-next-step client nil))
(smtp-send-command
- process
+ connection
(if (sasl-step-data step)
(format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
(format "AUTH %s" name)))
(catch 'done
(while t
- (setq response (smtp-read-response process))
+ (setq response (smtp-read-response connection))
(when (= (car response) 235)
;; The authentication process is finished.
(setq step (sasl-next-step client step))
(sasl-step-set-data step (base64-decode-string (nth 1 response)))
(setq step (sasl-next-step client step))
(smtp-send-command
- process (if (sasl-step-data step)
- (base64-encode-string (sasl-step-data step) t)
- ""))))))
+ connection
+ (if (sasl-step-data step)
+ (base64-encode-string (sasl-step-data step) t)
+ ""))))
+;;; (smtp-connection-set-encoder-internal
+;;; connection (sasl-client-encoder client))
+;;; (smtp-connection-set-decoder-internal
+;;; connection (sasl-client-decoder client))
+ ))
(defun smtp-primitive-starttls (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
;; STARTTLS --- begin a TLS negotiation (RFC 2595)
- (smtp-send-command process "STARTTLS")
- (setq response (smtp-read-response process))
+ (smtp-send-command connection "STARTTLS")
+ (setq response (smtp-read-response connection))
(if (/= (car response) 220)
(smtp-response-error response))
- (starttls-negotiate process)))
+ (starttls-negotiate (smtp-connection-process-internal connection))))
(defun smtp-primitive-mailfrom (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
(extensions
- (smtp-connection-extensions
+ (smtp-connection-extensions-internal
connection))
(sender
- (smtp-package-sender package))
+ (smtp-package-sender-internal package))
extension
response)
;; SIZE --- Message Size Declaration (RFC1870)
(if (and smtp-use-size
(assq 'size extensions))
- (setq extension (format "SIZE=%d" (smtp-package-buffer-size package))))
+ (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
(if (and smtp-use-8bitmime
(assq '8bitmime extensions))
(setq extension (concat extension " BODY=8BITMIME")))
(smtp-send-command
- process
+ connection
(if extension
(format "MAIL FROM:<%s> %s" sender extension)
(format "MAIL FROM:<%s>" sender)))
- (setq response (smtp-read-response process))
+ (setq response (smtp-read-response connection))
(if (/= (car response) 250)
(smtp-response-error response))))
(defun smtp-primitive-rcptto (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
(recipients
- (smtp-package-recipients package))
+ (smtp-package-recipients-internal package))
response)
(while recipients
(smtp-send-command
- process (format "RCPT TO:<%s>" (pop recipients)))
- (setq response (smtp-read-response process))
+ connection (format "RCPT TO:<%s>" (pop recipients)))
+ (setq response (smtp-read-response connection))
(unless (memq (car response) '(250 251))
(smtp-response-error response)))))
(defun smtp-primitive-data (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
- (smtp-send-command process "DATA")
- (setq response (smtp-read-response process))
+ (smtp-send-command connection "DATA")
+ (setq response (smtp-read-response connection))
(if (/= (car response) 354)
(smtp-response-error response))
(save-excursion
- (set-buffer (smtp-package-buffer package))
+ (set-buffer (smtp-package-buffer-internal package))
(goto-char (point-min))
(while (not (eobp))
(smtp-send-data
- process (buffer-substring (point) (progn (end-of-line)(point))))
+ connection (buffer-substring (point) (progn (end-of-line)(point))))
(beginning-of-line 2)))
- (smtp-send-command process ".")
- (setq response (smtp-read-response process))
+ (smtp-send-command connection ".")
+ (setq response (smtp-read-response connection))
(if (/= (car response) 250)
(smtp-response-error response))))
(defun smtp-primitive-quit (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
- (smtp-send-command process "QUIT")
- (setq response (smtp-read-response process))
+ (smtp-send-command connection "QUIT")
+ (setq response (smtp-read-response connection))
(if (/= (car response) 221)
(smtp-response-error response))))
(defun smtp-response-error (response)
(signal 'smtp-response-error response))
-(defun smtp-read-response (process)
- (let ((response-continue t)
+(defun smtp-read-response (connection)
+ (let ((decoder
+ (smtp-connection-decoder-internal connection))
+ (response-continue t)
response)
(while response-continue
(goto-char smtp-read-point)
(while (not (search-forward "\r\n" nil t))
- (accept-process-output process)
+ (accept-process-output (smtp-connection-process-internal connection))
(goto-char smtp-read-point))
+ (if decoder
+ (let ((string (buffer-substring smtp-read-point (- (point) 2))))
+ (delete-region smtp-read-point (point))
+ (insert (funcall decoder string) "\r\n")))
(setq response
(nconc response
(list (buffer-substring
response-continue nil)))
response))
-(defun smtp-send-command (process command)
+(defun smtp-send-command (connection command)
(save-excursion
- (set-buffer (process-buffer process))
- (goto-char (point-max))
- (insert command "\r\n")
- (setq smtp-read-point (point))
- (process-send-string process command)
- (process-send-string process "\r\n")))
-
-(defun smtp-send-data (process data)
- ;; Escape "." at start of a line.
- (if (eq (string-to-char data) ?.)
- (process-send-string process "."))
- (process-send-string process data)
- (process-send-string process "\r\n"))
+ (let ((process
+ (smtp-connection-process-internal connection))
+ (encoder
+ (smtp-connection-encoder-internal connection)))
+ (set-buffer (process-buffer process))
+ (goto-char (point-max))
+ (setq command (concat command "\r\n"))
+ (insert command)
+ (setq smtp-read-point (point))
+ (if encoder
+ (setq command (funcall encoder command)))
+ (process-send-string process command))))
+
+(defun smtp-send-data (connection data)
+ (let ((process
+ (smtp-connection-process-internal connection))
+ (encoder
+ (smtp-connection-encoder-internal connection)))
+ ;; Escape "." at start of a line.
+ (if (eq (string-to-char data) ?.)
+ (setq data (concat "." data "\r\n"))
+ (setq data (concat data "\r\n")))
+ (if encoder
+ (setq data (funcall encoder data)))
+ (process-send-string process data)))
(defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
"Get address list suitable for smtp RCPT TO:<address>."
--- /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