/[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.8.3 by miles, Tue May 11 02:34:43 2004 UTC revision 1.10.8.4 by miles, Thu Sep 16 00:12:16 2004 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,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>
# Line 29  Line 29 
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)
# Line 38  Line 55 
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
# Line 80  The values can be: Line 110  The values can 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.")
# Line 91  quoted-printable and base64 respectively Line 122  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  ;;;  ;;;
# Line 112  quoted-printable and base64 respectively Line 134  quoted-printable and base64 respectively
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
# Line 169  Should be called narrowed to the head of Line 197  Should be called narrowed to the head of
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)
# Line 178  Should be called narrowed to the head of Line 206  Should be called narrowed to the head of
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)
# Line 197  The buffer may be narrowed." Line 245  The buffer may be narrowed."
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
# Line 206  The buffer may be narrowed." Line 255  The buffer may be narrowed."
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)
# Line 228  Dynamically bind `rfc2047-encoding-type' Line 289  Dynamically bind `rfc2047-encoding-type'
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.)
# Line 306  Dynamically bind `rfc2047-encoding-type' Line 377  Dynamically bind `rfc2047-encoding-type'
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))
# Line 322  By default, the string is treated as con Line 394  By default, the string is treated as con
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
# Line 333  By default, the region is treated as con Line 405  By default, the region is treated as con
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
# Line 349  By default, the region is treated as con Line 443  By default, the region is treated as con
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))
# Line 367  By default, the region is treated as con Line 466  By default, the region is treated as con
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
# Line 377  By default, the region is treated as con Line 483  By default, the region is treated as con
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)
# Line 389  By default, the region is treated as con Line 496  By default, the region is treated as con
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)
# Line 412  By default, the region is treated as con Line 520  By default, the region is treated as con
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)
# Line 426  By default, the region is treated as con Line 537  By default, the region is treated as con
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."
# Line 435  By default, the region is treated as con Line 554  By default, the region is treated as con
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)
# Line 465  By default, the region is treated as con Line 583  By default, the region is treated as con
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)
# Line 485  By default, the region is treated as con Line 608  By default, the region is treated as con
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."
# Line 506  By default, the region is treated as con Line 641  By default, the region is treated as con
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.
# Line 519  By default, the region is treated as con Line 655  By default, the region is treated as con
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)))
# Line 528  By default, the region is treated as con Line 673  By default, the region is treated as con
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
# Line 554  Return WORD if not." Line 713  Return WORD if not."
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.
# Line 576  If your Emacs implementation can't decod Line 746  If your Emacs implementation can't decod
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    

Legend:
Removed from v.1.10.8.3  
changed lines
  Added in v.1.10.8.4

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