annotate lisp/mail/rmailmm.el @ 88306:7b65aade5e20

new file, based on Alexander Pohoyda's code.

;;; rmailmm.el --- MIME decoding and display stuff for RMAIL

;; Copyright (C) 2006  Free Software Foundation, Inc.

;; Maintainer: FSF
;; Keywords: mail

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; 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.

;;; 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))
  "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
function to run."
  :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."
  :type 'list
  :group 'mime)

(defvar 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))

;;; Buttons

(defun 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)))
    (setq filename (expand-file-name
		    (read-file-name "Save as: "
				    directory nil nil filename)))
    (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)

;;; Handlers

(defun 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)
  "Handle the current buffer as an attachment to download."
  (setq mime-total-number-of-bulk-attachments
	(1+ 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))))))
	 (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)
  "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
format."
  ;; Some MUAs start boundaries with "--", while it should start
  ;; with "CRLF--", as defined by RFC 2046:
  ;;    The boundary delimiter MUST occur at the beginning of a line,
  ;;    i.e., following a CRLF, and the initial CRLF is considered to
  ;;    be attached to the boundary delimiter line rather than part
  ;;    of the preceding part.
  ;; We currently don't handle that.
  (let ((boundary (cdr (assq 'boundary content-type)))
	(beg (point-min))
	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)
    (when (and (search-forward boundary nil t)
	       (looking-at "[ \t]*\n"))
      (mime-hide-region beg (match-end 0))
      (setq beg (match-end 0)))
    ;; Reset the counter
    (setq 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.
    (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.
      (cond ((looking-at "--[ \t]*\n")
	     (setq next (point-max)))
	    ((looking-at "[ \t]*\n")
	     (setq next (match-end 0)))
	    (t
	     (error "Malformed boundary" content-type
		    content-disposition content-transfer-encoding)))
      (mime-hide-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))))
      (setq beg next)
      (goto-char beg))))

(defun test-mime-multipart-handler ()
  "Test of a mail used as an example in RFC 2046."
  (let ((mail "From: Nathaniel Borenstein <[e-mail]>
To: Ned Freed <[e-mail]>
Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
Subject: Sample message
MIME-Version: 1.0
Content-type: multipart/mixed; boundary=\"simple boundary\"

This is the preamble.  It is to be ignored, though it
is a handy place for composition agents to include an
explanatory note to non-MIME conformant readers.

--simple boundary

This is implicitly typed plain US-ASCII text.
It does NOT end with a linebreak.
--simple boundary
Content-type: text/plain; charset=us-ascii

This is explicitly typed plain US-ASCII text.
It DOES end with a linebreak.

--simple boundary--

This is the epilogue.  It is also to be ignored."))
    (switch-to-buffer (get-buffer-create "*test*"))
    (erase-buffer)
    (insert mail)
    (mime-show t)
    (buffer-string)))

;;; Main code

(defun 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
are the values of the respective parsed headers.  The parsed
headers for CONTENT-TYPE and CONTENT-DISPOSITION have the form

  \(VALUE . ALIST)

In other words:

  \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)

VALUE is a string and ATTRIBUTE is a symbol.

Consider the following header, for example:

Content-Type: multipart/mixed;
	boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"

The parsed header value:

\(\"multipart/mixed\"
  \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
  (if (string= "inline" (car content-disposition))
      (let ((stop nil))
	(dolist (entry 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
		       content-disposition
		       content-transfer-encoding)))

(defun 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.

The current buffer must be narrowed to a single message.
This function will be called recursively if multiple parts
are available."
  (let ((end (point-min))
	content-type
	content-transfer-encoding
	content-disposition)
    ;; `point-min' returns the beginning and `end' points at the end
    ;; of the headers.  We're not using `rmail-header-get-header'
    ;; because we must be able to handle the case of no headers
    ;; existing in a part.  In this case end is at point-min.
    (goto-char (point-min))
    ;; If we're showing a part without headers, then it will start
    ;; with a newline.
    (if (eq (char-after) ?\n)
	(setq end (1+ (point)))
      (when (search-forward "\n\n" nil t)
	(setq end (match-end 0))
	(save-restriction
	  (narrow-to-region (point-min) end)
	  ;; FIXME: Default disposition of the multipart entities should
	  ;; be inherited.
	  (setq content-type
		(mail-fetch-field "Content-Type")
		content-transfer-encoding
		(mail-fetch-field "Content-Transfer-Encoding")
		content-disposition
		(mail-fetch-field "Content-Disposition")))))
    (if content-type
	(setq content-type (mail-header-parse-content-type
			    content-type))
      ;; FIXME: Default "message/rfc822" in a "multipart/digest"
      ;; according to RFC 2046.
      (setq content-type '("text/plain")))
    (setq content-disposition
	  (if content-disposition
	      (mail-header-parse-content-disposition content-disposition)
	    ;; 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")
      (setq content-disposition '("attachment")))
    (save-restriction
      (narrow-to-region end (point-max))
      (mime-handle content-type content-disposition
		   content-transfer-encoding))))