From: tomo Date: Thu, 14 Dec 2000 06:01:32 +0000 (+0000) Subject: Sync with deisui-1_14_0-2000-12-14. X-Git-Tag: flim-1_14_0-pre5~22 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=48f7f1e2c900582d0243f1087101308166bb23be;p=elisp%2Fflim.git Sync with deisui-1_14_0-2000-12-14. --- diff --git a/ChangeLog b/ChangeLog index 90c5237..b81970a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,74 @@ +2000-12-12 Daiki Ueno + + * sasl.el: Rewrite with luna. + +2000-12-06 Daiki Ueno + + * 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 + + * README.ja, README.en (load-path): Remove section. + (What's FLIM): Specify prerequisite version of Emacsen. + +2000-11-21 Daiki Ueno + + * 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 + + * tests/test-sasl.el (test-sasl-digest-md5-imap): New testcase. + (test-sasl-digest-md5-acap): New testcase. + +2000-11-10 Daiki Ueno + + * 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 + + * lunit.el (lunit-test-method-regexp): New variable. + (lunit-class): New function. + +2000-11-09 Daiki Ueno + + * lunit.el: New file. + 2000-12-13 Kenichi Handa * luna.el: Fix and add DOCs and comments; fix coding style. @@ -75,7 +146,8 @@ (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. @@ -236,7 +308,13 @@ 2000-10-31 Daiki Ueno - * smtp.el: New implementation; don't use `tram.el' and `luna.el'. + * smtp.el: New implementation. + +2000-08-16 Daiki Ueno + + * FLIM-ELS (flim-modules): Add `qmtp'. + + * qmtp.el: New file. 2000-08-28 Yuuichi Teranishi diff --git a/FLIM-CFG b/FLIM-CFG index 965c7b8..8a314fd 100644 --- a/FLIM-CFG +++ b/FLIM-CFG @@ -13,8 +13,7 @@ (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)) diff --git a/FLIM-ELS b/FLIM-ELS index abc3ce7..679aba5 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -5,7 +5,7 @@ ;;; 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 @@ -17,13 +17,9 @@ (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 @@ -35,4 +31,17 @@ (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 diff --git a/FLIM-MK b/FLIM-MK index 5038f50..701ff61 100644 --- a/FLIM-MK +++ b/FLIM-MK @@ -8,54 +8,62 @@ (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) @@ -68,8 +76,7 @@ LISPDIR=%s\n" PREFIX LISPDIR)) (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) @@ -80,7 +87,6 @@ LISPDIR=%s\n" PREFIX LISPDIR)) (expand-file-name "lisp" PACKAGEDIR))) (delete-file "./auto-autoloads.el") - (delete-file "./custom-load.el") - ) + (delete-file "./custom-load.el")) ;;; FLIM-MK ends here diff --git a/Makefile b/Makefile index 2e2759f..4c1e8b4 100644 --- a/Makefile +++ b/Makefile @@ -33,6 +33,10 @@ elc: $(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) diff --git a/README.en b/README.en index 8ded084..da9875d 100644 --- a/README.en +++ b/README.en @@ -35,6 +35,11 @@ What's FLIM mailcap.el --- mailcap parser and utility + This library should work on: + + Emacs 20.4 and up + XEmacs 21.1 and up + Installation ============ @@ -127,21 +132,6 @@ 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 =========== diff --git a/README.ja b/README.ja index 5327de3..b9592ba 100644 --- a/README.ja +++ b/README.ja @@ -33,6 +33,11 @@ FLIM とは？ mailcap.el --- mailcap の解析処理等 + 以下の環境で動作します： + + Emacs 20.4 以降 + XEmacs 21.1 以降 + 導入 (install) ============== @@ -78,10 +83,11 @@ FLIM とは？ `PREFIX=...' が省略されると、指定された emacs コマンドのディレクトリー 木の接頭辞が使用されます (おそらく /usr/local です)。 - 例えば、PREFIX=/usr/local と Emacs 19.34 が指定されれば、以下のディレ + 例えば、PREFIX=/usr/local と Emacs 20.7 が指定されれば、以下のディレ クトリー木が作成されます。 /usr/local/share/emacs/site-lisp/flim/ --- FLIM + /usr/local/share/emacs/20.7/site-lisp/flim/ --- FLIM Emacs Lisp プログラムのための lisp ディレクトリーを指定することがで きます。例えば、: @@ -134,20 +140,6 @@ FLIM とは？ です。 -load-path (Emacs と MULE 用) -============================= - - Emacs か Mule を使っているなら、FLIM のディレクトリーを load-path に - 追加してください。初期設定のまま導入したなら、次のように subdirs.el - を書くことができます。例: - - -------------------------------------------------------------------- - (normal-top-level-add-to-load-path '("apel" "flim")) - -------------------------------------------------------------------- - - XEmacs を使っているなら、load-path を設定する必要はありません。 - - バグ報告 ======== diff --git a/lunit.el b/lunit.el new file mode 100644 index 0000000..8f5c6e7 --- /dev/null +++ b/lunit.el @@ -0,0 +1,301 @@ +;;; lunit.el --- simple testing framework for luna + +;; Copyright (C) 2000 Daiki Ueno. + +;; Author: Daiki Ueno +;; Keywords: OOP, XP + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module is inspired by "JUnit A Cook's Tour". +;; + +;; (require 'lunit) +;; +;; (luna-define-class silly-test-case (lunit-test-case)) +;; +;; (luna-define-method test-1 ((case silly-test-case)) +;; (lunit-assert (integerp "a"))) +;; +;; (luna-define-method test-2 ((case silly-test-case)) +;; (lunit-assert (stringp "b"))) +;; +;; (with-output-to-temp-buffer "*Lunit Results*" +;; (lunit (lunit-make-test-suite-from-class 'silly-test-case))) +;; ______________________________________________________________________ +;; Starting test `silly-test-case#test-1' +;; failure: (integerp "a") +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +;; ______________________________________________________________________ +;; Starting test `silly-test-case#test-2' +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +;; 2 runs, 1 failures, 0 errors + +;;; Code: + +(require 'luna) + +(eval-when-compile (require 'cl)) + +;;; @ test +;;; + +(eval-and-compile + (luna-define-class lunit-test () + (name)) + + (luna-define-internal-accessors 'lunit-test)) + +(luna-define-generic lunit-test-number-of-tests (test) + "Count the number of test cases that will be run by the test.") + +(luna-define-generic lunit-test-run (test result) + "Run the test and collects its result in result.") + +(luna-define-generic lunit-test-suite-add-test (suite test) + "Add the test to the suite.") + +;;; @ test listener +;;; + +(luna-define-class lunit-test-listener ()) + +(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/smtp.el b/smtp.el index 2a979d4..7e22426 100644 --- a/smtp.el +++ b/smtp.el @@ -35,6 +35,7 @@ (require 'pcustom) (require 'mail-utils) ; mail-strip-quoted-names (require 'sasl) +(require 'luna) (defgroup smtp nil "SMTP protocol for sending mail." @@ -120,36 +121,32 @@ don't define this value." (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 @@ -165,49 +162,42 @@ BUFFER may be a buffer or a buffer name which contains mail message." (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 () @@ -318,22 +308,19 @@ of the host to connect to. SERVICE is name of the service desired." (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 @@ -347,21 +334,17 @@ of the host to connect to. SERVICE is name of the service desired." (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 @@ -373,20 +356,20 @@ of the host to connect to. SERVICE is name of the service desired." (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)) @@ -398,97 +381,93 @@ of the host to connect to. SERVICE is name of the service desired." (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)))) @@ -509,14 +488,20 @@ of the host to connect to. SERVICE is name of the service desired." (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 @@ -530,21 +515,33 @@ of the host to connect to. SERVICE is name of the service desired." 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:
." 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"))))