;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs 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.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs 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
+;; 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(eval-when-compile
- (require 'cl)
- (defvar message-posting-charset))
+ (require 'cl))
+(defvar message-posting-charset)
-(require 'qp)
(require 'mm-util)
+(require 'ietf-drums)
;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
(require 'mail-prsvr)
-(require 'base64)
+(require 'rfc2045) ;; rfc2045-encode-string
(autoload 'mm-body-7-or-8 "mm-bodies")
(defvar rfc2047-header-encoding-alist
'(("Newsgroups" . nil)
("Followup-To" . nil)
("Message-ID" . nil)
- ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\
+ ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\
\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime)
(t . mime))
"*Header/encoding method alist.
(iso-2022-jp . B)
(iso-2022-kr . B)
(gb2312 . B)
+ (gbk . B)
+ (gb18030 . B)
(big5 . B)
(cn-big5 . B)
(cn-gb . B)
(defvar rfc2047-encode-encoded-words t
"Whether encoded words should be encoded again.")
+(defvar rfc2047-allow-irregular-q-encoded-words t
+ "*Whether to decode irregular Q-encoded words.")
+
+(eval-and-compile ;; Necessary to hard code them in `rfc2047-decode-region'.
+ (defconst rfc2047-encoded-word-regexp
+ "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\
+\\(B\\?[+/0-9A-Za-z]*=*\
+\\|Q\\?[ ->@-~]*\
+\\)\\?="
+ "Regexp that matches encoded word."
+ ;; The patterns for the B encoding and the Q encoding, i.e. the ones
+ ;; beginning with "B" and "Q" respectively, are restricted into only
+ ;; the characters that those encodings may generally use.
+ )
+ (defconst rfc2047-encoded-word-regexp-loose
+ "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\
+\\(B\\?[+/0-9A-Za-z]*=*\
+\\|Q\\?\\(?:\\?+[ -<>@-~]\\)?\\(?:[ ->@-~]+\\?+[ -<>@-~]\\)*[ ->@-~]*\\?*\
+\\)\\?="
+ "Regexp that matches encoded word allowing loose Q encoding."
+ ;; The pattern for the Q encoding, i.e. the one beginning with "Q",
+ ;; is similar to:
+ ;; "Q\\?\\(\\?+[^\n=?]\\)?\\([^\n?]+\\?+[^\n=?]\\)*[^\n?]*\\?*"
+ ;; <--------1-------><----------2,3----------><--4--><-5->
+ ;; They mean:
+ ;; 1. After "Q?", allow "?"s that follow a character other than "=".
+ ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator.
+ ;; 3. In the middle of an encoded word, allow "?"s that follow a
+ ;; character other than "=".
+ ;; 4. Allow any characters other than "?" in the middle of an
+ ;; encoded word.
+ ;; 5. At the end, allow "?"s.
+ ))
+
;;;
;;; Functions for encoding RFC2047 messages
;;;
(re-search-forward ":[ \t\n]*" nil t)
(buffer-substring-no-properties (point) (point-max)))))
+(defun rfc2047-quote-special-characters-in-quoted-strings (&optional
+ encodable-regexp)
+ "Quote special characters with `\\'s in quoted strings.
+Quoting will not be done in a quoted string if it contains characters
+matching ENCODABLE-REGEXP or it is within parentheses."
+ (goto-char (point-min))
+ (let ((tspecials (concat "[" ietf-drums-tspecials "]"))
+ (start (point))
+ beg end)
+ (with-syntax-table (standard-syntax-table)
+ (while (not (eobp))
+ (if (ignore-errors
+ (forward-list 1)
+ (eq (char-before) ?\)))
+ (forward-list -1)
+ (goto-char (point-max)))
+ (save-restriction
+ (narrow-to-region start (point))
+ (goto-char start)
+ (while (search-forward "\"" nil t)
+ (setq beg (match-beginning 0))
+ (unless (eq (char-before beg) ?\\)
+ (goto-char beg)
+ (setq beg (1+ beg))
+ (condition-case nil
+ (progn
+ (forward-sexp)
+ (setq end (1- (point)))
+ (goto-char beg)
+ (if (and encodable-regexp
+ (re-search-forward encodable-regexp end t))
+ (goto-char (1+ end))
+ (save-restriction
+ (narrow-to-region beg end)
+ (while (re-search-forward tspecials nil 'move)
+ (if (eq (char-before) ?\\)
+ (if (looking-at tspecials) ;; Already quoted.
+ (forward-char)
+ (insert "\\"))
+ (goto-char (match-beginning 0))
+ (insert "\\")
+ (forward-char))))
+ (forward-char)))
+ (error
+ (goto-char beg)))))
+ (goto-char (point-max)))
+ (forward-list 1)
+ (setq start (point))))))
+
(defvar rfc2047-encoding-type 'address-mime
"The type of encoding done by `rfc2047-encode-region'.
This should be dynamically bound around calls to
(interactive "*")
(save-excursion
(goto-char (point-min))
- (let (alist elem method)
+ (let (alist elem method charsets)
(while (not (eobp))
(save-restriction
(rfc2047-narrow-to-field)
- (if (not (rfc2047-encodable-p))
- (prog1
- (if (and (eq (mm-body-7-or-8) '8bit)
- (mm-multibyte-p)
- (mm-coding-system-p
- (car message-posting-charset)))
- ;; 8 bit must be decoded.
- (mm-encode-coding-region
- (point-min) (point-max)
- (mm-charset-to-coding-system
- (car message-posting-charset))))
- ;; No encoding necessary, but folding is nice
- (rfc2047-fold-region
- (save-excursion
- (goto-char (point-min))
- (skip-chars-forward "^:")
- (when (looking-at ": ")
- (forward-char 2))
- (point))
- (point-max)))
- ;; We found something that may perhaps be encoded.
- (setq method nil
- alist rfc2047-header-encoding-alist)
+ (setq method nil
+ alist rfc2047-header-encoding-alist
+ charsets (mm-find-mime-charset-region (point-min) (point-max)))
+ ;; M$ Outlook boycotts decoding of a header if it consists
+ ;; of two or more encoded words and those charsets differ;
+ ;; it seems to decode all words in a header from a charset
+ ;; found first in the header. So, we unify the charsets into
+ ;; a single one used for encoding the whole text in a header.
+ (let ((mm-coding-system-priorities
+ (if (= (length charsets) 1)
+ (cons (mm-charset-to-coding-system (car charsets))
+ mm-coding-system-priorities)
+ mm-coding-system-priorities)))
(while (setq elem (pop alist))
(when (or (and (stringp (car elem))
(looking-at (car elem)))
(eq (car elem) t))
(setq alist nil
method (cdr elem))))
- (goto-char (point-min))
- (re-search-forward "^[^:]+: *" nil t)
- (cond
- ((eq method 'address-mime)
- (rfc2047-encode-region (point) (point-max)))
- ((eq method 'mime)
- (let ((rfc2047-encoding-type 'mime))
- (rfc2047-encode-region (point) (point-max))))
- ((eq method 'default)
- (if (and (featurep 'mule)
- (if (boundp 'default-enable-multibyte-characters)
- default-enable-multibyte-characters)
- mail-parse-charset)
- (mm-encode-coding-region (point) (point-max)
- mail-parse-charset)))
- ;; We get this when CC'ing messsages to newsgroups with
- ;; 8-bit names. The group name mail copy just got
- ;; unconditionally encoded. Previously, it would ask
- ;; whether to encode, which was quite confusing for the
- ;; user. If the new behaviour is wrong, tell me. I have
- ;; left the old code commented out below.
- ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07.
- ;; Modified by Dave Love, with the commented-out code changed
- ;; in accordance with changes elsewhere.
- ((null method)
- (rfc2047-encode-region (point) (point-max)))
-;;; ((null method)
-;;; (if (or (message-options-get
-;;; 'rfc2047-encode-message-header-encode-any)
-;;; (message-options-set
-;;; 'rfc2047-encode-message-header-encode-any
-;;; (y-or-n-p
-;;; "Some texts are not encoded. Encode anyway?")))
-;;; (rfc2047-encode-region (point-min) (point-max))
-;;; (error "Cannot send unencoded text")))
- ((mm-coding-system-p method)
- (if (and (featurep 'mule)
- (if (boundp 'default-enable-multibyte-characters)
- default-enable-multibyte-characters))
- (mm-encode-coding-region (point) (point-max) method)))
- ;; Hm.
- (t)))
- (goto-char (point-max)))))))
+ (if (not (rfc2047-encodable-p))
+ (prog2
+ (when (eq method 'address-mime)
+ (rfc2047-quote-special-characters-in-quoted-strings))
+ (if (and (eq (mm-body-7-or-8) '8bit)
+ (mm-multibyte-p)
+ (mm-coding-system-p
+ (car message-posting-charset)))
+ ;; 8 bit must be decoded.
+ (mm-encode-coding-region
+ (point-min) (point-max)
+ (mm-charset-to-coding-system
+ (car message-posting-charset))))
+ ;; No encoding necessary, but folding is nice
+ (when nil
+ (rfc2047-fold-region
+ (save-excursion
+ (goto-char (point-min))
+ (skip-chars-forward "^:")
+ (when (looking-at ": ")
+ (forward-char 2))
+ (point))
+ (point-max))))
+ ;; We found something that may perhaps be encoded.
+ (re-search-forward "^[^:]+: *" nil t)
+ (cond
+ ((eq method 'address-mime)
+ (rfc2047-encode-region (point) (point-max)))
+ ((eq method 'mime)
+ (let ((rfc2047-encoding-type 'mime))
+ (rfc2047-encode-region (point) (point-max))))
+ ((eq method 'default)
+ (if (and (featurep 'mule)
+ (if (boundp 'enable-multibyte-characters)
+ (default-value 'enable-multibyte-characters))
+ mail-parse-charset)
+ (mm-encode-coding-region (point) (point-max)
+ mail-parse-charset)))
+ ;; We get this when CC'ing messages to newsgroups with
+ ;; 8-bit names. The group name mail copy just got
+ ;; unconditionally encoded. Previously, it would ask
+ ;; whether to encode, which was quite confusing for the
+ ;; user. If the new behavior is wrong, tell me. I have
+ ;; left the old code commented out below.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07.
+ ;; Modified by Dave Love, with the commented-out code changed
+ ;; in accordance with changes elsewhere.
+ ((null method)
+ (rfc2047-encode-region (point) (point-max)))
+;;; ((null method)
+;;; (if (or (message-options-get
+;;; 'rfc2047-encode-message-header-encode-any)
+;;; (message-options-set
+;;; 'rfc2047-encode-message-header-encode-any
+;;; (y-or-n-p
+;;; "Some texts are not encoded. Encode anyway?")))
+;;; (rfc2047-encode-region (point-min) (point-max))
+;;; (error "Cannot send unencoded text")))
+ ((mm-coding-system-p method)
+ (if (or (and (featurep 'mule)
+ (if (boundp 'enable-multibyte-characters)
+ (default-value 'enable-multibyte-characters)))
+ (featurep 'file-coding))
+ (mm-encode-coding-region (point) (point-max) method)))
+ ;; Hm.
+ (t)))
+ (goto-char (point-max))))))))
;; Fixme: This, and the require below may not be the Right Thing, but
;; should be safe just before release. -- fx 2001-02-08
-(eval-when-compile (defvar message-posting-charset))
(defun rfc2047-encodable-p ()
"Return non-nil if any characters in current buffer need encoding in headers.
(goto-char (point-min))
(or (and rfc2047-encode-encoded-words
(prog1
- (search-forward "=?" nil t)
+ (re-search-forward rfc2047-encoded-word-regexp nil t)
(goto-char (point-min))))
(and charsets
(not (equal charsets (list (car message-posting-charset))))))))
(defconst rfc2047-syntax-table
;; (make-char-table 'syntax-table '(2)) only works in Emacs.
(let ((table (make-syntax-table)))
- ;; The following is done to work for setting all elements of the table
- ;; in Emacs 21 and 22 and XEmacs; it appears to be the cleanest way.
+ ;; The following is done to work for setting all elements of the table;
+ ;; it appears to be the cleanest way.
;; Play safe and don't assume the form of the word syntax entry --
;; copy it from ?a.
- (if (fboundp 'set-char-table-range) ; Emacs
- (funcall (intern "set-char-table-range")
- table t (aref (standard-syntax-table) ?a))
- (if (fboundp 'put-char-table)
- (if (fboundp 'get-char-table) ; warning avoidance
- (put-char-table t (get-char-table ?a (standard-syntax-table))
- table))))
+ (if (featurep 'xemacs)
+ (put-char-table t (get-char-table ?a (standard-syntax-table)) table)
+ (set-char-table-range table t (aref (standard-syntax-table) ?a)))
(modify-syntax-entry ?\\ "\\" table)
(modify-syntax-entry ?\" "\"" table)
- (modify-syntax-entry ?\( "." table)
- (modify-syntax-entry ?\) "." table)
+ (modify-syntax-entry ?\( "(" table)
+ (modify-syntax-entry ?\) ")" table)
(modify-syntax-entry ?\< "." table)
(modify-syntax-entry ?\> "." table)
(modify-syntax-entry ?\[ "." table)
(modify-syntax-entry ?@ "." table)
table))
-(defun rfc2047-encode-region (b e)
+(defun rfc2047-encode-region (b e &optional dont-fold)
"Encode words in region B to E that need encoding.
By default, the region is treated as containing RFC2822 addresses.
Dynamically bind `rfc2047-encoding-type' to change that."
(save-restriction
(narrow-to-region b e)
(let ((encodable-regexp (if rfc2047-encode-encoded-words
- "[^\000-\177]\\|=\\?"
- "[^\000-\177]"))
+ "[^\000-\177]+\\|=\\?"
+ "[^\000-\177]+"))
start ; start of current token
- end ; end of current token
+ end begin csyntax
;; Whether there's an encoded word before the current token,
;; either immediately or separated by space.
- last-encoded)
+ last-encoded
+ (orig-text (buffer-substring-no-properties b e)))
(if (eq 'mime rfc2047-encoding-type)
;; Simple case. Continuous words in which all those contain
;; non-ASCII characters are encoded collectively. Encoding
(rfc2047-encode start (point))
(goto-char end))))
;; `address-mime' case -- take care of quoted words, comments.
+ (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp)
(with-syntax-table rfc2047-syntax-table
(goto-char (point-min))
- (condition-case nil ; in case of unbalanced quotes
+ (condition-case err ; in case of unbalanced quotes
;; Look for rfc2822-style: sequences of atoms, quoted
;; strings, specials, whitespace. (Specials mustn't be
;; encoded.)
(cond
((not (char-after))) ; eob
;; else token start
- ((eq ?\" (char-syntax (char-after)))
+ ((eq ?\" (setq csyntax (char-syntax (char-after))))
;; Quoted word.
(forward-sexp)
(setq end (point))
;; Does it need encoding?
(goto-char start)
- (skip-chars-forward "\000-\177" end)
- (if (= end (point))
- (setq last-encoded nil)
- ;; It needs encoding. Strip the quotes first,
- ;; since encoded words can't occur in quotes.
- (goto-char end)
- (delete-backward-char 1)
- (goto-char start)
- (delete-char 1)
- (when last-encoded
- ;; There was a preceding quoted word. We need
- ;; to include any separating whitespace in this
- ;; word to avoid it getting lost.
- (skip-chars-backward " \t")
- ;; A space is needed between the encoded words.
- (insert ? )
- (setq start (point)
- end (1+ end)))
- ;; Adjust the end position for the deleted quotes.
- (rfc2047-encode start (- end 2))
- (setq last-encoded t))) ; record that it was encoded
- ((eq ?. (char-syntax (char-after)))
+ (if (re-search-forward encodable-regexp end 'move)
+ ;; It needs encoding. Strip the quotes first,
+ ;; since encoded words can't occur in quotes.
+ (progn
+ (goto-char end)
+ (delete-char -1)
+ (goto-char start)
+ (delete-char 1)
+ (when last-encoded
+ ;; There was a preceding quoted word. We need
+ ;; to include any separating whitespace in this
+ ;; word to avoid it getting lost.
+ (skip-chars-backward " \t")
+ ;; A space is needed between the encoded words.
+ (insert ? )
+ (setq start (point)
+ end (1+ end)))
+ ;; Adjust the end position for the deleted quotes.
+ (rfc2047-encode start (- end 2))
+ (setq last-encoded t)) ; record that it was encoded
+ (setq last-encoded nil)))
+ ((eq ?. csyntax)
;; Skip other delimiters, but record that they've
;; potentially separated quoted words.
(forward-char)
(setq last-encoded nil))
+ ((eq ?\) csyntax)
+ (error "Unbalanced parentheses"))
+ ((eq ?\( csyntax)
+ ;; Look for the end of parentheses.
+ (forward-list)
+ ;; Encode text as an unstructured field.
+ (let ((rfc2047-encoding-type 'mime))
+ (rfc2047-encode-region (1+ start) (1- (point))))
+ (skip-chars-forward ")"))
(t ; normal token/whitespace sequence
;; Find the end.
+ ;; Skip one ASCII word, or encode continuous words
+ ;; in which all those contain non-ASCII characters.
+ (setq end nil)
+ (while (not (or end (eobp)))
+ (when (looking-at "[\000-\177]+")
+ (setq begin (point)
+ end (match-end 0))
+ (when (progn
+ (while (and (or (re-search-forward
+ "[ \t\n]\\|\\Sw" end 'move)
+ (setq end nil))
+ (eq ?\\ (char-syntax (char-before))))
+ ;; Skip backslash-quoted characters.
+ (forward-char))
+ end)
+ (setq end (match-beginning 0))
+ (if rfc2047-encode-encoded-words
+ (progn
+ (goto-char begin)
+ (when (search-forward "=?" end 'move)
+ (goto-char (match-beginning 0))
+ (setq end nil)))
+ (goto-char end))))
+ ;; Where the value nil of `end' means there may be
+ ;; text to have to be encoded following the point.
+ ;; Otherwise, the point reached to the end of ASCII
+ ;; words separated by whitespace or a special char.
+ (unless end
+ (when (looking-at encodable-regexp)
+ (goto-char (setq begin (match-end 0)))
+ (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)")
+ (setq end (match-end 0))
+ (progn
+ (while (re-search-forward
+ encodable-regexp end t))
+ (< begin (point)))
+ (goto-char begin)
+ (or (not (re-search-forward "\\Sw" end t))
+ (progn
+ (goto-char (match-beginning 0))
+ nil)))
+ (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 (concat "\\sw*\\("
+ encodable-regexp
+ "\\)"))
+ (setq end nil))
+ (t
+ (goto-char (1- (match-end 0)))
+ (unless (= (point) (match-beginning 0))
+ ;; Separate encodable text and
+ ;; delimiter.
+ (insert " "))))
+ (goto-char end)
+ (skip-chars-forward " \t\n")
+ (if (and (looking-at "[^ \t\n]+")
+ (string-match encodable-regexp
+ (match-string 0)))
+ (setq end nil)
+ (goto-char end)))))))
(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))))))
+ (setq end (point))
+ (goto-char start)
+ (if (re-search-forward encodable-regexp end 'move)
+ (progn
+ (unless (memq (char-before start) '(nil ?\t ? ))
+ (if (progn
+ (goto-char start)
+ (skip-chars-backward "^ \t\n")
+ (and (looking-at "\\Sw+")
+ (= (match-end 0) start)))
+ ;; Also encode bogus delimiters.
+ (setq start (point))
+ ;; Separate encodable text and delimiter.
+ (goto-char start)
+ (insert " ")
+ (setq start (1+ start)
+ end (1+ end))))
+ (rfc2047-encode start end)
+ (setq last-encoded t))
+ (setq last-encoded nil)))))
(error
- (error "Invalid data for rfc2047 encoding: %s"
- (buffer-substring b e)))))))
- (rfc2047-fold-region b (point))))
+ (if (or debug-on-quit debug-on-error)
+ (signal (car err) (cdr err))
+ (error "Invalid data for rfc2047 encoding: %s"
+ (mm-replace-in-string orig-text "[ \t\n]+" " "))))))))
+ (unless dont-fold
+ (rfc2047-fold-region b (point)))
+ (goto-char (point-max))))
-(defun rfc2047-encode-string (string)
+(defun rfc2047-encode-string (string &optional dont-fold)
"Encode words in STRING.
By default, the string is treated as containing addresses (see
`rfc2047-encoding-type')."
- (with-temp-buffer
+ (mm-with-multibyte-buffer
(insert string)
- (rfc2047-encode-region (point-min) (point-max))
+ (rfc2047-encode-region (point-min) (point-max) dont-fold)
(buffer-string)))
-(defun rfc2047-encode-1 (column string cs encoder start space &optional eword)
+;; From RFC 2047:
+;; 2. Syntax of encoded-words
+;; [...]
+;; While there is no limit to the length of a multiple-line header
+;; field, each line of a header field that contains one or more
+;; 'encoded-word's is limited to 76 characters.
+;;
+;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it.
+(defvar rfc2047-encode-max-chars 76
+ "Maximum characters of each header line that contain encoded-words.
+According to RFC 2047, it is 76. If it is nil, encoded-words
+will not be folded. Too small value may cause an error. You
+should not change this value.")
+
+(defun rfc2047-encode-1 (column string cs encoder start crest tail
+ &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)))
+ ((not rfc2047-encode-max-chars)
+ (concat start
+ (funcall encoder (if cs
+ (mm-encode-coding-string string cs)
+ string))
+ "?="))
+ ((>= column rfc2047-encode-max-chars)
+ (when eword
+ (cond ((string-match "\n[ \t]+\\'" eword)
+ ;; Remove a superfluous empty line.
+ (setq eword (substring eword 0 (match-beginning 0))))
+ ((string-match "(+\\'" eword)
+ ;; Break the line before the open parenthesis.
+ (setq crest (concat crest (match-string 0 eword))
+ eword (substring eword 0 (match-beginning 0))))))
+ (rfc2047-encode-1 (length crest) string cs encoder start " " tail
+ (concat eword "\n" crest)))
(t
(let ((index 0)
(limit (1- (length string)))
(prev "")
- next)
+ next len)
(while (and prev
(<= index limit))
(setq next (concat start
(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))
+ "?=")
+ len (+ column (length next)))
+ (if (> len rfc2047-encode-max-chars)
+ (setq next prev
+ prev nil)
+ (if (or (< index limit)
+ (<= (+ len (or (string-match "\n" tail)
+ (length tail)))
+ rfc2047-encode-max-chars))
+ (setq prev next
+ index (1+ index))
+ (if (string-match "\\`)+" tail)
+ ;; Break the line after the close parenthesis.
+ (setq tail (concat (substring tail 0 (match-end 0))
+ "\n "
+ (substring tail (match-end 0)))
+ prev next
+ index (1+ index))
+ (setq next prev
+ prev nil)))))
(if (> index limit)
- eword
+ (concat eword next tail)
+ (if (= 0 index)
+ (if (and eword
+ (string-match "(+\\'" eword))
+ (setq crest (concat crest (match-string 0 eword))
+ eword (substring eword 0 (match-beginning 0)))
+ (setq eword (concat eword next)))
+ (setq crest " "
+ eword (concat eword next)))
(when (string-match "\n[ \t]+\\'" eword)
- ;; Reomove a superfluous empty line.
+ ;; Remove 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)))))))
+ (rfc2047-encode-1 (length crest) (substring string index)
+ cs encoder start " " tail
+ (concat eword "\n" crest)))))))
(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')."
+Point moves to the end of the region."
(let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii)))
- cs encoding space eword)
+ cs encoding tail crest eword)
+ ;; Use utf-8 as a last resort if determining charset of text fails.
+ (if (memq nil mime-charset)
+ (setq mime-charset (list 'utf-8)))
(cond ((> (length mime-charset) 1)
(error "Can't rfc2047-encode `%s'"
(buffer-substring-no-properties b e)))
'B
'Q)))
(widen)
+ (goto-char e)
+ (skip-chars-forward "^ \t\n")
+ ;; `tail' may contain a close parenthesis.
+ (setq tail (buffer-substring-no-properties e (point)))
+ (goto-char b)
+ (setq b (point-marker)
+ e (set-marker (make-marker) e))
+ (rfc2047-fold-region (point-at-bol) b)
(goto-char b)
+ (skip-chars-backward "^ \t\n")
(unless (= 0 (skip-chars-backward " \t"))
- (setq space (buffer-substring-no-properties (point) b)))
+ ;; `crest' may contain whitespace and an open parenthesis.
+ (setq crest (buffer-substring-no-properties (point) b)))
(setq eword (rfc2047-encode-1
(- b (point-at-bol))
(mm-replace-in-string
'identity)
(concat "=?" (downcase (symbol-name mime-charset))
"?" (upcase (symbol-name encoding)) "?")
- (or space " ")))
+ (or crest " ")
+ tail))
(delete-region (if (eq (aref eword 0) ?\n)
- (point)
+ (if (bolp)
+ ;; The line was folded before encoding.
+ (1- (point))
+ (point))
(goto-char b))
- e)
+ (+ e (length tail)))
+ ;; `eword' contains `crest' and `tail'.
(insert eword)
- (unless (or (eolp)
+ (set-marker b nil)
+ (set-marker e nil)
+ (unless (or (/= 0 (length tail))
+ (eobp)
(looking-at "[ \t\n)]"))
(insert " "))))
(t
(goto-char (or break qword-break))
(setq break nil
qword-break nil)
- (if (looking-at "[ \t]")
- (insert ?\n)
- (insert "\n "))
+ (if (or (> 0 (skip-chars-backward " \t"))
+ (looking-at "[ \t]"))
+ (insert ?\n)
+ (insert "\n "))
(setq bol (1- (point)))
;; Don't break before the first non-LWSP characters.
(skip-chars-forward " \t")
"Base64-encode the header contained in STRING."
(base64-encode-string string t))
+(autoload 'quoted-printable-encode-region "qp")
+
(defun rfc2047-q-encode-string (string)
"Quoted-printable-encode the header in STRING."
(mm-with-unibyte-buffer
(subst-char-in-region (point-min) (point-max) ? ?_)
(buffer-string)))
+(defun rfc2047-encode-parameter (param value)
+ "Return and PARAM=VALUE string encoded in the RFC2047-like style.
+This is a substitution for the `rfc2231-encode-string' function, that
+is the standard but many mailers don't support it."
+ (let ((rfc2047-encoding-type 'mime)
+ (rfc2047-encode-max-chars nil))
+ (rfc2045-encode-string param (rfc2047-encode-string value t))))
+
;;;
;;; Functions for decoding RFC2047 messages
;;;
-(eval-and-compile
- (defconst rfc2047-encoded-word-regexp
- "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\
-\\?\\(B\\|Q\\)\\?\\([!->@-~ ]*\\)\\?="))
+(defvar rfc2047-quote-decoded-words-containing-tspecials nil
+ "If non-nil, quote decoded words containing special characters.")
+
+(defvar rfc2047-allow-incomplete-encoded-text t
+ "*Non-nil means allow incomplete encoded-text in successive encoded-words.
+Dividing of encoded-text in the place other than character boundaries
+violates RFC2047 section 5, while we have a capability to decode it.
+If it is non-nil, the decoder will decode B- or Q-encoding in each
+encoded-word, concatenate them, and decode it by charset. Otherwise,
+the decoder will fully decode each encoded-word before concatenating
+them.")
+
+(defun rfc2047-strip-backslashes-in-quoted-strings ()
+ "Strip backslashes in quoted strings. `\\\"' remains."
+ (goto-char (point-min))
+ (let (beg)
+ (with-syntax-table (standard-syntax-table)
+ (while (search-forward "\"" nil t)
+ (unless (eq (char-before) ?\\)
+ (setq beg (match-end 0))
+ (goto-char (match-beginning 0))
+ (condition-case nil
+ (progn
+ (forward-sexp)
+ (save-restriction
+ (narrow-to-region beg (1- (point)))
+ (goto-char beg)
+ (while (search-forward "\\" nil 'move)
+ (unless (memq (char-after) '(?\"))
+ (delete-char -1))
+ (forward-char)))
+ (forward-char))
+ (error
+ (goto-char beg))))))))
+
+(defun rfc2047-charset-to-coding-system (charset &optional allow-override)
+ "Return coding-system corresponding to MIME CHARSET.
+If your Emacs implementation can't decode CHARSET, return nil.
+
+If allow-override is given, use `mm-charset-override-alist' to
+map undesired charset names to their replacement. This should
+only be used for decoding, not for encoding."
+ (when (stringp charset)
+ (setq charset (intern (downcase charset))))
+ (when (or (not charset)
+ (eq 'gnus-all mail-parse-ignored-charsets)
+ (memq 'gnus-all mail-parse-ignored-charsets)
+ (memq charset mail-parse-ignored-charsets))
+ (setq charset mail-parse-charset))
+ (let ((cs (mm-charset-to-coding-system charset nil allow-override)))
+ (cond ((eq cs 'ascii)
+ (setq cs (or (mm-charset-to-coding-system mail-parse-charset)
+ 'raw-text)))
+ ((mm-coding-system-p cs))
+ ((and charset
+ (listp mail-parse-ignored-charsets)
+ (memq 'gnus-unknown mail-parse-ignored-charsets))
+ (setq cs (mm-charset-to-coding-system mail-parse-charset))))
+ (if (eq cs 'ascii)
+ 'raw-text
+ cs)))
+
+(autoload 'quoted-printable-decode-string "qp")
+
+(defun rfc2047-decode-encoded-words (words)
+ "Decode successive encoded-words in WORDS and return a decoded string.
+Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT
+ENCODED-WORD)."
+ (let (word charset cs encoding text rest)
+ (while words
+ (setq word (pop words))
+ (if (and (setq cs (rfc2047-charset-to-coding-system
+ (setq charset (car word)) t))
+ (condition-case code
+ (cond ((char-equal ?B (nth 1 word))
+ (setq text (base64-decode-string
+ (rfc2047-pad-base64 (nth 2 word)))))
+ ((char-equal ?Q (nth 1 word))
+ (setq text (quoted-printable-decode-string
+ (mm-subst-char-in-string
+ ?_ ? (nth 2 word) t)))))
+ (error
+ (message "%s" (error-message-string code))
+ nil)))
+ (if (and rfc2047-allow-incomplete-encoded-text
+ (eq cs (caar rest)))
+ ;; Concatenate text of which the charset is the same.
+ (setcdr (car rest) (concat (cdar rest) text))
+ (push (cons cs text) rest))
+ ;; Don't decode encoded-word.
+ (push (cons nil (nth 3 word)) rest)))
+ (while rest
+ (setq words (concat
+ (or (and (setq cs (caar rest))
+ (condition-case code
+ (mm-decode-coding-string (cdar rest) cs)
+ (error
+ (message "%s" (error-message-string code))
+ nil)))
+ (concat (when (cdr rest) " ")
+ (cdar rest)
+ (when (and words
+ (not (eq (string-to-char words) ? )))
+ " ")))
+ words)
+ rest (cdr rest)))
+ words))
;; Fixme: This should decode in place, not cons intermediate strings.
;; Also check whether it needs to worry about delimiting fields like
;; and worthwhile (is it more correct or not?), e.g. something like
;; `=?iso-8859-1?q?foo?=@'.
-(defun rfc2047-decode-region (start end)
- "Decode MIME-encoded words in region between START and END."
+(defun rfc2047-decode-region (start end &optional address-mime)
+ "Decode MIME-encoded words in region between START and END.
+If ADDRESS-MIME is non-nil, strip backslashes which precede characters
+other than `\"' and `\\' in quoted strings."
(interactive "r")
(let ((case-fold-search t)
- b e)
+ (eword-regexp
+ (if rfc2047-allow-irregular-q-encoded-words
+ (eval-when-compile
+ (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)"))
+ (eval-when-compile
+ (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)"))))
+ b e match words)
(save-excursion
(save-restriction
(narrow-to-region start end)
- (goto-char (point-min))
- ;; Remove whitespace between encoded words.
- (while (re-search-forward
- (eval-when-compile
- (concat "\\(" rfc2047-encoded-word-regexp "\\)"
- "\\(\n?[ \t]\\)+"
- "\\(" rfc2047-encoded-word-regexp "\\)"))
- nil t)
- (delete-region (goto-char (match-end 1)) (match-beginning 6)))
- ;; Decode the encoded words.
- (setq b (goto-char (point-min)))
- (while (re-search-forward rfc2047-encoded-word-regexp nil t)
- (setq e (match-beginning 0))
- (insert (rfc2047-parse-and-decode
- (prog1
- (match-string 0)
- (delete-region (match-beginning 0) (match-end 0)))))
- ;; Remove newlines between decoded words, though such things
- ;; essentially must not be there.
+ (when address-mime
+ (rfc2047-strip-backslashes-in-quoted-strings))
+ (goto-char (setq b start))
+ ;; Look for the encoded-words.
+ (while (setq match (re-search-forward eword-regexp nil t))
+ (setq e (match-beginning 1)
+ end (match-end 0)
+ words nil)
+ (while match
+ (push (list (match-string 2) ;; charset
+ (char-after (match-beginning 3)) ;; encoding
+ (substring (match-string 3) 2) ;; encoded-text
+ (match-string 1)) ;; encoded-word
+ words)
+ ;; Look for the subsequent encoded-words.
+ (when (setq match (looking-at eword-regexp))
+ (goto-char (setq end (match-end 0)))))
+ ;; Replace the encoded-words with the decoded one.
+ (delete-region e end)
+ (insert (rfc2047-decode-encoded-words (nreverse words)))
(save-restriction
(narrow-to-region e (point))
(goto-char e)
+ ;; Remove newlines between decoded words, though such
+ ;; things essentially must not be there.
(while (re-search-forward "[\n\r]+" nil t)
(replace-match " "))
+ (setq end (point-max))
+ ;; Quote decoded words if there are special characters
+ ;; which might violate RFC2822.
+ (when (and rfc2047-quote-decoded-words-containing-tspecials
+ (let ((regexp (car (rassq
+ 'address-mime
+ rfc2047-header-encoding-alist))))
+ (when regexp
+ (save-restriction
+ (widen)
+ (and
+ ;; Don't quote words if already quoted.
+ (not (and (eq (char-before e) ?\")
+ (eq (char-after end) ?\")))
+ (progn
+ (beginning-of-line)
+ (while (and (memq (char-after) '(? ?\t))
+ (zerop (forward-line -1))))
+ (looking-at regexp)))))))
+ (let (quoted)
+ (goto-char e)
+ (skip-chars-forward " \t")
+ (setq start (point))
+ (setq quoted (eq (char-after) ?\"))
+ (goto-char (point-max))
+ (skip-chars-backward " \t" start)
+ (if (setq quoted (and quoted
+ (> (point) (1+ start))
+ (eq (char-before) ?\")))
+ (progn
+ (backward-char)
+ (setq start (1+ start)
+ end (point-marker)))
+ (setq end (point-marker)))
+ (goto-char start)
+ (while (search-forward "\"" end t)
+ (when (prog2
+ (backward-char)
+ (zerop (% (skip-chars-backward "\\\\") 2))
+ (goto-char (match-beginning 0)))
+ (insert "\\"))
+ (forward-char))
+ (when (and (not quoted)
+ (progn
+ (goto-char start)
+ (re-search-forward
+ (concat "[" ietf-drums-tspecials "]")
+ end t)))
+ (goto-char start)
+ (insert "\"")
+ (goto-char end)
+ (insert "\""))
+ (set-marker end nil)))
(goto-char (point-max)))
(when (and (mm-multibyte-p)
mail-parse-charset
(not (eq mail-parse-charset 'gnus-decoded)))
(mm-decode-coding-region b (point-max) mail-parse-charset))))))
-(defun rfc2047-decode-string (string)
- "Decode the quoted-printable-encoded STRING and return the results."
- (let ((m (mm-multibyte-p)))
+(defun rfc2047-decode-address-region (start end)
+ "Decode MIME-encoded words in region between START and END.
+Backslashes which precede characters other than `\"' and `\\' in quoted
+strings are stripped."
+ (rfc2047-decode-region start end t))
+
+(defun rfc2047-decode-string (string &optional address-mime)
+ "Decode MIME-encoded STRING and return the result.
+If ADDRESS-MIME is non-nil, strip backslashes which precede characters
+other than `\"' and `\\' in quoted strings."
+ ;; (let ((m (mm-multibyte-p)))
(if (string-match "=\\?" string)
(with-temp-buffer
- ;; Fixme: This logic is wrong, but seems to be required by
- ;; Gnus summary buffer generation. The value of `m' depends
- ;; on the current buffer, not global multibyteness or that
- ;; of the string. Also the string returned should always be
- ;; multibyte in a multibyte session, i.e. the buffer should
- ;; be multibyte before `buffer-string' is called.
- (when m
- (mm-enable-multibyte))
+ ;; We used to only call mm-enable-multibyte if `m' is non-nil,
+ ;; but this can't be the right criterion. Don't just revert this
+ ;; change if it encounters a bug. Please help me fix it
+ ;; right instead. --Stef
+ ;; The string returned should always be multibyte in a multibyte
+ ;; session, i.e. the buffer should be multibyte before
+ ;; `buffer-string' is called.
+ (mm-enable-multibyte)
(insert string)
(inline
- (rfc2047-decode-region (point-min) (point-max)))
+ (rfc2047-decode-region (point-min) (point-max) address-mime))
(buffer-string))
+ (when address-mime
+ (setq string
+ (with-temp-buffer
+ (when (mm-multibyte-string-p string)
+ (mm-enable-multibyte))
+ (insert string)
+ (rfc2047-strip-backslashes-in-quoted-strings)
+ (buffer-string))))
;; Fixme: As above, `m' here is inappropriate.
- (if (and m
+ (if (and ;; m
mail-parse-charset
(not (eq mail-parse-charset 'us-ascii))
(not (eq mail-parse-charset 'gnus-decoded)))
(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)
- "Decode WORD and return it if it is an encoded word.
-Return WORD if it is not not an encoded word or if the charset isn't
-decodable."
- (if (not (string-match rfc2047-encoded-word-regexp word))
- word
- (or
- (condition-case nil
- (rfc2047-decode
- (match-string 1 word)
- (string-to-char (match-string 2 word))
- (match-string 3 word))
- (error word))
- word))) ; un-decodable
+ string
+ (mm-decode-coding-string string mail-parse-charset))
+ (mm-string-to-multibyte string)))) ;; )
+
+(defun rfc2047-decode-address-string (string)
+ "Decode MIME-encoded STRING and return the result.
+Backslashes which precede characters other than `\"' and `\\' in quoted
+strings are stripped."
+ (rfc2047-decode-string string t))
(defun rfc2047-pad-base64 (string)
"Pad STRING to quartets."
(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 the characters \"B\" and \"Q\".
-If your Emacs implementation can't decode CHARSET, return nil."
- (if (stringp charset)
- (setq charset (intern (downcase charset))))
- (if (or (not charset)
- (eq 'gnus-all mail-parse-ignored-charsets)
- (memq 'gnus-all mail-parse-ignored-charsets)
- (memq charset mail-parse-ignored-charsets))
- (setq charset mail-parse-charset))
- (let ((cs (mm-charset-to-coding-system charset)))
- (if (and (not cs) charset
- (listp mail-parse-ignored-charsets)
- (memq 'gnus-unknown mail-parse-ignored-charsets))
- (setq cs (mm-charset-to-coding-system mail-parse-charset)))
- (when cs
- (when (and (eq cs 'ascii)
- mail-parse-charset)
- (setq cs mail-parse-charset))
- (mm-decode-coding-string
- (cond
- ((char-equal ?B encoding)
- (base64-decode-string
- (rfc2047-pad-base64 string)))
- ((char-equal ?Q encoding)
- (quoted-printable-decode-string
- (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