Improve rmail's MIME handling.

1 files changed, 337 insertions, 30 deletions

diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el
index e8ca11ee349..6dfa92aa93a 100644
--- a/lisp/mail/rmailmm.el
+++ b/lisp/mail/rmailmm.el
@@ -26,17 +26,57 @@
 
 ;; Essentially based on the design of Alexander Pohoyda's MIME
 ;; extensions (mime-display.el and mime.el).
-;; Call `M-x rmail-mime' when viewing an Rmail message.
+
+;; This file provides two operation modes for viewing a MIME message.
+
+;; (1) When rmail-enable-mime is non-nil (now it is the default), the
+;; function `rmail-show-mime' is automatically called.  That function
+;; shows a MIME message directly in RMAIL's view buffer.
+
+;; (2) When rmail-enable-mime is nil, the command 'v' (or M-x
+;; rmail-mime) shows a MIME message in a new buffer "*RMAIL*".
+
+;; Both operations share the intermediate functions rmail-mime-process
+;; and rmail-mime-process-multipart as below.
+
+;; rmail-show-mime
+;;   +- rmail-mime-parse
+;;   |    +- rmail-mime-process <--+------------+
+;;   |         |         +---------+            |
+;;   |         + rmail-mime-process-multipart --+
+;;   |
+;;   + rmail-mime-insert <----------------+
+;;       +- rmail-mime-insert-text        |
+;;       +- rmail-mime-insert-bulk        |
+;;       +- rmail-mime-insert-multipart --+
+;;
+;; rmail-mime
+;;  +- rmail-mime-show <----------------------------------+
+;;       +- rmail-mime-process                            | 
+;;            +- rmail-mime-handle                        |
+;;                 +- rmail-mime-text-handler             |
+;;                 +- rmail-mime-bulk-handler             |
+;;                 |    + rmail-mime-insert-bulk
+;;                 +- rmail-mime-multipart-handler        |
+;;                      +- rmail-mime-process-multipart --+
+
+;; In addition, for the case of rmail-enable-mime being non-nil, this
+;; file provides two functions rmail-insert-mime-forwarded-message and
+;; rmail-insert-mime-resent-message for composing forwarded and resent
+;; messages respectively.
 
 ;; Todo:
 
