gnus-notifications: add actions support

[gnus] / lisp / rfc2047.el

diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el
index fe0ec46..e881256 100644 (file)
--- a/lisp/rfc2047.el
+++ b/lisp/rfc2047.el
@@ -1,26 +1,23 @@
 ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
 
 ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
 

-;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004,
-;;   2005 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2012  Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>
 ;; This file is part of GNU Emacs.
 
 
 ;; 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
 ;; 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
 
 ;; 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
 ;; 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:
 
 
 ;;; Commentary:
 


@@ -30,15 +27,14 @@
 ;;; Code:
 
 (eval-when-compile
 ;;; 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 '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
 (autoload 'mm-body-7-or-8 "mm-bodies")
 
 (defvar rfc2047-header-encoding-alist


@@ -78,6 +74,8 @@ The values can be:
     (iso-2022-jp . B)
     (iso-2022-kr . B)
     (gb2312 . B)
     (iso-2022-jp . B)
     (iso-2022-kr . B)
     (gb2312 . B)

+    (gbk . B)
+    (gb18030 . B)

     (big5 . B)
     (cn-big5 . B)
     (cn-gb . B)
     (big5 . B)
     (cn-big5 . B)
     (cn-gb . B)


@@ -99,6 +97,40 @@ quoted-printable and base64 respectively.")
 (defvar rfc2047-encode-encoded-words t
   "Whether encoded words should be encoded again.")
 
 (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
 ;;;
 ;;;
 ;;; Functions for encoding RFC2047 messages
 ;;;


@@ -142,6 +174,55 @@ This is either `base64' or `quoted-printable'."
       (re-search-forward ":[ \t\n]*" nil t)
       (buffer-substring-no-properties (point) (point-max)))))
 
       (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
 (defvar rfc2047-encoding-type 'address-mime
   "The type of encoding done by `rfc2047-encode-region'.
 This should be dynamically bound around calls to


@@ -158,8 +239,18 @@ Should be called narrowed to the head of the message."
       (while (not (eobp))
        (save-restriction
          (rfc2047-narrow-to-field)
       (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))
          (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
                  (if (and (eq (mm-body-7-or-8) '8bit)
                           (mm-multibyte-p)
                           (mm-coding-system-p


@@ -180,14 +271,6 @@ Should be called narrowed to the head of the message."
                     (point))
                   (point-max))))
            ;; We found something that may perhaps be encoded.
                     (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)
            (re-search-forward "^[^:]+: *" nil t)
            (cond
             ((eq method 'address-mime)


@@ -197,16 +280,16 @@ Should be called narrowed to the head of the message."
                (rfc2047-encode-region (point) (point-max))))
             ((eq method 'default)
              (if (and (featurep 'mule)
                (rfc2047-encode-region (point) (point-max))))
             ((eq method 'default)
              (if (and (featurep 'mule)

-                      (if (boundp 'default-enable-multibyte-characters)
-                          default-enable-multibyte-characters)
+                      (if (boundp 'enable-multibyte-characters)
+                          (default-value 'enable-multibyte-characters))

                       mail-parse-charset)
                  (mm-encode-coding-region (point) (point-max)
                                           mail-parse-charset)))
                       mail-parse-charset)
                  (mm-encode-coding-region (point) (point-max)
                                           mail-parse-charset)))

-            ;; We get this when CC'ing messsages to newsgroups with
+            ;; 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
             ;; 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
+            ;; 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
             ;; 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


@@ -223,9 +306,10 @@ Should be called narrowed to the head of the message."
 ;;;              (rfc2047-encode-region (point-min) (point-max))
 ;;;            (error "Cannot send unencoded text")))
             ((mm-coding-system-p method)
 ;;;              (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 'enable-multibyte-characters)
+                              (default-value 'enable-multibyte-characters)))
+                     (featurep 'file-coding))

                  (mm-encode-coding-region (point) (point-max) method)))
             ;; Hm.
             (t)))
                  (mm-encode-coding-region (point) (point-max) method)))
             ;; Hm.
             (t)))


@@ -233,7 +317,6 @@ Should be called narrowed to the head of the message."
 
 ;; 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

-(eval-when-compile (defvar message-posting-charset))

 
 (defun rfc2047-encodable-p ()
   "Return non-nil if any characters in current buffer need encoding in headers.
 
 (defun rfc2047-encodable-p ()
   "Return non-nil if any characters in current buffer need encoding in headers.


@@ -244,7 +327,7 @@ The buffer may be narrowed."
     (goto-char (point-min))
     (or (and rfc2047-encode-encoded-words
             (prog1
     (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))))))))
               (goto-char (point-min))))
        (and charsets
             (not (equal charsets (list (car message-posting-charset))))))))


