;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009 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>
(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.
(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)
(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))
- (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 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 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)))))))
+ 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))))
+ (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
(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-23 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)
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."
;; since encoded words can't occur in quotes.
(progn
(goto-char end)
- (delete-backward-char 1)
+ (delete-char -1)
(goto-char start)
(delete-char 1)
(when last-encoded
(signal (car err) (cdr err))
(error "Invalid data for rfc2047 encoding: %s"
(mm-replace-in-string orig-text "[ \t\n]+" " "))))))))
- (rfc2047-fold-region b (point))
+ (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')."
(mm-with-multibyte-buffer
(insert string)
- (rfc2047-encode-region (point-min) (point-max))
+ (rfc2047-encode-region (point-min) (point-max) dont-fold)
(buffer-string)))
;; From RFC 2047:
((>= column rfc2047-encode-max-chars)
(when eword
(cond ((string-match "\n[ \t]+\\'" eword)
- ;; Reomove a superfluous empty line.
+ ;; 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 " "
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 crest) (substring string index)
cs encoder start " " tail
Point moves to the end of the region."
(let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii)))
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)))
"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
(defun rfc2047-encode-parameter (param value)
"Return and PARAM=VALUE string encoded in the RFC2047-like style.
-This is a replacement for the `rfc2231-encode-string' function.
-
-When attaching files as MIME parts, we should use the RFC2231 encoding
-to specify the file names containing non-ASCII characters. However,
-many mail softwares don't support it in practice and recipients won't
-be able to extract files with correct names. Instead, the RFC2047-like
-encoding is acceptable generally. This function provides the very
-RFC2047-like encoding, resigning to such a regrettable trend. To use
-it, put the following line in your ~/.gnus.el file:
-
-\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
-"
+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))))
+ (rfc2045-encode-string param (rfc2047-encode-string value t))))
;;;
;;; Functions for decoding RFC2047 messages
(goto-char beg)
(while (search-forward "\\" nil 'move)
(unless (memq (char-after) '(?\"))
- (delete-backward-char 1))
+ (delete-char -1))
(forward-char)))
(forward-char))
(error
'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
;; 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
(when regexp
(save-restriction
(widen)
- (beginning-of-line)
- (while (and (memq (char-after) '(? ?\t))
- (zerop (forward-line -1))))
- (looking-at regexp)))))
+ (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")
(provide 'rfc2047)
-;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6
;;; rfc2047.el ends here
projects / gnus / blobdiff