* smiley-ems.el (smiley-update-cache): Check for valid types.
[gnus] / lisp / rfc2047.el
1 ;;; rfc2047.el --- Functions for encoding and decoding rfc2047 messages
2 ;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; This file is part of GNU Emacs.
7
8 ;; GNU Emacs is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;; GNU General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA.
22
23 ;;; Commentary:
24
25 ;; RFC 2047 is "MIME (Multipurpose Internet Mail Extensions) Part
26 ;; Three:  Message Header Extensions for Non-ASCII Text".
27
28 ;;; Code:
29
30 (eval-when-compile (require 'cl))
31
32 (require 'qp)
33 (require 'mm-util)
34 (require 'ietf-drums)
35 (require 'mail-prsvr)
36 (require 'base64)
37 ;; Fixme: Avoid this (for gnus-point-at-...) mm dependence on gnus.
38 (require 'gnus-util)
39 (autoload 'mm-body-7-or-8 "mm-bodies")
40
41 (defvar rfc2047-header-encoding-alist
42   '(("Newsgroups" . nil)
43     ("Message-ID" . nil)
44     ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\)" .
45      "-A-Za-z0-9!*+/=_")
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) a charset, in which case it will be encoded as that charset;
56 4) `default', in which case the field will be encoded as the rest
57    of the article.
58 5) a string, like `mime', expect for using it as word-chars.")
59
60 (defvar rfc2047-charset-encoding-alist
61   '((us-ascii . nil)
62     (iso-8859-1 . Q)
63     (iso-8859-2 . Q)
64     (iso-8859-3 . Q)
65     (iso-8859-4 . Q)
66     (iso-8859-5 . B)
67     (koi8-r . B)
68     (iso-8859-7 . Q)
69     (iso-8859-8 . Q)
70     (iso-8859-9 . Q)
71     (iso-8859-14 . Q)
72     (iso-8859-15 . Q)
73     (iso-2022-jp . B)
74     (iso-2022-kr . B)
75     (gb2312 . B)
76     (big5 . B)
77     (cn-big5 . B)
78     (cn-gb . B)
79     (cn-gb-2312 . B)
80     (euc-kr . B)
81     (iso-2022-jp-2 . B)
82     (iso-2022-int-1 . B))
83   "Alist of MIME charsets to RFC2047 encodings.
84 Valid encodings are nil, `Q' and `B'.")
85
86 (defvar rfc2047-encoding-function-alist
87   '((Q . rfc2047-q-encode-region)
88     (B . rfc2047-b-encode-region)
89     (nil . ignore))
90   "Alist of RFC2047 encodings to encoding functions.")
91
92 (defvar rfc2047-q-encoding-alist
93   '(("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\):"
94      . "-A-Za-z0-9!*+/" )
95     ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
96     ;; Avoid using 8bit characters.
97     ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
98     ("." . "\010\012\014\040-\074\076\100-\136\140-\177"))
99   "Alist of header regexps and valid Q characters.")
100
101 ;;;
102 ;;; Functions for encoding RFC2047 messages
103 ;;;
104
105 (defun rfc2047-narrow-to-field ()
106   "Narrow the buffer to the header on the current line."
107   (beginning-of-line)
108   (narrow-to-region
109    (point)
110    (progn
111      (forward-line 1)
112      (if (re-search-forward "^[^ \n\t]" nil t)
113          (progn
114            (beginning-of-line)
115            (point))
116        (point-max))))
117   (goto-char (point-min)))
118
119 (defun rfc2047-field-value ()
120   "Return the value of the field at point."
121   (save-excursion
122     (save-restriction
123       (rfc2047-narrow-to-field)
124       (re-search-forward ":[ \t\n]*" nil t)
125       (buffer-substring (point) (point-max)))))
126
127 (defun rfc2047-encode-message-header ()
128   "Encode the message header according to `rfc2047-header-encoding-alist'.
129 Should be called narrowed to the head of the message."
130   (interactive "*")
131   (save-excursion
132     (goto-char (point-min))
133     (let (alist elem method)
134       (while (not (eobp))
135         (save-restriction
136           (rfc2047-narrow-to-field)
137           (if (not (rfc2047-encodable-p))
138               (prog1
139                 (if (and (eq (mm-body-7-or-8) '8bit)
140                          (mm-multibyte-p)
141                          (mm-coding-system-p
142                           (car message-posting-charset)))
143                     ;; 8 bit must be decoded.
144                     ;; Is message-posting-charset a coding system?
145                     (mm-encode-coding-region
146                      (point-min) (point-max)
147                      (car message-posting-charset))
148                   nil)
149                 ;; No encoding necessary, but folding is nice
150                 (rfc2047-fold-region
151                  (save-excursion
152                    (goto-char (point-min))
153                    (skip-chars-forward "^:")
154                    (when (looking-at ": ")
155                      (forward-char 2))
156                    (point))
157                  (point-max)))
158             ;; We found something that may perhaps be encoded.
159             (setq method nil
160                   alist rfc2047-header-encoding-alist)
161             (while (setq elem (pop alist))
162               (when (or (and (stringp (car elem))
163                              (looking-at (car elem)))
164                         (eq (car elem) t))
165                 (setq alist nil
166                       method (cdr elem))))
167             (cond
168              ((stringp method)
169               (rfc2047-encode-region (point-min) (point-max) method))
170              ((eq method 'mime)
171               (rfc2047-encode-region (point-min) (point-max)))
172              ((eq method 'default)
173               (if (and (featurep 'mule)
174                        (if (boundp 'default-enable-multibyte-characters)
175                            default-enable-multibyte-characters)
176                        mail-parse-charset)
177                   (mm-encode-coding-region (point-min) (point-max)
178                                            mail-parse-charset)))
179              ;; We get this when CC'ing messsages to newsgroups with
180              ;; 8-bit names.  The group name mail copy just get
181              ;; unconditionally encoded.  Previously, it would ask
182              ;; whether to encode, which was quite confusing for the
183              ;; user.  If the new behaviour is wrong, tell me. I have
184              ;; left the old code commented out below.
185              ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07.
186              ((null method)
187               (when (delq 'ascii 
188                           (mm-find-charset-region (point-min) (point-max)))
189                 (rfc2047-encode-region (point-min) (point-max))))
190 ;;;          ((null method)
191 ;;;           (and (delq 'ascii
192 ;;;                      (mm-find-charset-region (point-min)
193 ;;;                                              (point-max)))
194 ;;;                (if (or (message-options-get
195 ;;;                         'rfc2047-encode-message-header-encode-any)
196 ;;;                        (message-options-set
197 ;;;                         'rfc2047-encode-message-header-encode-any
198 ;;;                         (y-or-n-p
199 ;;;                          "Some texts are not encoded. Encode anyway?")))
200 ;;;                    (rfc2047-encode-region (point-min) (point-max))
201 ;;;                  (error "Cannot send unencoded text"))))
202              ((mm-coding-system-p method)
203               (if (and (featurep 'mule)
204                        (if (boundp 'default-enable-multibyte-characters)
205                            default-enable-multibyte-characters))
206                   (mm-encode-coding-region (point-min) (point-max) method)))
207              ;; Hm.
208              (t)))
209           (goto-char (point-max)))))))
210
211 ;; Fixme: This, and the require below may not be the Right Thing, but
212 ;; should be safe just before release.  -- fx 2001-02-08
213 (eval-when-compile (defvar message-posting-charset))
214
215 (defun rfc2047-encodable-p ()
216   "Return non-nil if any characters in current buffer need encoding in headers.
217 The buffer may be narrowed."
218   (require 'message)                    ; for message-posting-charset
219   (let ((charsets
220          (mapcar
221           'mm-mime-charset
222           (mm-find-charset-region (point-min) (point-max))))
223         (cs (list 'us-ascii (car message-posting-charset)))
224         found)
225     (while charsets
226       (unless (memq (pop charsets) cs)
227         (setq found t)))
228     found))
229
230 (defun rfc2047-dissect-region (b e &optional word-chars)
231   "Dissect the region between B and E into words."
232   (unless word-chars
233     ;; Anything except most CTLs, WSP
234     (setq word-chars "\010\012\014\041-\177"))
235   (let (mail-parse-mule-charset
236         words point current
237         result word)
238     (save-restriction
239       (narrow-to-region b e)
240       (goto-char (point-min))
241       (skip-chars-forward "\000-\177")
242       (while (not (eobp))
243         (setq point (point))
244         (skip-chars-backward word-chars b)
245         (unless (eq b (point))
246           (push (cons (buffer-substring b (point)) nil) words))
247         (setq b (point))
248         (goto-char point)
249         (setq current (mm-charset-after))
250         (forward-char 1)
251         (skip-chars-forward word-chars)
252         (while (and (not (eobp))
253                     (eq (mm-charset-after) current))
254           (forward-char 1)
255           (skip-chars-forward word-chars))
256         (unless (eq b (point))
257           (push (cons (buffer-substring b (point)) current) words))
258         (setq b (point))
259         (skip-chars-forward "\000-\177"))
260       (unless (eq b (point))
261         (push (cons (buffer-substring b (point)) nil) words)))
262     ;; merge adjacent words
263     (setq word (pop words))
264     (while word
265       (if (and (cdr word)
266                (caar words)
267                (not (cdar words))
268                (not (string-match "[^ \t]" (caar words))))
269           (if (eq (cdr (nth 1 words)) (cdr word))
270               (progn
271                 (setq word (cons (concat
272                                   (car (nth 1 words)) (caar words)
273                                   (car word))
274                                  (cdr word)))
275                 (pop words)
276                 (pop words))
277             (push (cons (concat (caar words) (car word)) (cdr word))
278                   result)
279             (pop words)
280             (setq word (pop words)))
281         (push word result)
282         (setq word (pop words))))
283     result))
284
285 (defun rfc2047-encode-region (b e &optional word-chars)
286   "Encode all encodable words in region B to E."
287   (let ((words (rfc2047-dissect-region b e word-chars)) word)
288     (save-restriction
289       (narrow-to-region b e)
290       (delete-region (point-min) (point-max))
291       (while (setq word (pop words))
292         (if (not (cdr word))
293             (insert (car word))
294           (rfc2047-fold-region (gnus-point-at-bol) (point))
295           (goto-char (point-max))
296           (if (> (- (point) (save-restriction
297                               (widen)
298                               (gnus-point-at-bol))) 76)
299               (insert "\n "))
300           ;; Insert blank between encoded words
301           (if (eq (char-before) ?=) (insert " "))
302           (rfc2047-encode (point)
303                           (progn (insert (car word)) (point))
304                           (cdr word))))
305       (rfc2047-fold-region (point-min) (point-max)))))
306
307 (defun rfc2047-encode-string (string &optional word-chars)
308   "Encode words in STRING."
309   (with-temp-buffer
310     (insert string)
311     (rfc2047-encode-region (point-min) (point-max) word-chars)
312     (buffer-string)))
313
314 (defun rfc2047-encode (b e charset)
315   "Encode the word in the region B to E with CHARSET."
316   (let* ((mime-charset (mm-mime-charset charset))
317          (cs (mm-charset-to-coding-system mime-charset))
318          (encoding (or (cdr (assq mime-charset
319                                   rfc2047-charset-encoding-alist))
320                        'B))
321          (start (concat
322                  "=?" (downcase (symbol-name mime-charset)) "?"
323                  (downcase (symbol-name encoding)) "?"))
324          (first t))
325     (save-restriction
326       (narrow-to-region b e)
327       (when (eq encoding 'B)
328         ;; break into lines before encoding
329         (goto-char (point-min))
330         (while (not (eobp))
331           (goto-char (min (point-max) (+ 15 (point))))
332           (unless (eobp)
333             (insert "\n"))))
334       (if (and (mm-multibyte-p)
335                (mm-coding-system-p cs))
336           (mm-encode-coding-region (point-min) (point-max) cs))
337       (funcall (cdr (assq encoding rfc2047-encoding-function-alist))
338                (point-min) (point-max))
339       (goto-char (point-min))
340       (while (not (eobp))
341         (unless first
342           (insert " "))
343         (setq first nil)
344         (insert start)
345         (end-of-line)
346         (insert "?=")
347         (forward-line 1)))))
348
349 (defun rfc2047-fold-field ()
350   "Fold the current line."
351   (save-excursion
352     (save-restriction
353       (rfc2047-narrow-to-field)
354       (rfc2047-fold-region (point-min) (point-max)))))
355
356 (defun rfc2047-fold-region (b e)
357   "Fold long lines in region B to E."
358   (save-restriction
359     (narrow-to-region b e)
360     (goto-char (point-min))
361     (let ((break nil)
362           (qword-break nil)
363           (first t)
364           (bol (save-restriction
365                  (widen)
366                  (gnus-point-at-bol))))
367       (while (not (eobp))
368         (when (and (or break qword-break)
369                    (> (- (point) bol) 76))
370           (goto-char (or break qword-break))
371           (setq break nil
372                 qword-break nil)
373           (if (looking-at "[ \t]")
374               (insert "\n")
375             (insert "\n "))
376           (setq bol (1- (point)))
377           ;; Don't break before the first non-LWSP characters.
378           (skip-chars-forward " \t")
379           (unless (eobp)
380             (forward-char 1)))
381         (cond
382          ((eq (char-after) ?\n)
383           (forward-char 1)
384           (setq bol (point)
385                 break nil
386                 qword-break nil)
387           (skip-chars-forward " \t")
388           (unless (or (eobp) (eq (char-after) ?\n))
389             (forward-char 1)))
390          ((eq (char-after) ?\r)
391           (forward-char 1))
392          ((memq (char-after) '(?  ?\t))
393           (skip-chars-forward " \t")
394           (if first
395               ;; Don't break just after the header name.
396               (setq first nil)
397             (setq break (1- (point)))))
398          ((not break)
399           (if (not (looking-at "=\\?[^=]"))
400               (if (eq (char-after) ?=)
401                   (forward-char 1)
402                 (skip-chars-forward "^ \t\n\r="))
403             (setq qword-break (point))
404             (skip-chars-forward "^ \t\n\r")))
405          (t
406           (skip-chars-forward "^ \t\n\r"))))
407       (when (and (or break qword-break)
408                  (> (- (point) bol) 76))
409         (goto-char (or break qword-break))
410         (setq break nil
411               qword-break nil)
412           (if (looking-at "[ \t]")
413               (insert "\n")
414             (insert "\n "))
415         (setq bol (1- (point)))
416         ;; Don't break before the first non-LWSP characters.
417         (skip-chars-forward " \t")
418         (unless (eobp)
419           (forward-char 1))))))
420
421 (defun rfc2047-unfold-field ()
422   "Fold the current line."
423   (save-excursion
424     (save-restriction
425       (rfc2047-narrow-to-field)
426       (rfc2047-unfold-region (point-min) (point-max)))))
427
428 (defun rfc2047-unfold-region (b e)
429   "Unfold lines in region B to E."
430   (save-restriction
431     (narrow-to-region b e)
432     (goto-char (point-min))
433     (let ((bol (save-restriction
434                  (widen)
435                  (gnus-point-at-bol)))
436           (eol (gnus-point-at-eol))
437           leading)
438       (forward-line 1)
439       (while (not (eobp))
440         (looking-at "[ \t]*")
441         (setq leading (- (match-end 0) (match-beginning 0)))
442         (if (< (- (gnus-point-at-eol) bol leading) 76)
443             (progn
444               (goto-char eol)
445               (delete-region eol (progn
446                                    (skip-chars-forward " \t\n\r")
447                                    (1- (point)))))
448           (setq bol (gnus-point-at-bol)))
449         (setq eol (gnus-point-at-eol))
450         (forward-line 1)))))
451
452 (defun rfc2047-b-encode-region (b e)
453   "Base64-encode the header contained in region B to E."
454   (save-restriction
455     (narrow-to-region (goto-char b) e)
456     (while (not (eobp))
457       (base64-encode-region (point) (progn (end-of-line) (point)) t)
458       (if (and (bolp) (eolp))
459           (delete-backward-char 1))
460       (forward-line))))
461
462 (defun rfc2047-q-encode-region (b e)
463   "Quoted-printable-encode the header in region B to E."
464   (save-excursion
465     (save-restriction
466       (narrow-to-region (goto-char b) e)
467       (let ((alist rfc2047-q-encoding-alist)
468             (bol (save-restriction
469                    (widen)
470                    (gnus-point-at-bol))))
471         (while alist
472           (when (looking-at (caar alist))
473             (mm-with-unibyte-current-buffer-mule4
474               (quoted-printable-encode-region
475                (point-min) (point-max) nil (cdar alist)))
476             (subst-char-in-region (point-min) (point-max) ?  ?_)
477             (setq alist nil))
478           (pop alist))
479         ;; The size of QP encapsulation is about 20, so set limit to
480         ;; 56=76-20.
481         (unless (< (- (point-max) (point-min)) 56)
482           ;; Don't break if it could fit in one line.
483           ;; Let rfc2047-encode-region break it later.
484           (goto-char (1+ (point-min)))
485           (while (and (not (bobp)) (not (eobp)))
486             (goto-char (min (point-max) (+ 56 bol)))
487             (search-backward "=" (- (point) 2) t)
488             (unless (or (bobp) (eobp))
489               (insert "\n")
490               (setq bol (point)))))))))
491
492 ;;;
493 ;;; Functions for decoding RFC2047 messages
494 ;;;
495
496 (defvar rfc2047-encoded-word-regexp
497   "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~ +]*\\)\\?=")
498
499 (defun rfc2047-decode-region (start end)
500   "Decode MIME-encoded words in region between START and END."
501   (interactive "r")
502   (let ((case-fold-search t)
503         b e)
504     (save-excursion
505       (save-restriction
506         (narrow-to-region start end)
507         (goto-char (point-min))
508         ;; Remove whitespace between encoded words.
509         (while (re-search-forward
510                 (concat "\\(" rfc2047-encoded-word-regexp "\\)"
511                         "\\(\n?[ \t]\\)+"
512                         "\\(" rfc2047-encoded-word-regexp "\\)")
513                 nil t)
514           (delete-region (goto-char (match-end 1)) (match-beginning 6)))
515         ;; Decode the encoded words.
516         (setq b (goto-char (point-min)))
517         (while (re-search-forward rfc2047-encoded-word-regexp nil t)
518           (setq e (match-beginning 0))
519           (insert (rfc2047-parse-and-decode
520                    (prog1
521                        (match-string 0)
522                      (delete-region (match-beginning 0) (match-end 0)))))
523           (when (and (mm-multibyte-p)
524                      mail-parse-charset
525                      (not (eq mail-parse-charset 'gnus-decoded)))
526             (mm-decode-coding-region b e mail-parse-charset))
527           (setq b (point)))
528         (when (and (mm-multibyte-p)
529                    mail-parse-charset
530                    (not (eq mail-parse-charset 'us-ascii))
531                    (not (eq mail-parse-charset 'gnus-decoded)))
532           (mm-decode-coding-region b (point-max) mail-parse-charset))
533         (rfc2047-unfold-region (point-min) (point-max))))))
534
535 (defun rfc2047-decode-string (string)
536   "Decode the quoted-printable-encoded STRING and return the results."
537   (let ((m (mm-multibyte-p)))
538     (with-temp-buffer
539       (when m
540         (mm-enable-multibyte))
541       (insert string)
542       (inline
543         (rfc2047-decode-region (point-min) (point-max)))
544       (buffer-string))))
545
546 (defun rfc2047-parse-and-decode (word)
547   "Decode WORD and return it if it is an encoded word.
548 Return WORD if not."
549   (if (not (string-match rfc2047-encoded-word-regexp word))
550       word
551     (or
552      (condition-case nil
553          (rfc2047-decode
554           (match-string 1 word)
555           (upcase (match-string 2 word))
556           (match-string 3 word))
557        (error word))
558      word)))
559
560 (defun rfc2047-pad-base64 (string)
561   "Pad STRING to quartets."
562   ;; Be more liberal to accept buggy base64 strings. If
563   ;; base64-decode-string accepts buggy strings, this function could
564   ;; be aliased to identity.
565   (case (mod (length string) 4)
566     (0 string)
567     (1 string) ;; Error, don't pad it.
568     (2 (concat string "=="))
569     (3 (concat string "="))))
570
571 (defun rfc2047-decode (charset encoding string)
572   "Decode STRING from the given MIME CHARSET in the given ENCODING.
573 Valid ENCODINGs are \"B\" and \"Q\".
574 If your Emacs implementation can't decode CHARSET, return nil."
575   (if (stringp charset)
576       (setq charset (intern (downcase charset))))
577   (if (or (not charset)
578           (eq 'gnus-all mail-parse-ignored-charsets)
579           (memq 'gnus-all mail-parse-ignored-charsets)
580           (memq charset mail-parse-ignored-charsets))
581       (setq charset mail-parse-charset))
582   (let ((cs (mm-charset-to-coding-system charset)))
583     (if (and (not cs) charset
584              (listp mail-parse-ignored-charsets)
585              (memq 'gnus-unknown mail-parse-ignored-charsets))
586         (setq cs (mm-charset-to-coding-system mail-parse-charset)))
587     (when cs
588       (when (and (eq cs 'ascii)
589                  mail-parse-charset)
590         (setq cs mail-parse-charset))
591       (mm-with-unibyte-current-buffer-mule4
592         ;; In Emacs Mule 4, decoding UTF-8 should be in unibyte mode.
593         (mm-decode-coding-string
594          (cond
595           ((equal "B" encoding)
596            (base64-decode-string
597             (rfc2047-pad-base64 string)))
598           ((equal "Q" encoding)
599            (quoted-printable-decode-string
600             (mm-replace-chars-in-string string ?_ ? )))
601           (t (error "Invalid encoding: %s" encoding)))
602          cs)))))
603
604 (provide 'rfc2047)
605
606 ;;; rfc2047.el ends here