cgit.sxemacs.org Git - gnus/blob - lisp/rfc2047.el

   1 ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009, 2010  Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; RFC 2047 is "MIME (Multipurpose Internet Mail Extensions) Part
  26 ;; Three:  Message Header Extensions for Non-ASCII Text".
  27
  28 ;;; Code:
  29
  30 (eval-when-compile
  31   (require 'cl))
  32 (defvar message-posting-charset)
  33
  34 (require 'mm-util)
  35 (require 'ietf-drums)
  36 ;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
  37 (require 'mail-prsvr)
  38 (require 'rfc2045) ;; rfc2045-encode-string
  39 (autoload 'mm-body-7-or-8 "mm-bodies")
  40
  41 (defvar rfc2047-header-encoding-alist
  42   '(("Newsgroups" . nil)
  43     ("Followup-To" . nil)
  44     ("Message-ID" . nil)
  45     ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\
  46 \\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime)
  47     (t . mime))
  48   "*Header/encoding method alist.
  49 The list is traversed sequentially.  The keys can either be
  50 header regexps or t.
  51
  52 The values can be:
  53
  54 1) nil, in which case no encoding is done;
  55 2) `mime', in which case the header will be encoded according to RFC2047;
  56 3) `address-mime', like `mime', but takes account of the rules for address
  57    fields (where quoted strings and comments must be treated separately);
  58 4) a charset, in which case it will be encoded as that charset;
  59 5) `default', in which case the field will be encoded as the rest
  60    of the article.")
  61
  62 (defvar rfc2047-charset-encoding-alist
  63   '((us-ascii . nil)
  64     (iso-8859-1 . Q)
  65     (iso-8859-2 . Q)
  66     (iso-8859-3 . Q)
  67     (iso-8859-4 . Q)
  68     (iso-8859-5 . B)
  69     (koi8-r . B)
  70     (iso-8859-7 . B)
  71     (iso-8859-8 . B)
  72     (iso-8859-9 . Q)
  73     (iso-8859-14 . Q)
  74     (iso-8859-15 . Q)
  75     (iso-2022-jp . B)
  76     (iso-2022-kr . B)
  77     (gb2312 . B)
  78     (gbk . B)
  79     (gb18030 . B)
  80     (big5 . B)
  81     (cn-big5 . B)
  82     (cn-gb . B)
  83     (cn-gb-2312 . B)
  84     (euc-kr . B)
  85     (iso-2022-jp-2 . B)
  86     (iso-2022-int-1 . B)
  87     (viscii . Q))
  88   "Alist of MIME charsets to RFC2047 encodings.
  89 Valid encodings are nil, `Q' and `B'.  These indicate binary (no) encoding,
  90 quoted-printable and base64 respectively.")
  91
  92 (defvar rfc2047-encode-function-alist
  93   '((Q . rfc2047-q-encode-string)
  94     (B . rfc2047-b-encode-string)
  95     (nil . identity))
  96   "Alist of RFC2047 encodings to encoding functions.")
  97
  98 (defvar rfc2047-encode-encoded-words t
  99   "Whether encoded words should be encoded again.")
 100
 101 (defvar rfc2047-allow-irregular-q-encoded-words t
 102   "*Whether to decode irregular Q-encoded words.")
 103
 104 (eval-and-compile ;; Necessary to hard code them in `rfc2047-decode-region'.
 105   (defconst rfc2047-encoded-word-regexp
 106     "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\
 107 \\(B\\?[+/0-9A-Za-z]*=*\
 108 \\|Q\\?[ ->@-~]*\
 109 \\)\\?="
 110     "Regexp that matches encoded word."
 111     ;; The patterns for the B encoding and the Q encoding, i.e. the ones
 112     ;; beginning with "B" and "Q" respectively, are restricted into only
 113     ;; the characters that those encodings may generally use.
 114     )
 115   (defconst rfc2047-encoded-word-regexp-loose
 116     "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\
 117 \\(B\\?[+/0-9A-Za-z]*=*\
 118 \\|Q\\?\\(?:\\?+[ -<>@-~]\\)?\\(?:[ ->@-~]+\\?+[ -<>@-~]\\)*[ ->@-~]*\\?*\
 119 \\)\\?="
 120     "Regexp that matches encoded word allowing loose Q encoding."
 121     ;; The pattern for the Q encoding, i.e. the one beginning with "Q",
 122     ;; is similar to:
 123     ;; "Q\\?\\(\\?+[^\n=?]\\)?\\([^\n?]+\\?+[^\n=?]\\)*[^\n?]*\\?*"
 124     ;;      <--------1-------><----------2,3----------><--4--><-5->
 125     ;; They mean:
 126     ;; 1. After "Q?", allow "?"s that follow a character other than "=".
 127     ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator.
 128     ;; 3. In the middle of an encoded word, allow "?"s that follow a
 129     ;;    character other than "=".
 130     ;; 4. Allow any characters other than "?" in the middle of an
 131     ;;    encoded word.
 132     ;; 5. At the end, allow "?"s.
 133     ))
 134
 135 ;;;
 136 ;;; Functions for encoding RFC2047 messages
 137 ;;;
 138
 139 (defun rfc2047-qp-or-base64 ()
 140   "Return the type with which to encode the buffer.
 141 This is either `base64' or `quoted-printable'."
 142   (save-excursion
 143     (let ((limit (min (point-max) (+ 2000 (point-min))))
 144           (n8bit 0))
 145       (goto-char (point-min))
 146       (skip-chars-forward "\x20-\x7f\r\n\t" limit)
 147       (while (< (point) limit)
 148         (incf n8bit)
 149         (forward-char 1)
 150         (skip-chars-forward "\x20-\x7f\r\n\t" limit))
 151       (if (or (< (* 6 n8bit) (- limit (point-min)))
 152               ;; Don't base64, say, a short line with a single
 153               ;; non-ASCII char when splitting parts by charset.
 154               (= n8bit 1))
 155           'quoted-printable
 156         'base64))))
 157
 158 (defun rfc2047-narrow-to-field ()
 159   "Narrow the buffer to the header on the current line."
 160   (beginning-of-line)
 161   (narrow-to-region
 162    (point)
 163    (progn
 164      (forward-line 1)
 165      (if (re-search-forward "^[^ \n\t]" nil t)
 166          (point-at-bol)
 167        (point-max))))
 168   (goto-char (point-min)))
 169
 170 (defun rfc2047-field-value ()
 171   "Return the value of the field at point."
 172   (save-excursion
 173     (save-restriction
 174       (rfc2047-narrow-to-field)
 175       (re-search-forward ":[ \t\n]*" nil t)
 176       (buffer-substring-no-properties (point) (point-max)))))
 177
 178 (defun rfc2047-quote-special-characters-in-quoted-strings (&optional
 179                                                            encodable-regexp)
 180   "Quote special characters with `\\'s in quoted strings.
 181 Quoting will not be done in a quoted string if it contains characters
 182 matching ENCODABLE-REGEXP or it is within parentheses."
 183   (goto-char (point-min))
 184   (let ((tspecials (concat "[" ietf-drums-tspecials "]"))
 185         (start (point))
 186         beg end)
 187     (with-syntax-table (standard-syntax-table)
 188       (while (not (eobp))
 189         (if (ignore-errors
 190               (forward-list 1)
 191               (eq (char-before) ?\)))
 192             (forward-list -1)
 193           (goto-char (point-max)))
 194         (save-restriction
 195           (narrow-to-region start (point))
 196           (goto-char start)
 197           (while (search-forward "\"" nil t)
 198             (setq beg (match-beginning 0))
 199             (unless (eq (char-before beg) ?\\)
 200               (goto-char beg)
 201               (setq beg (1+ beg))
 202               (condition-case nil
 203                   (progn
 204                     (forward-sexp)
 205                     (setq end (1- (point)))
 206                     (goto-char beg)
 207                     (if (and encodable-regexp
 208                              (re-search-forward encodable-regexp end t))
 209                         (goto-char (1+ end))
 210                       (save-restriction
 211                         (narrow-to-region beg end)
 212                         (while (re-search-forward tspecials nil 'move)
 213                           (if (eq (char-before) ?\\)
 214                               (if (looking-at tspecials) ;; Already quoted.
 215                                   (forward-char)
 216                                 (insert "\\"))
 217                             (goto-char (match-beginning 0))
 218                             (insert "\\")
 219                             (forward-char))))
 220                       (forward-char)))
 221                 (error
 222                  (goto-char beg)))))
 223           (goto-char (point-max)))
 224         (forward-list 1)
 225         (setq start (point))))))
 226
 227 (defvar rfc2047-encoding-type 'address-mime
 228   "The type of encoding done by `rfc2047-encode-region'.
 229 This should be dynamically bound around calls to
 230 `rfc2047-encode-region' to either `mime' or `address-mime'.  See
 231 `rfc2047-header-encoding-alist', for definitions.")
 232
 233 (defun rfc2047-encode-message-header ()
 234   "Encode the message header according to `rfc2047-header-encoding-alist'.
 235 Should be called narrowed to the head of the message."
 236   (interactive "*")
 237   (save-excursion
 238     (goto-char (point-min))
 239     (let (alist elem method)
 240       (while (not (eobp))
 241         (save-restriction
 242           (rfc2047-narrow-to-field)
 243           (setq method nil
 244                 alist rfc2047-header-encoding-alist)
 245           (while (setq elem (pop alist))
 246             (when (or (and (stringp (car elem))
 247                            (looking-at (car elem)))
 248                       (eq (car elem) t))
 249               (setq alist nil
 250                     method (cdr elem))))
 251           (if (not (rfc2047-encodable-p))
 252               (prog2
 253                   (when (eq method 'address-mime)
 254                     (rfc2047-quote-special-characters-in-quoted-strings))
 255                   (if (and (eq (mm-body-7-or-8) '8bit)
 256                            (mm-multibyte-p)
 257                            (mm-coding-system-p
 258                             (car message-posting-charset)))
 259                       ;; 8 bit must be decoded.
 260                       (mm-encode-coding-region
 261                        (point-min) (point-max)
 262                        (mm-charset-to-coding-system
 263                         (car message-posting-charset))))
 264                 ;; No encoding necessary, but folding is nice
 265                 (when nil
 266                   (rfc2047-fold-region
 267                    (save-excursion
 268                      (goto-char (point-min))
 269                      (skip-chars-forward "^:")
 270                      (when (looking-at ": ")
 271                        (forward-char 2))
 272                      (point))
 273                    (point-max))))
 274             ;; We found something that may perhaps be encoded.
 275             (re-search-forward "^[^:]+: *" nil t)
 276             (cond
 277              ((eq method 'address-mime)
 278               (rfc2047-encode-region (point) (point-max)))
 279              ((eq method 'mime)
 280               (let ((rfc2047-encoding-type 'mime))
 281                 (rfc2047-encode-region (point) (point-max))))
 282              ((eq method 'default)
 283               (if (and (featurep 'mule)
 284                        (if (boundp 'enable-multibyte-characters)
 285                            (default-value 'enable-multibyte-characters))
 286                        mail-parse-charset)
 287                   (mm-encode-coding-region (point) (point-max)
 288                                            mail-parse-charset)))
 289              ;; We get this when CC'ing messsages to newsgroups with
 290              ;; 8-bit names.  The group name mail copy just got
 291              ;; unconditionally encoded.  Previously, it would ask
 292              ;; whether to encode, which was quite confusing for the
 293              ;; user.  If the new behavior is wrong, tell me. I have
 294              ;; left the old code commented out below.
 295              ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07.
 296              ;; Modified by Dave Love, with the commented-out code changed
 297              ;; in accordance with changes elsewhere.
 298              ((null method)
 299               (rfc2047-encode-region (point) (point-max)))
 300 ;;;          ((null method)
 301 ;;;           (if (or (message-options-get
 302 ;;;                    'rfc2047-encode-message-header-encode-any)
 303 ;;;                   (message-options-set
 304 ;;;                    'rfc2047-encode-message-header-encode-any
 305 ;;;                    (y-or-n-p
 306 ;;;                     "Some texts are not encoded. Encode anyway?")))
 307 ;;;               (rfc2047-encode-region (point-min) (point-max))
 308 ;;;             (error "Cannot send unencoded text")))
 309              ((mm-coding-system-p method)
 310               (if (or (and (featurep 'mule)
 311                            (if (boundp 'enable-multibyte-characters)
 312                                (default-value 'enable-multibyte-characters)))
 313                       (featurep 'file-coding))
 314                   (mm-encode-coding-region (point) (point-max) method)))
 315              ;; Hm.
 316              (t)))
 317           (goto-char (point-max)))))))
 318
 319 ;; Fixme: This, and the require below may not be the Right Thing, but
 320 ;; should be safe just before release.  -- fx 2001-02-08
 321
 322 (defun rfc2047-encodable-p ()
 323   "Return non-nil if any characters in current buffer need encoding in headers.
 324 The buffer may be narrowed."
 325   (require 'message)                    ; for message-posting-charset
 326   (let ((charsets
 327          (mm-find-mime-charset-region (point-min) (point-max))))
 328     (goto-char (point-min))
 329     (or (and rfc2047-encode-encoded-words
 330              (prog1
 331                  (re-search-forward rfc2047-encoded-word-regexp nil t)
 332                (goto-char (point-min))))
 333         (and charsets
 334              (not (equal charsets (list (car message-posting-charset))))))))
 335
 336 ;; Use this syntax table when parsing into regions that may need
 337 ;; encoding.  Double quotes are string delimiters, backslash is
 338 ;; character quoting, and all other RFC 2822 special characters are
 339 ;; treated as punctuation so we can use forward-sexp/forward-word to
 340 ;; skip to the end of regions appropriately.  Nb. ietf-drums does
 341 ;; things differently.
 342 (defconst rfc2047-syntax-table
 343   ;; (make-char-table 'syntax-table '(2)) only works in Emacs.
 344   (let ((table (make-syntax-table)))
 345     ;; The following is done to work for setting all elements of the table
 346     ;; in Emacs 21-23 and XEmacs; it appears to be the cleanest way.
 347     ;; Play safe and don't assume the form of the word syntax entry --
 348     ;; copy it from ?a.
 349     (if (fboundp 'set-char-table-range) ; Emacs
 350         (funcall (intern "set-char-table-range")
 351                  table t (aref (standard-syntax-table) ?a))
 352       (if (fboundp 'put-char-table)
 353           (if (fboundp 'get-char-table) ; warning avoidance
 354               (put-char-table t (get-char-table ?a (standard-syntax-table))
 355                               table))))
 356     (modify-syntax-entry ?\\ "\\" table)
 357     (modify-syntax-entry ?\" "\"" table)
 358     (modify-syntax-entry ?\( "(" table)
 359     (modify-syntax-entry ?\) ")" table)
 360     (modify-syntax-entry ?\< "." table)
 361     (modify-syntax-entry ?\> "." table)
 362     (modify-syntax-entry ?\[ "." table)
 363     (modify-syntax-entry ?\] "." table)
 364     (modify-syntax-entry ?: "." table)
 365     (modify-syntax-entry ?\; "." table)
 366     (modify-syntax-entry ?, "." table)
 367     (modify-syntax-entry ?@ "." table)
 368     table))
 369
 370 (defun rfc2047-encode-region (b e)
 371   "Encode words in region B to E that need encoding.
 372 By default, the region is treated as containing RFC2822 addresses.
 373 Dynamically bind `rfc2047-encoding-type' to change that."
 374   (save-restriction
 375     (narrow-to-region b e)
 376     (let ((encodable-regexp (if rfc2047-encode-encoded-words
 377                                 "[^\000-\177]+\\|=\\?"
 378                               "[^\000-\177]+"))
 379           start                         ; start of current token
 380           end begin csyntax
 381           ;; Whether there's an encoded word before the current token,
 382           ;; either immediately or separated by space.
 383           last-encoded
 384           (orig-text (buffer-substring-no-properties b e)))
 385       (if (eq 'mime rfc2047-encoding-type)
 386           ;; Simple case.  Continuous words in which all those contain
 387           ;; non-ASCII characters are encoded collectively.  Encoding
 388           ;; ASCII words, including `Re:' used in Subject headers, is
 389           ;; avoided for interoperability with non-MIME clients and
 390           ;; for making it easy to find keywords.
 391           (progn
 392             (goto-char (point-min))
 393             (while (progn (skip-chars-forward " \t\n")
 394                           (not (eobp)))
 395               (setq start (point))
 396               (while (and (looking-at "[ \t\n]*\\([^ \t\n]+\\)")
 397                           (progn
 398                             (setq end (match-end 0))
 399                             (re-search-forward encodable-regexp end t)))
 400                 (goto-char end))
 401               (if (> (point) start)
 402                   (rfc2047-encode start (point))
 403                 (goto-char end))))
 404         ;; `address-mime' case -- take care of quoted words, comments.
 405         (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp)
 406         (with-syntax-table rfc2047-syntax-table
 407           (goto-char (point-min))
 408           (condition-case err           ; in case of unbalanced quotes
 409               ;; Look for rfc2822-style: sequences of atoms, quoted
 410               ;; strings, specials, whitespace.  (Specials mustn't be
 411               ;; encoded.)
 412               (while (not (eobp))
 413                 ;; Skip whitespace.
 414                 (skip-chars-forward " \t\n")
 415                 (setq start (point))
 416                 (cond
 417                  ((not (char-after)))   ; eob
 418                  ;; else token start
 419                  ((eq ?\" (setq csyntax (char-syntax (char-after))))
 420                   ;; Quoted word.
 421                   (forward-sexp)
 422                   (setq end (point))
 423                   ;; Does it need encoding?
 424                   (goto-char start)
 425                   (if (re-search-forward encodable-regexp end 'move)
 426                       ;; It needs encoding.  Strip the quotes first,
 427                       ;; since encoded words can't occur in quotes.
 428                       (progn
 429                         (goto-char end)
 430                         (delete-char -1)
 431                         (goto-char start)
 432                         (delete-char 1)
 433                         (when last-encoded
 434                           ;; There was a preceding quoted word.  We need
 435                           ;; to include any separating whitespace in this
 436                           ;; word to avoid it getting lost.
 437                           (skip-chars-backward " \t")
 438                           ;; A space is needed between the encoded words.
 439                           (insert ? )
 440                           (setq start (point)
 441                                 end (1+ end)))
 442                         ;; Adjust the end position for the deleted quotes.
 443                         (rfc2047-encode start (- end 2))
 444                         (setq last-encoded t)) ; record that it was encoded
 445                     (setq last-encoded  nil)))
 446                  ((eq ?. csyntax)
 447                   ;; Skip other delimiters, but record that they've
 448                   ;; potentially separated quoted words.
 449                   (forward-char)
 450                   (setq last-encoded nil))
 451                  ((eq ?\) csyntax)
 452                   (error "Unbalanced parentheses"))
 453                  ((eq ?\( csyntax)
 454                   ;; Look for the end of parentheses.
 455                   (forward-list)
 456                   ;; Encode text as an unstructured field.
 457                   (let ((rfc2047-encoding-type 'mime))
 458                     (rfc2047-encode-region (1+ start) (1- (point))))
 459                   (skip-chars-forward ")"))
 460                  (t                 ; normal token/whitespace sequence
 461                   ;; Find the end.
 462                   ;; Skip one ASCII word, or encode continuous words
 463                   ;; in which all those contain non-ASCII characters.
 464                   (setq end nil)
 465                   (while (not (or end (eobp)))
 466                     (when (looking-at "[\000-\177]+")
 467                       (setq begin (point)
 468                             end (match-end 0))
 469                       (when (progn
 470                               (while (and (or (re-search-forward
 471                                                "[ \t\n]\\|\\Sw" end 'move)
 472                                               (setq end nil))
 473                                           (eq ?\\ (char-syntax (char-before))))
 474                                 ;; Skip backslash-quoted characters.
 475                                 (forward-char))
 476                               end)
 477                         (setq end (match-beginning 0))
 478                         (if rfc2047-encode-encoded-words
 479                             (progn
 480                               (goto-char begin)
 481                               (when (search-forward "=?" end 'move)
 482                                 (goto-char (match-beginning 0))
 483                                 (setq end nil)))
 484                           (goto-char end))))
 485                     ;; Where the value nil of `end' means there may be
 486                     ;; text to have to be encoded following the point.
 487                     ;; Otherwise, the point reached to the end of ASCII
 488                     ;; words separated by whitespace or a special char.
 489                     (unless end
 490                       (when (looking-at encodable-regexp)
 491                         (goto-char (setq begin (match-end 0)))
 492                         (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)")
 493                                     (setq end (match-end 0))
 494                                     (progn
 495                                       (while (re-search-forward
 496                                               encodable-regexp end t))
 497                                       (< begin (point)))
 498                                     (goto-char begin)
 499                                     (or (not (re-search-forward "\\Sw" end t))
 500                                         (progn
 501                                           (goto-char (match-beginning 0))
 502                                           nil)))
 503                           (goto-char end))
 504                         (when (looking-at "[^ \t\n]+")
 505                           (setq end (match-end 0))
 506                           (if (re-search-forward "\\Sw+" end t)
 507                               ;; There are special characters better
 508                               ;; to be encoded so that MTAs may parse
 509                               ;; them safely.
 510                               (cond ((= end (point)))
 511                                     ((looking-at (concat "\\sw*\\("
 512                                                          encodable-regexp
 513                                                          "\\)"))
 514                                      (setq end nil))
 515                                     (t
 516                                      (goto-char (1- (match-end 0)))
 517                                      (unless (= (point) (match-beginning 0))
 518                                        ;; Separate encodable text and
 519                                        ;; delimiter.
 520                                        (insert " "))))
 521                             (goto-char end)
 522                             (skip-chars-forward " \t\n")
 523                             (if (and (looking-at "[^ \t\n]+")
 524                                      (string-match encodable-regexp
 525                                                    (match-string 0)))
 526                                 (setq end nil)
 527                               (goto-char end)))))))
 528                   (skip-chars-backward " \t\n")
 529                   (setq end (point))
 530                   (goto-char start)
 531                   (if (re-search-forward encodable-regexp end 'move)
 532                       (progn
 533                         (unless (memq (char-before start) '(nil ?\t ? ))
 534                           (if (progn
 535                                 (goto-char start)
 536                                 (skip-chars-backward "^ \t\n")
 537                                 (and (looking-at "\\Sw+")
 538                                      (= (match-end 0) start)))
 539                               ;; Also encode bogus delimiters.
 540                               (setq start (point))
 541                             ;; Separate encodable text and delimiter.
 542                             (goto-char start)
 543                             (insert " ")
 544                             (setq start (1+ start)
 545                                   end (1+ end))))
 546                         (rfc2047-encode start end)
 547                         (setq last-encoded t))
 548                     (setq last-encoded nil)))))
 549             (error
 550              (if (or debug-on-quit debug-on-error)
 551                  (signal (car err) (cdr err))
 552                (error "Invalid data for rfc2047 encoding: %s"
 553                       (mm-replace-in-string orig-text "[ \t\n]+" " "))))))))
 554     (rfc2047-fold-region b (point))
 555     (goto-char (point-max))))
 556
 557 (defun rfc2047-encode-string (string)
 558   "Encode words in STRING.
 559 By default, the string is treated as containing addresses (see
 560 `rfc2047-encoding-type')."
 561   (mm-with-multibyte-buffer
 562     (insert string)
 563     (rfc2047-encode-region (point-min) (point-max))
 564     (buffer-string)))
 565
 566 ;; From RFC 2047:
 567 ;; 2. Syntax of encoded-words
 568 ;;    [...]
 569 ;;    While there is no limit to the length of a multiple-line header
 570 ;;    field, each line of a header field that contains one or more
 571 ;;    'encoded-word's is limited to 76 characters.
 572 ;;
 573 ;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it.
 574 (defvar rfc2047-encode-max-chars 76
 575   "Maximum characters of each header line that contain encoded-words.
 576 According to RFC 2047, it is 76.  If it is nil, encoded-words
 577 will not be folded.  Too small value may cause an error.  You
 578 should not change this value.")
 579
 580 (defun rfc2047-encode-1 (column string cs encoder start crest tail
 581                                 &optional eword)
 582   "Subroutine used by `rfc2047-encode'."
 583   (cond ((string-equal string "")
 584          (or eword ""))
 585         ((not rfc2047-encode-max-chars)
 586          (concat start
 587                  (funcall encoder (if cs
 588                                       (mm-encode-coding-string string cs)
 589                                     string))
 590                  "?="))
 591         ((>= column rfc2047-encode-max-chars)
 592          (when eword
 593            (cond ((string-match "\n[ \t]+\\'" eword)
 594                   ;; Reomove a superfluous empty line.
 595                   (setq eword (substring eword 0 (match-beginning 0))))
 596                  ((string-match "(+\\'" eword)
 597                   ;; Break the line before the open parenthesis.
 598                   (setq crest (concat crest (match-string 0 eword))
 599                         eword (substring eword 0 (match-beginning 0))))))
 600          (rfc2047-encode-1 (length crest) string cs encoder start " " tail
 601                            (concat eword "\n" crest)))
 602         (t
 603          (let ((index 0)
 604                (limit (1- (length string)))
 605                (prev "")
 606                next len)
 607            (while (and prev
 608                        (<= index limit))
 609              (setq next (concat start
 610                                 (funcall encoder
 611                                          (if cs
 612                                              (mm-encode-coding-string
 613                                               (substring string 0 (1+ index))
 614                                               cs)
 615                                            (substring string 0 (1+ index))))
 616                                 "?=")
 617                    len (+ column (length next)))
 618              (if (> len rfc2047-encode-max-chars)
 619                  (setq next prev
 620                        prev nil)
 621                (if (or (< index limit)
 622                        (<= (+ len (or (string-match "\n" tail)
 623                                       (length tail)))
 624                            rfc2047-encode-max-chars))
 625                    (setq prev next
 626                          index (1+ index))
 627                  (if (string-match "\\`)+" tail)
 628                      ;; Break the line after the close parenthesis.
 629                      (setq tail (concat (substring tail 0 (match-end 0))
 630                                         "\n "
 631                                         (substring tail (match-end 0)))
 632                            prev next
 633                            index (1+ index))
 634                    (setq next prev
 635                          prev nil)))))
 636            (if (> index limit)
 637                (concat eword next tail)
 638              (if (= 0 index)
 639                  (if (and eword
 640                           (string-match "(+\\'" eword))
 641                      (setq crest (concat crest (match-string 0 eword))
 642                            eword (substring eword 0 (match-beginning 0)))
 643                    (setq eword (concat eword next)))
 644                (setq crest " "
 645                      eword (concat eword next)))
 646              (when (string-match "\n[ \t]+\\'" eword)
 647                ;; Reomove a superfluous empty line.
 648                (setq eword (substring eword 0 (match-beginning 0))))
 649              (rfc2047-encode-1 (length crest) (substring string index)
 650                                cs encoder start " " tail
 651                                (concat eword "\n" crest)))))))
 652
 653 (defun rfc2047-encode (b e)
 654   "Encode the word(s) in the region B to E.
 655 Point moves to the end of the region."
 656   (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii)))
 657         cs encoding tail crest eword)
 658     ;; Use utf-8 as a last resort if determining charset of text fails.
 659     (if (memq nil mime-charset)
 660         (setq mime-charset (list 'utf-8)))
 661     (cond ((> (length mime-charset) 1)
 662            (error "Can't rfc2047-encode `%s'"
 663                   (buffer-substring-no-properties b e)))
 664           ((= (length mime-charset) 1)
 665            (setq mime-charset (car mime-charset)
 666                  cs (mm-charset-to-coding-system mime-charset))
 667            (unless (and (mm-multibyte-p)
 668                         (mm-coding-system-p cs))
 669              (setq cs nil))
 670            (save-restriction
 671              (narrow-to-region b e)
 672              (setq encoding
 673                    (or (cdr (assq mime-charset
 674                                   rfc2047-charset-encoding-alist))
 675                        ;; For the charsets that don't have a preferred
 676                        ;; encoding, choose the one that's shorter.
 677                        (if (eq (rfc2047-qp-or-base64) 'base64)
 678                            'B
 679                          'Q)))
 680              (widen)
 681              (goto-char e)
 682              (skip-chars-forward "^ \t\n")
 683              ;; `tail' may contain a close parenthesis.
 684              (setq tail (buffer-substring-no-properties e (point)))
 685              (goto-char b)
 686              (setq b (point-marker)
 687                    e (set-marker (make-marker) e))
 688              (rfc2047-fold-region (point-at-bol) b)
 689              (goto-char b)
 690              (skip-chars-backward "^ \t\n")
 691              (unless (= 0 (skip-chars-backward " \t"))
 692                ;; `crest' may contain whitespace and an open parenthesis.
 693                (setq crest (buffer-substring-no-properties (point) b)))
 694              (setq eword (rfc2047-encode-1
 695                           (- b (point-at-bol))
 696                           (mm-replace-in-string
 697                            (buffer-substring-no-properties b e)
 698                            "\n\\([ \t]?\\)" "\\1")
 699                           cs
 700                           (or (cdr (assq encoding
 701                                          rfc2047-encode-function-alist))
 702                               'identity)
 703                           (concat "=?" (downcase (symbol-name mime-charset))
 704                                   "?" (upcase (symbol-name encoding)) "?")
 705                           (or crest " ")
 706                           tail))
 707              (delete-region (if (eq (aref eword 0) ?\n)
 708                                 (if (bolp)
 709                                     ;; The line was folded before encoding.
 710                                     (1- (point))
 711                                   (point))
 712                               (goto-char b))
 713                             (+ e (length tail)))
 714              ;; `eword' contains `crest' and `tail'.
 715              (insert eword)
 716              (set-marker b nil)
 717              (set-marker e nil)
 718              (unless (or (/= 0 (length tail))
 719                          (eobp)
 720                          (looking-at "[ \t\n)]"))
 721                (insert " "))))
 722           (t
 723            (goto-char e)))))
 724
 725 (defun rfc2047-fold-field ()
 726   "Fold the current header field."
 727   (save-excursion
 728     (save-restriction
 729       (rfc2047-narrow-to-field)
 730       (rfc2047-fold-region (point-min) (point-max)))))
 731
 732 (defun rfc2047-fold-region (b e)
 733   "Fold long lines in region B to E."
 734   (save-restriction
 735     (narrow-to-region b e)
 736     (goto-char (point-min))
 737     (let ((break nil)
 738           (qword-break nil)
 739           (first t)
 740           (bol (save-restriction
 741                  (widen)
 742                  (point-at-bol))))
 743       (while (not (eobp))
 744         (when (and (or break qword-break)
 745                    (> (- (point) bol) 76))
 746           (goto-char (or break qword-break))
 747           (setq break nil
 748                 qword-break nil)
 749           (skip-chars-backward " \t")
 750           (if (looking-at "[ \t]")
 751               (insert ?\n)
 752             (insert "\n "))
 753           (setq bol (1- (point)))
 754           ;; Don't break before the first non-LWSP characters.
 755           (skip-chars-forward " \t")
 756           (unless (eobp)
 757             (forward-char 1)))
 758         (cond
 759          ((eq (char-after) ?\n)
 760           (forward-char 1)
 761           (setq bol (point)
 762                 break nil
 763                 qword-break nil)
 764           (skip-chars-forward " \t")
 765           (unless (or (eobp) (eq (char-after) ?\n))
 766             (forward-char 1)))
 767          ((eq (char-after) ?\r)
 768           (forward-char 1))
 769          ((memq (char-after) '(?  ?\t))
 770           (skip-chars-forward " \t")
 771           (unless first ;; Don't break just after the header name.
 772             (setq break (point))))
 773          ((not break)
 774           (if (not (looking-at "=\\?[^=]"))
 775               (if (eq (char-after) ?=)
 776                   (forward-char 1)
 777                 (skip-chars-forward "^ \t\n\r="))
 778             ;; Don't break at the start of the field.
 779             (unless (= (point) b)
 780               (setq qword-break (point)))
 781             (skip-chars-forward "^ \t\n\r")))
 782          (t
 783           (skip-chars-forward "^ \t\n\r")))
 784         (setq first nil))
 785       (when (and (or break qword-break)
 786                  (> (- (point) bol) 76))
 787         (goto-char (or break qword-break))