/[emacs]/emacs/lisp/gnus/rfc2047.el
ViewVC logotype

Diff of /emacs/lisp/gnus/rfc2047.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by pj, Sun Jul 15 17:42:53 2001 UTC revision 1.10.8.1 by miles, Fri Apr 4 06:20:21 2003 UTC
# Line 1  Line 1 
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 Free Software Foundation, Inc.  ;; Copyright (C) 1998, 1999, 2000, 2002 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>
# Line 27  Line 27 
27    
28  ;;; Code:  ;;; Code:
29    
30  (eval-when-compile (require 'cl))  (eval-when-compile
31      (require 'cl)
32      (defvar message-posting-charset))
33    
34  (require 'qp)  (require 'qp)
35  (require 'mm-util)  (require 'mm-util)
36  (require 'ietf-drums)  ;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
37  (require 'mail-prsvr)  (require 'mail-prsvr)
38  (require 'base64)  (require 'base64)
 ;; Fixme: Avoid this (for gnus-point-at-...) mm dependence on gnus.  
 (require 'gnus-util)  
39  (autoload 'mm-body-7-or-8 "mm-bodies")  (autoload 'mm-body-7-or-8 "mm-bodies")
40    
41  (defvar rfc2047-header-encoding-alist  (defvar rfc2047-header-encoding-alist
42    '(("Newsgroups" . nil)    '(("Newsgroups" . nil)
43      ("Message-ID" . nil)      ("Message-ID" . nil)
44        ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\)" .
45         address-mime)
46      (t . mime))      (t . mime))
47    "*Header/encoding method alist.    "*Header/encoding method alist.
48  The list is traversed sequentially.  The keys can either be  The list is traversed sequentially.  The keys can either be
# Line 50  The values can be: Line 52  The values can be:
52    
53  1) nil, in which case no encoding is done;  1) nil, in which case no encoding is done;
54  2) `mime', in which case the header will be encoded according to RFC2047;  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;  3) `address-mime', like `mime', but takes account of the rules for address
56  4) `default', in which case the field will be encoded as the rest     fields (where quoted strings and comments must be treated separately);
57    4) a charset, in which case it will be encoded as that charset;
58    5) `default', in which case the field will be encoded as the rest
59     of the article.")     of the article.")
60    
61  (defvar rfc2047-charset-encoding-alist  (defvar rfc2047-charset-encoding-alist
# Line 62  The values can be: Line 66  The values can be:
66      (iso-8859-4 . Q)      (iso-8859-4 . Q)
67      (iso-8859-5 . B)      (iso-8859-5 . B)
68      (koi8-r . B)      (koi8-r . B)
69      (iso-8859-7 . Q)      (iso-8859-7 . B)
70      (iso-8859-8 . Q)      (iso-8859-8 . B)
71      (iso-8859-9 . Q)      (iso-8859-9 . Q)
72      (iso-8859-14 . Q)      (iso-8859-14 . Q)
73      (iso-8859-15 . Q)      (iso-8859-15 . Q)
# Line 78  The values can be: Line 82  The values can be:
82      (iso-2022-jp-2 . B)      (iso-2022-jp-2 . B)
83      (iso-2022-int-1 . B))      (iso-2022-int-1 . B))
84    "Alist of MIME charsets to RFC2047 encodings.    "Alist of MIME charsets to RFC2047 encodings.
85  Valid encodings are nil, `Q' and `B'.")  Valid encodings are nil, `Q' and `B'.  These indicate binary (no) encoding,
86    quoted-printable and base64 respectively.")
87    
88  (defvar rfc2047-encoding-function-alist  (defvar rfc2047-encoding-function-alist
89    '((Q . rfc2047-q-encode-region)    '((Q . rfc2047-q-encode-region)
# Line 87  Valid encodings are nil, `Q' and `B'.") Line 92  Valid encodings are nil, `Q' and `B'.")
92    "Alist of RFC2047 encodings to encoding functions.")    "Alist of RFC2047 encodings to encoding functions.")
93    
94  (defvar rfc2047-q-encoding-alist  (defvar rfc2047-q-encoding-alist
95    '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "-A-Za-z0-9!*+/")    '(("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\):"
96         . "-A-Za-z0-9!*+/" )
97      ;; = (\075), _ (\137), ? (\077) are used in the encoded word.      ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
98      ;; Avoid using 8bit characters.      ;; Avoid using 8bit characters.
99      ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"      ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
# Line 112  Valid encodings are nil, `Q' and `B'.") Line 118  Valid encodings are nil, `Q' and `B'.")
118         (point-max))))         (point-max))))
119    (goto-char (point-min)))    (goto-char (point-min)))
120    
121    (defvar rfc2047-encoding-type 'address-mime
122      "The type of encoding done by `rfc2047-encode-region'.
123    This should be dynamically bound around calls to
124    `rfc2047-encode-region' to either `mime' or `address-mime'.  See
125    `rfc2047-header-encoding-alist', for definitions.")
126    
127  (defun rfc2047-encode-message-header ()  (defun rfc2047-encode-message-header ()
128    "Encode the message header according to `rfc2047-header-encoding-alist'.    "Encode the message header according to `rfc2047-header-encoding-alist'.
129  Should be called narrowed to the head of the message."  Should be called narrowed to the head of the message."
# Line 141  Should be called narrowed to the head of Line 153  Should be called narrowed to the head of
153                          (eq (car elem) t))                          (eq (car elem) t))
154                  (setq alist nil                  (setq alist nil
155                        method (cdr elem))))                        method (cdr elem))))
156                (goto-char (point-min))
157                (re-search-forward "^[^:]+: *" nil t)
158              (cond              (cond
159                 ((eq method 'address-mime)
160                  (rfc2047-encode-region (point) (point-max)))
161               ((eq method 'mime)               ((eq method 'mime)
162                (rfc2047-encode-region (point-min) (point-max)))                (let (rfc2047-encoding-type)
163                    (rfc2047-encode-region (point) (point-max))))
164               ((eq method 'default)               ((eq method 'default)
165                (if (and (featurep 'mule)                (if (and (featurep 'mule)
166                         (if (boundp 'default-enable-multibyte-characters)                         (if (boundp 'default-enable-multibyte-characters)
167                             default-enable-multibyte-characters)                             default-enable-multibyte-characters)
168                         mail-parse-charset)                         mail-parse-charset)
169                    (mm-encode-coding-region (point-min) (point-max)                    (mm-encode-coding-region (point) (point-max)
170                                             mail-parse-charset)))                                             mail-parse-charset)))
171               ((mm-coding-system-p method)               ((mm-coding-system-p method)
172                (if (and (featurep 'mule)                (if (and (featurep 'mule)
173                         (if (boundp 'default-enable-multibyte-characters)                         (if (boundp 'default-enable-multibyte-characters)
174                             default-enable-multibyte-characters))                             default-enable-multibyte-characters))
175                    (mm-encode-coding-region (point-min) (point-max) method)))                    (mm-encode-coding-region (point) (point-max) method)))
176               ;; Hm.               ;; Hm.
177               (t)))               (t)))
178            (goto-char (point-max)))))))            (goto-char (point-max)))))))
# Line 169  Should be called narrowed to the head of Line 186  Should be called narrowed to the head of
186  The buffer may be narrowed."  The buffer may be narrowed."
187    (require 'message)                    ; for message-posting-charset    (require 'message)                    ; for message-posting-charset
188    (let ((charsets    (let ((charsets
189           (mapcar           (mm-find-mime-charset-region (point-min) (point-max))))
190            'mm-mime-charset      (and charsets (not (equal charsets (list message-posting-charset))))))
191            (mm-find-charset-region (point-min) (point-max))))  
192          (cs (list 'us-ascii (car message-posting-charset)))  ;; Use this syntax table when parsing into regions that may need
193          found)  ;; encoding.  Double quotes are string delimiters, backslash is
194      (while charsets  ;; character quoting, and all other RFC 2822 special characters are
195        (unless (memq (pop charsets) cs)  ;; treated as punctuation so we can use forward-sexp/forward-word to
196          (setq found t)))  ;; skip to the end of regions appropriately.  Nb. ietf-drums does
197      found))  ;; things differently.
198    (defconst rfc2047-syntax-table
199  (defun rfc2047-dissect-region (b e)    (let ((table (make-char-table 'syntax-table '(2))))
200    "Dissect the region between B and E into words."      (modify-syntax-entry ?\\ "\\" table)
201    (let ((word-chars "-A-Za-z0-9!*+/")      (modify-syntax-entry ?\" "\"" table)
202          ;; Not using ietf-drums-specials-token makes life simple.      (modify-syntax-entry ?\( "." table)
203          mail-parse-mule-charset      (modify-syntax-entry ?\) "." table)
204          words point current      (modify-syntax-entry ?\< "." table)
205          result word)      (modify-syntax-entry ?\> "." table)
206      (save-restriction      (modify-syntax-entry ?\[ "." table)
207        (narrow-to-region b e)      (modify-syntax-entry ?\] "." table)
208        (goto-char (point-min))      (modify-syntax-entry ?: "." table)
209        (skip-chars-forward "\000-\177")      (modify-syntax-entry ?\; "." table)
210        (while (not (eobp))      (modify-syntax-entry ?, "." table)
211          (setq point (point))      (modify-syntax-entry ?@ "." table)
212          (skip-chars-backward word-chars b)      table))
         (unless (eq b (point))  
           (push (cons (buffer-substring b (point)) nil) words))  
         (setq b (point))  
         (goto-char point)  
         (setq current (mm-charset-after))  
         (forward-char 1)  
         (skip-chars-forward word-chars)  
         (while (and (not (eobp))  
                     (eq (mm-charset-after) current))  
           (forward-char 1)  
           (skip-chars-forward word-chars))  
         (unless (eq b (point))  
           (push (cons (buffer-substring b (point)) current) words))  
         (setq b (point))  
         (skip-chars-forward "\000-\177"))  
       (unless (eq b (point))  
         (push (cons (buffer-substring b (point)) nil) words)))  
     ;; merge adjacent words  
     (setq word (pop words))  
     (while word  
       (if (and (cdr word)  
                (caar words)  
                (not (cdar words))  
                (not (string-match "[^ \t]" (caar words))))  
           (if (eq (cdr (nth 1 words)) (cdr word))  
               (progn  
                 (setq word (cons (concat  
                                   (car (nth 1 words)) (caar words)  
                                   (car word))  
                                  (cdr word)))  
                 (pop words)  
                 (pop words))  
             (push (cons (concat (caar words) (car word)) (cdr word))  
                   result)  
             (pop words)  
             (setq word (pop words)))  
         (push word result)  
         (setq word (pop words))))  
     result))  
213    
214  (defun rfc2047-encode-region (b e)  (defun rfc2047-encode-region (b e)
215    "Encode all encodable words in region B to E."    "Encode words in region B to E that need encoding.
216    (let ((words (rfc2047-dissect-region b e)) word)  By default, the region is treated as containing RFC2822 addresses.
217      (save-restriction  Dynamically bind `rfc2047-encoding-type' to change that."
218        (narrow-to-region b e)    (save-restriction
219        (delete-region (point-min) (point-max))      (narrow-to-region b e)
220        (while (setq word (pop words))      (if (eq 'mime rfc2047-encoding-type)
221          (if (not (cdr word))          ;; Simple case -- treat as single word.
222              (insert (car word))          (progn
223            (rfc2047-fold-region (gnus-point-at-bol) (point))            (goto-char (point-min))
224            (goto-char (point-max))            ;; Does it need encoding?
225            (if (> (- (point) (save-restriction            (skip-chars-forward "\000-\177" e)
226                                (widen)            (unless (eobp)
227                                (gnus-point-at-bol))) 76)              (rfc2047-encode b e)))
228                (insert "\n "))        ;; `address-mime' case -- take care of quoted words, comments.
229            ;; Insert blank between encoded words        (with-syntax-table rfc2047-syntax-table
230            (if (eq (char-before) ?=) (insert " "))          (let ((start (point))           ; start of current token
231            (rfc2047-encode (point)                end                       ; end of current token
232                            (progn (insert (car word)) (point))                ;; Whether there's an encoded word before the current
233                            (cdr word))))                ;; tpken, either immediately or separated by space.
234        (rfc2047-fold-region (point-min) (point-max)))))                last-encoded)
235              (goto-char (point-min))
236              (condition-case nil         ; in case of unbalanced quotes
237                  ;; Look for rfc2822-style: sequences of atoms, quoted
238                  ;; strings, specials, whitespace.  (Specials mustn't be
239                  ;; encoded.)
240                  (while (not (eobp))
241                    (setq start (point))
242                    ;; Skip whitespace.
243                    (unless (= 0 (skip-chars-forward " \t"))
244                      (setq start (point)))
245                    (cond
246                     ((not (char-after)))   ; eob
247                     ;; else token start
248                     ((eq ?\" (char-syntax (char-after)))
249                      ;; Quoted word.
250                      (forward-sexp)
251                      (setq end (point))
252                      ;; Does it need encoding?
253                      (goto-char start)
254                      (skip-chars-forward "\000-\177" end)
255                      (if (= end (point))
256                          (setq last-encoded  nil)
257                        ;; It needs encoding.  Strip the quotes first,
258                        ;; since encoded words can't occur in quotes.
259                        (goto-char end)
260                        (delete-backward-char 1)
261                        (goto-char start)
262                        (delete-char 1)
263                        (when last-encoded
264                          ;; There was a preceding quoted word.  We need
265                          ;; to include any separating whitespace in this
266                          ;; word to avoid it getting lost.
267                          (skip-chars-backward " \t")
268                          ;; A space is needed between the encoded words.
269                          (insert ? )
270                          (setq start (point)
271                                end (1+ end)))
272                        ;; Adjust the end position for the deleted quotes.
273                        (rfc2047-encode start (- end 2))
274                        (setq last-encoded t))) ; record that it was encoded
275                     ((eq ?. (char-syntax (char-after)))
276                      ;; Skip other delimiters, but record that they've
277                      ;; potentially separated quoted words.
278                      (forward-char)
279                      (setq last-encoded nil))
280                     (t                 ; normal token/whitespace sequence
281                      ;; Find the end.
282                      (forward-word 1)
283                      (skip-chars-backward " \t")
284                      (setq end (point))
285                      ;; Deal with encoding and leading space as for
286                      ;; quoted words.
287                      (goto-char start)
288                      (skip-chars-forward "\000-\177" end)
289                      (if (= end (point))
290                          (setq last-encoded  nil)
291                        (when last-encoded
292                          (goto-char start)
293                          (skip-chars-backward " \t")
294                          (insert ? )
295                          (setq start (point)
296                                end (1+ end)))
297                        (rfc2047-encode start end)
298                        (setq last-encoded t)))))
299                (error (error "Invalid data for rfc2047 encoding: %s"
300                              (buffer-substring b e)))))))
301        (rfc2047-fold-region b (point))))
302    
303  (defun rfc2047-encode-string (string)  (defun rfc2047-encode-string (string)
304    "Encode words in STRING."    "Encode words in STRING.
305    By default, the string is treated as containing addresses (see
306    `rfc2047-special-chars')."
307    (with-temp-buffer    (with-temp-buffer
308      (insert string)      (insert string)
309      (rfc2047-encode-region (point-min) (point-max))      (rfc2047-encode-region (point-min) (point-max))
310      (buffer-string)))      (buffer-string)))
311    
312  (defun rfc2047-encode (b e charset)  (defun rfc2047-encode (b e)
313    "Encode the word in the region B to E with CHARSET."    "Encode the word(s) in the region B to E.
314    (let* ((mime-charset (mm-mime-charset charset))  By default, the region is treated as containing addresses (see
315           (cs (mm-charset-to-coding-system mime-charset))  `rfc2047-special-chars')."
316           (encoding (or (cdr (assq mime-charset    (let* ((mime-charset (mm-find-mime-charset-region b e))
317             (cs (if (> (length mime-charset) 1)
318                     ;; Fixme: Instead of this, try to break region into
319                     ;; parts that can be encoded separately.
320                     (error "Can't rfc2047-encode `%s'"
321                            (buffer-substring b e))
322                   (setq mime-charset (car mime-charset))
323                   (mm-charset-to-coding-system mime-charset)))
324             ;; Fixme: Better, calculate the number of non-ASCII
325             ;; characters, at least for 8-bit charsets.
326             (encoding (if (assq mime-charset
327                                 rfc2047-charset-encoding-alist)
328                           (cdr (assq mime-charset
329                                    rfc2047-charset-encoding-alist))                                    rfc2047-charset-encoding-alist))
330                         'B))                       'B))
331           (start (concat           (start (concat
332                   "=?" (downcase (symbol-name mime-charset)) "?"                   "=?" (downcase (symbol-name mime-charset)) "?"
333                   (downcase (symbol-name encoding)) "?"))                   (downcase (symbol-name encoding)) "?"))
334           (first t))           (first t))
335      (save-restriction      (if mime-charset
336        (narrow-to-region b e)          (save-restriction
337        (when (eq encoding 'B)            (narrow-to-region b e)
338          ;; break into lines before encoding            (when (eq encoding 'B)
339          (goto-char (point-min))              ;; break into lines before encoding
340          (while (not (eobp))              (goto-char (point-min))
341            (goto-char (min (point-max) (+ 15 (point))))              (while (not (eobp))
342            (unless (eobp)                (goto-char (min (point-max) (+ 15 (point))))
343              (insert "\n"))))                (unless (eobp)
344        (if (and (mm-multibyte-p)                  (insert ?\n))))
345                 (mm-coding-system-p cs))            (if (and (mm-multibyte-p)
346            (mm-encode-coding-region (point-min) (point-max) cs))                     (mm-coding-system-p cs))
347        (funcall (cdr (assq encoding rfc2047-encoding-function-alist))                (mm-encode-coding-region (point-min) (point-max) cs))
348                 (point-min) (point-max))            (funcall (cdr (assq encoding rfc2047-encoding-function-alist))
349        (goto-char (point-min))                     (point-min) (point-max))
350        (while (not (eobp))            (goto-char (point-min))
351          (unless first            (while (not (eobp))
352            (insert " "))              (unless first
353          (setq first nil)                (insert ? ))
354          (insert start)              (setq first nil)
355          (end-of-line)              (insert start)
356          (insert "?=")              (end-of-line)
357          (forward-line 1)))))              (insert "?=")
358                (forward-line 1))))))
359    
360  (defun rfc2047-fold-region (b e)  (defun rfc2047-fold-region (b e)
361    "Fold long lines in region B to E."    "Fold long lines in region B to E."
# Line 306  The buffer may be narrowed." Line 366  The buffer may be narrowed."
366            (qword-break nil)            (qword-break nil)
367            (bol (save-restriction            (bol (save-restriction
368                   (widen)                   (widen)
369                   (gnus-point-at-bol))))                   (mm-point-at-bol))))
370        (while (not (eobp))        (while (not (eobp))
371          (when (and (or break qword-break) (> (- (point) bol) 76))          (when (and (or break qword-break) (> (- (point) bol) 76))
372            (goto-char (or break qword-break))            (goto-char (or break qword-break))
373            (setq break nil            (setq break nil
374                  qword-break nil)                  qword-break nil)
375            (if (looking-at " \t")            (if (looking-at " \t")
376                (insert "\n")                (insert ?\n)
377              (insert "\n "))              (insert "\n "))
378            (setq bol (1- (point)))            (setq bol (1- (point)))
379            ;; Don't break before the first non-LWSP characters.            ;; Don't break before the first non-LWSP characters.
# Line 347  The buffer may be narrowed." Line 407  The buffer may be narrowed."
407          (setq break nil          (setq break nil
408                qword-break nil)                qword-break nil)
409            (if (looking-at " \t")            (if (looking-at " \t")
410                (insert "\n")                (insert ?\n)
411              (insert "\n "))              (insert "\n "))
412          (setq bol (1- (point)))          (setq bol (1- (point)))
413          ;; Don't break before the first non-LWSP characters.          ;; Don't break before the first non-LWSP characters.
# Line 361  The buffer may be narrowed." Line 421  The buffer may be narrowed."
421      (goto-char (point-min))      (goto-char (point-min))
422      (let ((bol (save-restriction      (let ((bol (save-restriction
423                   (widen)                   (widen)
424                   (gnus-point-at-bol)))                   (mm-point-at-bol)))
425            (eol (gnus-point-at-eol))            (eol (mm-point-at-eol))
426            leading)            leading)
427        (forward-line 1)        (forward-line 1)
428        (while (not (eobp))        (while (not (eobp))
429          (looking-at "[ \t]*")          (looking-at "[ \t]*")
430          (setq leading (- (match-end 0) (match-beginning 0)))          (setq leading (- (match-end 0) (match-beginning 0)))
431          (if (< (- (gnus-point-at-eol) bol leading) 76)          (if (< (- (mm-point-at-eol) bol leading) 76)
432              (progn              (progn
433                (goto-char eol)                (goto-char eol)
434                (delete-region eol (progn                (delete-region eol (progn
435                                     (skip-chars-forward "[ \t\n\r]+")                                     (skip-chars-forward "[ \t\n\r]+")
436                                     (1- (point)))))                                     (1- (point)))))
437            (setq bol (gnus-point-at-bol)))            (setq bol (mm-point-at-bol)))
438          (setq eol (gnus-point-at-eol))          (setq eol (mm-point-at-eol))
439          (forward-line 1)))))          (forward-line 1)))))
440    
441  (defun rfc2047-b-encode-region (b e)  (defun rfc2047-b-encode-region (b e)
# Line 396  The buffer may be narrowed." Line 456  The buffer may be narrowed."
456        (let ((alist rfc2047-q-encoding-alist)        (let ((alist rfc2047-q-encoding-alist)
457              (bol (save-restriction              (bol (save-restriction
458                     (widen)                     (widen)
459                     (gnus-point-at-bol))))                     (mm-point-at-bol))))
460          (while alist          (while alist
461            (when (looking-at (caar alist))            (when (looking-at (caar alist))
462              (quoted-printable-encode-region b e nil (cdar alist))              (quoted-printable-encode-region b e nil (cdar alist))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.10.8.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26