/[emacs]/emacs/lisp/gnus/mm-bodies.el
ViewVC logotype

Diff of /emacs/lisp/gnus/mm-bodies.el

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

revision 1.6.8.2 by miles, Tue Oct 14 23:34:51 2003 UTC revision 1.6.8.3 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
1  ;;; mm-bodies.el --- functions for decoding MIME things  ;;; mm-bodies.el --- Functions for decoding MIME things
2  ;; Copyright (C) 1998, 1999, 2000, 2002 Free Software Foundation, Inc.  
3    ;; Copyright (C) 1998, 1999, 2000, 2001, 2003
4    ;;        Free Software Foundation, Inc.
5    
6  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7  ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>  ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
# Line 42  Line 44 
44    
45  (defcustom mm-body-charset-encoding-alist  (defcustom mm-body-charset-encoding-alist
46    '((iso-2022-jp . 7bit)    '((iso-2022-jp . 7bit)
47      (iso-2022-jp-2 . 7bit))      (iso-2022-jp-2 . 7bit)
48        ;; We MUST encode UTF-16 because it can contain \0's which is
49        ;; known to break servers.
50        ;; Note: UTF-16 variants are invalid for text parts [RFC 2781],
51        ;; so this can't happen :-/.
52        (utf-16 . base64)
53        (utf-16be . base64)
54        (utf-16le . base64))
55    "Alist of MIME charsets to encodings.    "Alist of MIME charsets to encodings.
56  Valid encodings are `7bit', `8bit', `quoted-printable' and `base64'."  Valid encodings are `7bit', `8bit', `quoted-printable' and `base64'."
57    :type '(repeat (cons (symbol :tag "charset")    :type '(repeat (cons (symbol :tag "charset")
# Line 53  Valid encodings are `7bit', `8bit', `quo Line 62  Valid encodings are `7bit', `8bit', `quo
62                                 (const base64))))                                 (const base64))))
63    :group 'mime)    :group 'mime)
64    
65  (defun mm-encode-body ()  (defun mm-encode-body (&optional charset)
66    "Encode a body.    "Encode a body.
67  Should be called narrowed to the body that is to be encoded.  Should be called narrowed to the body that is to be encoded.
68  If there is more than one non-ASCII Mule charset, then the list of found  If there is more than one non-ASCII MULE charset in the body, then the
69  Mule charsets is returned.  list of MULE charsets found is returned.
70    If CHARSET is non-nil, it is used as the MIME charset to encode the body.
71  If successful, the MIME charset is returned.  If successful, the MIME charset is returned.
72  If no encoding was done, nil is returned."  If no encoding was done, nil is returned."
73    (if (not (mm-multibyte-p))    (if (not (mm-multibyte-p))
74        ;; In the non-Mule case, we search for non-ASCII chars and        ;; In the non-Mule case, we search for non-ASCII chars and
75        ;; return the value of `mail-parse-charset' if any are found.        ;; return the value of `mail-parse-charset' if any are found.
76        (save-excursion        (or charset
77          (goto-char (point-min))            (save-excursion
78          (if (re-search-forward "[^\x0-\x7f]" nil t)              (goto-char (point-min))
79              (or mail-parse-charset              (if (re-search-forward "[^\x0-\x7f]" nil t)
80                  (mm-read-charset "Charset used in the article: "))                  (or mail-parse-charset
81            ;; The logic in `mml-generate-mime-1' confirms that it's OK                      (message-options-get 'mm-encody-body-charset)
82            ;; to return nil here.                      (message-options-set
83            nil))                       'mm-encody-body-charset
84                         (mm-read-coding-system "Charset used in the article: ")))
85                  ;; The logic in `mml-generate-mime-1' confirms that it's OK
86                  ;; to return nil here.
87                  nil)))
88      (save-excursion      (save-excursion
89        (goto-char (point-min))        (if charset
90        (let ((charsets (mm-find-mime-charset-region (point-min) (point-max))))            (progn
91          (cond              (mm-encode-coding-region (point-min) (point-max) charset)
92           ;; No encoding.              charset)
93           ((null charsets)          (goto-char (point-min))
94            nil)          (let ((charsets (mm-find-mime-charset-region (point-min) (point-max)
95           ;; Too many charsets.                                                       mm-hack-charsets)))
96           ((> (length charsets) 1)            (cond
97            charsets)             ;; No encoding.
98           ;; We encode.             ((null charsets)
99           (t              nil)
100            (mm-encode-coding-region (point-min) (point-max)             ;; Too many charsets.
101                                     (mm-charset-to-coding-system             ((> (length charsets) 1)
102                                      (car charsets)))              charsets)
103            (car charsets)))))))             ;; We encode.
104               (t
105                (prog1
106                    (setq charset (car charsets))
107                  (mm-encode-coding-region (point-min) (point-max)
108                                           (mm-charset-to-coding-system charset))))
109               ))))))
110    
111  (eval-when-compile (defvar message-posting-charset))  (defun mm-long-lines-p (length)
112      "Say whether any of the lines in the buffer is longer than LENGTH."
113      (save-excursion
114        (goto-char (point-min))
115        (end-of-line)
116        (while (and (not (eobp))
117                    (not (> (current-column) length)))
118          (forward-line 1)
119          (end-of-line))
120        (and (> (current-column) length)
121             (current-column))))
122    
123    (defvar message-posting-charset)
124    
125  (defun mm-body-encoding (charset &optional encoding)  (defun mm-body-encoding (charset &optional encoding)
126    "Do Content-Transfer-Encoding and return the encoding of the current buffer."    "Do Content-Transfer-Encoding and return the encoding of the current buffer."
127    (let ((bits (mm-body-7-or-8)))    (when (stringp encoding)
128        (setq encoding (intern (downcase encoding))))
129      (let ((bits (mm-body-7-or-8))
130            (longp (mm-long-lines-p 1000)))
131      (require 'message)      (require 'message)
132      (cond      (cond
133       ((and (not mm-use-ultra-safe-encoding) (eq bits '7bit))       ((and (not longp)
134               (not (and mm-use-ultra-safe-encoding
135                         (save-excursion (re-search-forward "^From " nil t))))
136               (eq bits '7bit))
137        bits)        bits)
138       ((and (not mm-use-ultra-safe-encoding)       ((and (not mm-use-ultra-safe-encoding)
139               (not longp)
140               (not (cdr (assq charset mm-body-charset-encoding-alist)))
141             (or (eq t (cdr message-posting-charset))             (or (eq t (cdr message-posting-charset))
142                 (memq charset (cdr message-posting-charset))                 (memq charset (cdr message-posting-charset))
143                 (eq charset mail-parse-charset)))                 (eq charset mail-parse-charset)))
# Line 124  If no encoding was done, nil is returned Line 164  If no encoding was done, nil is returned
164  ;;; Functions for decoding  ;;; Functions for decoding
165  ;;;  ;;;
166    
167    (eval-when-compile (defvar mm-uu-yenc-decode-function))
168    
169  (defun mm-decode-content-transfer-encoding (encoding &optional type)  (defun mm-decode-content-transfer-encoding (encoding &optional type)
170      "Decodes buffer encoded with ENCODING, returning success status.
171    If TYPE is `text/plain' CRLF->LF translation may occur."
172    (prog1    (prog1
173        (condition-case error        (condition-case error
174            (cond            (cond
175             ((eq encoding 'quoted-printable)             ((eq encoding 'quoted-printable)
176              (quoted-printable-decode-region (point-min) (point-max)))              (quoted-printable-decode-region (point-min) (point-max))
177                t)
178             ((eq encoding 'base64)             ((eq encoding 'base64)
179              (base64-decode-region              (base64-decode-region
180               (point-min)               (point-min)
# Line 144  If no encoding was done, nil is returned Line 189  If no encoding was done, nil is returned
189                   (delete-region (match-beginning 0) (match-end 0)))                   (delete-region (match-beginning 0) (match-end 0)))
190                 (goto-char (point-max))                 (goto-char (point-max))
191                 (when (re-search-backward "^[A-Za-z0-9+/]+=*[\t ]*$" nil t)                 (when (re-search-backward "^[A-Za-z0-9+/]+=*[\t ]*$" nil t)
192                   (forward-line)                   (forward-line))
193                   (delete-region (point) (point-max)))                 (point))))
                (point-max))))  
194             ((memq encoding '(7bit 8bit binary))             ((memq encoding '(7bit 8bit binary))
195              ;; Do nothing.              ;; Do nothing.
196              )              t)
197             ((null encoding)             ((null encoding)
198              ;; Do nothing.              ;; Do nothing.
199              )              t)
200             ((memq encoding '(x-uuencode x-uue))             ((memq encoding '(x-uuencode x-uue))
201              (require 'mm-uu)              (require 'mm-uu)
202              (funcall mm-uu-decode-function (point-min) (point-max)))              (funcall mm-uu-decode-function (point-min) (point-max))
203                t)
204             ((eq encoding 'x-binhex)             ((eq encoding 'x-binhex)
205              (require 'mm-uu)              (require 'mm-uu)
206              (funcall mm-uu-binhex-decode-function (point-min) (point-max)))              (funcall mm-uu-binhex-decode-function (point-min) (point-max))
207                t)
208               ((eq encoding 'x-yenc)
209                (require 'mm-uu)
210                (funcall mm-uu-yenc-decode-function (point-min) (point-max))
211                )
212             ((functionp encoding)             ((functionp encoding)
213              (funcall encoding (point-min) (point-max)))              (funcall encoding (point-min) (point-max))
214                t)
215             (t             (t
216              (message "Unknown encoding %s; defaulting to 8bit" encoding)))              (message "Unknown encoding %s; defaulting to 8bit" encoding)))
217          (error          (error
218           (message "Error while decoding: %s" error)           (message "Error while decoding: %s" error)
219           nil))           nil))
220      (when (and      (when (and
221             (memq encoding '(base64 x-uuencode x-uue x-binhex))             (memq encoding '(base64 x-uuencode x-uue x-binhex x-yenc))
222             (equal type "text/plain"))             (equal type "text/plain"))
223        (goto-char (point-min))        (goto-char (point-min))
224        (while (search-forward "\r\n" nil t)        (while (search-forward "\r\n" nil t)
225          (replace-match "\n" t t)))))          (replace-match "\n" t t)))))
226    
227  (defun mm-decode-body (charset &optional encoding type)  (defun mm-decode-body (charset &optional encoding type)
228    "Decode the current article that has been encoded with ENCODING.    "Decode the current article that has been encoded with ENCODING to CHARSET.
229  The characters in CHARSET should then be decoded."  ENCODING is a MIME content transfer encoding.
230    (if (stringp charset)  CHARSET is the MIME charset with which to decode the data after transfer
231        (setq charset (intern (downcase charset))))  decoding.  If it is nil, default to `mail-parse-charset'."
232    (if (or (not charset)    (when (stringp charset)
233            (eq 'gnus-all mail-parse-ignored-charsets)      (setq charset (intern (downcase charset))))
234            (memq 'gnus-all mail-parse-ignored-charsets)    (when (or (not charset)
235            (memq charset mail-parse-ignored-charsets))              (eq 'gnus-all mail-parse-ignored-charsets)
236        (setq charset mail-parse-charset))              (memq 'gnus-all mail-parse-ignored-charsets)
237                (memq charset mail-parse-ignored-charsets))
238        (setq charset mail-parse-charset))
239    (save-excursion    (save-excursion
240      (when encoding      (when encoding
241        (mm-decode-content-transfer-encoding encoding type))        (mm-decode-content-transfer-encoding encoding type))
242      (when (featurep 'mule)      (when (featurep 'mule)  ; Fixme: Wrong test for unibyte session.
243        (let ((coding-system (mm-charset-to-coding-system charset)))        (let ((coding-system (mm-charset-to-coding-system charset)))
244          (if (and (not coding-system)          (if (and (not coding-system)
245                   (listp mail-parse-ignored-charsets)                   (listp mail-parse-ignored-charsets)
# Line 201  The characters in CHARSET should then be Line 254  The characters in CHARSET should then be
254                     (or (not (eq coding-system 'ascii))                     (or (not (eq coding-system 'ascii))
255                         (setq coding-system mail-parse-charset))                         (setq coding-system mail-parse-charset))
256                     (not (eq coding-system 'gnus-decoded)))                     (not (eq coding-system 'gnus-decoded)))
257            (mm-decode-coding-region (point-min) (point-max) coding-system))))))            (mm-decode-coding-region (point-min) (point-max)
258                                       coding-system))
259            (setq buffer-file-coding-system
260                  (if (boundp 'last-coding-system-used)
261                      (symbol-value 'last-coding-system-used)
262                    coding-system))))))
263    
264  (defun mm-decode-string (string charset)  (defun mm-decode-string (string charset)
265    "Decode STRING with CHARSET."    "Decode STRING with CHARSET."

Legend:
Removed from v.1.6.8.2  
changed lines
  Added in v.1.6.8.3

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