;;; mm-decode.el --- Functions for decoding MIME things
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005 Free Software Foundation, Inc.
+;; 2005, 2006 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
(eval-and-compile
(autoload 'mm-inline-partial "mm-partial")
(autoload 'mm-inline-external-body "mm-extern")
+ (autoload 'mm-extern-cache-contents "mm-extern")
(autoload 'mm-insert-inline "mm-view"))
(defvar gnus-current-window-configuration)
"application/x-emacs-lisp"
"application/pgp-signature" "application/x-pkcs7-signature"
"application/pkcs7-signature" "application/x-pkcs7-mime"
- "application/pkcs7-mime")
+ "application/pkcs7-mime"
+ ;; Mutt still uses this even though it has already been withdrawn.
+ "application/pgp")
"List of media types that are to be displayed inline.
See also `mm-inline-media-tests', which says how to display a media
type inline."
"application/emacs-lisp" "application/x-emacs-lisp"
"application/x-pkcs7-signature"
"application/pkcs7-signature" "application/x-pkcs7-mime"
- "application/pkcs7-mime")
+ "application/pkcs7-mime"
+ ;; Mutt still uses this even though it has already been withdrawn.
+ "application/pgp")
"A list of MIME types to be displayed automatically."
:type '(repeat regexp)
:group 'mime-display)
loose-mime
(mail-fetch-field "mime-version"))
(setq ct (mail-fetch-field "content-type")
- ctl (ignore-errors (mail-header-parse-content-type ct))
+ ctl (and ct (mail-header-parse-content-type ct))
cte (mail-fetch-field "content-transfer-encoding")
cd (mail-fetch-field "content-disposition")
description (mail-fetch-field "content-description")
id (mail-fetch-field "content-id"))
(unless from
- (setq from (mail-fetch-field "from")))
+ (setq from (mail-fetch-field "from")))
;; FIXME: In some circumstances, this code is running within
;; an unibyte macro. mail-extract-address-components
;; creates unibyte buffers. This `if', though not a perfect
(list mm-dissect-default-type)
(and cte (intern (downcase (mail-header-strip cte))))
no-strict-mime
- (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
+ (and cd (mail-header-parse-content-disposition cd))
description)
(setq type (split-string (car ctl) "/"))
(setq subtype (cadr type)
ctl
(and cte (intern (downcase (mail-header-strip cte))))
no-strict-mime
- (and cd (ignore-errors
- (mail-header-parse-content-disposition cd)))
+ (and cd (mail-header-parse-content-disposition cd))
description id)
ctl))))
(when id
(gnus-map-function mm-file-name-rewrite-functions
(file-name-nondirectory filename))
dir))
- (setq file (mm-make-temp-file (expand-file-name "mm." dir)))
- (let ((newname
- ;; Use nametemplate (defined in RFC1524) if it is
- ;; specified in mailcap.
- (if (assoc "nametemplate" mime-info)
- (format (cdr (assoc "nametemplate" mime-info)) file)
- ;; Add a suffix according to `mailcap-mime-extensions'.
- (concat file (car (rassoc (mm-handle-media-type handle)
- mailcap-mime-extensions))))))
- (unless (string-equal file newname)
- (when (file-exists-p file)
- (rename-file file newname))
- (setq file newname))))
+ ;; Use nametemplate (defined in RFC1524) if it is specified
+ ;; in mailcap.
+ (let ((suffix (cdr (assoc "nametemplate" mime-info))))
+ (if (and suffix
+ (string-match "\\`%s\\(\\..+\\)\\'" suffix))
+ (setq suffix (match-string 1 suffix))
+ ;; Otherwise, use a suffix according to
+ ;; `mailcap-mime-extensions'.
+ (setq suffix (car (rassoc (mm-handle-media-type handle)
+ mailcap-mime-extensions))))
+ (setq file (mm-make-temp-file (expand-file-name "mm." dir)
+ nil suffix))))
(let ((coding-system-for-write mm-binary-coding-system))
(write-region (point-min) (point-max) file nil 'nomesg))
(message "Viewing with %s" method)
;;; Functions for outputting parts
;;;
-(defun mm-get-part (handle)
- "Return the contents of HANDLE as a string."
- (mm-with-unibyte-buffer
- (insert (with-current-buffer (mm-handle-buffer handle)
- (mm-with-unibyte-current-buffer
- (buffer-string))))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (mm-handle-media-type handle))
- (buffer-string)))
-
-(defun mm-insert-part (handle)
- "Insert the contents of HANDLE in the current buffer."
+(defmacro mm-with-part (handle &rest forms)
+ "Run FORMS in the temp buffer containing the contents of HANDLE."
+ `(let* ((handle ,handle)
+ ;; The multibyteness of the temp buffer should be turned on
+ ;; if inserting a multibyte string. Contrarily, the buffer's
+ ;; multibyteness should be off if inserting a unibyte string,
+ ;; especially if a string contains 8bit data.
+ (default-enable-multibyte-characters
+ (with-current-buffer (mm-handle-buffer handle)
+ (mm-multibyte-p))))
+ (with-temp-buffer
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-disable-multibyte)
+ (mm-decode-content-transfer-encoding
+ (mm-handle-encoding handle)
+ (mm-handle-media-type handle))
+ ,@forms)))
+(put 'mm-with-part 'lisp-indent-function 1)
+(put 'mm-with-part 'edebug-form-spec '(body))
+
+(defun mm-get-part (handle &optional no-cache)
+ "Return the contents of HANDLE as a string.
+If NO-CACHE is non-nil, cached contents of a message/external-body part
+are ignored."
+ (if (and (not no-cache)
+ (equal (mm-handle-media-type handle) "message/external-body"))
+ (progn
+ (unless (mm-handle-cache handle)
+ (mm-extern-cache-contents handle))
+ (with-current-buffer (mm-handle-buffer (mm-handle-cache handle))
+ (buffer-string)))
+ (mm-with-part handle
+ (buffer-string))))
+
+(defun mm-insert-part (handle &optional no-cache)
+ "Insert the contents of HANDLE in the current buffer.
+If NO-CACHE is non-nil, cached contents of a message/external-body part
+are ignored."
(save-excursion
(insert
(cond ((eq (mail-content-type-get (mm-handle-type handle) 'charset)
(with-current-buffer (mm-handle-buffer handle)
(buffer-string)))
((mm-multibyte-p)
- (mm-string-as-multibyte (mm-get-part handle)))
+ (mm-string-as-multibyte (mm-get-part handle no-cache)))
(t
- (mm-get-part handle))))))
+ (mm-get-part handle no-cache))))))
(defun mm-file-name-delete-whitespace (file-name)
"Remove all whitespace characters from FILE-NAME."
(defun mm-save-part (handle &optional prompt)
"Write HANDLE to a file.
PROMPT overrides the default one used to ask user for a file name."
- (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
- (filename (mail-content-type-get
- (mm-handle-disposition handle) 'filename))
- file)
+ (let ((filename (or (mail-content-type-get
+ (mm-handle-disposition handle) 'filename)
+ (mail-content-type-get
+ (mm-handle-type handle) 'name)))
+ file)
(when filename
(setq filename (gnus-map-function mm-file-name-rewrite-functions
(file-name-nondirectory filename))))
(setq file
(mm-with-multibyte
- (read-file-name (or prompt "Save MIME part to: ")
- (or mm-default-directory default-directory)
- nil nil (or filename name ""))))
+ (read-file-name (or prompt "Save MIME part to: ")
+ (or mm-default-directory default-directory)
+ nil nil (or filename ""))))
(setq mm-default-directory (file-name-directory file))
(and (or (not (file-exists-p file))
(yes-or-no-p (format "File %s already exists; overwrite? "
;; out to a file, and then create a file
;; specifier.
(let ((file (mm-make-temp-file
- (expand-file-name "emm.xbm"
- mm-tmp-directory))))
+ (expand-file-name "emm" mm-tmp-directory)
+ nil ".xbm")))
(unwind-protect
(progn
(write-region (point-min) (point-max) file)
(save-excursion
(save-restriction
(narrow-to-region start (1- (point)))
- (when (let ((ctl (ignore-errors
- (mail-header-parse-content-type
- (mail-fetch-field "content-type")))))
+ (when (let* ((ct (mail-fetch-field "content-type"))
+ (ctl (and ct (mail-header-parse-content-type ct))))
(if notp
(not (equal (car ctl) type))
(equal (car ctl) type)))
(save-excursion
(save-restriction
(narrow-to-region start end)
- (when (let ((ctl (ignore-errors
- (mail-header-parse-content-type
- (mail-fetch-field "content-type")))))
+ (when (let* ((ct (mail-fetch-field "content-type"))
+ (ctl (and ct (mail-header-parse-content-type ct))))
(if notp
(not (equal (car ctl) type))
(equal (car ctl) type)))
projects / gnus / blobdiff