--- /dev/null
+;;; hex-util.el --- Functions to encode/decode hexadecimal string.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; 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
--- /dev/null
+;;; hmac-def.el --- A macro for defining HMAC functions.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; 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
--- /dev/null
+;;; hmac-md5.el --- Compute HMAC-MD5.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Kenichi OKADA <okada@opaopa.org>
+;; Maintainer: Kenichi OKADA <okada@opaopa.org>
+;; 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
--- /dev/null
+;;; hmac-sha1.el --- Compute HMAC-SHA1.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; 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
--- /dev/null
+;;; qmtp.el --- basic functions to send mail with QMTP server
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; 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
--- /dev/null
+;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Kenichi OKADA <okada@opaopa.org>
+;; 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
--- /dev/null
+;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Kenichi OKADA <okada@opaopa.org>
+;; 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
--- /dev/null
+;;; sasl.el --- SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; 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
--- /dev/null
+;;; sha1.el --- SHA1 Secure Hash Algorithm.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Kenichi OKADA <okada@opaopa.org>
+;; Maintainer: Kenichi OKADA <okada@opaopa.org>
+;; 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.
+;; <URL:http://www.itl.nist.gov/div897/pubs/fip180-1.htm>
+;;
+;; (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
;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
-;; Simon Leinen <simon@switch.ch> (ESMTP support)
-;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Simon Leinen <simon@switch.ch> (ESMTP support)
+;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Daiki Ueno <ueno@unixuser.org>
;; Keywords: SMTP, mail
;; This file is part of FLIM (Faithful Library about Internet Message).
;; 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:<sender>
- (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:<recipient>
- (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:<address>."
(let ((simple-address-list "")
; 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
(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"))
)))
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)
(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
;;;
',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
(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)
(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))
(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)
((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)
(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)
(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."
(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)))
"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)
(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"
(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))))
(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))
+++ /dev/null
-;;; mailcap.el --- mailcap parser
-
-;; Copyright (C) 1997,1998 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; 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
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; 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
)
(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)
"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)
projects / elisp / lemi.git / commitdiff