epa.texi (Encrypting/decrypting gpg files): Fix a typo

[gnus] / lisp / rfc2047.el

diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el
index 89c10a9..ea558d7 100644 (file)
--- a/lisp/rfc2047.el
+++ b/lisp/rfc2047.el
@@ -1,7 +1,6 @@
 ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
 
 ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
 

-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008 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>
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>


@@ -31,7 +30,6 @@
   (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 'mm-util)
 (require 'ietf-drums)
 ;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.


@@ -237,85 +235,96 @@ Should be called narrowed to the head of the message."
   (interactive "*")
   (save-excursion
     (goto-char (point-min))
   (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
       (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 '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 (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)))
-         (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
 
 ;; Fixme: This, and the require below may not be the Right Thing, but
 ;; should be safe just before release.  -- fx 2001-02-08


@@ -343,17 +352,13 @@ The buffer may be narrowed."
 (defconst rfc2047-syntax-table
   ;; (make-char-table 'syntax-table '(2)) only works in Emacs.
   (let ((table (make-syntax-table)))
 (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.
     ;; 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)


@@ -368,7 +373,7 @@ The buffer may be narrowed."
     (modify-syntax-entry ?@ "." table)
     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."
   "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."


@@ -428,7 +433,7 @@ Dynamically bind `rfc2047-encoding-type' to change that."
                      ;; since encoded words can't occur in quotes.
                      (progn
                        (goto-char end)
                      ;; 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
                        (goto-char start)
                        (delete-char 1)
                        (when last-encoded


@@ -552,16 +557,17 @@ Dynamically bind `rfc2047-encoding-type' to change that."
                 (signal (car err) (cdr err))
               (error "Invalid data for rfc2047 encoding: %s"
                      (mm-replace-in-string orig-text "[ \t\n]+" " "))))))))
                 (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))))
 
     (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)
   "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:
     (buffer-string)))
 
 ;; From RFC 2047:


@@ -592,7 +598,7 @@ should not change this value.")
        ((>= column rfc2047-encode-max-chars)
         (when eword
           (cond ((string-match "\n[ \t]+\\'" eword)
        ((>= 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 eword (substring eword 0 (match-beginning 0))))
                 ((string-match "(+\\'" eword)
                  ;; Break the line before the open parenthesis.


@@ -645,7 +651,7 @@ should not change this value.")
               (setq crest " "
                     eword (concat eword next)))
             (when (string-match "\n[ \t]+\\'" eword)
               (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
               (setq eword (substring eword 0 (match-beginning 0))))
             (rfc2047-encode-1 (length crest) (substring string index)
                               cs encoder start " " tail


@@ -656,6 +662,9 @@ should not change this value.")
 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)
 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)))
     (cond ((> (length mime-charset) 1)
           (error "Can't rfc2047-encode `%s'"
                  (buffer-substring-no-properties b e)))


@@ -827,6 +836,8 @@ Point moves to the end of the region."
   "Base64-encode the header contained in STRING."
   (base64-encode-string string 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
 (defun rfc2047-q-encode-string (string)
   "Quoted-printable-encode the header in STRING."
   (mm-with-unibyte-buffer


@@ -847,21 +858,11 @@ Point moves to the end of the region."
 
 (defun rfc2047-encode-parameter (param value)
   "Return and PARAM=VALUE string encoded in the RFC2047-like style.
 
 (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))
   (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
 
 ;;;
 ;;; Functions for decoding RFC2047 messages


@@ -896,15 +897,19 @@ them.")
                  (goto-char beg)
                  (while (search-forward "\\" nil 'move)
                    (unless (memq (char-after) '(?\"))
                  (goto-char beg)
                  (while (search-forward "\\" nil 'move)
                    (unless (memq (char-after) '(?\"))

-                     (delete-backward-char 1))
+                     (delete-char -1))

                    (forward-char)))
                (forward-char))
            (error
             (goto-char beg))))))))
 
                    (forward-char)))
                (forward-char))
            (error
             (goto-char beg))))))))
 

-(defun rfc2047-charset-to-coding-system (charset)
+(defun rfc2047-charset-to-coding-system (charset &optional allow-override)

   "Return coding-system corresponding to MIME CHARSET.
   "Return coding-system corresponding to MIME CHARSET.

-If your Emacs implementation can't decode CHARSET, return nil."
+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)
   (when (stringp charset)
     (setq charset (intern (downcase charset))))
   (when (or (not charset)


@@ -912,7 +917,7 @@ If your Emacs implementation can't decode CHARSET, return nil."
            (memq 'gnus-all mail-parse-ignored-charsets)
            (memq charset mail-parse-ignored-charsets))
     (setq charset mail-parse-charset))
            (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)))
+  (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)))
     (cond ((eq cs 'ascii)
           (setq cs (or (mm-charset-to-coding-system mail-parse-charset)
                        'raw-text)))


@@ -925,6 +930,8 @@ If your Emacs implementation can't decode CHARSET, return nil."
        'raw-text
       cs)))
 
        '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
 (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


@@ -933,7 +940,7 @@ ENCODED-WORD)."
     (while words
       (setq word (pop words))
       (if (and (setq cs (rfc2047-charset-to-coding-system
     (while words
       (setq word (pop words))
       (if (and (setq cs (rfc2047-charset-to-coding-system

-                        (setq charset (car word))))
+                        (setq charset (car word)) t))

               (condition-case code
                   (cond ((char-equal ?B (nth 1 word))
                          (setq text (base64-decode-string
               (condition-case code
                   (cond ((char-equal ?B (nth 1 word))
                          (setq text (base64-decode-string


@@ -1022,6 +1029,7 @@ other than `\"' and `\\' in quoted strings."
            ;; things essentially must not be there.
            (while (re-search-forward "[\n\r]+" nil t)
              (replace-match " "))
            ;; 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
            ;; Quote decoded words if there are special characters
            ;; which might violate RFC2822.
            (when (and rfc2047-quote-decoded-words-containing-tspecials


@@ -1031,17 +1039,22 @@ other than `\"' and `\\' in quoted strings."
                         (when regexp
                           (save-restriction
                             (widen)
                         (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")
                (setq start (point))
                (setq quoted (eq (char-after) ?\"))
                (goto-char (point-max))
              (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")
+               (skip-chars-backward " \t" start)

                (if (setq quoted (and quoted
                                      (> (point) (1+ start))
                                      (eq (char-before) ?\")))
                (if (setq quoted (and quoted
                                      (> (point) (1+ start))
                                      (eq (char-before) ?\")))


@@ -1123,7 +1136,7 @@ other than `\"' and `\\' in quoted strings."
          ;; `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
          ;; `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
+         ;; 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
          ;; trivial.
          ;; `rfc2047-decode-string' is called multiple times for each
          ;; article during summary buffer generation, and we really


@@ -1159,5 +1172,4 @@ strings are stripped."
 
 (provide 'rfc2047)
 
 
 (provide 'rfc2047)
 

-;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6

 ;;; rfc2047.el ends here
 ;;; rfc2047.el ends here