From: tomo Date: Wed, 6 Dec 2000 02:19:21 +0000 (+0000) Subject: Sync with flim-1_14_0-pre1. X-Git-Tag: semi21-1_14_0-pre1~3 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=f7f52f6359543fd07c7a7e2ef5b2cb914dab8cab;p=elisp%2Flemi.git Sync with flim-1_14_0-pre1. --- diff --git a/mail/hex-util.el b/mail/hex-util.el new file mode 100644 index 0000000..92a09ff --- /dev/null +++ b/mail/hex-util.el @@ -0,0 +1,73 @@ +;;; hex-util.el --- Functions to encode/decode hexadecimal string. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: data + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (defmacro hex-char-to-num (chr) + (` (let ((chr (, chr))) + (cond + ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10)) + ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10)) + ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0)) + (t (error "Invalid hexadecimal digit `%c'" chr)))))) + (defmacro num-to-hex-char (num) + (` (aref "0123456789abcdef" (, num))))) + +(defun decode-hex-string (string) + "Decode hexadecimal STRING to octet string." + (let* ((len (length string)) + (dst (make-string (/ len 2) 0)) + (idx 0)(pos 0)) + (while (< pos len) +;;; logior and lsh are not byte-coded. +;;; (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4) +;;; (hex-char-to-num (aref string (1+ pos))))) + (aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16) + (hex-char-to-num (aref string (1+ pos))))) + (setq idx (1+ idx) + pos (+ 2 pos))) + dst)) + +(defun encode-hex-string (string) + "Encode octet STRING to hexadecimal string." + (let* ((len (length string)) + (dst (make-string (* len 2) 0)) + (idx 0)(pos 0)) + (while (< pos len) +;;; logand and lsh are not byte-coded. +;;; (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15))) + (aset dst idx (num-to-hex-char (/ (aref string pos) 16))) + (setq idx (1+ idx)) +;;; (aset dst idx (num-to-hex-char (logand (aref string pos) 15))) + (aset dst idx (num-to-hex-char (% (aref string pos) 16))) + (setq idx (1+ idx) + pos (1+ pos))) + dst)) + +(provide 'hex-util) + +;;; hex-util.el ends here diff --git a/mail/hmac-def.el b/mail/hmac-def.el new file mode 100644 index 0000000..7525c89 --- /dev/null +++ b/mail/hmac-def.el @@ -0,0 +1,85 @@ +;;; hmac-def.el --- A macro for defining HMAC functions. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: HMAC, RFC 2104 + +;; 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 this program; 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 program is implemented from RFC 2104, +;; "HMAC: Keyed-Hashing for Message Authentication". + +;;; Code: + +(defmacro define-hmac-function (name H B L &optional bit) + "Define a function NAME(TEXT KEY) which computes HMAC with function H. + +HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)): + +H is a cryptographic hash function, such as SHA1 and MD5, which takes +a string and return a digest of it (in binary form). +B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.) +L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.) +If BIT is non-nil, truncate output to specified bits." + (` (defun (, name) (text key) + (, (concat "Compute " + (upcase (symbol-name name)) + " over TEXT with KEY.")) + (let ((key-xor-ipad (make-string (, B) ?\x36)) + (key-xor-opad (make-string (, B) ?\x5C)) + (len (length key)) + (pos 0)) + (unwind-protect + (progn + ;; if `key' is longer than the block size, apply hash function + ;; to `key' and use the result as a real `key'. + (if (> len (, B)) + (setq key ((, H) key) + len (, L))) + (while (< pos len) + (aset key-xor-ipad pos (logxor (aref key pos) ?\x36)) + (aset key-xor-opad pos (logxor (aref key pos) ?\x5C)) + (setq pos (1+ pos))) + (setq key-xor-ipad (unwind-protect + (concat key-xor-ipad text) + (fillarray key-xor-ipad 0)) + key-xor-ipad (unwind-protect + ((, H) key-xor-ipad) + (fillarray key-xor-ipad 0)) + key-xor-opad (unwind-protect + (concat key-xor-opad key-xor-ipad) + (fillarray key-xor-opad 0)) + key-xor-opad (unwind-protect + ((, H) key-xor-opad) + (fillarray key-xor-opad 0))) + ;; now `key-xor-opad' contains + ;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)). + (, (if (and bit (< (/ bit 8) L)) + (` (substring key-xor-opad 0 (, (/ bit 8)))) + ;; return a copy of `key-xor-opad'. + (` (concat key-xor-opad))))) + ;; cleanup. + (fillarray key-xor-ipad 0) + (fillarray key-xor-opad 0)))))) + +(provide 'hmac-def) + +;;; hmac-def.el ends here diff --git a/mail/hmac-md5.el b/mail/hmac-md5.el new file mode 100644 index 0000000..9c936d0 --- /dev/null +++ b/mail/hmac-md5.el @@ -0,0 +1,95 @@ +;;; hmac-md5.el --- Compute HMAC-MD5. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Kenichi OKADA +;; Maintainer: Kenichi OKADA +;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". +;; +;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) +;; => "9294727a3638bb1c13f48ef8158bfc9d" +;; +;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) +;; => "750c783e6ab0b503eaa86e310a5db738" +;; +;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) +;; => "56be34521d144c88dbb8c733f0e8b3f6" +;; +;; (encode-hex-string +;; (hmac-md5 +;; (make-string 50 ?\xcd) +;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) +;; => "697eaf0aca3a3aea3a75164746ffaa79" +;; +;; (encode-hex-string +;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) +;; => "56461ef2342edc00f9bab995690efd4c" +;; (encode-hex-string +;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) +;; => "56461ef2342edc00f9bab995" +;; +;; (encode-hex-string +;; (hmac-md5 +;; "Test Using Larger Than Block-Size Key - Hash Key First" +;; (make-string 80 ?\xaa))) +;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" +;; +;; (encode-hex-string +;; (hmac-md5 +;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" +;; (make-string 80 ?\xaa))) +;; => "6f630fad67cda0ee1fb1f562db3aa53e" + +;;; Code: + +(eval-when-compile (require 'hmac-def)) +(require 'hex-util) ; (decode-hex-string STRING) +(require 'md5) ; expects (md5 STRING) + +;; We cannot define this function in md5.el because recent XEmacs provides +;; built-in md5 function and provides feature 'md5 at startup. +(if (and (featurep 'xemacs) + (fboundp 'md5) + (subrp (symbol-function 'md5)) + (condition-case nil + ;; `md5' of XEmacs 21 takes 4th arg CODING (and 5th arg NOERROR). + (md5 "" nil nil 'binary) ; => "fb5d2156096fa1f254352f3cc3fada7e" + (error nil))) + ;; XEmacs 21. + (defun md5-binary (string &optional start end) + "Return the MD5 of STRING in binary form." + (decode-hex-string (md5 string start end 'binary))) + ;; not XEmacs 21 and not DL. + (if (not (fboundp 'md5-binary)) + (defun md5-binary (string) + "Return the MD5 of STRING in binary form." + (decode-hex-string (md5 string))))) + +(define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY) +;; (define-hmac-function hmac-md5-96 md5-binary 64 16 96) + +(provide 'hmac-md5) + +;;; hmac-md5.el ends here diff --git a/mail/hmac-sha1.el b/mail/hmac-sha1.el new file mode 100644 index 0000000..6b2beea --- /dev/null +++ b/mail/hmac-sha1.el @@ -0,0 +1,80 @@ +;;; hmac-sha1.el --- Compute HMAC-SHA1. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: HMAC, RFC 2104, HMAC-SHA1, SHA1, Cancel-Lock + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". +;; +;; (encode-hex-string (hmac-sha1 "Hi There" (make-string 20 ?\x0b))) +;; => "b617318655057264e28bc0b6fb378c8ef146be00" +;; +;; (encode-hex-string (hmac-sha1 "what do ya want for nothing?" "Jefe")) +;; => "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79" +;; +;; (encode-hex-string (hmac-sha1 (make-string 50 ?\xdd) (make-string 20 ?\xaa))) +;; => "125d7342b9ac11cd91a39af48aa17b4f63f175d3" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; (make-string 50 ?\xcd) +;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) +;; => "4c9007f4026250c6bc8414f9bf50c86c2d7235da" +;; +;; (encode-hex-string +;; (hmac-sha1 "Test With Truncation" (make-string 20 ?\x0c))) +;; => "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04" +;; (encode-hex-string +;; (hmac-sha1-96 "Test With Truncation" (make-string 20 ?\x0c))) +;; => "4c1a03424b55e07fe7f27be1" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; "Test Using Larger Than Block-Size Key - Hash Key First" +;; (make-string 80 ?\xaa))) +;; => "aa4ae5e15272d00e95705637ce8a3b55ed402112" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" +;; (make-string 80 ?\xaa))) +;; => "e8e99d0f45237d786d6bbaa7965c7808bbff1a91" + +;;; Code: + +(eval-when-compile (require 'hmac-def)) +(require 'hex-util) ; (decode-hex-string STRING) +(require 'sha1) ; expects (sha1 STRING) + +;;; For consintency with hmac-md5.el, we define this function here. +(or (fboundp 'sha1-binary) + (defun sha1-binary (string) + "Return the SHA1 of STRING in binary form." + (decode-hex-string (sha1 string)))) + +(define-hmac-function hmac-sha1 sha1-binary 64 20) ; => (hmac-sha1 TEXT KEY) +;; (define-hmac-function hmac-sha1-96 sha1-binary 64 20 96) + +(provide 'hmac-sha1) + +;;; hmac-sha1.el ends here diff --git a/mail/qmtp.el b/mail/qmtp.el new file mode 100644 index 0000000..459cd7f --- /dev/null +++ b/mail/qmtp.el @@ -0,0 +1,142 @@ +;;; qmtp.el --- basic functions to send mail with QMTP server + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Keywords: QMTP, qmail + +;; 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: + +;; Installation: + +;; To send mail using QMTP instead of SMTP, do + +;; (fset 'smtp-via-smtp 'qmtp-via-qmtp) + +;;; Code: + +(require 'poem) +(require 'pcustom) + +(defgroup qmtp nil + "QMTP protocol for sending mail." + :group 'mail) + +(defcustom qmtp-default-server nil + "Specify default QMTP server." + :type '(choice (const nil) string) + :group 'qmtp) + +(defvar qmtp-server qmtp-default-server + "The name of the host running QMTP server. +It can also be a function +called from `qmtp-via-qmtp' with arguments SENDER and RECIPIENTS.") + +(defcustom qmtp-service "qmtp" + "QMTP service port number. \"qmtp\" or 209." + :type '(choice (integer :tag "209" 209) + (string :tag "qmtp" "qmtp")) + :group 'qmtp) + +(defcustom qmtp-timeout 30 + "Timeout for each QMTP session." + :type 'integer + :group 'qmtp) + +(defvar qmtp-open-connection-function (function open-network-stream)) + +(defvar qmtp-error-response-alist + '((?Z "Temporary failure") + (?D "Permanent failure"))) + +(defvar qmtp-read-point nil) + +(defun qmtp-encode-netstring-string (string) + (format "%d:%s," (length string) string)) + +(defun qmtp-send-package (process sender recipients buffer) + (with-temp-buffer + (buffer-disable-undo) + (erase-buffer) + (set-buffer-multibyte nil) + (insert + (format "%d:\n" + (with-current-buffer buffer + (1+ (point-max));; for the "\n" + ))) + (insert-buffer-substring buffer) + (insert + "\n," + (qmtp-encode-netstring-string sender) + (qmtp-encode-netstring-string + (mapconcat #'qmtp-encode-netstring-string + recipients ""))) + (process-send-region process (point-min)(point-max))) + (goto-char qmtp-read-point) + (while (and (memq (process-status process) '(open run)) + (not (re-search-forward "^[0-9]+:" nil 'noerror))) + (unless (accept-process-output process qmtp-timeout) + (error "timeout expired: %d" qmtp-timeout)) + (goto-char qmtp-read-point)) + (let ((response (char-after (match-end 0)))) + (unless (eq response ?K) + (error (nth 1 (assq response qmtp-error-response-alist)))) + (setq recipients (cdr recipients)) + (beginning-of-line 2) + (setq qmtp-read-point (point)))) + +;;;###autoload +(defun qmtp-via-qmtp (sender recipients buffer) + (condition-case nil + (progn + (qmtp-send-buffer sender recipients buffer) + t) + (error))) + +(make-obsolete 'qmtp-via-qmtp "It's old API.") + +;;;###autoload +(defun qmtp-send-buffer (sender recipients buffer) + (save-excursion + (set-buffer + (get-buffer-create + (format "*trace of QMTP session to %s*" qmtp-server))) + (buffer-disable-undo) + (erase-buffer) + (make-local-variable 'qmtp-read-point) + (setq qmtp-read-point (point-min)) + (let (process) + (unwind-protect + (progn + (as-binary-process + (setq process + (funcall qmtp-open-connection-function + "QMTP" (current-buffer) qmtp-server qmtp-service))) + (qmtp-send-package process sender recipients buffer)) + (when (and process + (memq (process-status process) '(open run))) + ;; QUIT + (process-send-eof process) + (delete-process process)))))) + +(provide 'qmtp) + +;;; qmtp.el ends here diff --git a/mail/sasl-cram.el b/mail/sasl-cram.el new file mode 100644 index 0000000..25d1082 --- /dev/null +++ b/mail/sasl-cram.el @@ -0,0 +1,51 @@ +;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Kenichi OKADA +;; Keywords: SASL, CRAM-MD5 + +;; 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defconst sasl-cram-md5-steps + '(ignore ;no initial response + sasl-cram-md5-response)) + +(defun sasl-cram-md5-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "CRAM-MD5 passphrase for %s: " + (sasl-client-name client))))) + (unwind-protect + (concat (sasl-client-name client) " " + (encode-hex-string + (hmac-md5 (sasl-step-data step) passphrase))) + (fillarray passphrase 0)))) + +(put 'sasl-cram 'sasl-mechanism + (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps)) + +(provide 'sasl-cram) + +;;; sasl-cram.el ends here diff --git a/mail/sasl-digest.el b/mail/sasl-digest.el new file mode 100644 index 0000000..9e061b7 --- /dev/null +++ b/mail/sasl-digest.el @@ -0,0 +1,156 @@ +;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Kenichi OKADA +;; Keywords: SASL, DIGEST-MD5 + +;; 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; This program is implemented from draft-leach-digest-sasl-05.txt. +;; +;; It is caller's responsibility to base64-decode challenges and +;; base64-encode responses in IMAP4 AUTHENTICATE command. +;; +;; Passphrase should be longer than 16 bytes. (See RFC 2195) + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defvar sasl-digest-md5-nonce-count 1) +(defvar sasl-digest-md5-unique-id-function + sasl-unique-id-function) + +(defvar sasl-digest-md5-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?, "." table) + table) + "A syntax table for parsing digest-challenge attributes.") + +(defconst sasl-digest-md5-steps + '(ignore ;no initial response + sasl-digest-md5-response + ignore)) ;"" + +(defun sasl-digest-md5-parse-string (string) + "Parse STRING and return a property list. +The value is a cons cell of the form \(realm nonce qop-options stale maxbuf +charset algorithm cipher-opts auth-param)." + (with-temp-buffer + (set-syntax-table sasl-digest-md5-syntax-table) + (save-excursion + (insert string) + (goto-char (point-min)) + (insert "(") + (while (progn (forward-sexp) (not (eobp))) + (delete-char 1) + (insert " ")) + (insert ")") + (read (point-min-marker))))) + +(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name) + (concat serv-type "/" host + (if (and serv-name + (not (string= host serv-name))) + (concat "/" serv-name)))) + +(defun sasl-digest-md5-cnonce () + (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function)) + (sasl-unique-id))) + +(defun sasl-digest-md5-response-value (username + realm + nonce + cnonce + nonce-count + qop + digest-uri + authzid) + (let ((passphrase + (sasl-read-passphrase + (format "DIGEST-MD5 passphrase for %s: " + username)))) + (unwind-protect + (encode-hex-string + (md5-binary + (concat + (encode-hex-string + (md5-binary (concat (md5-binary + (concat username ":" realm ":" passphrase)) + ":" nonce ":" cnonce + (if authzid + (concat ":" authzid))))) + ":" nonce + ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" + (encode-hex-string + (md5-binary + (concat "AUTHENTICATE:" digest-uri + (if (member qop '("auth-int" "auth-conf")) + ":00000000000000000000000000000000"))))))) + (fillarray passphrase 0)))) + +(defun sasl-digest-md5-response (client step) + (let* ((plist + (sasl-digest-md5-parse-string (sasl-step-data step))) + (realm + (or (sasl-client-property client 'realm) + (plist-get plist 'realm))) ;need to check + (nonce-count + (or (sasl-client-property client 'nonce-count) + sasl-digest-md5-nonce-count)) + (qop + (or (sasl-client-property client 'qop) + "auth")) + (digest-uri + (sasl-digest-md5-digest-uri + (sasl-client-service client)(sasl-client-server client))) + (cnonce + (or (sasl-client-property client 'cnonce) + (sasl-digest-md5-cnonce)))) + (sasl-client-set-property client 'nonce-count (1+ nonce-count)) + (unless (string= qop "auth") + (sasl-error (format "Unsupported \"qop-value\": %s" qop))) + (concat + "username=\"" (sasl-client-name client) "\"," + "realm=\"" realm "\"," + "nonce=\"" (plist-get plist 'nonce) "\"," + "cnonce=\"" cnonce "\"," + (format "nc=%08x," nonce-count) + "digest-uri=\"" digest-uri "\"," + "qop=" qop "," + "response=" + (sasl-digest-md5-response-value + (sasl-client-name client) + realm + (plist-get plist 'nonce) + cnonce + nonce-count + qop + digest-uri + (plist-get plist 'authzid))))) + +(put 'sasl-digest 'sasl-mechanism + (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps)) + +(provide 'sasl-digest) + +;;; sasl-digest.el ends here diff --git a/mail/sasl.el b/mail/sasl.el new file mode 100644 index 0000000..8528898 --- /dev/null +++ b/mail/sasl.el @@ -0,0 +1,269 @@ +;;; sasl.el --- SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Keywords: SASL + +;; 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 this program; 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 provides common interface functions to share several +;; SASL mechanism drivers. The toplevel is designed to be mostly +;; compatible with [Java-SASL]. +;; +;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)", +;; RFC 2222, October 1997. +;; +;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program +;; Interface", draft-weltman-java-sasl-03.txt, March 2000. + +;;; Code: + +(defvar sasl-mechanisms + '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS")) + +(defvar sasl-mechanism-alist + '(("CRAM-MD5" sasl-cram) + ("DIGEST-MD5" sasl-digest) + ("PLAIN" sasl-plain) + ("LOGIN" sasl-login) + ("ANONYMOUS" sasl-anonymous))) + +(defvar sasl-unique-id-function #'sasl-unique-id-function) + +(put 'sasl-error 'error-message "SASL error") +(put 'sasl-error 'error-conditions '(sasl-error error)) + +(defun sasl-error (datum) + (signal 'sasl-error (list datum))) + +;;; @ SASL client +;;; + +(defun sasl-make-client (mechanism name service server) + "Return a newly allocated SASL client. +NAME is name of the authorization. SERVICE is name of the service desired. +SERVER is the fully qualified host name of the server to authenticate to." + (vector mechanism name service server (make-symbol "sasl-client-properties"))) + +(defun sasl-client-mechanism (client) + "Return the authentication mechanism driver of CLIENT." + (aref client 0)) + +(defun sasl-client-name (client) + "Return the authorization name of CLIENT, a string." + (aref client 1)) + +(defun sasl-client-service (client) + "Return the service name of CLIENT, a string." + (aref client 2)) + +(defun sasl-client-server (client) + "Return the server name of CLIENT, a string." + (aref client 3)) + +(defun sasl-client-set-properties (client plist) + "Destructively set the properties of CLIENT. +The second argument PLIST is the new property list." + (setplist (aref client 4) plist)) + +(defun sasl-client-set-property (client property value) + "Add the given property/value to CLIENT." + (put (aref client 4) property value)) + +(defun sasl-client-property (client property) + "Return the value of the PROPERTY of CLIENT." + (get (aref client 4) property)) + +(defun sasl-client-properties (client) + "Return the properties of CLIENT." + (symbol-plist (aref client 4))) + +;;; @ SASL mechanism +;;; + +(defun sasl-make-mechanism (name steps) + "Make an authentication mechanism. +NAME is a IANA registered SASL mechanism name. +STEPS is list of continuation function." + (vector name + (mapcar + (lambda (step) + (let ((symbol (make-symbol (symbol-name step)))) + (fset symbol (symbol-function step)) + symbol)) + steps))) + +(defun sasl-mechanism-name (mechanism) + "Return name of MECHANISM, a string." + (aref mechanism 0)) + +(defun sasl-mechanism-steps (mechanism) + "Return the authentication steps of MECHANISM, a list of functions." + (aref mechanism 1)) + +(defun sasl-find-mechanism (mechanisms) + "Retrieve an apropriate mechanism object from MECHANISMS hints." + (let* ((sasl-mechanisms sasl-mechanisms) + (mechanism + (catch 'done + (while sasl-mechanisms + (if (member (car sasl-mechanisms) mechanisms) + (throw 'done (nth 1 (assoc (car sasl-mechanisms) + sasl-mechanism-alist)))) + (setq sasl-mechanisms (cdr sasl-mechanisms)))))) + (if mechanism + (require mechanism)) + (get mechanism 'sasl-mechanism))) + +;;; @ SASL authentication step +;;; + +(defun sasl-step-data (step) + "Return the data which STEP holds, a string." + (aref step 1)) + +(defun sasl-step-set-data (step data) + "Store DATA string to STEP." + (aset step 1 data)) + +(defun sasl-next-step (client step) + "Evaluate the challenge and prepare an appropriate next response. +The data type of the value and optional 2nd argument STEP is nil or +opaque authentication step which holds the reference to the next action +and the current challenge. At the first time STEP should be set to nil." + (let* ((steps + (sasl-mechanism-steps + (sasl-client-mechanism client))) + (function + (if (vectorp step) + (nth 1 (memq (aref step 0) steps)) + (car steps)))) + (if function + (vector function (funcall function client step))))) + +(defvar sasl-read-passphrase nil) +(defun sasl-read-passphrase (prompt) + (if (not sasl-read-passphrase) + (if (functionp 'read-passwd) + (setq sasl-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq sasl-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq sasl-read-passphrase 'ange-ftp-read-passwd)))) + (funcall sasl-read-passphrase prompt)) + +(defun sasl-unique-id () + "Compute a data string which must be different each time. +It contain at least 64 bits of entropy." + (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function))) + +(defvar sasl-unique-id-char nil) + +;; stolen (and renamed) from message.el +(defun sasl-unique-id-function () + ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Instead we use this randomly inited counter. + (setq sasl-unique-id-char + (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20))))) + ;; (current-time) returns 16-bit ints, + ;; and 2^16*25 just fits into 4 digits i base 36. + (* 25 25))) + (let ((tm (current-time))) + (concat + (sasl-unique-id-number-base36 + (+ (car tm) + (lsh (% sasl-unique-id-char 25) 16)) 4) + (sasl-unique-id-number-base36 + (+ (nth 1 tm) + (lsh (/ sasl-unique-id-char 25) 16)) 4)))) + +(defun sasl-unique-id-number-base36 (num len) + (if (if (< len 0) + (<= num 0) + (= len 0)) + "" + (concat (sasl-unique-id-number-base36 (/ num 36) (1- len)) + (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" + (% num 36)))))) + +;;; PLAIN (RFC2595 Section 6) +(defconst sasl-plain-steps + '(sasl-plain-response)) + +(defun sasl-plain-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "PLAIN passphrase for %s: " (sasl-client-name client)))) + (authenticator-name + (sasl-client-property + client 'authenticator-name)) + (name (sasl-client-name client))) + (unwind-protect + (if (and authenticator-name + (not (string= authenticator-name name))) + (concat authenticator-name "\0" name "\0" passphrase) + (concat "\0" name "\0" passphrase)) + (fillarray passphrase 0)))) + +(put 'sasl-plain 'sasl-mechanism + (sasl-make-mechanism "PLAIN" sasl-plain-steps)) + +(provide 'sasl-plain) + +;;; LOGIN (No specification exists) +(defconst sasl-login-steps + '(ignore ;no initial response + sasl-login-response-1 + sasl-login-response-2)) + +(defun sasl-login-response-1 (client step) +;;; (unless (string-match "^Username:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-client-name client)) + +(defun sasl-login-response-2 (client step) +;;; (unless (string-match "^Password:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-read-passphrase + (format "LOGIN passphrase for %s: " (sasl-client-name client)))) + +(put 'sasl-login 'sasl-mechanism + (sasl-make-mechanism "LOGIN" sasl-login-steps)) + +(provide 'sasl-login) + +;;; ANONYMOUS (RFC2245) +(defconst sasl-anonymous-steps + '(ignore ;no initial response + sasl-anonymous-response)) + +(defun sasl-anonymous-response (client step) + (or (sasl-client-property client 'trace) + (sasl-client-name client))) + +(put 'sasl-anonymous 'sasl-mechanism + (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps)) + +(provide 'sasl-anonymous) + +(provide 'sasl) + +;;; sasl.el ends here diff --git a/mail/sha1.el b/mail/sha1.el new file mode 100644 index 0000000..a7265b6 --- /dev/null +++ b/mail/sha1.el @@ -0,0 +1,77 @@ +;;; sha1.el --- SHA1 Secure Hash Algorithm. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Kenichi OKADA +;; Maintainer: Kenichi OKADA +;; Keywords: SHA1, FIPS 180-1 + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Examples from FIPS PUB 180-1. +;; +;; +;; (sha1 "abc") +;; => a9993e364706816aba3e25717850c26c9cd0d89d +;; +;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") +;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1 +;; +;; (sha1 (make-string 1000000 ?a)) +;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f + +;;; Code: + +(require 'hex-util) + +(eval-when-compile + (defun-maybe sha1-string (a))) + +(defvar sha1-dl-module + (if (and (fboundp 'sha1-string) + (subrp (symbol-function 'sha1-string))) + nil + (if (fboundp 'dynamic-link) + (let ((path (expand-file-name "sha1.so" exec-directory))) + (and (file-exists-p path) + path))))) + +(cond + (sha1-dl-module + ;; Emacs with DL patch. + (require 'sha1-dl)) + (t + (require 'sha1-el))) + +;; compatibility for another sha1.el by Keiichi Suzuki. +(defun sha1-encode (string) + (decode-hex-string + (sha1-string string))) +(defun sha1-encode-binary (string) + (decode-hex-string + (sha1-string string))) + +(make-obsolete 'sha1-encode "It's old API.") +(make-obsolete 'sha1-encode-binary "It's old API.") + +(provide 'sha1) + +;;; sha1.el ends here diff --git a/mail/smtp.el b/mail/smtp.el index 27a0b99..2a979d4 100644 --- a/mail/smtp.el +++ b/mail/smtp.el @@ -3,8 +3,9 @@ ;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani -;; Simon Leinen (ESMTP support) -;; Shuhei KOBAYASHI +;; Simon Leinen (ESMTP support) +;; Shuhei KOBAYASHI +;; Daiki Ueno ;; Keywords: SMTP, mail ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -24,328 +25,527 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; + ;;; Code: -(require 'poe) -(require 'poem) +(require 'pces) (require 'pcustom) (require 'mail-utils) ; mail-strip-quoted-names - -(eval-when-compile (require 'cl)) ; push +(require 'sasl) (defgroup smtp nil "SMTP protocol for sending mail." :group 'mail) +(defgroup smtp-extensions nil + "SMTP service extensions (RFC1869)." + :group 'smtp) + (defcustom smtp-default-server nil - "*Specify default SMTP server." + "Specify default SMTP server." :type '(choice (const nil) string) :group 'smtp) (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server) - "*The name of the host running SMTP server. It can also be a function + "The name of the host running SMTP server. +It can also be a function called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS." :type '(choice (string :tag "Name") (function :tag "Function")) :group 'smtp) (defcustom smtp-service "smtp" - "*SMTP service port number. \"smtp\" or 25." + "SMTP service port number. \"smtp\" or 25." :type '(choice (integer :tag "25" 25) (string :tag "smtp" "smtp")) :group 'smtp) -(defcustom smtp-use-8bitmime t - "*If non-nil, use ESMTP 8BITMIME if available." - :type 'boolean - :group 'smtp) - (defcustom smtp-local-domain nil - "*Local domain name without a host name. + "Local domain name without a host name. If the function (system-name) returns the full internet address, don't define this value." :type '(choice (const nil) string) :group 'smtp) -(defcustom smtp-debug-info nil - "*smtp debug info printout. messages and process buffer." - :type 'boolean +(defcustom smtp-fqdn nil + "Fully qualified domain name used for Message-ID." + :type '(choice (const nil) string) :group 'smtp) -(defcustom smtp-notify-success nil - "*If non-nil, notification for successful mail delivery is returned - to user (RFC1891)." +(defcustom smtp-use-8bitmime t + "If non-nil, use ESMTP 8BITMIME (RFC1652) if available." :type 'boolean - :group 'smtp) - + :group 'smtp-extensions) + +(defcustom smtp-use-size t + "If non-nil, use ESMTP SIZE (RFC1870) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-use-starttls nil + "If non-nil, use STARTTLS (RFC2595) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-use-sasl nil + "If non-nil, use SMTP Authentication (RFC2554) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-sasl-user-name (user-login-name) + "Identification to be used for authorization." + :type 'string + :group 'smtp-extensions) + +(defcustom smtp-sasl-properties nil + "Properties set to SASL client." + :type 'string + :group 'smtp-extensions) + +(defcustom smtp-sasl-mechanisms nil + "List of authentication mechanisms." + :type '(repeat string) + :group 'smtp-extensions) + +(defvar sasl-mechanisms) + +(defvar smtp-open-connection-function #'open-network-stream) + (defvar smtp-read-point nil) +(defvar smtp-connection-alist nil) + +(defvar smtp-submit-package-function #'smtp-submit-package) + +;;; @ SMTP package structure +;;; 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)) + +(defmacro smtp-package-buffer (package) + "Return the data of PACKAGE, a buffer." + `(aref ,package 2)) + +(defmacro 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)) + +(defun smtp-package-buffer-size (package) + "Return the size of PACKAGE, an integer." + (save-excursion + (set-buffer (smtp-package-buffer package)) + (let ((size + (+ (buffer-size) + ;; Add one byte for each change-of-line + ;; because or CR-LF representation: + (count-lines (point-min) (point-max)) + ;; For some reason, an empty line is + ;; added to the message. Maybe this + ;; is a bug, but it can't hurt to add + ;; those two bytes anyway: + 2))) + (goto-char (point-min)) + (while (re-search-forward "^\\." nil t) + (setq size (1+ size))) + size))) + +;;; @ SMTP connection structure +;;; 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)) + +(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)) + +(defmacro 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)) + +(defun smtp-connection-opened (connection) + "Say whether the CONNECTION to server has been opened." + (let ((process (smtp-connection-process 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))) + (delete-process process))) + (defun smtp-make-fqdn () "Return user's fully qualified domain name." - (let ((system-name (system-name))) - (cond - (smtp-local-domain - (concat system-name "." smtp-local-domain)) - ((string-match "[^.]\\.[^.]" system-name) - system-name) - (t - (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly."))))) - -(defun smtp-via-smtp (sender recipients smtp-text-buffer) - (let ((server (if (functionp smtp-server) - (funcall smtp-server sender recipients) - smtp-server)) - process response extensions) + (if smtp-fqdn + smtp-fqdn + (let ((system-name (system-name))) + (cond + (smtp-local-domain + (concat system-name "." smtp-local-domain)) + ((string-match "[^.]\\.[^.]" system-name) + system-name) + (t + (error "Cannot generate valid FQDN")))))) + +(defun smtp-find-connection (buffer) + "Find the connection delivering to BUFFER." + (let ((entry (assq buffer smtp-connection-alist)) + connection) + (when entry + (setq connection (nth 1 entry)) + (if (smtp-connection-opened connection) + connection + (setq smtp-connection-alist + (delq entry smtp-connection-alist)) + nil)))) + +(eval-and-compile + (autoload 'starttls-open-stream "starttls") + (autoload 'starttls-negotiate "starttls")) + +(defun smtp-open-connection (buffer server service) + "Open a SMTP connection for a service to a host. +Return a newly allocated connection-object. +BUFFER is the buffer to associate with the connection. SERVER is name +of the host to connect to. SERVICE is name of the service desired." + (let ((process + (as-binary-process + (funcall smtp-open-connection-function + "SMTP" buffer server service))) + connection) + (when process + (setq connection (smtp-make-connection process server service)) + (set-process-filter process 'smtp-process-filter) + (setq smtp-connection-alist + (cons (list buffer connection) + smtp-connection-alist)) + connection))) + +;;;###autoload +(defun smtp-via-smtp (sender recipients buffer) + (condition-case nil + (progn + (smtp-send-buffer sender recipients buffer) + t) + (smtp-error))) + +(make-obsolete 'smtp-via-smtp "It's old API.") + +;;;###autoload +(defun smtp-send-buffer (sender recipients buffer) + (let ((server + (if (functionp smtp-server) + (funcall smtp-server sender recipients) + smtp-server)) + (package + (smtp-make-package sender recipients buffer)) + (smtp-open-connection-function + (if smtp-use-starttls + #'starttls-open-stream + smtp-open-connection-function))) (save-excursion (set-buffer (get-buffer-create (format "*trace of SMTP session to %s*" server))) (erase-buffer) + (buffer-disable-undo) + (unless (smtp-find-connection (current-buffer)) + (smtp-open-connection (current-buffer) server smtp-service)) (make-local-variable 'smtp-read-point) (setq smtp-read-point (point-min)) - - (unwind-protect - (catch 'done - (setq process (open-network-stream-as-binary - "SMTP" (current-buffer) server smtp-service)) - (or process (throw 'done nil)) - - (set-process-filter process 'smtp-process-filter) - - ;; Greeting - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - ;; EHLO - (smtp-send-command process - (format "EHLO %s" (smtp-make-fqdn))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (progn - ;; HELO - (smtp-send-command process - (format "HELO %s" (smtp-make-fqdn))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response))))) - (let ((extension-lines (cdr (cdr response)))) - (while extension-lines - (push (intern (downcase (substring (car extension-lines) 4))) - extensions) - (setq extension-lines (cdr extension-lines))))) - - ;; ONEX --- One message transaction only (sendmail extension?) - (if (or (memq 'onex extensions) - (memq 'xone extensions)) - (progn - (smtp-send-command process "ONEX") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; VERB --- Verbose (sendmail extension?) - (if (and smtp-debug-info - (or (memq 'verb extensions) - (memq 'xvrb extensions))) - (progn - (smtp-send-command process "VERB") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; XUSR --- Initial (user) submission (sendmail extension?) - (if (memq 'xusr extensions) - (progn - (smtp-send-command process "XUSR") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; MAIL FROM: - (smtp-send-command - process - (format "MAIL FROM:<%s>%s%s" - sender - ;; SIZE --- Message Size Declaration (RFC1870) - (if (memq 'size extensions) - (format " SIZE=%d" - (save-excursion - (set-buffer smtp-text-buffer) - (+ (- (point-max) (point-min)) - ;; Add one byte for each change-of-line - ;; because or CR-LF representation: - (count-lines (point-min) (point-max)) - ;; For some reason, an empty line is - ;; added to the message. Maybe this - ;; is a bug, but it can't hurt to add - ;; those two bytes anyway: - 2))) - "") - ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652) - (if (and (memq '8bitmime extensions) - smtp-use-8bitmime) - " BODY=8BITMIME" - ""))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - ;; RCPT TO: - (while recipients - (smtp-send-command process - (format - (if smtp-notify-success - "RCPT TO:<%s> NOTIFY=SUCCESS" - "RCPT TO:<%s>") - (car recipients))) - (setq recipients (cdr recipients)) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response))))) - - ;; DATA - (smtp-send-command process "DATA") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - ;; Mail contents - (smtp-send-data process smtp-text-buffer) - - ;; DATA end "." - (smtp-send-command process ".") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - t) - - (if (and process - (eq (process-status process) 'open)) - (progn - ;; QUIT - (smtp-send-command process "QUIT") - (smtp-read-response process) - (delete-process process))))))) - + (funcall smtp-submit-package-function package)))) + +(defun smtp-submit-package (package) + (unwind-protect + (progn + (smtp-primitive-greeting package) + (condition-case nil + (smtp-primitive-ehlo package) + (smtp-response-error + (smtp-primitive-helo package))) + (if smtp-use-starttls + (smtp-primitive-starttls package)) + (if smtp-use-sasl + (smtp-primitive-auth package)) + (smtp-primitive-mailfrom package) + (smtp-primitive-rcptto package) + (smtp-primitive-data package)) + (let ((connection (smtp-find-connection (current-buffer)))) + (when (smtp-connection-opened connection) + (smtp-primitive-quit package) + (smtp-close-connection connection))))) + +;;; @ hook methods for `smtp-submit-package' +;;; + +(defun smtp-primitive-greeting (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (response + (smtp-read-response + (smtp-connection-process 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)) + (if (/= (car response) 250) + (smtp-response-error response)) + (smtp-connection-set-extensions + connection (mapcar + (lambda (extension) + (let ((extensions + (split-string extension))) + (setcar extensions + (car (read-from-string + (downcase (car extensions))))) + extensions)) + (cdr response))))) + +(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)) + (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)))) + (sasl-mechanisms + (or smtp-sasl-mechanisms sasl-mechanisms)) + (mechanism + (sasl-find-mechanism mechanisms)) + client + name + step + response) + (unless mechanism + (error "No authentication mechanism available")) + (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp" + (smtp-connection-server 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 + (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)) + (when (= (car response) 235) + ;; The authentication process is finished. + (setq step (sasl-next-step client step)) + (if (null step) + (throw 'done nil)) + (smtp-response-error response)) ;Bogus server? + (if (/= (car response) 334) + (smtp-response-error response)) + (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) + "")))))) + +(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)) + (if (/= (car response) 220) + (smtp-response-error response)) + (starttls-negotiate process))) + +(defun smtp-primitive-mailfrom (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + (extensions + (smtp-connection-extensions + connection)) + (sender + (smtp-package-sender 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)))) + ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652) + (if (and smtp-use-8bitmime + (assq '8bitmime extensions)) + (setq extension (concat extension " BODY=8BITMIME"))) + (smtp-send-command + process + (if extension + (format "MAIL FROM:<%s> %s" sender extension) + (format "MAIL FROM:<%s>" sender))) + (setq response (smtp-read-response process)) + (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)) + response) + (while recipients + (smtp-send-command + process (format "RCPT TO:<%s>" (pop recipients))) + (setq response (smtp-read-response process)) + (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)) + (if (/= (car response) 354) + (smtp-response-error response)) + (save-excursion + (set-buffer (smtp-package-buffer package)) + (goto-char (point-min)) + (while (not (eobp)) + (smtp-send-data + process (buffer-substring (point) (progn (end-of-line)(point)))) + (beginning-of-line 2))) + (smtp-send-command process ".") + (setq response (smtp-read-response process)) + (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)) + (if (/= (car response) 221) + (smtp-response-error response)))) + +;;; @ low level process manipulating function +;;; (defun smtp-process-filter (process output) (save-excursion (set-buffer (process-buffer process)) (goto-char (point-max)) (insert output))) -(defun smtp-read-response (process) - (let ((case-fold-search nil) - (response-strings nil) - (response-continue t) - (return-value '(nil ())) - match-end) +(put 'smtp-error 'error-message "SMTP error") +(put 'smtp-error 'error-conditions '(smtp-error error)) + +(put 'smtp-response-error 'error-message "SMTP response error") +(put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error)) +(defun smtp-response-error (response) + (signal 'smtp-response-error response)) + +(defun smtp-read-response (process) + (let ((response-continue t) + response) (while response-continue (goto-char smtp-read-point) (while (not (search-forward "\r\n" nil t)) (accept-process-output process) (goto-char smtp-read-point)) - - (setq match-end (point)) - (setq response-strings - (cons (buffer-substring smtp-read-point (- match-end 2)) - response-strings)) - - (goto-char smtp-read-point) - (if (looking-at "[0-9]+ ") - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (if smtp-debug-info - (message "%s" (car response-strings))) - - (setq smtp-read-point match-end) - - ;; ignore lines that start with "0" - (if (looking-at "0[0-9]+ ") - nil - (setq response-continue nil) - (setq return-value - (cons (string-to-int - (buffer-substring begin end)) - (nreverse response-strings))))) - - (if (looking-at "[0-9]+-") - (progn (if smtp-debug-info - (message "%s" (car response-strings))) - (setq smtp-read-point match-end) - (setq response-continue t)) - (progn - (setq smtp-read-point match-end) - (setq response-continue nil) - (setq return-value - (cons nil (nreverse response-strings))))))) - (setq smtp-read-point match-end) - return-value)) + (setq response + (nconc response + (list (buffer-substring + (+ 4 smtp-read-point) + (- (point) 2))))) + (goto-char + (prog1 smtp-read-point + (setq smtp-read-point (point)))) + (if (looking-at "[1-5][0-9][0-9] ") + (setq response (cons (read (point-marker)) response) + response-continue nil))) + response)) (defun smtp-send-command (process command) - (goto-char (point-max)) - (insert command "\r\n") - (setq smtp-read-point (point)) - (process-send-string process command) - (process-send-string process "\r\n")) + (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-1 (process data) - (goto-char (point-max)) - (if smtp-debug-info - (insert data "\r\n")) - (setq smtp-read-point (point)) +(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")) -(defun smtp-send-data (process buffer) - (let ((data-continue t) - (sending-data nil) - this-line - this-line-end) - - (save-excursion - (set-buffer buffer) - (goto-char (point-min))) - - (while data-continue - (save-excursion - (set-buffer buffer) - (beginning-of-line) - (setq this-line (point)) - (end-of-line) - (setq this-line-end (point)) - (setq sending-data nil) - (setq sending-data (buffer-substring this-line this-line-end)) - (if (or (/= (forward-line 1) 0) (eobp)) - (setq data-continue nil))) - - (smtp-send-data-1 process sending-data)))) - (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO:
." (let ((simple-address-list "") diff --git a/mail/smtpmail.el b/mail/smtpmail.el index 74638aa..8582394 100644 --- a/mail/smtpmail.el +++ b/mail/smtpmail.el @@ -226,10 +226,9 @@ This is relative to `smtpmail-queue-dir'.") ; Send or queue (if (not smtpmail-queue-mail) (if smtpmail-recipient-address-list - (if (not (smtp-via-smtp user-mail-address - smtpmail-recipient-address-list - tembuf)) - (error "Sending failed; SMTP protocol error")) + (smtp-send-buffer user-mail-address + smtpmail-recipient-address-list + tembuf) (error "Sending failed; no recipients")) (let* ((file-data (convert-standard-filename (concat @@ -284,9 +283,8 @@ This is relative to `smtpmail-queue-dir'.") (load file-msg) (setq tembuf (find-file-noselect-as-binary file-msg)) (if smtpmail-recipient-address-list - (if (not (smtp-via-smtp user-mail-address - smtpmail-recipient-address-list tembuf)) - (error "Sending failed; SMTP protocol error")) + (smtp-send-buffer user-mail-address + smtpmail-recipient-address-list tembuf) (error "Sending failed; no recipients")) (delete-file file-msg) (delete-file (concat file-msg ".el")) diff --git a/mime/eword-encode.el b/mime/eword-encode.el index 5735e04..f7111c1 100644 --- a/mime/eword-encode.el +++ b/mime/eword-encode.el @@ -517,17 +517,37 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is ))) dest)) +(defsubst eword-encode-mailboxes-to-rword-list (mboxes) + (let ((dest (eword-encode-mailbox-to-rword-list (car mboxes)))) + (if dest + (while (setq mboxes (cdr mboxes)) + (setq dest + (nconc dest + (list '("," nil nil)) + (eword-encode-mailbox-to-rword-list + (car mboxes)))))) + dest)) + +(defsubst eword-encode-address-to-rword-list (address) + (cond + ((eq (car address) 'mailbox) + (eword-encode-mailbox-to-rword-list address)) + ((eq (car address) 'group) + (nconc + (eword-encode-phrase-to-rword-list (nth 1 address)) + (list (list ":" nil nil)) + (eword-encode-mailboxes-to-rword-list (nth 2 address)) + (list (list ";" nil nil)))))) + (defsubst eword-encode-addresses-to-rword-list (addresses) - (let ((dest (eword-encode-mailbox-to-rword-list (car addresses)))) + (let ((dest (eword-encode-address-to-rword-list (car addresses)))) (if dest (while (setq addresses (cdr addresses)) (setq dest (nconc dest (list '("," nil nil)) ;; (list '(" " nil nil)) - (eword-encode-mailbox-to-rword-list (car addresses)) - )) - )) + (eword-encode-address-to-rword-list (car addresses)))))) dest)) (defsubst eword-encode-msg-id-to-rword-list (msg-id) diff --git a/mime/luna.el b/mime/luna.el index 48da490..7a8cb53 100644 --- a/mime/luna.el +++ b/mime/luna.el @@ -26,15 +26,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile (require 'static)) - -(static-condition-case nil - :symbol-for-testing-whether-colon-keyword-is-available-or-not - (void-variable - (defconst :before ':before) - (defconst :after ':after) - (defconst :around ':around))) - ;;; @ class ;;; @@ -64,13 +55,6 @@ If SLOTS is specified, TYPE will be defined to have them." ',slots)) (defun luna-define-class-function (type &optional parents slots) - (static-condition-case nil - :symbol-for-testing-whether-colon-keyword-is-available-or-not - (void-variable - (let (key) - (dolist (slot slots) - (setq key (intern (format ":%s" slot))) - (set key key))))) (let ((oa (make-vector 31 0)) (rest parents) parent name @@ -84,19 +68,15 @@ If SLOTS is specified, TYPE will be defined to have them." (setq name (symbol-name sym)) (unless (intern-soft name oa) (put (intern name oa) 'luna-slot-index (+ j b)) - (setq i (1+ i)) - ))) - (luna-class-obarray (luna-find-class parent))) - ) + (setq i (1+ i))))) + (luna-class-obarray (luna-find-class parent)))) (setq rest slots) (while rest (setq name (symbol-name (pop rest))) (unless (intern-soft name oa) (put (intern name oa) 'luna-slot-index i) - (setq i (1+ i)) - )) - (luna-set-class type (vector 'class oa parents i)) - )) + (setq i (1+ i)))) + (luna-set-class type (vector 'class oa parents i)))) (defun luna-class-find-member (class member-name) (or (stringp member-name) @@ -143,8 +123,7 @@ BODY is the body of method." (if (memq method-qualifier '(:before :after :around)) (setq args (pop definition)) (setq args method-qualifier - method-qualifier nil) - ) + method-qualifier nil)) (setq specializer (car args) class (nth 1 specializer) self (car specializer)) @@ -153,10 +132,12 @@ BODY is the body of method." (cdr args)) ,@definition)) (sym (luna-class-find-or-make-member - (luna-find-class ',class) ',name))) + (luna-find-class ',class) ',name)) + (cache (get ',name 'luna-method-cache))) + (if cache + (unintern ',class cache)) (fset sym func) - (put sym 'luna-method-qualifier ,method-qualifier) - ))) + (put sym 'luna-method-qualifier ,method-qualifier)))) (put 'luna-define-method 'lisp-indent-function 'defun) @@ -165,8 +146,7 @@ BODY is the body of method." ((arg symbolp) [&rest arg] [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ) + &optional ["&rest" arg]) def-body)) (defun luna-class-find-parents-functions (class service) @@ -184,20 +164,15 @@ BODY is the body of method." (if (fboundp sym) (cond ((eq (get sym 'luna-method-qualifier) :before) (cons (symbol-function sym) - (luna-class-find-parents-functions class service)) - ) + (luna-class-find-parents-functions class service))) ((eq (get sym 'luna-method-qualifier) :after) (nconc (luna-class-find-parents-functions class service) - (list (symbol-function sym))) - ) + (list (symbol-function sym)))) ((eq (get sym 'luna-method-qualifier) :around) - (cons sym (luna-class-find-parents-functions class service)) - ) + (cons sym (luna-class-find-parents-functions class service))) (t - (list (symbol-function sym)) - )) - (luna-class-find-parents-functions class service) - ))) + (list (symbol-function sym)))) + (luna-class-find-parents-functions class service)))) ;;; @ instance (entity) @@ -252,8 +227,7 @@ LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." (eval-when-compile (defvar luna-next-methods nil) - (defvar luna-current-method-arguments nil) - ) + (defvar luna-current-method-arguments nil)) (defun luna-call-next-method () "Call the next method in a method with :around qualifier." @@ -279,20 +253,31 @@ It must be plist and each slot name must have prefix `:'." (v (make-vector (luna-class-number-of-slots c) nil))) (luna-set-class-name v type) (luna-set-obarray v (make-vector 7 0)) - (apply #'luna-send v 'initialize-instance v init-args) - )) + (apply #'luna-send v 'initialize-instance v init-args))) ;;; @ interface (generic function) ;;; +(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))) + (defsubst luna-arglist-to-arguments (arglist) (let (dest) (while arglist (let ((arg (car arglist))) (or (memq arg '(&optional &rest)) - (setq dest (cons arg dest))) - ) + (setq dest (cons arg dest)))) (setq arglist (cdr arglist))) (nreverse dest))) @@ -300,15 +285,17 @@ It must be plist and each slot name must have prefix `:'." "Define generic-function NAME. ARGS is argument of and DOC is DOC-string." (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) @@ -329,8 +316,7 @@ ARGS is argument of and DOC is DOC-string." (setq parent-class (luna-find-class (car parents))) (if (luna-class-slot-index parent-class slot) (throw 'derived nil)) - (setq parents (cdr parents)) - ) + (setq parents (cdr parents))) (eval `(progn (defmacro ,(intern (format "%s-%s-internal" @@ -338,17 +324,14 @@ ARGS is argument of and DOC is DOC-string." (entity) (list 'aref entity ,(luna-class-slot-index entity-class - (intern (symbol-name slot))) - )) + (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)))) @@ -366,8 +349,7 @@ ARGS is argument of and DOC is DOC-string." (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa) i (pop init-args)) (if s - (aset entity (get s 'luna-slot-index) i) - )) + (aset entity (get s 'luna-slot-index) i))) entity)) diff --git a/mime/mailcap.el b/mime/mailcap.el deleted file mode 100644 index 25595f0..0000000 --- a/mime/mailcap.el +++ /dev/null @@ -1,270 +0,0 @@ -;;; mailcap.el --- mailcap parser - -;; Copyright (C) 1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Created: 1997/6/27 -;; Keywords: mailcap, setting, configuration, MIME, multimedia - -;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mime-def) - - -;;; @ comment -;;; - -(defsubst mailcap-skip-comment () - (let ((chr (char-after (point)))) - (when (and chr - (or (= chr ?\n) - (= chr ?#))) - (forward-line) - t))) - - -;;; @ token -;;; - -(defsubst mailcap-look-at-token () - (if (looking-at mime-token-regexp) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (goto-char end) - (buffer-substring beg end) - ))) - - -;;; @ typefield -;;; - -(defsubst mailcap-look-at-type-field () - (let ((type (mailcap-look-at-token))) - (if type - (if (eq (char-after (point)) ?/) - (progn - (forward-char) - (let ((subtype (mailcap-look-at-token))) - (if subtype - (cons (cons 'type (intern type)) - (unless (string= subtype "*") - (list (cons 'subtype (intern subtype))) - ))))) - (list (cons 'type (intern type))) - )))) - - -;;; @ field separator -;;; - -(defsubst mailcap-skip-field-separator () - (let ((ret (looking-at "\\([ \t]\\|\\\\\n\\)*;\\([ \t]\\|\\\\\n\\)*"))) - (when ret - (goto-char (match-end 0)) - t))) - - -;;; @ mtext -;;; - -(defsubst mailcap-look-at-schar () - (let ((chr (char-after (point)))) - (if (and chr - (>= chr ? ) - (/= chr ?\;) - (/= chr ?\\) - ) - (prog1 - chr - (forward-char))))) - -(defsubst mailcap-look-at-qchar () - (when (eq (char-after (point)) ?\\) - (prog2 - (forward-char) - (char-after (point)) - (forward-char)))) - -(defsubst mailcap-look-at-mtext () - (let ((beg (point))) - (while (or (mailcap-look-at-qchar) - (mailcap-look-at-schar))) - (buffer-substring beg (point)) - )) - - -;;; @ field -;;; - -(defsubst mailcap-look-at-field () - (let ((token (mailcap-look-at-token))) - (if token - (if (looking-at "[ \t]*=[ \t]*") - (let ((value (progn - (goto-char (match-end 0)) - (mailcap-look-at-mtext)))) - (if value - (cons (intern token) value) - )) - (list (intern token)) - )))) - - -;;; @ mailcap entry -;;; - -(defun mailcap-look-at-entry () - (let ((type (mailcap-look-at-type-field))) - (if (and type (mailcap-skip-field-separator)) - (let ((view (mailcap-look-at-mtext)) - fields field) - (when view - (while (and (mailcap-skip-field-separator) - (setq field (mailcap-look-at-field)) - ) - (setq fields (cons field fields)) - ) - (nconc type - (list (cons 'view view)) - fields)))))) - - -;;; @ main -;;; - -(defun mailcap-parse-buffer (&optional buffer order) - "Parse BUFFER as a mailcap, and return the result. -If optional argument ORDER is a function, result is sorted by it. -If optional argument ORDER is not specified, result is sorted original -order. Otherwise result is not sorted." - (save-excursion - (if buffer - (set-buffer buffer)) - (goto-char (point-min)) - (let (entries entry) - (while (progn - (while (mailcap-skip-comment)) - (setq entry (mailcap-look-at-entry)) - ) - (setq entries (cons entry entries)) - (forward-line) - ) - (cond ((functionp order) (sort entries order)) - ((null order) (nreverse entries)) - (t entries) - )))) - - -(defcustom mailcap-file "~/.mailcap" - "*File name of user's mailcap file." - :group 'mime - :type 'file) - -(defun mailcap-parse-file (&optional filename order) - "Parse FILENAME as a mailcap, and return the result. -If optional argument ORDER is a function, result is sorted by it. -If optional argument ORDER is not specified, result is sorted original -order. Otherwise result is not sorted." - (or filename - (setq filename mailcap-file)) - (with-temp-buffer - (insert-file-contents filename) - (mailcap-parse-buffer (current-buffer) order) - )) - -(defun mailcap-format-command (mtext situation) - "Return formated command string from MTEXT and SITUATION. - -MTEXT is a command text of mailcap specification, such as -view-command. - -SITUATION is an association-list about information of entity. Its key -may be: - - 'type primary media-type - 'subtype media-subtype - 'filename filename - STRING parameter of Content-Type field" - (let ((i 0) - (len (length mtext)) - (p 0) - dest) - (while (< i len) - (let ((chr (aref mtext i))) - (cond ((eq chr ?%) - (setq i (1+ i) - chr (aref mtext i)) - (cond ((eq chr ?s) - (let ((file (cdr (assq 'filename situation)))) - (if (null file) - (error "'filename is not specified in situation.") - (setq dest (concat dest - (substring mtext p (1- i)) - file) - i (1+ i) - p i) - ))) - ((eq chr ?t) - (let ((type (or (mime-type/subtype-string - (cdr (assq 'type situation)) - (cdr (assq 'subtype situation))) - "text/plain"))) - (setq dest (concat dest - (substring mtext p (1- i)) - type) - i (1+ i) - p i) - )) - ((eq chr ?\{) - (setq i (1+ i)) - (if (not (string-match "}" mtext i)) - (error "parse error!!!") - (let* ((me (match-end 0)) - (attribute (substring mtext i (1- me))) - (parameter (cdr (assoc attribute situation)))) - (if (null parameter) - (error "\"%s\" is not specified in situation." - attribute) - (setq dest (concat dest - (substring mtext p (- i 2)) - parameter) - i me - p i) - ) - ))) - (t (error "Invalid sequence `%%%c'." chr)) - )) - ((eq chr ?\\) - (setq dest (concat dest (substring mtext p i)) - p (1+ i) - i (+ i 2)) - ) - (t (setq i (1+ i))) - ))) - (concat dest (substring mtext p)) - )) - - -;;; @ end -;;; - -(provide 'mailcap) - -;;; mailcap.el ends here diff --git a/mime/mime-def.el b/mime/mime-def.el index 6c55e6b..73602ac 100644 --- a/mime/mime-def.el +++ b/mime/mime-def.el @@ -5,7 +5,8 @@ ;; Author: MORIOKA Tomohiko ;; Keywords: definition, MIME, multimedia, mail, news -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of DEISUI (Deisui is an Entity Implementation for +;; SEMI based User Interfaces). ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -36,7 +37,7 @@ ) (eval-and-compile - (defconst mime-library-product ["Chao" (1 14 1) "Rokujizò"] + (defconst mime-library-product ["FLIM" (1 14 0) "Ninokuchi"] "Product name, version number and code name of MIME-library package.")) (defmacro mime-product-name (product) diff --git a/mime/std11.el b/mime/std11.el index 982b895..dc7bde5 100644 --- a/mime/std11.el +++ b/mime/std11.el @@ -765,7 +765,7 @@ represents addr-spec of RFC 822." "Return string of address part from parsed ADDRESS of RFC 822." (cond ((eq (car address) 'group) (mapconcat (function std11-address-string) - (car (cdr address)) + (nth 2 address) ", ") ) ((eq (car address) 'mailbox)