(eval-when-compile (require 'hmac-def))
(require 'hex-util) ; (decode-hex-string STRING)
-(require 'md5) ; We have a built-in `md5'.
+(require 'md5) ; expects (md5 STRING)
-(defun md5-binary (string &optional start end)
- "Return the MD5 of STRING in binary form."
- (decode-hex-string (md5 string start end 'binary)))
+;; To share *.elc files between Emacs w/ and w/o DL patch,
+;; this check must be done at load-time.
+(cond
+ ((fboundp 'md5-binary)
+ ;; do nothing.
+ )
+ ((condition-case nil
+ ;; `md5' of v21 takes 4th arg CODING (and 5th arg NOERROR).
+ (md5 "" nil nil 'binary) ; => "d41d8cd98f00b204e9800998ecf8427e"
+ (wrong-number-of-arguments nil))
+ (defun md5-binary (string)
+ "Return the MD5 of STRING in binary form."
+ (decode-hex-string (md5 string nil nil 'binary))))
+ (t
+ (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)
+(define-hmac-function hmac-md5-96 md5-binary 64 16 96)
(provide 'hmac-md5)
(eval-when-compile (require 'hmac-def))
(require 'hex-util) ; (decode-hex-string STRING)
-(require 'sha1) ; expects (sha1-binary STRING)
+(require 'sha1) ; expects (sha1 STRING)
-;;; (defun sha1-binary (string)
-;;; "Return the SHA1 of STRING in binary form."
-;;; (decode-hex-string (sha1 string)))
+;; To share *.elc files between Emacs w/ and w/o DL patch,
+;; this check must be done at load-time.
+(cond
+ ((fboundp 'sha1-binary)
+ ;; do nothing.
+ )
+ (t
+ (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)
+(define-hmac-function hmac-sha1-96 sha1-binary 64 20 96)
(provide 'hmac-sha1)
;;; Code:
(defvar sasl-mechanisms
- '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS"))
+ '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS"
+ "NTLM" "SCRAM-MD5"))
(defvar sasl-mechanism-alist
'(("CRAM-MD5" sasl-cram)
("DIGEST-MD5" sasl-digest)
("PLAIN" sasl-plain)
("LOGIN" sasl-login)
- ("ANONYMOUS" sasl-anonymous)))
+ ("ANONYMOUS" sasl-anonymous)
+ ("NTLM" sasl-ntlm)
+ ("SCRAM-MD5" sasl-scram)))
(defvar sasl-unique-id-function #'sasl-unique-id-function)
-;;; sha1.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp.
+;;; sha1.el --- SHA1 Secure Hash Algorithm.
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
;;; Commentary:
-;; This program is implemented from the definition of SHA-1 in FIPS PUB
-;; 180-1 (Federal Information Processing Standards Publication 180-1),
-;; "Announcing the Standard for SECURE HASH STANDARD".
+;; Examples from FIPS PUB 180-1.
;; <URL:http://www.itl.nist.gov/div897/pubs/fip180-1.htm>
-;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c)
-;;
-;; Test cases from FIPS PUB 180-1.
;;
;; (sha1 "abc")
;; => a9993e364706816aba3e25717850c26c9cd0d89d
;;
;; (sha1 (make-string 1000000 ?a))
;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f
-;;
-;; BUGS:
-;; * It is assumed that length of input string is less than 2^29 bytes.
-;; * It is caller's responsibility to make string (or region) unibyte.
-;;
-;; TODO:
-;; * Rewrite from scratch!
-;; This version is much faster than Keiichi Suzuki's another sha1.el,
-;; but it is too dirty.
;;; Code:
-(require 'hex-util)
-
-;;;
-;;; external SHA1 function.
-;;;
-
-(defvar sha1-maximum-internal-length 500
- "*Maximum length of message to use lisp version of SHA1 function.
-If message is longer than this, `sha1-program' is used instead.
-
-If this variable is set to 0, use extarnal program only.
-If this variable is set to nil, use internal function only.")
-
-(defvar sha1-program '("openssl" "sha1")
- "*Name of program to compute SHA1.
-It must be a string \(program name\) or list of strings \(name and its args\).")
-
-(defun sha1-string-external (string)
- ;; `with-temp-buffer' is new in v20, so we do not use it.
- (save-excursion
- (let (buffer)
- (unwind-protect
- (let (prog args)
- (if (consp sha1-program)
- (setq prog (car sha1-program)
- args (cdr sha1-program))
- (setq prog sha1-program
- args nil))
- (setq buffer (set-buffer
- (generate-new-buffer " *sha1 external*")))
- (insert string)
- (apply (function call-process-region)
- (point-min)(point-max)
- prog t t nil args)
- ;; SHA1 is 40 bytes long in hexadecimal form.
- (buffer-substring (point-min)(+ (point-min) 40)))
- (and buffer
- (buffer-name buffer)
- (kill-buffer buffer))))))
-
-(defun sha1-region-external (beg end)
- (sha1-string-external (buffer-substring-no-properties beg end)))
-
-;;;
-;;; internal SHA1 function.
-;;;
-
-(eval-when-compile
- ;; optional second arg of string-to-number is new in v20.
- (defconst sha1-K0-high 23170) ; (string-to-number "5A82" 16)
- (defconst sha1-K0-low 31129) ; (string-to-number "7999" 16)
- (defconst sha1-K1-high 28377) ; (string-to-number "6ED9" 16)
- (defconst sha1-K1-low 60321) ; (string-to-number "EBA1" 16)
- (defconst sha1-K2-high 36635) ; (string-to-number "8F1B" 16)
- (defconst sha1-K2-low 48348) ; (string-to-number "BCDC" 16)
- (defconst sha1-K3-high 51810) ; (string-to-number "CA62" 16)
- (defconst sha1-K3-low 49622) ; (string-to-number "C1D6" 16)
-
-;;; original definition of sha1-F0.
-;;; (defmacro sha1-F0 (B C D)
-;;; (` (logior (logand (, B) (, C))
-;;; (logand (lognot (, B)) (, D)))))
-;;; a little optimization from GnuPG/cipher/sha1.c.
- (defmacro sha1-F0 (B C D)
- (` (logxor (, D) (logand (, B) (logxor (, C) (, D))))))
- (defmacro sha1-F1 (B C D)
- (` (logxor (, B) (, C) (, D))))
-;;; original definition of sha1-F2.
-;;; (defmacro sha1-F2 (B C D)
-;;; (` (logior (logand (, B) (, C))
-;;; (logand (, B) (, D))
-;;; (logand (, C) (, D)))))
-;;; a little optimization from GnuPG/cipher/sha1.c.
- (defmacro sha1-F2 (B C D)
- (` (logior (logand (, B) (, C))
- (logand (, D) (logior (, B) (, C))))))
- (defmacro sha1-F3 (B C D)
- (` (logxor (, B) (, C) (, D))))
-
- (defmacro sha1-S1 (W-high W-low)
- (` (let ((W-high (, W-high))
- (W-low (, W-low)))
- (setq S1W-high (+ (% (* W-high 2) 65536)
- (/ W-low (, (/ 65536 2)))))
- (setq S1W-low (+ (/ W-high (, (/ 65536 2)))
- (% (* W-low 2) 65536))))))
- (defmacro sha1-S5 (A-high A-low)
- (` (progn
- (setq S5A-high (+ (% (* (, A-high) 32) 65536)
- (/ (, A-low) (, (/ 65536 32)))))
- (setq S5A-low (+ (/ (, A-high) (, (/ 65536 32)))
- (% (* (, A-low) 32) 65536))))))
- (defmacro sha1-S30 (B-high B-low)
- (` (progn
- (setq S30B-high (+ (/ (, B-high) 4)
- (* (% (, B-low) 4) (, (/ 65536 4)))))
- (setq S30B-low (+ (/ (, B-low) 4)
- (* (% (, B-high) 4) (, (/ 65536 4))))))))
-
- (defmacro sha1-OP (round)
- (` (progn
- (sha1-S5 sha1-A-high sha1-A-low)
- (sha1-S30 sha1-B-high sha1-B-low)
- (setq sha1-A-low (+ ((, (intern (format "sha1-F%d" round)))
- sha1-B-low sha1-C-low sha1-D-low)
- sha1-E-low
- (, (symbol-value
- (intern (format "sha1-K%d-low" round))))
- (aref block-low idx)
- (progn
- (setq sha1-E-low sha1-D-low)
- (setq sha1-D-low sha1-C-low)
- (setq sha1-C-low S30B-low)
- (setq sha1-B-low sha1-A-low)
- S5A-low)))
- (setq carry (/ sha1-A-low 65536))
- (setq sha1-A-low (% sha1-A-low 65536))
- (setq sha1-A-high (% (+ ((, (intern (format "sha1-F%d" round)))
- sha1-B-high sha1-C-high sha1-D-high)
- sha1-E-high
- (, (symbol-value
- (intern (format "sha1-K%d-high" round))))
- (aref block-high idx)
- (progn
- (setq sha1-E-high sha1-D-high)
- (setq sha1-D-high sha1-C-high)
- (setq sha1-C-high S30B-high)
- (setq sha1-B-high sha1-A-high)
- S5A-high)
- carry)
- 65536)))))
-
- (defmacro sha1-add-to-H (H X)
- (` (progn
- (setq (, (intern (format "sha1-%s-low" H)))
- (+ (, (intern (format "sha1-%s-low" H)))
- (, (intern (format "sha1-%s-low" X)))))
- (setq carry (/ (, (intern (format "sha1-%s-low" H))) 65536))
- (setq (, (intern (format "sha1-%s-low" H)))
- (% (, (intern (format "sha1-%s-low" H))) 65536))
- (setq (, (intern (format "sha1-%s-high" H)))
- (% (+ (, (intern (format "sha1-%s-high" H)))
- (, (intern (format "sha1-%s-high" X)))
- carry)
- 65536)))))
- )
-
-;;; buffers (H0 H1 H2 H3 H4).
-(defvar sha1-H0-high)
-(defvar sha1-H0-low)
-(defvar sha1-H1-high)
-(defvar sha1-H1-low)
-(defvar sha1-H2-high)
-(defvar sha1-H2-low)
-(defvar sha1-H3-high)
-(defvar sha1-H3-low)
-(defvar sha1-H4-high)
-(defvar sha1-H4-low)
-
-(defun sha1-block (block-high block-low)
- (let (;; step (c) --- initialize buffers (A B C D E).
- (sha1-A-high sha1-H0-high) (sha1-A-low sha1-H0-low)
- (sha1-B-high sha1-H1-high) (sha1-B-low sha1-H1-low)
- (sha1-C-high sha1-H2-high) (sha1-C-low sha1-H2-low)
- (sha1-D-high sha1-H3-high) (sha1-D-low sha1-H3-low)
- (sha1-E-high sha1-H4-high) (sha1-E-low sha1-H4-low)
- (idx 16))
- ;; step (b).
- (let (;; temporary variables used in sha1-S1 macro.
- S1W-high S1W-low)
- (while (< idx 80)
- (sha1-S1 (logxor (aref block-high (- idx 3))
- (aref block-high (- idx 8))
- (aref block-high (- idx 14))
- (aref block-high (- idx 16)))
- (logxor (aref block-low (- idx 3))
- (aref block-low (- idx 8))
- (aref block-low (- idx 14))
- (aref block-low (- idx 16))))
- (aset block-high idx S1W-high)
- (aset block-low idx S1W-low)
- (setq idx (1+ idx))))
- ;; step (d).
- (setq idx 0)
- (let (;; temporary variables used in sha1-OP macro.
- S5A-high S5A-low S30B-high S30B-low carry)
- (while (< idx 20) (sha1-OP 0) (setq idx (1+ idx)))
- (while (< idx 40) (sha1-OP 1) (setq idx (1+ idx)))
- (while (< idx 60) (sha1-OP 2) (setq idx (1+ idx)))
- (while (< idx 80) (sha1-OP 3) (setq idx (1+ idx))))
- ;; step (e).
- (let (;; temporary variables used in sha1-add-to-H macro.
- carry)
- (sha1-add-to-H H0 A)
- (sha1-add-to-H H1 B)
- (sha1-add-to-H H2 C)
- (sha1-add-to-H H3 D)
- (sha1-add-to-H H4 E))))
-
-(defun sha1-binary (string)
- "Return the SHA1 of STRING in binary form."
- (let (;; prepare buffers for a block. byte-length of block is 64.
- ;; input block is split into two vectors.
- ;;
- ;; input block: 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ...
- ;; block-high: +-0-+ +-1-+ +-2-+ +-3-+
- ;; block-low: +-0-+ +-1-+ +-2-+ +-3-+
- ;;
- ;; length of each vector is 80, and elements of each vector are
- ;; 16bit integers. elements 0x10-0x4F of each vector are
- ;; assigned later in `sha1-block'.
- (block-high (eval-when-compile (make-vector 80 nil)))
- (block-low (eval-when-compile (make-vector 80 nil))))
- (unwind-protect
- (let* (;; byte-length of input string.
- (len (length string))
- (lim (* (/ len 64) 64))
- (rem (% len 4))
- (idx 0)(pos 0))
- ;; initialize buffers (H0 H1 H2 H3 H4).
- (setq sha1-H0-high 26437 ; (string-to-number "6745" 16)
- sha1-H0-low 8961 ; (string-to-number "2301" 16)
- sha1-H1-high 61389 ; (string-to-number "EFCD" 16)
- sha1-H1-low 43913 ; (string-to-number "AB89" 16)
- sha1-H2-high 39098 ; (string-to-number "98BA" 16)
- sha1-H2-low 56574 ; (string-to-number "DCFE" 16)
- sha1-H3-high 4146 ; (string-to-number "1032" 16)
- sha1-H3-low 21622 ; (string-to-number "5476" 16)
- sha1-H4-high 50130 ; (string-to-number "C3D2" 16)
- sha1-H4-low 57840) ; (string-to-number "E1F0" 16)
- ;; loop for each 64 bytes block.
- (while (< pos lim)
- ;; step (a).
- (setq idx 0)
- (while (< idx 16)
- (aset block-high idx (+ (* (aref string pos) 256)
- (aref string (1+ pos))))
- (setq pos (+ pos 2))
- (aset block-low idx (+ (* (aref string pos) 256)
- (aref string (1+ pos))))
- (setq pos (+ pos 2))
- (setq idx (1+ idx)))
- (sha1-block block-high block-low))
- ;; last block.
- (if (prog1
- (< (- len lim) 56)
- (setq lim (- len rem))
- (setq idx 0)
- (while (< pos lim)
- (aset block-high idx (+ (* (aref string pos) 256)
- (aref string (1+ pos))))
- (setq pos (+ pos 2))
- (aset block-low idx (+ (* (aref string pos) 256)
- (aref string (1+ pos))))
- (setq pos (+ pos 2))
- (setq idx (1+ idx)))
- ;; this is the last (at most) 32bit word.
- (cond
- ((= rem 3)
- (aset block-high idx (+ (* (aref string pos) 256)
- (aref string (1+ pos))))
- (setq pos (+ pos 2))
- (aset block-low idx (+ (* (aref string pos) 256)
- 128)))
- ((= rem 2)
- (aset block-high idx (+ (* (aref string pos) 256)
- (aref string (1+ pos))))
- (aset block-low idx 32768))
- ((= rem 1)
- (aset block-high idx (+ (* (aref string pos) 256)
- 128))
- (aset block-low idx 0))
- (t ;; (= rem 0)
- (aset block-high idx 32768)
- (aset block-low idx 0)))
- (setq idx (1+ idx))
- (while (< idx 16)
- (aset block-high idx 0)
- (aset block-low idx 0)
- (setq idx (1+ idx))))
- ;; last block has enough room to write the length of string.
- (progn
- ;; write bit length of string to last 4 bytes of the block.
- (aset block-low 15 (* (% len 8192) 8))
- (setq len (/ len 8192))
- (aset block-high 15 (% len 65536))
- ;; XXX: It is not practical to compute SHA1 of
- ;; such a huge message on emacs.
- ;; (setq len (/ len 65536)) ; for 64bit emacs.
- ;; (aset block-low 14 (% len 65536))
- ;; (aset block-high 14 (/ len 65536))
- (sha1-block block-high block-low))
- ;; need one more block.
- (sha1-block block-high block-low)
- (fillarray block-high 0)
- (fillarray block-low 0)
- ;; write bit length of string to last 4 bytes of the block.
- (aset block-low 15 (* (% len 8192) 8))
- (setq len (/ len 8192))
- (aset block-high 15 (% len 65536))
- ;; XXX: It is not practical to compute SHA1 of
- ;; such a huge message on emacs.
- ;; (setq len (/ len 65536)) ; for 64bit emacs.
- ;; (aset block-low 14 (% len 65536))
- ;; (aset block-high 14 (/ len 65536))
- (sha1-block block-high block-low))
- ;; make output string (in binary form).
- (let ((result (make-string 20 0)))
- (aset result 0 (/ sha1-H0-high 256))
- (aset result 1 (% sha1-H0-high 256))
- (aset result 2 (/ sha1-H0-low 256))
- (aset result 3 (% sha1-H0-low 256))
- (aset result 4 (/ sha1-H1-high 256))
- (aset result 5 (% sha1-H1-high 256))
- (aset result 6 (/ sha1-H1-low 256))
- (aset result 7 (% sha1-H1-low 256))
- (aset result 8 (/ sha1-H2-high 256))
- (aset result 9 (% sha1-H2-high 256))
- (aset result 10 (/ sha1-H2-low 256))
- (aset result 11 (% sha1-H2-low 256))
- (aset result 12 (/ sha1-H3-high 256))
- (aset result 13 (% sha1-H3-high 256))
- (aset result 14 (/ sha1-H3-low 256))
- (aset result 15 (% sha1-H3-low 256))
- (aset result 16 (/ sha1-H4-high 256))
- (aset result 17 (% sha1-H4-high 256))
- (aset result 18 (/ sha1-H4-low 256))
- (aset result 19 (% sha1-H4-low 256))
- result))
- ;; do not leave a copy of input string.
- (fillarray block-high nil)
- (fillarray block-low nil))))
-
-(defun sha1-string-internal (string)
- (encode-hex-string (sha1-binary string)))
-
-(defun sha1-region-internal (beg end)
- (sha1-string-internal (buffer-substring-no-properties beg end)))
-
-;;;
-;;; application interface.
-;;;
-
-(defun sha1-region (beg end)
- (if (and sha1-maximum-internal-length
- (> (abs (- end beg)) sha1-maximum-internal-length))
- (sha1-region-external beg end)
- (sha1-region-internal beg end)))
-
-(defun sha1-string (string)
- (if (and sha1-maximum-internal-length
- (> (length string) sha1-maximum-internal-length))
- (sha1-string-external string)
- (sha1-string-internal string)))
-
-(defun sha1 (object &optional beg end)
- "Return the SHA1 (Secure Hash Algorithm) of an object.
-OBJECT is either a string or a buffer.
-Optional arguments BEG and END denote buffer positions for computing the
-hash of a portion of OBJECT."
- (if (stringp object)
- (sha1-string object)
- (save-excursion
- (set-buffer object)
- (sha1-region (or beg (point-min)) (or end (point-max))))))
+(defvar sha1-dl-module
+ (cond
+ ((and (fboundp 'sha1)
+ (subrp (symbol-function 'sha1)))
+ nil)
+ ((fboundp 'dynamic-link)
+ ;; Should we take care of `dynamic-link-path'?
+ (let ((path (expand-file-name "sha1.so" exec-directory)))
+ (if (file-exists-p path)
+ path
+ nil)))
+ (t
+ nil)))
+
+(cond
+ ((and (stringp sha1-dl-module)
+ (file-exists-p sha1-dl-module))
+ (require 'sha1-dl))
+ (t
+ (require 'sha1-el)))
(provide 'sha1)
(smtp-response-error
(smtp-primitive-helo package)))
(if smtp-use-starttls
- (smtp-primitive-starttls package))
+ (progn
+ (smtp-primitive-starttls package)
+ (smtp-primitive-ehlo package)))
(if smtp-use-sasl
(smtp-primitive-auth package))
(smtp-primitive-mailfrom package)
;;; smtpmail.el --- SMTP interface for mail-mode
-;; Copyright (C) 1995, 1996, 1998, 1999, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,98,99,2000,01,02 Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
;; Keywords: mail
;;; (insert "Sender: " (user-login-name) "\n")))
;; Don't send out a blank subject line
(goto-char (point-min))
- (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
- (replace-match ""))
+ (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t)
+ (replace-match "")
+ ;; This one matches a Subject just before the header delimiter.
+ (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t)
+ (= (match-end 0) delimline))
+ (replace-match "")))
;; Put the "From:" field in unless for some odd reason
;; they put one in themselves.
(goto-char (point-min))
(eval-when-compile
(concat (regexp-quote "=?")
"\\("
- mime-charset-regexp
+ mime-charset-regexp ; 1
"\\)"
+ "\\("
+ (regexp-quote "*")
+ mime-language-regexp ; 2
+ "\\)?"
(regexp-quote "?")
- "\\([BbQq]\\)"
+ "\\("
+ mime-encoding-regexp ; 3
+ "\\)"
(regexp-quote "?")
"\\("
- eword-encoded-text-regexp
+ eword-encoded-text-regexp ; 4
"\\)"
(regexp-quote "?="))))
)
"\\(\n?[ \t]\\)+"
"\\(" eword-encoded-word-regexp "\\)")
nil t)
- (replace-match "\\1\\6")
+ (replace-match "\\1\\7")
(goto-char (point-min))
)
(while (re-search-forward eword-encoded-word-regexp nil t)
word))
(defun eword-decode-encoded-word (word &optional must-unfold)
- "Decode WORD if it is an encoded-word.
-
-If your emacs implementation can not decode the charset of WORD, it
-returns WORD. Similarly the encoded-word is broken, it returns WORD.
-
-If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
-if there are in decoded encoded-word (generated by bad manner MUA such
-as a version of Net$cape)."
- (or (if (string-match eword-encoded-word-regexp word)
- (let ((charset
- (substring word (match-beginning 1) (match-end 1))
- )
- (encoding
- (upcase
- (substring word (match-beginning 2) (match-end 2))
- ))
- (text
- (substring word (match-beginning 3) (match-end 3))
- ))
- (condition-case err
- (eword-decode-encoded-text charset encoding text must-unfold)
- (error
- (funcall eword-decode-encoded-word-error-handler word err)
- ))
- ))
+ "Decode WORD as an encoded-word.
+
+If charset is unknown or unsupported, return WORD.
+If encoding is unknown, or some error occurs while decoding,
+`eword-decode-encoded-word-error-handler' is called with WORD and an
+error condition.
+
+If MUST-UNFOLD is non-nil, unfold decoded WORD."
+ (or (and (string-match eword-encoded-word-regexp word)
+ (condition-case err
+ (eword-decode-encoded-text
+ ;; charset
+ (substring word (match-beginning 1)(match-end 1))
+ ;; language
+ (when (match-beginning 2)
+ (intern
+ (downcase
+ (substring word (1+ (match-beginning 2))(match-end 2)))))
+ ;; encoding
+ (upcase
+ (substring word (match-beginning 3)(match-end 3)))
+ ;; encoded-text
+ (substring word (match-beginning 4)(match-end 4))
+ must-unfold)
+ (error
+ (funcall eword-decode-encoded-word-error-handler word err))))
word))
;;; @ encoded-text decoder
;;;
-(defun eword-decode-encoded-text (charset encoding string
+(defun eword-decode-encoded-text (charset language encoding string
&optional must-unfold)
"Decode STRING as an encoded-text.
If your emacs implementation can not decode CHARSET, it returns nil.
+If LANGUAGE is non-nil, it is put to `mime-language' text-property.
If ENCODING is not \"B\" or \"Q\", it occurs error.
So you should write error-handling code if you don't want break by errors.
If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
if there are in decoded encoded-text (generated by bad manner MUA such
as a version of Net$cape)."
- (let ((cs (mime-charset-to-coding-system charset)))
- (if cs
- (let ((dest (encoded-text-decode-string string encoding)))
- (when dest
- (setq dest (decode-mime-charset-string dest charset))
- (if must-unfold
- (mapconcat (function
- (lambda (chr)
- (cond ((eq chr ?\n) "")
- ((eq chr ?\t) " ")
- (t (char-to-string chr)))
- ))
- (std11-unfold-string dest)
- "")
- dest))))))
+ (when (mime-charset-to-coding-system charset)
+ (let ((dest (encoded-text-decode-string string encoding)))
+ (when dest
+ (setq dest (decode-mime-charset-string dest charset))
+ (when must-unfold
+ (mapconcat
+ (function
+ (lambda (chr)
+ (cond ((eq chr ?\n) "")
+ ((eq chr ?\t) " ")
+ (t (char-to-string chr)))))
+ (std11-unfold-string dest) ""))
+ (when language
+ (put-text-property 0 (length dest) 'mime-language language dest))
+ dest))))
;;; @ lexical analyze
)
(setq rest (cdr rest)))
(or r
- (list (cons 'error (substring string start)) (1+ len)))
+ (cons (cons 'error (substring string start)) (1+ len)))
))
(setq dest (cons (car ret) dest)
start (cdr ret))
(defvar mime-header-default-charset-encoding "Q")
+(defvar mime-header-encode-method-alist
+ '((eword-encode-address-list
+ . (Reply-To
+ From Sender
+ Resent-Reply-To Resent-From
+ Resent-Sender To Resent-To
+ Cc Resent-Cc Bcc Resent-Bcc
+ Dcc))
+ (eword-encode-in-reply-to . (In-Reply-To))
+ (eword-encode-structured-field-body . (Mime-Version User-Agent))
+ (eword-encode-unstructured-field-body)))
;;; @ encoded-text encoder
;;;
(setq field-body (std11-unfold-string field-body))
(if (string= field-body "")
""
- (let (start)
+ (let ((method-alist mime-header-encode-method-alist)
+ start ret)
(if (symbolp field-name)
(setq start (1+ (length (symbol-name field-name))))
(setq start (1+ (length field-name))
field-name (intern (capitalize field-name))))
- (cond ((memq field-name
- '(Reply-To
- From Sender
- Resent-Reply-To Resent-From
- Resent-Sender To Resent-To
- Cc Resent-Cc Bcc Resent-Bcc
- Dcc))
- (eword-encode-address-list field-body start))
- ((eq field-name 'In-Reply-To)
- (eword-encode-in-reply-to field-body start))
- ((memq field-name '(Mime-Version User-Agent))
- (eword-encode-structured-field-body field-body start))
- (t
- (eword-encode-unstructured-field-body field-body start))))))
+ (while (car method-alist)
+ (if (or (not (cdr (car method-alist)))
+ (memq field-name
+ (cdr (car method-alist))))
+ (progn
+ (setq ret
+ (apply (caar method-alist) (list field-body start)))
+ (setq method-alist nil)))
+ (setq method-alist (cdr method-alist)))
+ ret)))
(defalias 'eword-encode-field-body 'mime-encode-field-body)
(make-obsolete 'eword-encode-field-body 'mime-encode-field-body)
(let ((method (eword-find-field-encoding-method
(downcase field-name))))
(cond ((eq method 'mime)
- (let ((field-body
- (buffer-substring-no-properties bbeg end)
- ))
- (delete-region bbeg end)
- (insert (mime-encode-field-body field-body
- field-name))))
+ (let* ((field-body
+ (buffer-substring-no-properties bbeg end))
+ (encoded-body
+ (mime-encode-field-body
+ field-body field-name)))
+ (if (not encoded-body)
+ (error "Cannot encode %s:%s"
+ field-name field-body)
+ (delete-region bbeg end)
+ (insert encoded-body))))
(code-conversion
(let ((cs
(or (mime-charset-to-coding-system
;;; mel-g.el --- Gzip64 encoder/decoder.
-;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
-;; Copyright (C) 1996,1997,1999 Shuhei KOBAYASHI
+;; Copyright (C) 1995,96,97,98,99,2001 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; MORIOKA Tomohiko <tomo@m17n.org>
+;; MORIOKA Tomohiko <tomo@m17n.org>
;; Maintainer: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
;; Created: 1995/10/25
;; Keywords: Gzip64, base64, gzip, MIME
(provide 'mel-g)
-;;; mel-g.el ends here.
+;;; mel-g.el ends here
;;; mime-def.el --- definition module about MIME -*- coding: iso-8859-4; -*-
-;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98,99,2000,2001,2002 Free Software Foundation, Inc.
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
;; Keywords: definition, MIME, multimedia, mail, news
;; This file is part of FLIM (Faithful Library about Internet Message).
(require 'mcharset)
(require 'alist)
-(eval-when-compile
- (require 'cl) ; list*
- (require 'luna) ; luna-arglist-to-arguments
- )
+(eval-when-compile (require 'luna)) ; luna-arglist-to-arguments
(eval-and-compile
- (defconst mime-library-product ["FLIM" (1 14 2) "Yagi-Nishiguchi"]
+ (defconst mime-library-product ["FLIM" (1 14 4) "Kashiharajingþ-mae"]
"Product name, version number and code name of MIME-library package."))
(defmacro mime-product-name (product)
(defalias 'char-int 'identity))
-;;; @ about STD 11
+;;; @ MIME constants
;;;
-(eval-and-compile
- (defconst std11-quoted-pair-regexp "\\\\.")
- (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
- (defconst std11-qtext-regexp
- (eval-when-compile
- (concat "[^" std11-non-qtext-char-list "]"))))
-(defconst std11-quoted-string-regexp
- (eval-when-compile
- (concat "\""
- (regexp-*
- (regexp-or std11-qtext-regexp std11-quoted-pair-regexp))
- "\"")))
+(defconst mime-tspecial-char-list
+ '(?\] ?\[ ?\( ?\) ?< ?> ?@ ?, ?\; ?: ?\\ ?\" ?/ ?? ?=))
+(defconst mime-token-regexp
+ (concat "[^" mime-tspecial-char-list "\000-\040]+"))
+(defconst mime-attribute-char-regexp
+ (concat "[^" mime-tspecial-char-list "\000-\040"
+ "*'%" ; introduced in RFC 2231.
+ "]"))
+(defconst mime-charset-regexp
+ (concat "[^" mime-tspecial-char-list "\000-\040"
+ "*'%" ; should not include "%"?
+ "]+"))
-;;; @ about MIME
-;;;
+;; More precisely, length of "[A-Za-z]+" is limited to at most 8.
+;; (defconst mime-language-regexp "[A-Za-z]+\\(-[A-Za-z]+\\)*")
+(defconst mime-language-regexp "[-A-Za-z]+")
-(eval-and-compile
- (defconst mime-tspecial-char-list
- '(?\] ?\[ ?\( ?\) ?< ?> ?@ ?, ?\; ?: ?\\ ?\" ?/ ?? ?=)))
-(defconst mime-token-regexp
- (eval-when-compile
- (concat "[^" mime-tspecial-char-list "\000-\040]+")))
-(defconst mime-charset-regexp mime-token-regexp)
-
-(defconst mime-media-type/subtype-regexp
- (concat mime-token-regexp "/" mime-token-regexp))
+(defconst mime-encoding-regexp mime-token-regexp)
;;; @@ base64 / B
;;;
(defsubst make-mime-content-type (type subtype &optional parameters)
- (list* (cons 'type type)
- (cons 'subtype subtype)
- (nreverse parameters))
- )
+ (cons (cons 'type type)
+ (cons (cons 'subtype subtype)
+ parameters)))
(defsubst mime-content-type-primary-type (content-type)
"Return primary-type of CONTENT-TYPE."
(defsubst mime-content-type-subtype (content-type)
"Return subtype of CONTENT-TYPE."
- (cdr (cadr content-type)))
+ (cdr (car (cdr content-type))))
(defsubst mime-content-type-parameters (content-type)
"Return parameters of CONTENT-TYPE."
- (cddr content-type))
+ (cdr (cdr content-type)))
(defsubst mime-content-type-parameter (content-type parameter)
"Return PARAMETER value of CONTENT-TYPE."
- (cdr (assoc parameter (mime-content-type-parameters content-type))))
+ (cdr (assoc parameter (cdr (cdr content-type)))))
(defsubst mime-type/subtype-string (type &optional subtype)
;;; @ Content-Disposition
;;;
+(defsubst make-mime-content-disposition (type &optional parameters)
+ (cons (cons 'type type)
+ parameters))
+
(defsubst mime-content-disposition-type (content-disposition)
"Return disposition-type of CONTENT-DISPOSITION."
(cdr (car content-disposition)))
(defun mime-find-root-entity (entity)
"Return root entity of ENTITY."
- (let ((p (mime-entity-parent entity)))
- (if (null p)
- entity
- (mime-entity-parent p))))
+ (while (not (mime-root-entity-p entity))
+ (setq entity (mime-entity-parent entity)))
+ entity)
;;; @ Header buffer (obsolete)
(prog1
field-name
(setq field-name (symbol-name field-name)))
- (intern (capitalize (capitalize field-name))))))
+ (intern (capitalize field-name)))))
(cond ((eq sym 'Content-Type)
(mime-entity-content-type entity)
)
(let ((ret (std11-fetch-field field-name)))
(when ret
(or (symbolp field-name)
- (setq field-name
- (intern (capitalize (capitalize field-name)))))
+ (setq field-name (intern (capitalize field-name))))
(mime-entity-set-original-header-internal
entity
(put-alist field-name ret
(let ((ret (std11-fetch-field field-name)))
(when ret
(or (symbolp field-name)
- (setq field-name
- (intern (capitalize (capitalize field-name)))))
+ (setq field-name (intern (capitalize field-name))))
(mime-entity-set-original-header-internal
entity
(put-alist field-name ret
(luna-define-method mime-entity-fetch-field ((entity mime-entity)
field-name)
(or (symbolp field-name)
- (setq field-name (intern (capitalize (capitalize field-name)))))
+ (setq field-name (intern (capitalize field-name))))
(cdr (assq field-name
(mime-entity-original-header-internal entity))))
(null (setq r (funcall func string start))))
(setq rest (cdr rest)))
(or r
- (list (cons 'error (substring string start)) (1+ len)))
+ (cons (cons 'error (substring string start)) (1+ len)))
))
(setq dest (cons (car ret) dest)
start (cdr ret))
projects / elisp / lemi.git / commitdiff