;;; Commentary:
;; Essentially based on the design of Alexander Pohoyda's MIME
-;; extensions (mime-display.el and mime.el). The current design tries
-;; to work on the current buffer, without changing it's text. All it
-;; does is add text properties: It uses the text property `invisible'
-;; to hide MIME boundaries and ignored media types, and it uses the
-;; text property `display' to display something instead of the actual
-;; MIME part.
+;; extensions (mime-display.el and mime.el). To use, copy a complete
+;; message into a new buffer and call (mime-show t).
;;; Code:
;;; Variables
-(defcustom mime-media-type-handlers-alist
- '(("multipart/.*" mime-multipart-handler)
- ("message/rfc822" mime-toggler-handler)
- ("message/delivery-status" mime-entity-hider-handler)
- ("message/x-body" mime-entity-hider-handler)
- ("message/x-command-input" mime-message/x-command-input-handler)
- ("message/external-body" mime-message/external-body-handler)
- ("text/.*" mime-text-handler)
- ("text/\\(x-\\)?patch" mime-bulk-handler)
- ("image/.*" mime-image-handler)
- ("application/pgp-signature" mime-application/pgp-signature-handler)
- ("\\(image\\|audio\\|video\\|application\\)/.*" mime-bulk-handler))
+(defcustom rmail-mime-media-type-handlers-alist
+ '(("multipart/.*" rmail-mime-multipart-handler)
+ ("message/rfc822" rmail-mime-toggler-handler)
+ ("message/delivery-status" rmail-mime-entity-hider-handler)
+ ("message/x-body" rmail-mime-entity-hider-handler)
+ ("message/x-command-input" rmail-mime-message/x-command-input-handler)
+ ("message/external-body" rmail-mime-message/external-body-handler)
+ ("text/.*" rmail-mime-text-handler)
+ ("text/\\(x-\\)?patch" rmail-mime-bulk-handler)
+ ("image/.*" rmail-mime-image-handler)
+ ("application/pgp-signature" rmail-mime-application/pgp-signature-handler)
+ ("\\(image\\|audio\\|video\\|application\\)/.*" rmail-mime-bulk-handler))
"Alist of media type handlers, also known as agents.
Every handler is a list of type (string symbol) where STRING is a
regular expression to match the media type with and SYMBOL is a
:type 'list
:group 'mime)
-(defcustom mime-attachment-dirs-alist
- '(("text/.*" ("~/Documents"))
- ("image/.*" ("~/Pictures"))
- (".*" ("/tmp/")))
- "Default directories to save attachments into. Each media type may have
-it's own directory."
+(defcustom rmail-mime-attachment-dirs-alist
+ '(("text/.*" "~/Documents")
+ ("image/.*" "~/Pictures")
+ (".*" "~/Desktop" "~" "/tmp"))
+ "Default directories to save attachments into.
+Each media type may have it's own list of directories in order of
+preference. The first existing directory in the list will be
+used."
:type 'list
:group 'mime)
-(defvar mime-total-number-of-bulk-attachments 0
+(defvar rmail-mime-total-number-of-bulk-attachments 0
"A total number of attached bulk bodyparts in the message. If more than 3,
offer a way to save all attachments at once.")
-(put 'mime-total-number-of-bulk-attachments 'permanent-local t)
-
-;;; Utility Functions
-
-(defun mime-hide-region (from to)
- "Put text property `invisible' on the region FROM TO."
- (put-text-property from to 'invisible t))
-
-(defun mime-unhide-region (from to)
- "Remove the text property `invisible' on the region FROM TO."
- (remove-text-properties from to '(invisible nil)))
-
-(defun mime-display-region-as (from to text)
- "Put text property `display' with value TEXT on the region FROM TO."
- (put-text-property from to 'display text))
+(put 'rmail-mime-total-number-of-bulk-attachments 'permanent-local t)
;;; Buttons
-(defun mime-save (button)
+(defun rmail-mime-save (button)
"Save the attachment using info in the BUTTON."
(let* ((filename (button-get button 'filename))
(directory (button-get button 'directory))
(data (button-get button 'data)))
+ (while (file-exists-p (expand-file-name filename directory))
+ (let* ((f (file-name-sans-extension filename))
+ (i 1))
+ (when (string-match "-\\([0-9]+\\)$" f)
+ (setq i (1+ (string-to-number (match-string 1 f)))
+ f (substring f 0 (match-beginning 0))))
+ (setq filename (concat f "-" (number-to-string i) "."
+ (file-name-extension filename)))))
(setq filename (expand-file-name
- (read-file-name "Save as: "
- directory nil nil filename)))
+ (read-file-name (format "Save as (default: %s): " filename)
+ directory
+ (expand-file-name filename directory))
+ directory))
(when (file-regular-p filename)
(error (message "File `%s' already exists" filename)))
(with-temp-file filename
(set-buffer-file-coding-system 'no-conversion)
(insert data))))
-(define-button-type 'mime-save
- 'action 'mime-save)
+(define-button-type 'rmail-mime-save
+ 'action 'rmail-mime-save)
;;; Handlers
-(defun mime-text-handler (content-type
- content-disposition
- content-transfer-encoding)
+(defun rmail-mime-text-handler (content-type
+ content-disposition
+ content-transfer-encoding)
"Handle the current buffer as a plain text MIME part.")
-(defun mime-bulk-handler (content-type
- content-disposition
- content-transfer-encoding)
+(defun rmail-mime-bulk-handler (content-type
+ content-disposition
+ content-transfer-encoding)
"Handle the current buffer as an attachment to download."
- (setq mime-total-number-of-bulk-attachments
- (1+ mime-total-number-of-bulk-attachments))
+ (setq rmail-mime-total-number-of-bulk-attachments
+ (1+ rmail-mime-total-number-of-bulk-attachments))
;; Find the default directory for this media type
(let* ((directory (catch 'directory
- (dolist (entry mime-attachment-dirs-alist)
- (when (string-match (car entry) (car content-type))
- (throw 'directory (cadr entry))))))
+ (dolist (entry rmail-mime-attachment-dirs-alist)
+ (when (string-match (car entry) (car content-type))
+ (dolist (dir (cdr entry))
+ (when (file-directory-p dir)
+ (throw 'directory dir)))))))
(filename (or (cdr (assq 'name (cdr content-type)))
(cdr (assq 'filename (cdr content-disposition)))
"noname"))
- (button (format "\nAttached %s file: %s"
- (car content-type)
- (let ((data (buffer-string)))
- (with-temp-buffer
- (insert-button filename :type 'mime-save
- 'filename filename
- 'directory directory
- 'data data)
- (buffer-string))))))
- (mime-display-region-as (point-min) (point-max) button)))
-
-(defun mime-multipart-handler (content-type
- content-disposition
- content-transfer-encoding)
+ (label (format "\nAttached %s file: " (car content-type)))
+ (data (buffer-string)))
+ (delete-region (point-min) (point-max))
+ (insert label)
+ (insert-button filename
+ :type 'rmail-mime-save
+ 'filename filename
+ 'directory directory
+ 'data data)))
+
+(defun test-rmail-mime-bulk-handler ()
+ "Test of a mail used as an example in RFC 2183."
+ (let ((mail "Content-Type: image/jpeg
+Content-Disposition: attachment; filename=genome.jpeg;
+ modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
+Content-Description: a complete map of the human genome
+Content-Transfer-Encoding: base64
+
+iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
+TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
++ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
+WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
+9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
+UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
+lgAAAABJRU5ErkJggg==
+"))
+ (switch-to-buffer (get-buffer-create "*test*"))
+ (erase-buffer)
+ (insert mail)
+ (rmail-mime-show)))
+
+(defun rmail-mime-multipart-handler (content-type
+ content-disposition
+ content-transfer-encoding)
"Handle the current buffer as a multipart MIME body.
The current buffer should be narrowed to the body. CONTENT-TYPE,
CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
-of the respective parsed headers. See `mime-handle' for their
+of the respective parsed headers. See `rmail-mime-handle' for their
format."
;; Some MUAs start boundaries with "--", while it should start
;; with "CRLF--", as defined by RFC 2046:
;; of the preceding part.
;; We currently don't handle that.
(let ((boundary (cdr (assq 'boundary content-type)))
- (beg (point-min))
- next)
+ beg next)
(unless boundary
(error "No boundary defined" content-type content-disposition
content-transfer-encoding))
(setq boundary (concat "\n--" boundary))
;; Hide the body before the first bodypart
- (goto-char beg)
+ (goto-char (point-min))
(when (and (search-forward boundary nil t)
(looking-at "[ \t]*\n"))
- (mime-hide-region beg (match-end 0))
- (setq beg (match-end 0)))
+ (delete-region (point-min) (match-end 0)))
;; Reset the counter
- (setq mime-total-number-of-bulk-attachments 0)
+ (setq rmail-mime-total-number-of-bulk-attachments 0)
;; Loop over all body parts, where beg points at the beginning of
;; the part and end points at the end of the part. next points at
;; the beginning of the next part.
+ (setq beg (point-min))
(while (search-forward boundary nil t)
(setq end (match-beginning 0))
;; If this is the last boundary according to RFC 2046, hide the
- ;; epilogue, else hide the boundary only.
+ ;; epilogue, else hide the boundary only. Use a marker for
+ ;; `next' because `rmail-mime-show' may change the buffer.
(cond ((looking-at "--[ \t]*\n")
- (setq next (point-max)))
+ (setq next (point-max-marker)))
((looking-at "[ \t]*\n")
- (setq next (match-end 0)))
+ (setq next (copy-marker (match-end 0))))
(t
(error "Malformed boundary" content-type
content-disposition content-transfer-encoding)))
- (mime-hide-region end next)
+ (delete-region end next)
;; Handle the part.
(save-match-data
(save-excursion
(save-restriction
(narrow-to-region beg end)
- ;; FIXME: Do decoding of content-transfer-encoding
- (mime-show))))
+ (rmail-mime-show))))
(setq beg next)
(goto-char beg))))
-(defun test-mime-multipart-handler ()
+(defun test-rmail-mime-multipart-handler ()
"Test of a mail used as an example in RFC 2046."
(let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
To: Ned Freed <ned@innosoft.com>
(switch-to-buffer (get-buffer-create "*test*"))
(erase-buffer)
(insert mail)
- (mime-show t)
- (buffer-string)))
+ (rmail-mime-show t)))
;;; Main code
-(defun mime-handle (content-type content-disposition content-transfer-encoding)
+(defun rmail-mime-handle (content-type
+ content-disposition
+ content-transfer-encoding)
"Handle the current buffer as a MIME part.
The current buffer should be narrowed to the respective body.
CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING
\(\"multipart/mixed\"
\(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
+ ;; Handle the content transfer encodings we know. Unknown transfer
+ ;; encodings will be passed on to the various handlers.
+ (cond ((string= content-transfer-encoding "base64")
+ (base64-decode-region (point-min) (point-max))
+ (setq content-transfer-encoding nil))
+ ((string= content-transfer-encoding "quoted-printable")
+ (quoted-printable-decode-region (point-min) (point-max))
+ (setq content-transfer-encoding nil)))
+ ;; Inline stuff requires work. Attachments are handled by the bulk
+ ;; handler.
(if (string= "inline" (car content-disposition))
(let ((stop nil))
- (dolist (entry mime-media-type-handlers-alist)
+ (dolist (entry rmail-mime-media-type-handlers-alist)
(when (and (string-match (car entry) (car content-type)) (not stop))
(progn
(setq stop (funcall (cadr entry) content-type
content-disposition
content-transfer-encoding))))))
- ;; treat everything else as an attachment
- (mime-bulk-handler content-type
+ ;; Everything else is an attachment.
+ (rmail-mime-bulk-handler content-type
content-disposition
content-transfer-encoding)))
-(defun mime-show (&optional show-headers)
+(defun rmail-mime-show (&optional show-headers)
"Handle the current buffer as a MIME message.
If SHOW-HEADERS is non-nil, then the headers of the current part
-are not all hidden, as they usually are \(except for
-message/rfc822 content types\). This is usually only used for
-the top-level call.
+will shown as usual for a MIME message. The headers are also
+shown for the content type message/rfc822. This function will be
+called recursively if multiple parts are available.
-The current buffer must be narrowed to a single message.
-This function will be called recursively if multiple parts
-are available."
+The current buffer must contain a single message. It will be
+modifed."
(let ((end (point-min))
content-type
content-transfer-encoding
;; If none specified, we are free to choose what we deem
;; suitable according to RFC 2183. We like inline.
'("inline")))
- ;; Hide headers.
- (if (or (string= (car content-type) "message/rfc822")
- show-headers)
- (rmail-header-hide-headers)
- (mime-hide-region (point-min) end))
;; Unrecognized disposition types are to be treated like
;; attachment according to RFC 2183.
- (unless (string= (car content-disposition) "inline")
+ (unless (member (car content-disposition) '("inline" "attachment"))
(setq content-disposition '("attachment")))
+ ;; Hide headers and handle the part.
(save-restriction
- (narrow-to-region end (point-max))
- (mime-handle content-type content-disposition
- content-transfer-encoding))))
+ (if (or show-headers
+ (string= (car content-type) "message/rfc822"))
+ (progn
+ (rmail-header-hide-headers)
+ (narrow-to-region end (point-max)))
+ (delete-region (point-min) end))
+ (rmail-mime-handle content-type content-disposition
+ content-transfer-encoding))))
projects / emacs.git / commitdiff