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

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