;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998, 1999, 2000, 2002, 2003 Free Software Foundation, Inc.
+
+;; Copyright (C) 1998-2014 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)
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.")
+
+(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.
(let ((charsets
(mm-find-mime-charset-region (point-min) (point-max))))
(goto-char (point-min))
- (or (search-forward "=?" nil t)
+ (or (and rfc2047-encode-encoded-words
+ (prog1
+ (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)
- (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.
- (let ((encodable-regexp "[^\000-\177]\\|=\\?"))
- (goto-char (point-min))
- ;; Does it need encoding?
- (re-search-forward encodable-regexp (point-max) 'move)
- (unless (eobp)
- (skip-chars-backward "^ \n") ; beginning of space-delimited word
- (rfc2047-encode
- (point)
- (progn
- (goto-char e)
- (re-search-backward encodable-regexp (point-max) 'move)
- (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 begin csyntax
+ ;; Whether there's an encoded word before the current token,
+ ;; either immediately or separated by space.
+ 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
+ ;; 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.
+ (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.)
(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
- ((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.
projects / gnus / blobdiff