@@ -258,17 +341,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 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.
     ;; 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)


@@ -283,7 +362,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."


@@ -318,6 +397,7 @@ Dynamically bind `rfc2047-encoding-type' to change that."
                  (rfc2047-encode start (point))
                (goto-char end))))
        ;; `address-mime' case -- take care of quoted words, comments.
                  (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
        (with-syntax-table rfc2047-syntax-table
          (goto-char (point-min))
          (condition-case err           ; in case of unbalanced quotes


@@ -342,7 +422,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


@@ -466,22 +546,32 @@ 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)))
 
     (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.
 (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)
 
 (defun rfc2047-encode-1 (column string cs encoder start crest tail
                                &optional eword)


@@ -497,7 +587,7 @@ cause an error.  Don't change this for no particular reason.")
        ((>= 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.


@@ -550,7 +640,7 @@ cause an error.  Don't change this for no particular reason.")
               (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


@@ -561,6 +651,9 @@ cause an error.  Don't change this for no particular reason.")
 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)))


@@ -732,6 +825,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


@@ -752,34 +847,16 @@ 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)
-"
-  (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))))
+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
 ;;;
 
 
 ;;;
 ;;; 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-quote-decoded-words-containing-tspecials nil
   "If non-nil, quote decoded words containing special characters.")
 


@@ -792,9 +869,36 @@ encoded-word, concatenate them, and decode it by charset.  Otherwise,
 the decoder will fully decode each encoded-word before concatenating
 them.")
 
 the decoder will fully decode each encoded-word before concatenating
 them.")
 

-(defun rfc2047-charset-to-coding-system (charset)
+(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.
   "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)


@@ -802,7 +906,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)))


@@ -815,6 +919,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


@@ -822,11 +928,8 @@ ENCODED-WORD)."
   (let (word charset cs encoding text rest)
     (while words
       (setq word (pop words))
   (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)) 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


@@ -872,18 +975,24 @@ ENCODED-WORD)."
 ;; and worthwhile (is it more correct or not?), e.g. something like
 ;; `=?iso-8859-1?q?foo?=@'.
 
 ;; 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)
   (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)
        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))
        (goto-char (setq b start))
        ;; Look for the encoded-words.
        (while (setq match (re-search-forward eword-regexp nil t))


@@ -893,7 +1002,7 @@ ENCODED-WORD)."
          (while match
            (push (list (match-string 2) ;; charset
                        (char-after (match-beginning 3)) ;; encoding
          (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.
                        (match-string 1)) ;; encoded-word
                  words)
            ;; Look for the subsequent encoded-words.


@@ -909,6 +1018,7 @@ ENCODED-WORD)."
            ;; 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


@@ -918,17 +1028,22 @@ ENCODED-WORD)."
                         (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) ?\")))


@@ -969,25 +1084,41 @@ ENCODED-WORD)."
                   (not (eq mail-parse-charset 'gnus-decoded)))
          (mm-decode-coding-region b (point-max) 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
     (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
          (insert string)
          (inline

-           (rfc2047-decode-region (point-min) (point-max)))
+           (rfc2047-decode-region (point-min) (point-max) address-mime))

          (buffer-string))
          (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.
       ;; 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)))
               mail-parse-charset
               (not (eq mail-parse-charset 'us-ascii))
               (not (eq mail-parse-charset 'gnus-decoded)))


@@ -1003,9 +1134,15 @@ ENCODED-WORD)."
          (if (and (fboundp 'detect-coding-string)
                   ;; string is purely ASCII
                   (eq (detect-coding-string string t) 'undecided))
          (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."
 
 (defun rfc2047-pad-base64 (string)
   "Pad STRING to quartets."


@@ -1024,5 +1161,4 @@ ENCODED-WORD)."
 
 (provide 'rfc2047)
 
 
 (provide 'rfc2047)
 

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

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