delete_temp_file fix
[bpt/emacs.git] / lisp / gnus / rfc2047.el
CommitLineData
715a2ca2 1;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
270a576a 2
ba318903 3;; Copyright (C) 1998-2014 Free Software Foundation, Inc.
c113de23
GM
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
5e809f55 9;; GNU Emacs is free software: you can redistribute it and/or modify
c113de23 10;; it under the terms of the GNU General Public License as published by
5e809f55
GM
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
c113de23
GM
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
5e809f55 16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
c113de23
GM
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
5e809f55 20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
c113de23
GM
21
22;;; Commentary:
23
d49a4975
DL
24;; RFC 2047 is "MIME (Multipurpose Internet Mail Extensions) Part
25;; Three: Message Header Extensions for Non-ASCII Text".
26
c113de23
GM
27;;; Code:
28
7f0321ff 29(eval-when-compile
9efa445f
DN
30 (require 'cl))
31(defvar message-posting-charset)
c113de23 32
c113de23 33(require 'mm-util)
270a576a 34(require 'ietf-drums)
7f0321ff 35;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
c113de23 36(require 'mail-prsvr)
82fe1aed 37(require 'rfc2045) ;; rfc2045-encode-string
f2307f18 38(autoload 'mm-body-7-or-8 "mm-bodies")
1c33719f 39
c113de23 40(defvar rfc2047-header-encoding-alist
23f87bed
MB
41 '(("Newsgroups" . nil)
42 ("Followup-To" . nil)
c113de23 43 ("Message-ID" . nil)
ad136a7c 44 ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\
23f87bed 45\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime)
c113de23
GM
46 (t . mime))
47 "*Header/encoding method alist.
48The list is traversed sequentially. The keys can either be
f2307f18 49header regexps or t.
c113de23
GM
50
51The values can be:
52
531) nil, in which case no encoding is done;
542) `mime', in which case the header will be encoded according to RFC2047;
7f0321ff
DL
553) `address-mime', like `mime', but takes account of the rules for address
56 fields (where quoted strings and comments must be treated separately);
574) a charset, in which case it will be encoded as that charset;
585) `default', in which case the field will be encoded as the rest
c113de23
GM
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)
7f0321ff
DL
69 (iso-8859-7 . B)
70 (iso-8859-8 . B)
c113de23 71 (iso-8859-9 . Q)
f2307f18
DL
72 (iso-8859-14 . Q)
73 (iso-8859-15 . Q)
c113de23
GM
74 (iso-2022-jp . B)
75 (iso-2022-kr . B)
76 (gb2312 . B)
650c9e21
KH
77 (gbk . B)
78 (gb18030 . B)
676a7cc9
SZ
79 (big5 . B)
80 (cn-big5 . B)
c113de23
GM
81 (cn-gb . B)
82 (cn-gb-2312 . B)
83 (euc-kr . B)
84 (iso-2022-jp-2 . B)
23f87bed
MB
85 (iso-2022-int-1 . B)
86 (viscii . Q))
c113de23 87 "Alist of MIME charsets to RFC2047 encodings.
7f0321ff
DL
88Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding,
89quoted-printable and base64 respectively.")
c113de23 90
10ace8ea
MB
91(defvar rfc2047-encode-function-alist
92 '((Q . rfc2047-q-encode-string)
93 (B . rfc2047-b-encode-string)
94 (nil . identity))
c113de23
GM
95 "Alist of RFC2047 encodings to encoding functions.")
96
10ace8ea
MB
97(defvar rfc2047-encode-encoded-words t
98 "Whether encoded words should be encoded again.")
99
b890d447
MB
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
c113de23
GM
134;;;
135;;; Functions for encoding RFC2047 messages
136;;;
137
f4dd4ae8
MB
138(defun rfc2047-qp-or-base64 ()
139 "Return the type with which to encode the buffer.
140This 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
c113de23
GM
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)
01c52d31 165 (point-at-bol)
c113de23
GM
166 (point-max))))
167 (goto-char (point-min)))
168
23f87bed
MB
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)
10ace8ea 175 (buffer-substring-no-properties (point) (point-max)))))
23f87bed 176
343d6628
MB
177(defun rfc2047-quote-special-characters-in-quoted-strings (&optional
178 encodable-regexp)
179 "Quote special characters with `\\'s in quoted strings.
180Quoting will not be done in a quoted string if it contains characters
01c52d31 181matching ENCODABLE-REGEXP or it is within parentheses."
343d6628
MB
182 (goto-char (point-min))
183 (let ((tspecials (concat "[" ietf-drums-tspecials "]"))
01c52d31 184 (start (point))
b110774a 185 beg end)
343d6628 186 (with-syntax-table (standard-syntax-table)
01c52d31
MB
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))))))
343d6628 225
7f0321ff
DL
226(defvar rfc2047-encoding-type 'address-mime
227 "The type of encoding done by `rfc2047-encode-region'.
228This 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
c113de23
GM
232(defun rfc2047-encode-message-header ()
233 "Encode the message header according to `rfc2047-header-encoding-alist'.
234Should be called narrowed to the head of the message."
235 (interactive "*")
236 (save-excursion
237 (goto-char (point-min))
707c77c1 238 (let (alist elem method charsets)
c113de23
GM
239 (while (not (eobp))
240 (save-restriction
241 (rfc2047-narrow-to-field)
343d6628 242 (setq method nil
707c77c1
KY
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))))))))
c113de23 328
a553a9f5
DL
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
a553a9f5 331
f2307f18
DL
332(defun rfc2047-encodable-p ()
333 "Return non-nil if any characters in current buffer need encoding in headers.
334The buffer may be narrowed."
a553a9f5 335 (require 'message) ; for message-posting-charset
c113de23 336 (let ((charsets
7f0321ff 337 (mm-find-mime-charset-region (point-min) (point-max))))
10ace8ea
MB
338 (goto-char (point-min))
339 (or (and rfc2047-encode-encoded-words
340 (prog1
b890d447 341 (re-search-forward rfc2047-encoded-word-regexp nil t)
10ace8ea
MB
342 (goto-char (point-min))))
343 (and charsets
344 (not (equal charsets (list (car message-posting-charset))))))))
7f0321ff
DL
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
23f87bed
MB
353 ;; (make-char-table 'syntax-table '(2)) only works in Emacs.
354 (let ((table (make-syntax-table)))
0c43b6f8
KY
355 ;; The following is done to work for setting all elements of the table;
356 ;; it appears to be the cleanest way.
23f87bed
MB
357 ;; Play safe and don't assume the form of the word syntax entry --
358 ;; copy it from ?a.
3d492670
KY
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)))
7f0321ff
DL
362 (modify-syntax-entry ?\\ "\\" table)
363 (modify-syntax-entry ?\" "\"" table)
10ace8ea
MB
364 (modify-syntax-entry ?\( "(" table)
365 (modify-syntax-entry ?\) ")" table)
7f0321ff
DL
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))
c113de23 375
ba775afe 376(defun rfc2047-encode-region (b e &optional dont-fold)
7f0321ff
DL
377 "Encode words in region B to E that need encoding.
378By default, the region is treated as containing RFC2822 addresses.
379Dynamically bind `rfc2047-encoding-type' to change that."
380 (save-restriction
381 (narrow-to-region b e)
10ace8ea
MB
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.
343d6628 411 (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp)
10ace8ea 412 (with-syntax-table rfc2047-syntax-table
7f0321ff 413 (goto-char (point-min))
10ace8ea 414 (condition-case err ; in case of unbalanced quotes
7f0321ff
DL
415 ;; Look for rfc2822-style: sequences of atoms, quoted
416 ;; strings, specials, whitespace. (Specials mustn't be
417 ;; encoded.)
418 (while (not (eobp))
7f0321ff 419 ;; Skip whitespace.
10ace8ea
MB
420 (skip-chars-forward " \t\n")
421 (setq start (point))
7f0321ff
DL
422 (cond
423 ((not (char-after))) ; eob
424 ;; else token start
10ace8ea 425 ((eq ?\" (setq csyntax (char-syntax (char-after))))
7f0321ff
DL
426 ;; Quoted word.
427 (forward-sexp)
428 (setq end (point))
429 ;; Does it need encoding?
430 (goto-char start)
10ace8ea
MB
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)
d355a0b7 436 (delete-char -1)
10ace8ea
MB
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)
7f0321ff
DL
453 ;; Skip other delimiters, but record that they've
454 ;; potentially separated quoted words.
455 (forward-char)
456 (setq last-encoded nil))
10ace8ea
MB
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 ")"))
7f0321ff
DL
466 (t ; normal token/whitespace sequence
467 ;; Find the end.
10ace8ea
MB
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")
7f0321ff 535 (setq end (point))
7f0321ff 536 (goto-char start)
10ace8ea
MB
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)))))
23f87bed 555 (error
10ace8ea
MB
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]+" " "))))))))
ba775afe
G
560 (unless dont-fold
561 (rfc2047-fold-region b (point)))
10ace8ea 562 (goto-char (point-max))))
c113de23 563
ba775afe 564(defun rfc2047-encode-string (string &optional dont-fold)
7f0321ff
DL
565 "Encode words in STRING.
566By default, the string is treated as containing addresses (see
23f87bed 567`rfc2047-encoding-type')."
10ace8ea 568 (mm-with-multibyte-buffer
c113de23 569 (insert string)
ba775afe 570 (rfc2047-encode-region (point-min) (point-max) dont-fold)
c113de23
GM
571 (buffer-string)))
572
b890d447
MB
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.
10ace8ea
MB
581(defvar rfc2047-encode-max-chars 76
582 "Maximum characters of each header line that contain encoded-words.
b890d447
MB
583According to RFC 2047, it is 76. If it is nil, encoded-words
584will not be folded. Too small value may cause an error. You
585should not change this value.")
10ace8ea
MB
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)
e4920bc9 601 ;; Remove a superfluous empty line.
10ace8ea
MB
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)
e4920bc9 654 ;; Remove a superfluous empty line.
10ace8ea
MB
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
7f0321ff
DL
660(defun rfc2047-encode (b e)
661 "Encode the word(s) in the region B to E.
10ace8ea
MB
662Point 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)
cbfb9427
KY
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)))
10ace8ea
MB
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
c113de23 681 rfc2047-charset-encoding-alist))
23f87bed
MB
682 ;; For the charsets that don't have a preferred
683 ;; encoding, choose the one that's shorter.
10ace8ea
MB
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))
01c52d31 695 (rfc2047-fold-region (point-at-bol) b)
10ace8ea
MB
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
01c52d31 702 (- b (point-at-bol))
10ace8ea
MB
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)))))
c113de23 731
23f87bed
MB
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
c113de23 739(defun rfc2047-fold-region (b e)
a553a9f5 740 "Fold long lines in region B to E."
c113de23
GM
741 (save-restriction
742 (narrow-to-region b e)
743 (goto-char (point-min))
f2307f18
DL
744 (let ((break nil)
745 (qword-break nil)
c6e26ce2 746 (first t)
f2307f18
DL
747 (bol (save-restriction
748 (widen)
01c52d31 749 (point-at-bol))))
c113de23 750 (while (not (eobp))
23f87bed
MB
751 (when (and (or break qword-break)
752 (> (- (point) bol) 76))
f2307f18
DL
753 (goto-char (or break qword-break))
754 (setq break nil
755 qword-break nil)
10ace8ea 756 (skip-chars-backward " \t")
c6e26ce2 757 (if (looking-at "[ \t]")
7f0321ff 758 (insert ?\n)
619ac84f 759 (insert "\n "))
f2307f18
DL
760 (setq bol (1- (point)))
761 ;; Don't break before the first non-LWSP characters.
762 (skip-chars-forward " \t")
23f87bed
MB
763 (unless (eobp)
764 (forward-char 1)))
c113de23 765 (cond
f2307f18
DL
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))
c113de23 776 ((memq (char-after) '(? ?\t))
f2307f18 777 (skip-chars-forward " \t")
10ace8ea
MB
778 (unless first ;; Don't break just after the header name.
779 (setq break (point))))
f2307f18
DL
780 ((not break)
781 (if (not (looking-at "=\\?[^=]"))
782 (if (eq (char-after) ?=)
783 (forward-char 1)
784 (skip-chars-forward "^ \t\n\r="))
23f87bed
MB
785 ;; Don't break at the start of the field.
786 (unless (= (point) b)
787 (setq qword-break (point)))
f2307f18
DL
788 (skip-chars-forward "^ \t\n\r")))
789 (t
10ace8ea
MB
790 (skip-chars-forward "^ \t\n\r")))
791 (setq first nil))
23f87bed
MB
792 (when (and (or break qword-break)
793 (> (- (point) bol) 76))
f2307f18
DL
794 (goto-char (or break qword-break))
795 (setq break nil
796 qword-break nil)
10ace8ea
MB
797 (if (or (> 0 (skip-chars-backward " \t"))
798 (looking-at "[ \t]"))
799 (insert ?\n)
800 (insert "\n "))
f2307f18
DL
801 (setq bol (1- (point)))
802 ;; Don't break before the first non-LWSP characters.
803 (skip-chars-forward " \t")
23f87bed
MB
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 (rfc2047-unfold-region (point-min) (point-max)))))
f2307f18
DL
813
814(defun rfc2047-unfold-region (b e)
a553a9f5 815 "Unfold lines in region B to E."
f2307f18
DL
816 (save-restriction
817 (narrow-to-region b e)
818 (goto-char (point-min))
819 (let ((bol (save-restriction
820 (widen)
01c52d31
MB
821 (point-at-bol)))
822 (eol (point-at-eol)))
f2307f18
DL
823 (forward-line 1)
824 (while (not (eobp))
c6e26ce2 825 (if (and (looking-at "[ \t]")
01c52d31 826 (< (- (point-at-eol) bol) 76))
c6e26ce2
DL
827 (delete-region eol (progn
828 (goto-char eol)
829 (skip-chars-forward "\r\n")
830 (point)))
01c52d31
MB
831 (setq bol (point-at-bol)))
832 (setq eol (point-at-eol))
f2307f18 833 (forward-line 1)))))
c113de23 834
10ace8ea
MB
835(defun rfc2047-b-encode-string (string)
836 "Base64-encode the header contained in STRING."
837 (base64-encode-string string t))
838
aa8f8277
GM
839(autoload 'quoted-printable-encode-region "qp")
840
10ace8ea
MB
841(defun rfc2047-q-encode-string (string)
842 "Quoted-printable-encode the header in STRING."
843 (mm-with-unibyte-buffer
844 (insert string)
845 (quoted-printable-encode-region
846 (point-min) (point-max) nil
847 ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
848 ;; Avoid using 8bit characters.
849 ;; This list excludes `especials' (see the RFC2047 syntax),
850 ;; meaning that some characters in non-structured fields will
851 ;; get encoded when they con't need to be. The following is
852 ;; what it used to be.
853 ;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
854 ;;; "\010\012\014\040-\074\076\100-\136\140-\177")
855 "-\b\n\f !#-'*+0-9A-Z\\^`-~\d")
856 (subst-char-in-region (point-min) (point-max) ? ?_)
857 (buffer-string)))
858
859(defun rfc2047-encode-parameter (param value)
860 "Return and PARAM=VALUE string encoded in the RFC2047-like style.
e4e22d29
KY
861This is a substitution for the `rfc2231-encode-string' function, that
862is the standard but many mailers don't support it."
82fe1aed
MB
863 (let ((rfc2047-encoding-type 'mime)
864 (rfc2047-encode-max-chars nil))
ba775afe 865 (rfc2045-encode-string param (rfc2047-encode-string value t))))
c113de23
GM
866
867;;;
868;;; Functions for decoding RFC2047 messages
869;;;
870
270a576a
MB
871(defvar rfc2047-quote-decoded-words-containing-tspecials nil
872 "If non-nil, quote decoded words containing special characters.")
873
292f71fe
MB
874(defvar rfc2047-allow-incomplete-encoded-text t
875 "*Non-nil means allow incomplete encoded-text in successive encoded-words.
876Dividing of encoded-text in the place other than character boundaries
877violates RFC2047 section 5, while we have a capability to decode it.
878If it is non-nil, the decoder will decode B- or Q-encoding in each
879encoded-word, concatenate them, and decode it by charset. Otherwise,
880the decoder will fully decode each encoded-word before concatenating
881them.")
882
343d6628 883(defun rfc2047-strip-backslashes-in-quoted-strings ()
d7093904 884 "Strip backslashes in quoted strings. `\\\"' remains."
343d6628
MB
885 (goto-char (point-min))
886 (let (beg)
887 (with-syntax-table (standard-syntax-table)
888 (while (search-forward "\"" nil t)
889 (unless (eq (char-before) ?\\)
890 (setq beg (match-end 0))
891 (goto-char (match-beginning 0))
892 (condition-case nil
893 (progn
894 (forward-sexp)
895 (save-restriction
896 (narrow-to-region beg (1- (point)))
897 (goto-char beg)
898 (while (search-forward "\\" nil 'move)
d7093904 899 (unless (memq (char-after) '(?\"))
d355a0b7 900 (delete-char -1))
343d6628
MB
901 (forward-char)))
902 (forward-char))
903 (error
904 (goto-char beg))))))))
905
b6b8f5fd 906(defun rfc2047-charset-to-coding-system (charset &optional allow-override)
292f71fe 907 "Return coding-system corresponding to MIME CHARSET.
b6b8f5fd
KY
908If your Emacs implementation can't decode CHARSET, return nil.
909
910If allow-override is given, use `mm-charset-override-alist' to
911map undesired charset names to their replacement. This should
912only be used for decoding, not for encoding."
292f71fe
MB
913 (when (stringp charset)
914 (setq charset (intern (downcase charset))))
915 (when (or (not charset)
916 (eq 'gnus-all mail-parse-ignored-charsets)
917 (memq 'gnus-all mail-parse-ignored-charsets)
918 (memq charset mail-parse-ignored-charsets))
919 (setq charset mail-parse-charset))
b6b8f5fd 920 (let ((cs (mm-charset-to-coding-system charset nil allow-override)))
292f71fe
MB
921 (cond ((eq cs 'ascii)
922 (setq cs (or (mm-charset-to-coding-system mail-parse-charset)
923 'raw-text)))
e13be7a2 924 ((mm-coding-system-p cs))
292f71fe
MB
925 ((and charset
926 (listp mail-parse-ignored-charsets)
927 (memq 'gnus-unknown mail-parse-ignored-charsets))
928 (setq cs (mm-charset-to-coding-system mail-parse-charset))))
929 (if (eq cs 'ascii)
930 'raw-text
931 cs)))
932
aa8f8277
GM
933(autoload 'quoted-printable-decode-string "qp")
934
292f71fe
MB
935(defun rfc2047-decode-encoded-words (words)
936 "Decode successive encoded-words in WORDS and return a decoded string.
937Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT
938ENCODED-WORD)."
939 (let (word charset cs encoding text rest)
940 (while words
941 (setq word (pop words))
14e6dc54 942 (if (and (setq cs (rfc2047-charset-to-coding-system
b6b8f5fd 943 (setq charset (car word)) t))
292f71fe
MB
944 (condition-case code
945 (cond ((char-equal ?B (nth 1 word))
946 (setq text (base64-decode-string
947 (rfc2047-pad-base64 (nth 2 word)))))
948 ((char-equal ?Q (nth 1 word))
949 (setq text (quoted-printable-decode-string
950 (mm-subst-char-in-string
951 ?_ ? (nth 2 word) t)))))
952 (error
953 (message "%s" (error-message-string code))
954 nil)))
955 (if (and rfc2047-allow-incomplete-encoded-text
956 (eq cs (caar rest)))
957 ;; Concatenate text of which the charset is the same.
958 (setcdr (car rest) (concat (cdar rest) text))
959 (push (cons cs text) rest))
960 ;; Don't decode encoded-word.
961 (push (cons nil (nth 3 word)) rest)))
962 (while rest
963 (setq words (concat
964 (or (and (setq cs (caar rest))
965 (condition-case code
966 (mm-decode-coding-string (cdar rest) cs)
967 (error
968 (message "%s" (error-message-string code))
969 nil)))
970 (concat (when (cdr rest) " ")
971 (cdar rest)
972 (when (and words
973 (not (eq (string-to-char words) ? )))
974 " ")))
975 words)
976 rest (cdr rest)))
977 words))
978
23f87bed
MB
979;; Fixme: This should decode in place, not cons intermediate strings.
980;; Also check whether it needs to worry about delimiting fields like
981;; encoding.
982
983;; In fact it's reported that (invalid) encoding of mailboxes in
984;; addr-specs is in use, so delimiting fields might help. Probably
985;; not decoding a word which isn't properly delimited is good enough
986;; and worthwhile (is it more correct or not?), e.g. something like
987;; `=?iso-8859-1?q?foo?=@'.
c113de23 988
343d6628
MB
989(defun rfc2047-decode-region (start end &optional address-mime)
990 "Decode MIME-encoded words in region between START and END.
991If ADDRESS-MIME is non-nil, strip backslashes which precede characters
992other than `\"' and `\\' in quoted strings."
c113de23
GM
993 (interactive "r")
994 (let ((case-fold-search t)
b890d447
MB
995 (eword-regexp
996 (if rfc2047-allow-irregular-q-encoded-words
997 (eval-when-compile
998 (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)"))
999 (eval-when-compile
1000 (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)"))))
292f71fe 1001 b e match words)
652dbc07
DL
1002 (save-excursion
1003 (save-restriction
1004 (narrow-to-region start end)
343d6628
MB
1005 (when address-mime
1006 (rfc2047-strip-backslashes-in-quoted-strings))
292f71fe
MB
1007 (goto-char (setq b start))
1008 ;; Look for the encoded-words.
1009 (while (setq match (re-search-forward eword-regexp nil t))
1010 (setq e (match-beginning 1)
1011 end (match-end 0)
1012 words nil)
1013 (while match
1014 (push (list (match-string 2) ;; charset
01c52d31 1015 (char-after (match-beginning 3)) ;; encoding
b890d447 1016 (substring (match-string 3) 2) ;; encoded-text
292f71fe
MB
1017 (match-string 1)) ;; encoded-word
1018 words)
1019 ;; Look for the subsequent encoded-words.
1020 (when (setq match (looking-at eword-regexp))
1021 (goto-char (setq end (match-end 0)))))
1022 ;; Replace the encoded-words with the decoded one.
1023 (delete-region e end)
1024 (insert (rfc2047-decode-encoded-words (nreverse words)))
23f87bed
MB
1025 (save-restriction
1026 (narrow-to-region e (point))
1027 (goto-char e)
270a576a
MB
1028 ;; Remove newlines between decoded words, though such
1029 ;; things essentially must not be there.
23f87bed
MB
1030 (while (re-search-forward "[\n\r]+" nil t)
1031 (replace-match " "))
30123838 1032 (setq end (point-max))
270a576a
MB
1033 ;; Quote decoded words if there are special characters
1034 ;; which might violate RFC2822.
1035 (when (and rfc2047-quote-decoded-words-containing-tspecials
1036 (let ((regexp (car (rassq
1037 'address-mime
1038 rfc2047-header-encoding-alist))))
1039 (when regexp
1040 (save-restriction
1041 (widen)
30123838
KY
1042 (and
1043 ;; Don't quote words if already quoted.
1044 (not (and (eq (char-before e) ?\")
1045 (eq (char-after end) ?\")))
1046 (progn
1047 (beginning-of-line)
1048 (while (and (memq (char-after) '(? ?\t))
1049 (zerop (forward-line -1))))
1050 (looking-at regexp)))))))
270a576a
MB
1051 (let (quoted)
1052 (goto-char e)
1053 (skip-chars-forward " \t")
1054 (setq start (point))
1055 (setq quoted (eq (char-after) ?\"))
1056 (goto-char (point-max))
1dbc941a 1057 (skip-chars-backward " \t" start)
270a576a
MB
1058 (if (setq quoted (and quoted
1059 (> (point) (1+ start))
1060 (eq (char-before) ?\")))
1061 (progn
1062 (backward-char)
1063 (setq start (1+ start)
1064 end (point-marker)))
1065 (setq end (point-marker)))
1066 (goto-char start)
1067 (while (search-forward "\"" end t)
1068 (when (prog2
1069 (backward-char)
1070 (zerop (% (skip-chars-backward "\\\\") 2))
1071 (goto-char (match-beginning 0)))
1072 (insert "\\"))
1073 (forward-char))
1074 (when (and (not quoted)
1075 (progn
1076 (goto-char start)
1077 (re-search-forward
1078 (concat "[" ietf-drums-tspecials "]")
1079 end t)))
1080 (goto-char start)
1081 (insert "\"")
1082 (goto-char end)
1083 (insert "\""))
1084 (set-marker end nil)))
23f87bed 1085 (goto-char (point-max)))
652dbc07
DL
1086 (when (and (mm-multibyte-p)
1087 mail-parse-charset
23f87bed 1088 (not (eq mail-parse-charset 'us-ascii))
652dbc07
DL
1089 (not (eq mail-parse-charset 'gnus-decoded)))
1090 (mm-decode-coding-region b e mail-parse-charset))
1091 (setq b (point)))
1092 (when (and (mm-multibyte-p)
1093 mail-parse-charset
1094 (not (eq mail-parse-charset 'us-ascii))
1095 (not (eq mail-parse-charset 'gnus-decoded)))
23f87bed 1096 (mm-decode-coding-region b (point-max) mail-parse-charset))))))
c113de23 1097
343d6628
MB
1098(defun rfc2047-decode-address-region (start end)
1099 "Decode MIME-encoded words in region between START and END.
1100Backslashes which precede characters other than `\"' and `\\' in quoted
1101strings are stripped."
1102 (rfc2047-decode-region start end t))
1103
1104(defun rfc2047-decode-string (string &optional address-mime)
1105 "Decode MIME-encoded STRING and return the result.
1106If ADDRESS-MIME is non-nil, strip backslashes which precede characters
1107other than `\"' and `\\' in quoted strings."
f15a9fec 1108 ;; (let ((m (mm-multibyte-p)))
23f87bed
MB
1109 (if (string-match "=\\?" string)
1110 (with-temp-buffer
f15a9fec
SM
1111 ;; We used to only call mm-enable-multibyte if `m' is non-nil,
1112 ;; but this can't be the right criterion. Don't just revert this
1113 ;; change if it encounters a bug. Please help me fix it
1114 ;; right instead. --Stef
1115 ;; The string returned should always be multibyte in a multibyte
1116 ;; session, i.e. the buffer should be multibyte before
1117 ;; `buffer-string' is called.
1118 (mm-enable-multibyte)
23f87bed
MB
1119 (insert string)
1120 (inline
343d6628 1121 (rfc2047-decode-region (point-min) (point-max) address-mime))
23f87bed 1122 (buffer-string))
343d6628
MB
1123 (when address-mime
1124 (setq string
1125 (with-temp-buffer
1126 (when (mm-multibyte-string-p string)
1127 (mm-enable-multibyte))
1128 (insert string)
1129 (rfc2047-strip-backslashes-in-quoted-strings)
1130 (buffer-string))))
23f87bed 1131 ;; Fixme: As above, `m' here is inappropriate.
f15a9fec 1132 (if (and ;; m
23f87bed
MB
1133 mail-parse-charset
1134 (not (eq mail-parse-charset 'us-ascii))
1135 (not (eq mail-parse-charset 'gnus-decoded)))
10ace8ea
MB
1136 ;; `decode-coding-string' in Emacs offers a third optional
1137 ;; arg NOCOPY to avoid consing a new string if the decoding
1138 ;; is "trivial". Unfortunately it currently doesn't
1139 ;; consider anything else than a `nil' coding system
1140 ;; trivial.
1141 ;; `rfc2047-decode-string' is called multiple times for each
1142 ;; article during summary buffer generation, and we really
1143 ;; want to avoid unnecessary consing. So we bypass
1144 ;; `decode-coding-string' if the string is purely ASCII.
1145 (if (and (fboundp 'detect-coding-string)
1146 ;; string is purely ASCII
1147 (eq (detect-coding-string string t) 'undecided))
f15a9fec
SM
1148 string
1149 (mm-decode-coding-string string mail-parse-charset))
1150 (mm-string-to-multibyte string)))) ;; )
c113de23 1151
343d6628
MB
1152(defun rfc2047-decode-address-string (string)
1153 "Decode MIME-encoded STRING and return the result.
1154Backslashes which precede characters other than `\"' and `\\' in quoted
1155strings are stripped."
1156 (rfc2047-decode-string string t))
1157
23f87bed
MB
1158(defun rfc2047-pad-base64 (string)
1159 "Pad STRING to quartets."
1160 ;; Be more liberal to accept buggy base64 strings. If
1161 ;; base64-decode-string accepts buggy strings, this function could
1162 ;; be aliased to identity.
f4dd4ae8
MB
1163 (if (= 0 (mod (length string) 4))
1164 string
1165 (when (string-match "=+$" string)
1166 (setq string (substring string 0 (match-beginning 0))))
1167 (case (mod (length string) 4)
1168 (0 string)
1169 (1 string) ;; Error, don't pad it.
1170 (2 (concat string "=="))
1171 (3 (concat string "=")))))
652dbc07 1172
c113de23
GM
1173(provide 'rfc2047)
1174
1175;;; rfc2047.el ends here