1 |
;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages |
;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages |
2 |
;; Copyright (C) 1998,1999,2000,02,03,2004 Free Software Foundation, Inc. |
;; Copyright (C) 1998, 1999, 2000, 2002, 2003 Free Software Foundation, Inc. |
3 |
|
|
4 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
5 |
;; MORIOKA Tomohiko <morioka@jaist.ac.jp> |
;; MORIOKA Tomohiko <morioka@jaist.ac.jp> |
29 |
|
|
30 |
(eval-when-compile |
(eval-when-compile |
31 |
(require 'cl) |
(require 'cl) |
32 |
(defvar message-posting-charset)) |
(defvar message-posting-charset) |
33 |
|
(unless (fboundp 'with-syntax-table) ; not in Emacs 20 |
34 |
|
(defmacro with-syntax-table (table &rest body) |
35 |
|
"Evaluate BODY with syntax table of current buffer set to TABLE. |
36 |
|
The syntax table of the current buffer is saved, BODY is evaluated, and the |
37 |
|
saved table is restored, even in case of an abnormal exit. |
38 |
|
Value is what BODY returns." |
39 |
|
(let ((old-table (make-symbol "table")) |
40 |
|
(old-buffer (make-symbol "buffer"))) |
41 |
|
`(let ((,old-table (syntax-table)) |
42 |
|
(,old-buffer (current-buffer))) |
43 |
|
(unwind-protect |
44 |
|
(progn |
45 |
|
(set-syntax-table ,table) |
46 |
|
,@body) |
47 |
|
(save-current-buffer |
48 |
|
(set-buffer ,old-buffer) |
49 |
|
(set-syntax-table ,old-table)))))))) |
50 |
|
|
51 |
(require 'qp) |
(require 'qp) |
52 |
(require 'mm-util) |
(require 'mm-util) |
55 |
(require 'base64) |
(require 'base64) |
56 |
(autoload 'mm-body-7-or-8 "mm-bodies") |
(autoload 'mm-body-7-or-8 "mm-bodies") |
57 |
|
|
58 |
|
(eval-and-compile |
59 |
|
;; Avoid gnus-util for mm- code. |
60 |
|
(defalias 'rfc2047-point-at-bol |
61 |
|
(if (fboundp 'point-at-bol) |
62 |
|
'point-at-bol |
63 |
|
'line-beginning-position)) |
64 |
|
|
65 |
|
(defalias 'rfc2047-point-at-eol |
66 |
|
(if (fboundp 'point-at-eol) |
67 |
|
'point-at-eol |
68 |
|
'line-end-position))) |
69 |
|
|
70 |
(defvar rfc2047-header-encoding-alist |
(defvar rfc2047-header-encoding-alist |
71 |
'(("Newsgroups\\|Followup-To" . nil) |
'(("Newsgroups" . nil) |
72 |
|
("Followup-To" . nil) |
73 |
("Message-ID" . nil) |
("Message-ID" . nil) |
74 |
("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\)" . |
("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\ |
75 |
address-mime) |
\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime) |
76 |
(t . mime)) |
(t . mime)) |
77 |
"*Header/encoding method alist. |
"*Header/encoding method alist. |
78 |
The list is traversed sequentially. The keys can either be |
The list is traversed sequentially. The keys can either be |
110 |
(cn-gb-2312 . B) |
(cn-gb-2312 . B) |
111 |
(euc-kr . B) |
(euc-kr . B) |
112 |
(iso-2022-jp-2 . B) |
(iso-2022-jp-2 . B) |
113 |
(iso-2022-int-1 . B)) |
(iso-2022-int-1 . B) |
114 |
|
(viscii . Q)) |
115 |
"Alist of MIME charsets to RFC2047 encodings. |
"Alist of MIME charsets to RFC2047 encodings. |
116 |
Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding, |
Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding, |
117 |
quoted-printable and base64 respectively.") |
quoted-printable and base64 respectively.") |
122 |
(nil . ignore)) |
(nil . ignore)) |
123 |
"Alist of RFC2047 encodings to encoding functions.") |
"Alist of RFC2047 encodings to encoding functions.") |
124 |
|
|
|
(defvar rfc2047-q-encoding-alist |
|
|
'(("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\):" |
|
|
. "-A-Za-z0-9!*+/" ) |
|
|
;; = (\075), _ (\137), ? (\077) are used in the encoded word. |
|
|
;; Avoid using 8bit characters. |
|
|
;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?" |
|
|
("." . "\010\012\014\040-\074\076\100-\136\140-\177")) |
|
|
"Alist of header regexps and valid Q characters.") |
|
|
|
|
125 |
;;; |
;;; |
126 |
;;; Functions for encoding RFC2047 messages |
;;; Functions for encoding RFC2047 messages |
127 |
;;; |
;;; |
134 |
(progn |
(progn |
135 |
(forward-line 1) |
(forward-line 1) |
136 |
(if (re-search-forward "^[^ \n\t]" nil t) |
(if (re-search-forward "^[^ \n\t]" nil t) |
137 |
(progn |
(rfc2047-point-at-bol) |
|
(beginning-of-line) |
|
|
(point)) |
|
138 |
(point-max)))) |
(point-max)))) |
139 |
(goto-char (point-min))) |
(goto-char (point-min))) |
140 |
|
|
141 |
|
(defun rfc2047-field-value () |
142 |
|
"Return the value of the field at point." |
143 |
|
(save-excursion |
144 |
|
(save-restriction |
145 |
|
(rfc2047-narrow-to-field) |
146 |
|
(re-search-forward ":[ \t\n]*" nil t) |
147 |
|
(buffer-substring (point) (point-max))))) |
148 |
|
|
149 |
(defvar rfc2047-encoding-type 'address-mime |
(defvar rfc2047-encoding-type 'address-mime |
150 |
"The type of encoding done by `rfc2047-encode-region'. |
"The type of encoding done by `rfc2047-encode-region'. |
151 |
This should be dynamically bound around calls to |
This should be dynamically bound around calls to |
197 |
((eq method 'address-mime) |
((eq method 'address-mime) |
198 |
(rfc2047-encode-region (point) (point-max))) |
(rfc2047-encode-region (point) (point-max))) |
199 |
((eq method 'mime) |
((eq method 'mime) |
200 |
(let ((rfc2047-encoding-type method)) |
(let ((rfc2047-encoding-type 'mime)) |
201 |
(rfc2047-encode-region (point) (point-max)))) |
(rfc2047-encode-region (point) (point-max)))) |
202 |
((eq method 'default) |
((eq method 'default) |
203 |
(if (and (featurep 'mule) |
(if (and (featurep 'mule) |
206 |
mail-parse-charset) |
mail-parse-charset) |
207 |
(mm-encode-coding-region (point) (point-max) |
(mm-encode-coding-region (point) (point-max) |
208 |
mail-parse-charset))) |
mail-parse-charset))) |
209 |
|
;; We get this when CC'ing messsages to newsgroups with |
210 |
|
;; 8-bit names. The group name mail copy just got |
211 |
|
;; unconditionally encoded. Previously, it would ask |
212 |
|
;; whether to encode, which was quite confusing for the |
213 |
|
;; user. If the new behaviour is wrong, tell me. I have |
214 |
|
;; left the old code commented out below. |
215 |
|
;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07. |
216 |
|
;; Modified by Dave Love, with the commented-out code changed |
217 |
|
;; in accordance with changes elsewhere. |
218 |
|
((null method) |
219 |
|
(rfc2047-encode-region (point) (point-max))) |
220 |
|
;;; ((null method) |
221 |
|
;;; (if (or (message-options-get |
222 |
|
;;; 'rfc2047-encode-message-header-encode-any) |
223 |
|
;;; (message-options-set |
224 |
|
;;; 'rfc2047-encode-message-header-encode-any |
225 |
|
;;; (y-or-n-p |
226 |
|
;;; "Some texts are not encoded. Encode anyway?"))) |
227 |
|
;;; (rfc2047-encode-region (point-min) (point-max)) |
228 |
|
;;; (error "Cannot send unencoded text"))) |
229 |
((mm-coding-system-p method) |
((mm-coding-system-p method) |
230 |
(if (and (featurep 'mule) |
(if (and (featurep 'mule) |
231 |
(if (boundp 'default-enable-multibyte-characters) |
(if (boundp 'default-enable-multibyte-characters) |
245 |
(require 'message) ; for message-posting-charset |
(require 'message) ; for message-posting-charset |
246 |
(let ((charsets |
(let ((charsets |
247 |
(mm-find-mime-charset-region (point-min) (point-max)))) |
(mm-find-mime-charset-region (point-min) (point-max)))) |
248 |
(and charsets (not (equal charsets (list message-posting-charset)))))) |
(and charsets |
249 |
|
(not (equal charsets (list (car message-posting-charset))))))) |
250 |
|
|
251 |
;; Use this syntax table when parsing into regions that may need |
;; Use this syntax table when parsing into regions that may need |
252 |
;; encoding. Double quotes are string delimiters, backslash is |
;; encoding. Double quotes are string delimiters, backslash is |
255 |
;; skip to the end of regions appropriately. Nb. ietf-drums does |
;; skip to the end of regions appropriately. Nb. ietf-drums does |
256 |
;; things differently. |
;; things differently. |
257 |
(defconst rfc2047-syntax-table |
(defconst rfc2047-syntax-table |
258 |
(let ((table (make-char-table 'syntax-table '(2)))) |
;; (make-char-table 'syntax-table '(2)) only works in Emacs. |
259 |
|
(let ((table (make-syntax-table))) |
260 |
|
;; The following is done to work for setting all elements of the table |
261 |
|
;; in Emacs 21 and 22 and XEmacs; it appears to be the cleanest way. |
262 |
|
;; Play safe and don't assume the form of the word syntax entry -- |
263 |
|
;; copy it from ?a. |
264 |
|
(if (fboundp 'set-char-table-range) ; Emacs |
265 |
|
(funcall (intern "set-char-table-range") |
266 |
|
table t (aref (standard-syntax-table) ?a)) |
267 |
|
(if (fboundp 'put-char-table) |
268 |
|
(if (fboundp 'get-char-table) ; warning avoidance |
269 |
|
(put-char-table t (get-char-table ?a (standard-syntax-table)) |
270 |
|
table)))) |
271 |
(modify-syntax-entry ?\\ "\\" table) |
(modify-syntax-entry ?\\ "\\" table) |
272 |
(modify-syntax-entry ?\" "\"" table) |
(modify-syntax-entry ?\" "\"" table) |
273 |
(modify-syntax-entry ?\( "." table) |
(modify-syntax-entry ?\( "." table) |
289 |
(save-restriction |
(save-restriction |
290 |
(narrow-to-region b e) |
(narrow-to-region b e) |
291 |
(if (eq 'mime rfc2047-encoding-type) |
(if (eq 'mime rfc2047-encoding-type) |
292 |
;; Simple case -- treat as single word. |
;; Simple case. Treat as single word after any initial ASCII |
293 |
|
;; part and before any tailing ASCII part. The leading ASCII |
294 |
|
;; is relevant for instance in Subject headers with `Re:' for |
295 |
|
;; interoperability with non-MIME clients, and we might as |
296 |
|
;; well avoid the tail too. |
297 |
(progn |
(progn |
298 |
(goto-char (point-min)) |
(goto-char (point-min)) |
299 |
;; Does it need encoding? |
;; Does it need encoding? |
300 |
(skip-chars-forward "\000-\177" e) |
(skip-chars-forward "\000-\177") |
301 |
(unless (eobp) |
(unless (eobp) |
302 |
(rfc2047-encode b e))) |
(skip-chars-backward "^ \n") ; beginning of space-delimited word |
303 |
|
(rfc2047-encode (point) (progn |
304 |
|
(goto-char e) |
305 |
|
(skip-chars-backward "\000-\177") |
306 |
|
(skip-chars-forward "^ \n") |
307 |
|
;; end of space-delimited word |
308 |
|
(point))))) |
309 |
;; `address-mime' case -- take care of quoted words, comments. |
;; `address-mime' case -- take care of quoted words, comments. |
310 |
(with-syntax-table rfc2047-syntax-table |
(with-syntax-table rfc2047-syntax-table |
311 |
(let ((start (point)) ; start of current token |
(let ((start) ; start of current token |
312 |
end ; end of current token |
end ; end of current token |
313 |
;; Whether there's an encoded word before the current |
;; Whether there's an encoded word before the current |
314 |
;; token, either immediately or separated by space. |
;; token, either immediately or separated by space. |
315 |
last-encoded) |
last-encoded) |
316 |
(goto-char (point-min)) |
(goto-char (point-min)) |
317 |
(condition-case nil ; in case of unbalanced quotes |
(condition-case nil ; in case of unbalanced quotes |
318 |
;; Look for rfc2822-style: sequences of atoms, quoted |
;; Look for rfc2822-style: sequences of atoms, quoted |
319 |
;; strings, specials, whitespace. (Specials mustn't be |
;; strings, specials, whitespace. (Specials mustn't be |
320 |
;; encoded.) |
;; encoded.) |
377 |
end (1+ end))) |
end (1+ end))) |
378 |
(rfc2047-encode start end) |
(rfc2047-encode start end) |
379 |
(setq last-encoded t))))) |
(setq last-encoded t))))) |
380 |
(error (error "Invalid data for rfc2047 encoding: %s" |
(error |
381 |
(buffer-substring b e))))))) |
(error "Invalid data for rfc2047 encoding: %s" |
382 |
|
(buffer-substring b e))))))) |
383 |
(rfc2047-fold-region b (point)))) |
(rfc2047-fold-region b (point)))) |
384 |
|
|
385 |
(defun rfc2047-encode-string (string) |
(defun rfc2047-encode-string (string) |
386 |
"Encode words in STRING. |
"Encode words in STRING. |
387 |
By default, the string is treated as containing addresses (see |
By default, the string is treated as containing addresses (see |
388 |
`rfc2047-special-chars')." |
`rfc2047-encoding-type')." |
389 |
(with-temp-buffer |
(with-temp-buffer |
390 |
(insert string) |
(insert string) |
391 |
(rfc2047-encode-region (point-min) (point-max)) |
(rfc2047-encode-region (point-min) (point-max)) |
394 |
(defun rfc2047-encode (b e) |
(defun rfc2047-encode (b e) |
395 |
"Encode the word(s) in the region B to E. |
"Encode the word(s) in the region B to E. |
396 |
By default, the region is treated as containing addresses (see |
By default, the region is treated as containing addresses (see |
397 |
`rfc2047-special-chars')." |
`rfc2047-encoding-type')." |
398 |
(let* ((mime-charset (mm-find-mime-charset-region b e)) |
(let* ((mime-charset (mm-find-mime-charset-region b e)) |
399 |
(cs (if (> (length mime-charset) 1) |
(cs (if (> (length mime-charset) 1) |
400 |
;; Fixme: Instead of this, try to break region into |
;; Fixme: Instead of this, try to break region into |
405 |
(mm-charset-to-coding-system mime-charset))) |
(mm-charset-to-coding-system mime-charset))) |
406 |
;; Fixme: Better, calculate the number of non-ASCII |
;; Fixme: Better, calculate the number of non-ASCII |
407 |
;; characters, at least for 8-bit charsets. |
;; characters, at least for 8-bit charsets. |
408 |
(encoding (if (assq mime-charset |
(encoding (or (cdr (assq mime-charset |
|
rfc2047-charset-encoding-alist) |
|
|
(cdr (assq mime-charset |
|
409 |
rfc2047-charset-encoding-alist)) |
rfc2047-charset-encoding-alist)) |
410 |
'B)) |
;; For the charsets that don't have a preferred |
411 |
|
;; encoding, choose the one that's shorter. |
412 |
|
(save-restriction |
413 |
|
(narrow-to-region b e) |
414 |
|
(if (eq (mm-qp-or-base64) 'base64) |
415 |
|
'B |
416 |
|
'Q)))) |
417 |
(start (concat |
(start (concat |
418 |
"=?" (downcase (symbol-name mime-charset)) "?" |
"=?" (downcase (symbol-name mime-charset)) "?" |
419 |
(downcase (symbol-name encoding)) "?")) |
(downcase (symbol-name encoding)) "?")) |
420 |
|
(factor (case mime-charset |
421 |
|
((iso-8859-5 iso-8859-7 iso-8859-8 koi8-r) 1) |
422 |
|
((big5 gb2312 euc-kr) 2) |
423 |
|
(utf-8 4) |
424 |
|
(t 8))) |
425 |
|
(pre (- b (save-restriction |
426 |
|
(widen) |
427 |
|
(rfc2047-point-at-bol)))) |
428 |
|
;; encoded-words must not be longer than 75 characters, |
429 |
|
;; including charset, encoding etc. This leaves us with |
430 |
|
;; 75 - (length start) - 2 - 2 characters. The last 2 is for |
431 |
|
;; possible base64 padding. In the worst case (iso-2022-*) |
432 |
|
;; each character expands to 8 bytes which is expanded by a |
433 |
|
;; factor of 4/3 by base64 encoding. |
434 |
|
(length (floor (- 75 (length start) 4) (* factor (/ 4.0 3.0)))) |
435 |
|
;; Limit line length to 76 characters. |
436 |
|
(length1 (max 1 (floor (- 76 (length start) 4 pre) |
437 |
|
(* factor (/ 4.0 3.0))))) |
438 |
(first t)) |
(first t)) |
439 |
(if mime-charset |
(if mime-charset |
440 |
(save-restriction |
(save-restriction |
443 |
;; break into lines before encoding |
;; break into lines before encoding |
444 |
(goto-char (point-min)) |
(goto-char (point-min)) |
445 |
(while (not (eobp)) |
(while (not (eobp)) |
446 |
(goto-char (min (point-max) (+ 15 (point)))) |
(if first |
447 |
|
(progn |
448 |
|
(goto-char (min (point-max) (+ length1 (point)))) |
449 |
|
(setq first nil)) |
450 |
|
(goto-char (min (point-max) (+ length (point))))) |
451 |
(unless (eobp) |
(unless (eobp) |
452 |
(insert ?\n)))) |
(insert ?\n))) |
453 |
|
(setq first t)) |
454 |
(if (and (mm-multibyte-p) |
(if (and (mm-multibyte-p) |
455 |
(mm-coding-system-p cs)) |
(mm-coding-system-p cs)) |
456 |
(mm-encode-coding-region (point-min) (point-max) cs)) |
(mm-encode-coding-region (point-min) (point-max) cs)) |
466 |
(insert "?=") |
(insert "?=") |
467 |
(forward-line 1)))))) |
(forward-line 1)))))) |
468 |
|
|
469 |
|
(defun rfc2047-fold-field () |
470 |
|
"Fold the current header field." |
471 |
|
(save-excursion |
472 |
|
(save-restriction |
473 |
|
(rfc2047-narrow-to-field) |
474 |
|
(rfc2047-fold-region (point-min) (point-max))))) |
475 |
|
|
476 |
(defun rfc2047-fold-region (b e) |
(defun rfc2047-fold-region (b e) |
477 |
"Fold long lines in region B to E." |
"Fold long lines in region B to E." |
478 |
(save-restriction |
(save-restriction |
483 |
(first t) |
(first t) |
484 |
(bol (save-restriction |
(bol (save-restriction |
485 |
(widen) |
(widen) |
486 |
(mm-point-at-bol)))) |
(rfc2047-point-at-bol)))) |
487 |
(while (not (eobp)) |
(while (not (eobp)) |
488 |
(when (and (or break qword-break) (> (- (point) bol) 76)) |
(when (and (or break qword-break) |
489 |
|
(> (- (point) bol) 76)) |
490 |
(goto-char (or break qword-break)) |
(goto-char (or break qword-break)) |
491 |
(setq break nil |
(setq break nil |
492 |
qword-break nil) |
qword-break nil) |
496 |
(setq bol (1- (point))) |
(setq bol (1- (point))) |
497 |
;; Don't break before the first non-LWSP characters. |
;; Don't break before the first non-LWSP characters. |
498 |
(skip-chars-forward " \t") |
(skip-chars-forward " \t") |
499 |
(unless (eobp) (forward-char 1))) |
(unless (eobp) |
500 |
|
(forward-char 1))) |
501 |
(cond |
(cond |
502 |
((eq (char-after) ?\n) |
((eq (char-after) ?\n) |
503 |
(forward-char 1) |
(forward-char 1) |
520 |
(if (eq (char-after) ?=) |
(if (eq (char-after) ?=) |
521 |
(forward-char 1) |
(forward-char 1) |
522 |
(skip-chars-forward "^ \t\n\r=")) |
(skip-chars-forward "^ \t\n\r=")) |
523 |
(setq qword-break (point)) |
;; Don't break at the start of the field. |
524 |
|
(unless (= (point) b) |
525 |
|
(setq qword-break (point))) |
526 |
(skip-chars-forward "^ \t\n\r"))) |
(skip-chars-forward "^ \t\n\r"))) |
527 |
(t |
(t |
528 |
(skip-chars-forward "^ \t\n\r")))) |
(skip-chars-forward "^ \t\n\r")))) |
529 |
(when (and (or break qword-break) (> (- (point) bol) 76)) |
(when (and (or break qword-break) |
530 |
|
(> (- (point) bol) 76)) |
531 |
(goto-char (or break qword-break)) |
(goto-char (or break qword-break)) |
532 |
(setq break nil |
(setq break nil |
533 |
qword-break nil) |
qword-break nil) |
537 |
(setq bol (1- (point))) |
(setq bol (1- (point))) |
538 |
;; Don't break before the first non-LWSP characters. |
;; Don't break before the first non-LWSP characters. |
539 |
(skip-chars-forward " \t") |
(skip-chars-forward " \t") |
540 |
(unless (eobp) (forward-char 1)))))) |
(unless (eobp) |
541 |
|
(forward-char 1)))))) |
542 |
|
|
543 |
|
(defun rfc2047-unfold-field () |
544 |
|
"Fold the current line." |
545 |
|
(save-excursion |
546 |
|
(save-restriction |
547 |
|
(rfc2047-narrow-to-field) |
548 |
|
(rfc2047-unfold-region (point-min) (point-max))))) |
549 |
|
|
550 |
(defun rfc2047-unfold-region (b e) |
(defun rfc2047-unfold-region (b e) |
551 |
"Unfold lines in region B to E." |
"Unfold lines in region B to E." |
554 |
(goto-char (point-min)) |
(goto-char (point-min)) |
555 |
(let ((bol (save-restriction |
(let ((bol (save-restriction |
556 |
(widen) |
(widen) |
557 |
(mm-point-at-bol))) |
(rfc2047-point-at-bol))) |
558 |
(eol (mm-point-at-eol)) |
(eol (rfc2047-point-at-eol))) |
|
leading) |
|
559 |
(forward-line 1) |
(forward-line 1) |
560 |
(while (not (eobp)) |
(while (not (eobp)) |
561 |
(if (and (looking-at "[ \t]") |
(if (and (looking-at "[ \t]") |
562 |
(< (- (mm-point-at-eol) bol) 76)) |
(< (- (rfc2047-point-at-eol) bol) 76)) |
563 |
(delete-region eol (progn |
(delete-region eol (progn |
564 |
(goto-char eol) |
(goto-char eol) |
565 |
(skip-chars-forward "\r\n") |
(skip-chars-forward "\r\n") |
566 |
(point))) |
(point))) |
567 |
(setq bol (mm-point-at-bol))) |
(setq bol (rfc2047-point-at-bol))) |
568 |
(setq eol (mm-point-at-eol)) |
(setq eol (rfc2047-point-at-eol)) |
569 |
(forward-line 1))))) |
(forward-line 1))))) |
570 |
|
|
571 |
(defun rfc2047-b-encode-region (b e) |
(defun rfc2047-b-encode-region (b e) |
583 |
(save-excursion |
(save-excursion |
584 |
(save-restriction |
(save-restriction |
585 |
(narrow-to-region (goto-char b) e) |
(narrow-to-region (goto-char b) e) |
586 |
(let ((alist rfc2047-q-encoding-alist) |
(let ((bol (save-restriction |
|
(bol (save-restriction |
|
587 |
(widen) |
(widen) |
588 |
(mm-point-at-bol)))) |
(rfc2047-point-at-bol)))) |
589 |
(while alist |
(quoted-printable-encode-region |
590 |
(when (looking-at (caar alist)) |
b e nil |
591 |
(quoted-printable-encode-region b e nil (cdar alist)) |
;; = (\075), _ (\137), ? (\077) are used in the encoded word. |
592 |
(subst-char-in-region (point-min) (point-max) ? ?_) |
;; Avoid using 8bit characters. |
593 |
(setq alist nil)) |
;; This list excludes `especials' (see the RFC2047 syntax), |
594 |
(pop alist)) |
;; meaning that some characters in non-structured fields will |
595 |
|
;; get encoded when they con't need to be. The following is |
596 |
|
;; what it used to be. |
597 |
|
;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?" |
598 |
|
;;; "\010\012\014\040-\074\076\100-\136\140-\177") |
599 |
|
"-\b\n\f !#-'*+0-9A-Z\\^`-~\d") |
600 |
|
(subst-char-in-region (point-min) (point-max) ? ?_) |
601 |
;; The size of QP encapsulation is about 20, so set limit to |
;; The size of QP encapsulation is about 20, so set limit to |
602 |
;; 56=76-20. |
;; 56=76-20. |
603 |
(unless (< (- (point-max) (point-min)) 56) |
(unless (< (- (point-max) (point-min)) 56) |
608 |
(goto-char (min (point-max) (+ 56 bol))) |
(goto-char (min (point-max) (+ 56 bol))) |
609 |
(search-backward "=" (- (point) 2) t) |
(search-backward "=" (- (point) 2) t) |
610 |
(unless (or (bobp) (eobp)) |
(unless (or (bobp) (eobp)) |
611 |
(insert "\n") |
(insert ?\n) |
612 |
(setq bol (point))))))))) |
(setq bol (point))))))))) |
613 |
|
|
614 |
;;; |
;;; |
615 |
;;; Functions for decoding RFC2047 messages |
;;; Functions for decoding RFC2047 messages |
616 |
;;; |
;;; |
617 |
|
|
618 |
(defvar rfc2047-encoded-word-regexp |
(eval-and-compile |
619 |
"=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~ +]+\\)\\?=") |
(defconst rfc2047-encoded-word-regexp |
620 |
|
"=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\ |
621 |
|
\\?\\([!->@-~ +]*\\)\\?=")) |
622 |
|
|
623 |
|
;; Fixme: This should decode in place, not cons intermediate strings. |
624 |
|
;; Also check whether it needs to worry about delimiting fields like |
625 |
|
;; encoding. |
626 |
|
|
627 |
|
;; In fact it's reported that (invalid) encoding of mailboxes in |
628 |
|
;; addr-specs is in use, so delimiting fields might help. Probably |
629 |
|
;; not decoding a word which isn't properly delimited is good enough |
630 |
|
;; and worthwhile (is it more correct or not?), e.g. something like |
631 |
|
;; `=?iso-8859-1?q?foo?=@'. |
632 |
|
|
633 |
(defun rfc2047-decode-region (start end) |
(defun rfc2047-decode-region (start end) |
634 |
"Decode MIME-encoded words in region between START and END." |
"Decode MIME-encoded words in region between START and END." |
641 |
(goto-char (point-min)) |
(goto-char (point-min)) |
642 |
;; Remove whitespace between encoded words. |
;; Remove whitespace between encoded words. |
643 |
(while (re-search-forward |
(while (re-search-forward |
644 |
(concat "\\(" rfc2047-encoded-word-regexp "\\)" |
(eval-when-compile |
645 |
"\\(\n?[ \t]\\)+" |
(concat "\\(" rfc2047-encoded-word-regexp "\\)" |
646 |
"\\(" rfc2047-encoded-word-regexp "\\)") |
"\\(\n?[ \t]\\)+" |
647 |
|
"\\(" rfc2047-encoded-word-regexp "\\)")) |
648 |
nil t) |
nil t) |
649 |
(delete-region (goto-char (match-end 1)) (match-beginning 6))) |
(delete-region (goto-char (match-end 1)) (match-beginning 6))) |
650 |
;; Decode the encoded words. |
;; Decode the encoded words. |
655 |
(prog1 |
(prog1 |
656 |
(match-string 0) |
(match-string 0) |
657 |
(delete-region (match-beginning 0) (match-end 0))))) |
(delete-region (match-beginning 0) (match-end 0))))) |
658 |
|
;; Remove newlines between decoded words, though such things |
659 |
|
;; essentially must not be there. |
660 |
|
(save-restriction |
661 |
|
(narrow-to-region e (point)) |
662 |
|
(goto-char e) |
663 |
|
(while (re-search-forward "[\n\r]+" nil t) |
664 |
|
(replace-match " ")) |
665 |
|
(goto-char (point-max))) |
666 |
(when (and (mm-multibyte-p) |
(when (and (mm-multibyte-p) |
667 |
mail-parse-charset |
mail-parse-charset |
668 |
|
(not (eq mail-parse-charset 'us-ascii)) |
669 |
(not (eq mail-parse-charset 'gnus-decoded))) |
(not (eq mail-parse-charset 'gnus-decoded))) |
670 |
(mm-decode-coding-region b e mail-parse-charset)) |
(mm-decode-coding-region b e mail-parse-charset)) |
671 |
(setq b (point))) |
(setq b (point))) |
673 |
mail-parse-charset |
mail-parse-charset |
674 |
(not (eq mail-parse-charset 'us-ascii)) |
(not (eq mail-parse-charset 'us-ascii)) |
675 |
(not (eq mail-parse-charset 'gnus-decoded))) |
(not (eq mail-parse-charset 'gnus-decoded))) |
676 |
(mm-decode-coding-region b (point-max) mail-parse-charset)) |
(mm-decode-coding-region b (point-max) mail-parse-charset)))))) |
|
(rfc2047-unfold-region (point-min) (point-max)))))) |
|
677 |
|
|
678 |
(defun rfc2047-decode-string (string) |
(defun rfc2047-decode-string (string) |
679 |
"Decode the quoted-printable-encoded STRING and return the results." |
"Decode the quoted-printable-encoded STRING and return the results." |
680 |
(let ((m (mm-multibyte-p))) |
(let ((m (mm-multibyte-p))) |
681 |
(with-temp-buffer |
(if (string-match "=\\?" string) |
682 |
(when m |
(with-temp-buffer |
683 |
(mm-enable-multibyte)) |
;; Fixme: This logic is wrong, but seems to be required by |
684 |
(insert string) |
;; Gnus summary buffer generation. The value of `m' depends |
685 |
(inline |
;; on the current buffer, not global multibyteness or that |
686 |
(rfc2047-decode-region (point-min) (point-max))) |
;; of the string. Also the string returned should always be |
687 |
(buffer-string)))) |
;; multibyte in a multibyte session, i.e. the buffer should |
688 |
|
;; be multibyte before `buffer-string' is called. |
689 |
|
(when m |
690 |
|
(mm-enable-multibyte)) |
691 |
|
(insert string) |
692 |
|
(inline |
693 |
|
(rfc2047-decode-region (point-min) (point-max))) |
694 |
|
(buffer-string)) |
695 |
|
;; Fixme: As above, `m' here is inappropriate. |
696 |
|
(if (and m |
697 |
|
mail-parse-charset |
698 |
|
(not (eq mail-parse-charset 'us-ascii)) |
699 |
|
(not (eq mail-parse-charset 'gnus-decoded))) |
700 |
|
(mm-decode-coding-string string mail-parse-charset) |
701 |
|
(mm-string-as-multibyte string))))) |
702 |
|
|
703 |
(defun rfc2047-parse-and-decode (word) |
(defun rfc2047-parse-and-decode (word) |
704 |
"Decode WORD and return it if it is an encoded word. |
"Decode WORD and return it if it is an encoded word. |
705 |
Return WORD if not." |
Return WORD if it is not not an encoded word or if the charset isn't |
706 |
|
decodable." |
707 |
(if (not (string-match rfc2047-encoded-word-regexp word)) |
(if (not (string-match rfc2047-encoded-word-regexp word)) |
708 |
word |
word |
709 |
(or |
(or |
713 |
(upcase (match-string 2 word)) |
(upcase (match-string 2 word)) |
714 |
(match-string 3 word)) |
(match-string 3 word)) |
715 |
(error word)) |
(error word)) |
716 |
word))) |
word))) ; un-decodable |
717 |
|
|
718 |
|
(defun rfc2047-pad-base64 (string) |
719 |
|
"Pad STRING to quartets." |
720 |
|
;; Be more liberal to accept buggy base64 strings. If |
721 |
|
;; base64-decode-string accepts buggy strings, this function could |
722 |
|
;; be aliased to identity. |
723 |
|
(case (mod (length string) 4) |
724 |
|
(0 string) |
725 |
|
(1 string) ;; Error, don't pad it. |
726 |
|
(2 (concat string "==")) |
727 |
|
(3 (concat string "=")))) |
728 |
|
|
729 |
(defun rfc2047-decode (charset encoding string) |
(defun rfc2047-decode (charset encoding string) |
730 |
"Decode STRING from the given MIME CHARSET in the given ENCODING. |
"Decode STRING from the given MIME CHARSET in the given ENCODING. |
746 |
(when (and (eq cs 'ascii) |
(when (and (eq cs 'ascii) |
747 |
mail-parse-charset) |
mail-parse-charset) |
748 |
(setq cs mail-parse-charset)) |
(setq cs mail-parse-charset)) |
749 |
;; Ensure unibyte result in Emacs 20. |
(mm-decode-coding-string |
750 |
(let (default-enable-multibyte-characters) |
(cond |
751 |
(with-temp-buffer |
((equal "B" encoding) |
752 |
(mm-decode-coding-string |
(base64-decode-string |
753 |
(cond |
(rfc2047-pad-base64 string))) |
754 |
((equal "B" encoding) |
((equal "Q" encoding) |
755 |
(base64-decode-string string)) |
(quoted-printable-decode-string |
756 |
((equal "Q" encoding) |
(mm-replace-chars-in-string string ?_ ? ))) |
757 |
(quoted-printable-decode-string |
(t (error "Invalid encoding: %s" encoding))) |
758 |
(mm-replace-chars-in-string string ?_ ? ))) |
cs)))) |
|
(t (error "Invalid encoding: %s" encoding))) |
|
|
cs)))))) |
|
759 |
|
|
760 |
(provide 'rfc2047) |
(provide 'rfc2047) |
761 |
|
|