From: tomo Date: Mon, 3 Jun 2002 10:10:30 +0000 (+0000) Subject: Sync up with FLIM 1.14.4. X-Git-Tag: Emacs-21_1-LEMI-1_14-0~4 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=52bffc6e896ff5f2aa60b3458db367a91204b37c;p=elisp%2Flemi.git Sync up with FLIM 1.14.4. --- diff --git a/mail/hmac-md5.el b/mail/hmac-md5.el index a26189e..097a959 100644 --- a/mail/hmac-md5.el +++ b/mail/hmac-md5.el @@ -65,14 +65,28 @@ (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) diff --git a/mail/hmac-sha1.el b/mail/hmac-sha1.el index 00fe338..70b665f 100644 --- a/mail/hmac-sha1.el +++ b/mail/hmac-sha1.el @@ -65,14 +65,21 @@ (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) diff --git a/mail/sasl.el b/mail/sasl.el index 8528898..593f46b 100644 --- a/mail/sasl.el +++ b/mail/sasl.el @@ -37,14 +37,17 @@ ;;; 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) diff --git a/mail/sha1.el b/mail/sha1.el index 1690944..a9e5e9d 100644 --- a/mail/sha1.el +++ b/mail/sha1.el @@ -1,4 +1,4 @@ -;;; sha1.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp. +;;; sha1.el --- SHA1 Secure Hash Algorithm. ;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. @@ -24,13 +24,8 @@ ;;; 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. ;; -;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c) -;; -;; Test cases from FIPS PUB 180-1. ;; ;; (sha1 "abc") ;; => a9993e364706816aba3e25717850c26c9cd0d89d @@ -40,383 +35,29 @@ ;; ;; (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) diff --git a/mail/smtp.el b/mail/smtp.el index 4265bbd..a3f97c6 100644 --- a/mail/smtp.el +++ b/mail/smtp.el @@ -295,7 +295,9 @@ BUFFER may be a buffer or a buffer name which contains mail message." (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) diff --git a/mail/smtpmail.el b/mail/smtpmail.el index 6a6bd59..d037486 100644 --- a/mail/smtpmail.el +++ b/mail/smtpmail.el @@ -1,6 +1,6 @@ ;;; 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 ;; Keywords: mail @@ -155,8 +155,12 @@ This is relative to `smtpmail-queue-dir'.") ;;; (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)) diff --git a/mime/eword-decode.el b/mime/eword-decode.el index 0fc7d33..328cc28 100644 --- a/mime/eword-decode.el +++ b/mime/eword-decode.el @@ -55,13 +55,19 @@ (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 "?=")))) ) @@ -224,7 +230,7 @@ such as a version of Net$cape)." "\\(\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) @@ -522,64 +528,66 @@ If SEPARATOR is not nil, it is used as header separator." 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 @@ -749,7 +757,7 @@ be the result.") ) (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)) diff --git a/mime/eword-encode.el b/mime/eword-encode.el index f075db3..83ff53a 100644 --- a/mime/eword-encode.el +++ b/mime/eword-encode.el @@ -61,6 +61,17 @@ (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 ;;; @@ -603,25 +614,22 @@ encoded-word. ASCII token is not encoded." (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) @@ -666,12 +674,16 @@ It refer variable `mime-field-encoding-method-alist'." (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 diff --git a/mime/mel-g.el b/mime/mel-g.el index 9f79197..7f88e19 100644 --- a/mime/mel-g.el +++ b/mime/mel-g.el @@ -1,10 +1,9 @@ ;;; 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 -;; MORIOKA Tomohiko +;; MORIOKA Tomohiko ;; Maintainer: Shuhei KOBAYASHI ;; Created: 1995/10/25 ;; Keywords: Gzip64, base64, gzip, MIME @@ -132,4 +131,4 @@ START and END are buffer positions." (provide 'mel-g) -;;; mel-g.el ends here. +;;; mel-g.el ends here diff --git a/mime/mime-def.el b/mime/mime-def.el index 5ff449e..25002ef 100644 --- a/mime/mime-def.el +++ b/mime/mime-def.el @@ -1,8 +1,9 @@ ;;; 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 +;; Shuhei KOBAYASHI ;; Keywords: definition, MIME, multimedia, mail, news ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -28,13 +29,10 @@ (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) @@ -129,36 +127,28 @@ If method is nil, this field will not be encoded." (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 @@ -204,10 +194,9 @@ If method is nil, this field will not be encoded." ;;; (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." @@ -215,15 +204,15 @@ If method is nil, this field will not be encoded." (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) @@ -237,6 +226,10 @@ If method is nil, this field will not be encoded." ;;; @ 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))) diff --git a/mime/mime.el b/mime/mime.el index 2160569..005790e 100644 --- a/mime/mime.el +++ b/mime/mime.el @@ -144,10 +144,9 @@ If MESSAGE is specified, it is regarded as root entity." (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) @@ -333,7 +332,7 @@ default value." (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) ) diff --git a/mime/mmbuffer.el b/mime/mmbuffer.el index 1447d17..a034f5a 100644 --- a/mime/mmbuffer.el +++ b/mime/mmbuffer.el @@ -174,8 +174,7 @@ (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 diff --git a/mime/mmexternal.el b/mime/mmexternal.el index aafddcc..9b4b18b 100644 --- a/mime/mmexternal.el +++ b/mime/mmexternal.el @@ -156,8 +156,7 @@ (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 diff --git a/mime/mmgeneric.el b/mime/mmgeneric.el index 532dfd9..4b632f3 100644 --- a/mime/mmgeneric.el +++ b/mime/mmgeneric.el @@ -59,7 +59,7 @@ (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)))) diff --git a/mime/std11.el b/mime/std11.el index 051d45a..97f9359 100644 --- a/mime/std11.el +++ b/mime/std11.el @@ -396,7 +396,7 @@ be the result." (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))