;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998, 1999, 2000, 2002, 2003 Free Software Foundation, Inc.
+
+;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
(eval-when-compile
(require 'cl)
- (defvar message-posting-charset)
- (unless (fboundp 'with-syntax-table) ; not in Emacs 20
- (defmacro with-syntax-table (table &rest body)
- "Evaluate BODY with syntax table of current buffer set to TABLE.
-The syntax table of the current buffer is saved, BODY is evaluated, and the
-saved table is restored, even in case of an abnormal exit.
-Value is what BODY returns."
- (let ((old-table (make-symbol "table"))
- (old-buffer (make-symbol "buffer")))
- `(let ((,old-table (syntax-table))
- (,old-buffer (current-buffer)))
- (unwind-protect
- (progn
- (set-syntax-table ,table)
- ,@body)
- (save-current-buffer
- (set-buffer ,old-buffer)
- (set-syntax-table ,old-table))))))))
+ (defvar message-posting-charset))
(require 'qp)
(require 'mm-util)
(require 'base64)
(autoload 'mm-body-7-or-8 "mm-bodies")
-(eval-and-compile
- ;; Avoid gnus-util for mm- code.
- (defalias 'rfc2047-point-at-bol
- (if (fboundp 'point-at-bol)
- 'point-at-bol
- 'line-beginning-position))
-
- (defalias 'rfc2047-point-at-eol
- (if (fboundp 'point-at-eol)
- 'point-at-eol
- 'line-end-position)))
-
(defvar rfc2047-header-encoding-alist
'(("Newsgroups" . nil)
("Followup-To" . nil)
("Message-ID" . nil)
- ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\)" .
- address-mime)
+ ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\
+\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime)
(t . mime))
"*Header/encoding method alist.
The list is traversed sequentially. The keys can either be
(cn-gb-2312 . B)
(euc-kr . B)
(iso-2022-jp-2 . B)
- (iso-2022-int-1 . B))
+ (iso-2022-int-1 . B)
+ (viscii . Q))
"Alist of MIME charsets to RFC2047 encodings.
Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding,
quoted-printable and base64 respectively.")
-(defvar rfc2047-encoding-function-alist
- '((Q . rfc2047-q-encode-region)
- (B . rfc2047-b-encode-region)
- (nil . ignore))
+(defvar rfc2047-encode-function-alist
+ '((Q . rfc2047-q-encode-string)
+ (B . rfc2047-b-encode-string)
+ (nil . identity))
"Alist of RFC2047 encodings to encoding functions.")
+(defvar rfc2047-encode-encoded-words t
+ "Whether encoded words should be encoded again.")
+
;;;
;;; Functions for encoding RFC2047 messages
;;;
+(defun rfc2047-qp-or-base64 ()
+ "Return the type with which to encode the buffer.
+This is either `base64' or `quoted-printable'."
+ (save-excursion
+ (let ((limit (min (point-max) (+ 2000 (point-min))))
+ (n8bit 0))
+ (goto-char (point-min))
+ (skip-chars-forward "\x20-\x7f\r\n\t" limit)
+ (while (< (point) limit)
+ (incf n8bit)
+ (forward-char 1)
+ (skip-chars-forward "\x20-\x7f\r\n\t" limit))
+ (if (or (< (* 6 n8bit) (- limit (point-min)))
+ ;; Don't base64, say, a short line with a single
+ ;; non-ASCII char when splitting parts by charset.
+ (= n8bit 1))
+ 'quoted-printable
+ 'base64))))
+
(defun rfc2047-narrow-to-field ()
"Narrow the buffer to the header on the current line."
(beginning-of-line)
(progn
(forward-line 1)
(if (re-search-forward "^[^ \n\t]" nil t)
- (progn
- (beginning-of-line)
- (point))
+ (point-at-bol)
(point-max))))
(goto-char (point-min)))
(save-restriction
(rfc2047-narrow-to-field)
(re-search-forward ":[ \t\n]*" nil t)
- (buffer-substring (point) (point-max)))))
+ (buffer-substring-no-properties (point) (point-max)))))
(defvar rfc2047-encoding-type 'address-mime
"The type of encoding done by `rfc2047-encode-region'.
(require 'message) ; for message-posting-charset
(let ((charsets
(mm-find-mime-charset-region (point-min) (point-max))))
- (and charsets
- (not (equal charsets (list (car message-posting-charset)))))))
+ (goto-char (point-min))
+ (or (and rfc2047-encode-encoded-words
+ (search-forward "=?" nil t))
+ (and charsets
+ (not (equal charsets (list (car message-posting-charset))))))))
;; Use this syntax table when parsing into regions that may need
;; encoding. Double quotes are string delimiters, backslash is
Dynamically bind `rfc2047-encoding-type' to change that."
(save-restriction
(narrow-to-region b e)
- (if (eq 'mime rfc2047-encoding-type)
- ;; Simple case. Treat as single word after any initial ASCII
- ;; part and before any tailing ASCII part. The leading ASCII
- ;; is relevant for instance in Subject headers with `Re:' for
- ;; interoperability with non-MIME clients, and we might as
- ;; well avoid the tail too.
- (progn
- (goto-char (point-min))
- ;; Does it need encoding?
- (skip-chars-forward "\000-\177")
- (unless (eobp)
- (skip-chars-backward "^ \n") ; beginning of space-delimited word
- (rfc2047-encode (point) (progn
- (goto-char e)
- (skip-chars-backward "\000-\177")
- (skip-chars-forward "^ \n")
- ;; end of space-delimited word
- (point)))))
- ;; `address-mime' case -- take care of quoted words, comments.
- (with-syntax-table rfc2047-syntax-table
- (let ((start) ; start of current token
- end ; end of current token
- ;; Whether there's an encoded word before the current
- ;; token, either immediately or separated by space.
- last-encoded)
+ (let ((encodable-regexp (if rfc2047-encode-encoded-words
+ "[^\000-\177]\\|=\\?"
+ "[^\000-\177]"))
+ start ; start of current token
+ end ; end of current token
+ ;; Whether there's an encoded word before the current token,
+ ;; either immediately or separated by space.
+ last-encoded)
+ (if (eq 'mime rfc2047-encoding-type)
+ ;; Simple case. Continuous words in which all those contain
+ ;; non-ASCII characters are encoded collectively. Encoding
+ ;; ASCII words, including `Re:' used in Subject headers, is
+ ;; avoided for interoperability with non-MIME clients and
+ ;; for making it easy to find keywords.
+ (progn
+ (goto-char (point-min))
+ (while (progn (skip-chars-forward " \t\n")
+ (not (eobp)))
+ (setq start (point))
+ (while (and (looking-at "[ \t\n]*\\([^ \t\n]+\\)")
+ (progn
+ (setq end (match-end 0))
+ (re-search-forward encodable-regexp end t)))
+ (goto-char end))
+ (if (> (point) start)
+ (rfc2047-encode start (point))
+ (goto-char end))))
+ ;; `address-mime' case -- take care of quoted words, comments.
+ (with-syntax-table rfc2047-syntax-table
(goto-char (point-min))
(condition-case nil ; in case of unbalanced quotes
;; Look for rfc2822-style: sequences of atoms, quoted
;; strings, specials, whitespace. (Specials mustn't be
;; encoded.)
(while (not (eobp))
- (setq start (point))
;; Skip whitespace.
- (unless (= 0 (skip-chars-forward " \t\n"))
- (setq start (point)))
+ (skip-chars-forward " \t\n")
+ (setq start (point))
(cond
((not (char-after))) ; eob
;; else token start
(setq last-encoded nil))
(t ; normal token/whitespace sequence
;; Find the end.
- (forward-word 1)
- (skip-chars-backward " \t")
- (setq end (point))
- ;; Deal with encoding and leading space as for
- ;; quoted words.
- (goto-char start)
- (skip-chars-forward "\000-\177" end)
- (if (= end (point))
- (setq last-encoded nil)
- (when last-encoded
- (goto-char start)
- (skip-chars-backward " \t")
- (insert ? )
- (setq start (point)
- end (1+ end)))
- (rfc2047-encode start end)
- (setq last-encoded t)))))
- (error (error "Invalid data for rfc2047 encoding: %s"
- (buffer-substring b e)))))))
+ (skip-chars-backward " \t\n")
+ (if (and (eq (char-before) ?\()
+ ;; Look for the end of parentheses.
+ (let ((string (buffer-substring (point)
+ (point-max)))
+ (default-major-mode 'fundamental-mode))
+ ;; Use `standard-syntax-table'.
+ (with-temp-buffer
+ (insert "(" string)
+ (goto-char (point-min))
+ (condition-case nil
+ (progn
+ (forward-list 1)
+ (setq end (- (point) 3)))
+ (error nil)))))
+ ;; Encode text as an unstructured field.
+ (let ((rfc2047-encoding-type 'mime))
+ (rfc2047-encode-region start (+ (point) end))
+ (forward-char))
+ ;; Skip one ASCII word, or encode continuous words
+ ;; in which all those contain non-ASCII characters.
+ (skip-chars-forward " \t\n")
+ (setq end nil)
+ (while (not end)
+ (when (looking-at "[\000-\177]+")
+ (setq end (match-end 0))
+ (if (re-search-forward "[ \t\n]\\|\\Sw" end t)
+ (goto-char (match-beginning 0))
+ (goto-char end)
+ (setq end nil)))
+ (unless end
+ (setq end t)
+ (when (looking-at "[^\000-\177]+")
+ (goto-char (match-end 0))
+ (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)")
+ (setq end (match-end 0))
+ (string-match "[^\000-\177]"
+ (match-string 1)))
+ (goto-char end))
+ (when (looking-at "[^ \t\n]+")
+ (setq end (match-end 0))
+ (if (re-search-forward "\\Sw+" end t)
+ ;; There are special characters better
+ ;; to be encoded so that MTAs may parse
+ ;; them safely.
+ (cond ((= end (point)))
+ ((looking-at "[^\000-\177]")
+ (setq end nil))
+ (t
+ (goto-char (1- (match-end 0)))
+ (unless (= (point) (match-beginning 0))
+ (insert " "))))
+ (goto-char end)
+ (skip-chars-forward " \t\n")
+ (if (and (looking-at "[^ \t\n]+")
+ (string-match "[^\000-\177]"
+ (match-string 0)))
+ (setq end nil)
+ (goto-char end)))))))
+ (skip-chars-backward " \t\n")
+ (setq end (point))
+ (goto-char start)
+ (skip-chars-forward "\000-\177" end)
+ (if (= end (point))
+ (setq last-encoded nil)
+ (rfc2047-encode start end)
+ (setq last-encoded t))))))
+ (error
+ (error "Invalid data for rfc2047 encoding: %s"
+ (buffer-substring b e)))))))
(rfc2047-fold-region b (point))))
(defun rfc2047-encode-string (string)
(rfc2047-encode-region (point-min) (point-max))
(buffer-string)))
+(defun rfc2047-encode-1 (column string cs encoder start space &optional eword)
+ "Subroutine used by `rfc2047-encode'."
+ (cond ((string-equal string "")
+ (or eword ""))
+ ((>= column 76)
+ (when (and eword
+ (string-match "\n[ \t]+\\'" eword))
+ ;; Reomove a superfluous empty line.
+ (setq eword (substring eword 0 (match-beginning 0))))
+ (rfc2047-encode-1 (length space) string cs encoder start " "
+ (concat eword "\n" space)))
+ (t
+ (let ((index 0)
+ (limit (1- (length string)))
+ (prev "")
+ next)
+ (while (and prev
+ (<= index limit))
+ (setq next (concat start
+ (funcall encoder
+ (if cs
+ (mm-encode-coding-string
+ (substring string 0 (1+ index))
+ cs)
+ (substring string 0 (1+ index))))
+ "?="))
+ (if (<= (+ column (length next)) 76)
+ (setq prev next
+ index (1+ index))
+ (setq next prev
+ prev nil)))
+ (setq eword (concat eword next))
+ (if (> index limit)
+ eword
+ (when (string-match "\n[ \t]+\\'" eword)
+ ;; Reomove a superfluous empty line.
+ (setq eword (substring eword 0 (match-beginning 0))))
+ (rfc2047-encode-1 (length space) (substring string index)
+ cs encoder start " "
+ (concat eword "\n" space)))))))
+
(defun rfc2047-encode (b e)
"Encode the word(s) in the region B to E.
By default, the region is treated as containing addresses (see
`rfc2047-encoding-type')."
- (let* ((mime-charset (mm-find-mime-charset-region b e))
- (cs (if (> (length mime-charset) 1)
- ;; Fixme: Instead of this, try to break region into
- ;; parts that can be encoded separately.
- (error "Can't rfc2047-encode `%s'"
- (buffer-substring b e))
- (setq mime-charset (car mime-charset))
- (mm-charset-to-coding-system mime-charset)))
- ;; Fixme: Better, calculate the number of non-ASCII
- ;; characters, at least for 8-bit charsets.
- (encoding (if (assq mime-charset
- rfc2047-charset-encoding-alist)
- (cdr (assq mime-charset
+ (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii)))
+ cs encoding space eword)
+ (cond ((> (length mime-charset) 1)
+ (error "Can't rfc2047-encode `%s'"
+ (buffer-substring-no-properties b e)))
+ ((= (length mime-charset) 1)
+ (setq mime-charset (car mime-charset)
+ cs (mm-charset-to-coding-system mime-charset))
+ (unless (and (mm-multibyte-p)
+ (mm-coding-system-p cs))
+ (setq cs nil))
+ (save-restriction
+ (narrow-to-region b e)
+ (setq encoding
+ (or (cdr (assq mime-charset
rfc2047-charset-encoding-alist))
- 'B))
- (start (concat
- "=?" (downcase (symbol-name mime-charset)) "?"
- (downcase (symbol-name encoding)) "?"))
- (first t))
- (if mime-charset
- (save-restriction
- (narrow-to-region b e)
- (when (eq encoding 'B)
- ;; break into lines before encoding
- (goto-char (point-min))
- (while (not (eobp))
- (goto-char (min (point-max) (+ 15 (point))))
- (unless (eobp)
- (insert ?\n))))
- (if (and (mm-multibyte-p)
- (mm-coding-system-p cs))
- (mm-encode-coding-region (point-min) (point-max) cs))
- (funcall (cdr (assq encoding rfc2047-encoding-function-alist))
- (point-min) (point-max))
- (goto-char (point-min))
- (while (not (eobp))
- (unless first
- (insert ? ))
- (setq first nil)
- (insert start)
- (end-of-line)
- (insert "?=")
- (forward-line 1))))))
+ ;; For the charsets that don't have a preferred
+ ;; encoding, choose the one that's shorter.
+ (if (eq (rfc2047-qp-or-base64) 'base64)
+ 'B
+ 'Q)))
+ (widen)
+ (goto-char b)
+ (unless (= 0 (skip-chars-backward " \t"))
+ (setq space (buffer-substring-no-properties (point) b)))
+ (setq eword (rfc2047-encode-1
+ (- b (point-at-bol))
+ (mm-replace-in-string
+ (buffer-substring-no-properties b e)
+ "\n\\([ \t]?\\)" "\\1")
+ cs
+ (or (cdr (assq encoding
+ rfc2047-encode-function-alist))
+ 'identity)
+ (concat "=?" (downcase (symbol-name mime-charset))
+ "?" (upcase (symbol-name encoding)) "?")
+ (or space " ")))
+ (delete-region (if (eq (aref eword 0) ?\n)
+ (point)
+ (goto-char b))
+ e)
+ (insert eword)
+ (unless (or (eolp)
+ (looking-at "[ \t\n)]"))
+ (insert " "))))
+ (t
+ (goto-char e)))))
(defun rfc2047-fold-field ()
"Fold the current header field."
(first t)
(bol (save-restriction
(widen)
- (rfc2047-point-at-bol))))
+ (point-at-bol))))
(while (not (eobp))
(when (and (or break qword-break)
(> (- (point) bol) 76))
(goto-char (or break qword-break))
(setq break nil
qword-break nil)
+ (skip-chars-backward " \t")
(if (looking-at "[ \t]")
(insert ?\n)
(insert "\n "))
(forward-char 1))
((memq (char-after) '(? ?\t))
(skip-chars-forward " \t")
- (if first
- ;; Don't break just after the header name.
- (setq first nil)
- (setq break (1- (point)))))
+ (unless first ;; Don't break just after the header name.
+ (setq break (point))))
((not break)
(if (not (looking-at "=\\?[^=]"))
(if (eq (char-after) ?=)
(forward-char 1)
(skip-chars-forward "^ \t\n\r="))
- (setq qword-break (point))
+ ;; Don't break at the start of the field.
+ (unless (= (point) b)
+ (setq qword-break (point)))
(skip-chars-forward "^ \t\n\r")))
(t
- (skip-chars-forward "^ \t\n\r"))))
+ (skip-chars-forward "^ \t\n\r")))
+ (setq first nil))
(when (and (or break qword-break)
(> (- (point) bol) 76))
(goto-char (or break qword-break))
(goto-char (point-min))
(let ((bol (save-restriction
(widen)
- (rfc2047-point-at-bol)))
- (eol (rfc2047-point-at-eol)))
+ (point-at-bol)))
+ (eol (point-at-eol)))
(forward-line 1)
(while (not (eobp))
(if (and (looking-at "[ \t]")
- (< (- (rfc2047-point-at-eol) bol) 76))
+ (< (- (point-at-eol) bol) 76))
(delete-region eol (progn
(goto-char eol)
(skip-chars-forward "\r\n")
(point)))
- (setq bol (rfc2047-point-at-bol)))
- (setq eol (rfc2047-point-at-eol))
+ (setq bol (point-at-bol)))
+ (setq eol (point-at-eol))
(forward-line 1)))))
-(defun rfc2047-b-encode-region (b e)
- "Base64-encode the header contained in region B to E."
- (save-restriction
- (narrow-to-region (goto-char b) e)
- (while (not (eobp))
- (base64-encode-region (point) (progn (end-of-line) (point)) t)
- (if (and (bolp) (eolp))
- (delete-backward-char 1))
- (forward-line))))
-
-(defun rfc2047-q-encode-region (b e)
- "Quoted-printable-encode the header in region B to E."
- (save-excursion
- (save-restriction
- (narrow-to-region (goto-char b) e)
- (let ((bol (save-restriction
- (widen)
- (rfc2047-point-at-bol))))
- (quoted-printable-encode-region
- b e nil
- ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
- ;; Avoid using 8bit characters.
- ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
- "\010\012\014\040-\074\076\100-\136\140-\177")
- (subst-char-in-region (point-min) (point-max) ? ?_)
- ;; The size of QP encapsulation is about 20, so set limit to
- ;; 56=76-20.
- (unless (< (- (point-max) (point-min)) 56)
- ;; Don't break if it could fit in one line.
- ;; Let rfc2047-encode-region break it later.
- (goto-char (1+ (point-min)))
- (while (and (not (bobp)) (not (eobp)))
- (goto-char (min (point-max) (+ 56 bol)))
- (search-backward "=" (- (point) 2) t)
- (unless (or (bobp) (eobp))
- (insert ?\n)
- (setq bol (point)))))))))
+(defun rfc2047-b-encode-string (string)
+ "Base64-encode the header contained in STRING."
+ (base64-encode-string string t))
+
+(defun rfc2047-q-encode-string (string)
+ "Quoted-printable-encode the header in STRING."
+ (mm-with-unibyte-buffer
+ (insert string)
+ (quoted-printable-encode-region
+ (point-min) (point-max) nil
+ ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
+ ;; Avoid using 8bit characters.
+ ;; This list excludes `especials' (see the RFC2047 syntax),
+ ;; meaning that some characters in non-structured fields will
+ ;; get encoded when they con't need to be. The following is
+ ;; what it used to be.
+ ;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
+ ;;; "\010\012\014\040-\074\076\100-\136\140-\177")
+ "-\b\n\f !#-'*+0-9A-Z\\^`-~\d")
+ (subst-char-in-region (point-min) (point-max) ? ?_)
+ (buffer-string)))
;;;
;;; Functions for decoding RFC2047 messages
(eval-and-compile
(defconst rfc2047-encoded-word-regexp
- "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\
-\\?\\([!->@-~ +]*\\)\\?="))
+ "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\
+\\?\\(B\\|Q\\)\\?\\([!->@-~ ]*\\)\\?="))
;; Fixme: This should decode in place, not cons intermediate strings.
;; Also check whether it needs to worry about delimiting fields like
mail-parse-charset
(not (eq mail-parse-charset 'us-ascii))
(not (eq mail-parse-charset 'gnus-decoded)))
- (mm-decode-coding-string string mail-parse-charset)
+ ;; `decode-coding-string' in Emacs offers a third optional
+ ;; arg NOCOPY to avoid consing a new string if the decoding
+ ;; is "trivial". Unfortunately it currently doesn't
+ ;; consider anything else than a `nil' coding system
+ ;; trivial.
+ ;; `rfc2047-decode-string' is called multiple times for each
+ ;; article during summary buffer generation, and we really
+ ;; want to avoid unnecessary consing. So we bypass
+ ;; `decode-coding-string' if the string is purely ASCII.
+ (if (and (fboundp 'detect-coding-string)
+ ;; string is purely ASCII
+ (eq (detect-coding-string string t) 'undecided))
+ string
+ (mm-decode-coding-string string mail-parse-charset))
(mm-string-as-multibyte string)))))
(defun rfc2047-parse-and-decode (word)
(condition-case nil
(rfc2047-decode
(match-string 1 word)
- (upcase (match-string 2 word))
+ (string-to-char (match-string 2 word))
(match-string 3 word))
(error word))
word))) ; un-decodable
;; Be more liberal to accept buggy base64 strings. If
;; base64-decode-string accepts buggy strings, this function could
;; be aliased to identity.
- (case (mod (length string) 4)
- (0 string)
- (1 string) ;; Error, don't pad it.
- (2 (concat string "=="))
- (3 (concat string "="))))
+ (if (= 0 (mod (length string) 4))
+ string
+ (when (string-match "=+$" string)
+ (setq string (substring string 0 (match-beginning 0))))
+ (case (mod (length string) 4)
+ (0 string)
+ (1 string) ;; Error, don't pad it.
+ (2 (concat string "=="))
+ (3 (concat string "=")))))
(defun rfc2047-decode (charset encoding string)
"Decode STRING from the given MIME CHARSET in the given ENCODING.
-Valid ENCODINGs are \"B\" and \"Q\".
+Valid ENCODINGs are the characters \"B\" and \"Q\".
If your Emacs implementation can't decode CHARSET, return nil."
(if (stringp charset)
(setq charset (intern (downcase charset))))
(setq cs mail-parse-charset))
(mm-decode-coding-string
(cond
- ((equal "B" encoding)
+ ((char-equal ?B encoding)
(base64-decode-string
(rfc2047-pad-base64 string)))
- ((equal "Q" encoding)
+ ((char-equal ?Q encoding)
(quoted-printable-decode-string
- (mm-replace-chars-in-string string ?_ ? )))
- (t (error "Invalid encoding: %s" encoding)))
+ (mm-subst-char-in-string ?_ ? string t)))
+ (t (error "Invalid encoding: %c" encoding)))
cs))))
(provide 'rfc2047)
+;;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6
;;; rfc2047.el ends here
projects / gnus / blobdiff