;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004,
-;; 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, 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
(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
(while (not (eobp))
(save-restriction
(rfc2047-narrow-to-field)
+ (setq method nil
+ alist rfc2047-header-encoding-alist)
+ (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))))
(if (not (rfc2047-encodable-p))
- (prog1
+ (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
(point))
(point-max))))
;; We found something that may perhaps be encoded.
- (setq method nil
- alist rfc2047-header-encoding-alist)
- (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))))
(re-search-forward "^[^:]+: *" nil t)
(cond
((eq method 'address-mime)
;;; (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))
+ (if (or (and (featurep 'mule)
+ (if (boundp 'default-enable-multibyte-characters)
+ default-enable-multibyte-characters))
+ (featurep 'file-coding))
(mm-encode-coding-region (point) (point-max) method)))
;; Hm.
(t)))
;; 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))))))))
;; (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.
+ ;; in Emacs 21-23 and XEmacs; 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
(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 err ; in case of unbalanced quotes
(rfc2047-encode-region (point-min) (point-max))
(buffer-string)))
+;; 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.
-If it is nil, encoded-words will not be folded. Too small value may
-cause an error. Don't change this for no particular reason.")
+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)
\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
"
- (let* ((rfc2047-encoding-type 'mime)
- (rfc2047-encode-max-chars nil)
- (string (rfc2047-encode-string value)))
- (if (string-match (concat "[" ietf-drums-tspecials "]") string)
- (format "%s=%S" param string)
- (concat param "=" string))))
+ (let ((rfc2047-encoding-type 'mime)
+ (rfc2047-encode-max-chars nil))
+ (rfc2045-encode-string param (rfc2047-encode-string value))))
;;;
;;; 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.")
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-backward-char 1))
+ (forward-char)))
+ (forward-char))
+ (error
+ (goto-char beg))))))))
+
(defun rfc2047-charset-to-coding-system (charset)
"Return coding-system corresponding to MIME CHARSET.
If your Emacs implementation can't decode CHARSET, return nil."
(cond ((eq cs 'ascii)
(setq cs (or (mm-charset-to-coding-system mail-parse-charset)
'raw-text)))
- ((setq cs (mm-coding-system-p cs)))
+ ((mm-coding-system-p cs))
((and charset
(listp mail-parse-ignored-charsets)
(memq 'gnus-unknown mail-parse-ignored-charsets))
(let (word charset cs encoding text rest)
(while words
(setq word (pop words))
- (if (and (or (setq cs (rfc2047-charset-to-coding-system
- (setq charset (car word))))
- (progn
- (message "Unknown charset: %s" charset)
- nil))
+ (if (and (setq cs (rfc2047-charset-to-coding-system
+ (setq charset (car word))))
(condition-case code
(cond ((char-equal ?B (nth 1 word))
(setq text (base64-decode-string
;; 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)
- (eword-regexp (eval-when-compile
- ;; Ignore whitespace between encoded-words.
- (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp
- "\\)")))
+ (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)
+ (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))
(while match
(push (list (match-string 2) ;; charset
(char-after (match-beginning 3)) ;; encoding
- (match-string 4) ;; encoded-text
+ (substring (match-string 3) 2) ;; encoded-text
(match-string 1)) ;; encoded-word
words)
;; Look for the subsequent encoded-words.
(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)))))
+ 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."
(provide 'rfc2047)
-;;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6
+;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6
;;; rfc2047.el ends here
projects / gnus / blobdiff