-;; Handle multipart/alternative.
+;; Make rmail-mime-media-type-handlers-alist usable in the first
+;; operation mode.
+;; Handle multipart/alternative in the second operation mode.
 ;; Offer the option to call external/internal viewers (doc-view, xpdf, etc).
 
 ;;; Code:
 
 (require 'rmail)
 (require 'mail-parse)
+(require 'message)
 
 ;;; User options.
 
@@ -90,6 +130,52 @@ automatically display the image in the buffer."
 
 ;;; End of user options.
 
+;;; MIME-entity object
+
+(defun rmail-mime-entity (type disposition transfer-encoding
+			       header body children)
+  "Retrun a newly created MIME-entity object.
+
+A MIME-entity is a vector of 6 elements:
+
+  [ TYPE DISPOSITION TRANSFER-ENCODING HEADER BODY CHILDREN ]
+  
+TYPE and DISPOSITION correspond to MIME headers Content-Type: and
+Cotent-Disposition: respectively, and has this format:
+
+  \(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 corresponding TYPE argument must be:
+
+\(\"multipart/mixed\"
+  \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))
+
+TRANSFER-ENCODING corresponds to MIME header
+Content-Transfer-Encoding, and is a lowercased string.
+
+HEADER and BODY are a cons (BEG . END), where BEG and END specify
+the region of the corresponding part in RMAIL's data (mbox)
+buffer.  BODY may be nil.  In that case, the current buffer is
+narrowed to the body part.
+
+CHILDREN is a list of MIME-entities for a \"multipart\" entity, and
+nil for the other types."
+  (vector type disposition transfer-encoding header body children))
+
+;; Accessors for a MIME-entity object.
+(defsubst rmail-mime-entity-type (entity) (aref entity 0))
+(defsubst rmail-mime-entity-disposition (entity) (aref entity 1))
+(defsubst rmail-mime-entity-transfer-encoding (entity) (aref entity 2))
+(defsubst rmail-mime-entity-header (entity) (aref entity 3))
+(defsubst rmail-mime-entity-body (entity) (aref entity 4))
+(defsubst rmail-mime-entity-children (entity) (aref entity 5))
 
 ;;; Buttons
 
@@ -98,6 +184,7 @@ automatically display the image in the buffer."
   (let* ((filename (button-get button 'filename))
 	 (directory (button-get button 'directory))
 	 (data (button-get button 'data))
+	 (mbox-buf rmail-view-buffer)
 	 (ofilename filename))
     (setq filename (expand-file-name
 		    (read-file-name (format "Save as (default: %s): " filename)
@@ -116,7 +203,17 @@ automatically display the image in the buffer."
       ;; file, the magic signature compares equal with the unibyte
       ;; signature string recorded in jka-compr-compression-info-list.
       (set-buffer-multibyte nil)
-      (insert data)
+      (setq buffer-undo-list t)
+      (if (stringp data)
+	  (insert data)
+	;; DATA is a MIME-entity object.
+	(let ((transfer-encoding (rmail-mime-entity-transfer-encoding data))
+	      (body (rmail-mime-entity-body data)))
+	  (insert-buffer-substring mbox-buf (car body) (cdr body))
+	  (cond ((string= transfer-encoding "base64")
+		 (ignore-errors (base64-decode-region (point-min) (point-max))))
+		((string= transfer-encoding "quoted-printable")
+		 (quoted-printable-decode-region (point-min) (point-max))))))
       (write-region nil nil filename nil nil nil t))))
 
 (define-button-type 'rmail-mime-save 'action 'rmail-mime-save)
@@ -133,6 +230,23 @@ automatically display the image in the buffer."
     (when (coding-system-p coding-system)
       (decode-coding-region (point-min) (point-max) coding-system))))
 
+(defun rmail-mime-insert-text (entity)
+  "Insert MIME-entity ENTITY as a plain text MIME part in the current buffer."
+  (let* ((content-type (rmail-mime-entity-type entity))
+	 (charset (cdr (assq 'charset (cdr content-type))))
+	 (coding-system (if charset (intern (downcase charset))))
+	 (transfer-encoding (rmail-mime-entity-transfer-encoding entity))
+	 (body (rmail-mime-entity-body entity)))
+    (save-restriction
+      (narrow-to-region (point) (point))
+      (insert-buffer-substring rmail-buffer (car body) (cdr body))
+      (cond ((string= transfer-encoding "base64")
+	     (ignore-errors (base64-decode-region (point-min) (point-max))))
+	    ((string= transfer-encoding "quoted-printable")
+	     (quoted-printable-decode-region (point-min) (point-max))))
+      (if (coding-system-p coding-system)
+	  (decode-coding-region (point-min) (point-max) coding-system)))))
+
 ;; FIXME move to the test/ directory?
 (defun test-rmail-mime-handler ()
   "Test of a mail using no MIME parts at all."
@@ -151,10 +265,28 @@ MIME-Version: 1.0
 
 
 (defun rmail-mime-insert-image (type data)
-  "Insert an image of type TYPE, where DATA is the image data."
+  "Insert an image of type TYPE, where DATA is the image data.
+If DATA is not a string, it is a MIME-entity object."
   (end-of-line)
-  (insert ?\n)
-  (insert-image (create-image data type t)))
+  (let ((modified (buffer-modified-p)))
+    (insert ?\n)
+    (unless (stringp data)
+      ;; DATA is a MIME-entity.
+      (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data))
+	    (body (rmail-mime-entity-body data))
+	    (mbox-buffer rmail-view-buffer))
+	(with-temp-buffer
+	  (set-buffer-multibyte nil)
+	  (setq buffer-undo-list t)
+	  (insert-buffer-substring mbox-buffer (car body) (cdr body))
+	  (cond ((string= transfer-encoding "base64")
+		 (ignore-errors (base64-decode-region (point-min) (point-max))))
+		((string= transfer-encoding "quoted-printable")
+		 (quoted-printable-decode-region (point-min) (point-max))))
+	  (setq data
+		(buffer-substring-no-properties (point-min) (point-max))))))
+    (insert-image (create-image data type t))
+    (set-buffer-modified-p modified)))
 
 (defun rmail-mime-image (button)
   "Display the image associated with BUTTON."
@@ -171,8 +303,19 @@ MIME-Version: 1.0
   "Handle the current buffer as an attachment to download.
 For images that Emacs is capable of displaying, the behavior
 depends upon the value of `rmail-mime-show-images'."
+  (rmail-mime-insert-bulk
+   (rmail-mime-entity content-type content-disposition content-transfer-encoding
+		      nil nil nil)))
+
+(defun rmail-mime-insert-bulk (entity)
+  "Inesrt a MIME-entity ENTITY as an attachment.
+The optional second arg DATA, if non-nil, is a string containing
+the attachment data that is already decoded."
   ;; Find the default directory for this media type.
-  (let* ((directory (catch 'directory
+  (let* ((content-type (rmail-mime-entity-type entity))
+	 (content-disposition (rmail-mime-entity-disposition entity))
+	 (body (rmail-mime-entity-body entity))
+	 (directory (catch 'directory
 		      (dolist (entry rmail-mime-attachment-dirs-alist)
 			(when (string-match (car entry) (car content-type))
 			  (dolist (dir (cdr entry))
@@ -182,17 +325,21 @@ depends upon the value of `rmail-mime-show-images'."
 		       (cdr (assq 'filename (cdr content-disposition)))
 		       "noname"))
 	 (label (format "\nAttached %s file: " (car content-type)))
-	 (data (buffer-string))
-	 (udata (string-as-unibyte data))
-	 (size (length udata))
-	 (osize size)
 	 (units '(B kB MB GB))
-	 type)
-    (while (and (> size 1024.0)	; cribbed from gnus-agent-expire-done-message
+	 data udata size osize type)
+    (if body
+	(setq data entity
+	      udata entity
+	      size (- (cdr body) (car body)))
+      (setq data (buffer-string)
+	    udata (string-as-unibyte data)
+	    size (length udata))
+      (delete-region (point-min) (point-max)))
+    (setq osize size)
+    (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message
 		(cdr units))
       (setq size (/ size 1024.0)
 	    units (cdr units)))
-    (delete-region (point-min) (point-max))
     (insert label)
     (insert-button filename
 		   :type 'rmail-mime-save
@@ -248,6 +395,22 @@ 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 `rmail-mime-handle' for their
 format."
+  (rmail-mime-process-multipart
+   content-type content-disposition content-transfer-encoding nil))
+
+(defun rmail-mime-process-multipart (content-type
+				     content-disposition
+				     content-transfer-encoding
+				     parse-only)
+  "Process the current buffer as a multipart MIME body.
+
+If PARSE-ONLY is nil, modify the current buffer directly for showing
+the MIME body and return nil.
+
+Otherwise, just parse the current buffer and return a list of
+MIME-entity objects.
+
+The other arguments are the same as `rmail-mime-multipart-handler'."
   ;; 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,
@@ -256,7 +419,7 @@ format."
   ;;    of the preceding part.
   ;; We currently don't handle that.
   (let ((boundary (cdr (assq 'boundary content-type)))
-	beg end next)
+	beg end next entities)
     (unless boundary
       (rmail-mm-get-boundary-error-message
        "No boundary defined" content-type content-disposition
@@ -266,7 +429,9 @@ format."
     (goto-char (point-min))
     (when (and (search-forward boundary nil t)
 	       (looking-at "[ \t]*\n"))
-      (delete-region (point-min) (match-end 0)))
+      (if parse-only
+	  (narrow-to-region (match-end 0) (point-max))
+	(delete-region (point-min) (match-end 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.
@@ -284,13 +449,17 @@ format."
 	     (rmail-mm-get-boundary-error-message
 	      "Malformed boundary" content-type content-disposition
 	      content-transfer-encoding)))
-      (delete-region end next)
       ;; Handle the part.
-      (save-restriction
-	(narrow-to-region beg end)
-	(rmail-mime-show))
-      (goto-char (setq beg next)))))
-
+      (if parse-only
+	  (save-restriction
+	    (narrow-to-region beg end)
+	    (setq entities (cons (rmail-mime-process nil t) entities)))
+	(delete-region end next)
+	(save-restriction
+	  (narrow-to-region beg end)
+	  (rmail-mime-show)))
+      (goto-char (setq beg next)))
+    (nreverse entities)))
 
 (defun test-rmail-mime-multipart-handler ()
   "Test of a mail used as an example in RFC 2046."
@@ -393,6 +562,9 @@ called recursively if multiple parts are available.
 
 The current buffer must contain a single message.  It will be
 modified."
+  (rmail-mime-process show-headers nil))
+
+(defun rmail-mime-process (show-headers parse-only)
   (let ((end (point-min))
 	content-type
 	content-transfer-encoding
@@ -436,14 +608,105 @@ modified."
     ;; attachment according to RFC 2183.
     (unless (member (car content-disposition) '("inline" "attachment"))
       (setq content-disposition '("attachment")))
-    ;; Hide headers and handle the part.
-    (save-restriction
-      (cond ((string= (car content-type) "message/rfc822")
-	     (narrow-to-region end (point-max)))
-	    ((not show-headers)
-	     (delete-region (point-min) end)))
-      (rmail-mime-handle content-type content-disposition
-			 content-transfer-encoding))))
+
+    (if parse-only
+	(cond ((string-match "multipart/.*" (car content-type))
+	       (setq end (1- end))
+	       (save-restriction
+		 (let ((header (if show-headers (cons (point-min) end))))
+		   (narrow-to-region end (point-max))
+		   (rmail-mime-entity content-type
+				      content-disposition
+				      content-transfer-encoding
+				      header nil
+				      (rmail-mime-process-multipart
+				       content-type content-disposition
+				       content-transfer-encoding t)))))
+	      ((string-match "message/rfc822" (car content-type))
+	       (or show-headers
+		   (narrow-to-region end (point-max)))
+	       (rmail-mime-process t t))
+	      (t
+	       (rmail-mime-entity content-type
+				  content-disposition
+				  content-transfer-encoding
+				  nil
+				  (cons end (point-max))
+				  nil)))
+      ;; Hide headers and handle the part.
+      (save-restriction
+	(cond ((string= (car content-type) "message/rfc822")
+	       (narrow-to-region end (point-max)))
+	      ((not show-headers)
+	       (delete-region (point-min) end)))
+	(rmail-mime-handle content-type content-disposition
+			   content-transfer-encoding)))))
+
+(defun rmail-mime-insert-multipart (entity)
+  "Insert MIME-entity ENTITY of multipart type in the current buffer."
+  (let ((subtype (cadr (split-string (car (rmail-mime-entity-type entity))
+				     "/")))
+	(disposition (rmail-mime-entity-disposition entity))
+	(header (rmail-mime-entity-header entity))
+	(children (rmail-mime-entity-children entity)))
+    (if header
+	(let ((pos (point)))
+	  (or (bolp)
+	      (insert "\n"))
+	  (insert-buffer-substring rmail-buffer (car header) (cdr header))
+	  (rfc2047-decode-region pos (point))
+	  (insert "\n")))
+    (cond
+     ((string= subtype "mixed")
+      (dolist (child children)
+	(rmail-mime-insert child '("text/plain") disposition)))
+     ((string= subtype "digest")
+      (dolist (child children)
+	(rmail-mime-insert child '("message/rfc822") disposition)))
+     ((string= subtype "alternative")
+      (let (best-plain-text best-text)
+	(dolist (child children)
+	  (if (string= (or (car (rmail-mime-entity-disposition child))
+			   (car disposition))
+		       "inline")
+	      (if (string-match "text/plain"
+				(car (rmail-mime-entity-type child)))
+		  (setq best-plain-text child)
+		(if (string-match "text/.*"
+				  (car (rmail-mime-entity-type child)))
+		    (setq best-text child)))))
+	(if (or best-plain-text best-text)
+	    (rmail-mime-insert (or best-plain-text best-text))
+	  ;; No child could be handled.  Insert all.
+	  (dolist (child children)
+	    (rmail-mime-insert child nil disposition)))))
+     (t
+      ;; Unsupported subtype.  Insert all as attachment.
+      (dolist (child children)
+	(rmail-mime-insert-bulk child))))))
+
+(defun rmail-mime-parse ()
+  "Parse the current Rmail message as a MIME message.
+The value is a MIME-entiy object (see `rmail-mime-enty-new')."
+  (save-excursion
+    (goto-char (point-min))
+    (rmail-mime-process nil t)))
+
+(defun rmail-mime-insert (entity &optional content-type disposition)
+  "Insert a MIME-entity ENTITY in the current buffer.
+
+This function will be called recursively if multiple parts are
+available."
+  (if (rmail-mime-entity-children entity)
+      (rmail-mime-insert-multipart entity)
+    (setq content-type
+	  (or (rmail-mime-entity-type entity) content-type))
+    (setq disposition
+	  (or (rmail-mime-entity-disposition entity) disposition))
+    (if (and (string= (car disposition) "inline")
+	     (string-match "text/.*" (car content-type)))
+	(rmail-mime-insert-text entity)
+      (rmail-mime-insert-bulk entity))))
 
 (define-derived-mode rmail-mime-mode fundamental-mode "RMIME"
   "Major mode used in `rmail-mime' buffers."
@@ -479,6 +742,50 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'."
   (error "%s; type: %s; disposition: %s; encoding: %s"
 	 message type disposition encoding))
 
+(defun rmail-show-mime ()
+  (let ((mbox-buf rmail-buffer))
+    (condition-case nil
+	(let ((entity (rmail-mime-parse)))
+	  (with-current-buffer rmail-view-buffer
+	    (let ((inhibit-read-only t)
+		  (rmail-buffer mbox-buf))
+	      (erase-buffer)
+	      (rmail-mime-insert entity))))
+      (error
+       ;; Decoding failed.  Insert the original message body as is.
+       (let ((region (with-current-buffer mbox-buf
+		       (goto-char (point-min))
+		       (re-search-forward "^$" nil t)
+		       (forward-line 1)
+		       (cons (point) (point-max)))))
+	 (with-current-buffer rmail-view-buffer
+	   (let ((inhibit-read-only t))
+	     (erase-buffer)
+	     (insert-buffer-substring mbox-buf (car region) (cdr region))))
+	 (message "MIME decoding failed"))))))
+
+(setq rmail-show-mime-function 'rmail-show-mime)
+
+(defun rmail-insert-mime-forwarded-message (forward-buffer)
+  (let ((mbox-buf (with-current-buffer forward-buffer rmail-view-buffer)))
+    (save-restriction
+      (narrow-to-region (point) (point))
+      (message-forward-make-body-mime mbox-buf))))
+
+(setq rmail-insert-mime-forwarded-message-function
+      'rmail-insert-mime-forwarded-message)
+
+(defun rmail-insert-mime-resent-message (forward-buffer)
+  (insert-buffer-substring
+   (with-current-buffer forward-buffer rmail-view-buffer))
+  (goto-char (point-min))
+  (when (looking-at "From ")
+    (forward-line 1)
+    (delete-region (point-min) (point))))
+
+(setq rmail-insert-mime-resent-message-function
+      'rmail-insert-mime-resent-message)
+
 (provide 'rmailmm)
 
 ;; Local Variables: