emacs: Allow indentation of multipart children.

[notmuch] / emacs / notmuch-show.el

diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index 3a60d4308470c5643975741d21912c4ac49d89bc..b208003277f4181a7433e4cb10dcbc3d4e40ef15 100644 (file)
--- a/emacs/notmuch-show.el
+++ b/emacs/notmuch-show.el
@@ -82,6 +82,12 @@ any given message."
             notmuch-wash-elide-blank-lines
             notmuch-wash-excerpt-citations))
 
+(defcustom notmuch-show-indent-multipart nil
+  "Should the sub-parts of a multipart/* part be indented?"
+  ;; dme: Not sure which is a good default.
+  :group 'notmuch
+  :type 'boolean)
+
 (defmacro with-current-notmuch-show-message (&rest body)
   "Evaluate body with current buffer set to the text of current message"
   `(save-excursion
@@ -236,7 +242,7 @@ message at DEPTH in the current thread."
   'follow-link t
   'face 'message-mml)
 
-(defun notmuch-show-insert-part-header (nth content-type declared-type &optional name)
+(defun notmuch-show-insert-part-header (nth content-type declared-type &optional name comment)
   (insert-button
    (concat "[ "
           (if name (concat name ": ") "")
@@ -244,6 +250,7 @@ message at DEPTH in the current thread."
           (if (not (string-equal declared-type content-type))
               (concat " (as " content-type ")")
             "")
+          (or comment "")
           " ]\n")
    :type 'notmuch-show-part-button-type
    :notmuch-part nth
@@ -280,6 +287,77 @@ current buffer, if possible."
              t)
          nil)))))
 
+(defvar notmuch-show-multipart/alternative-discouraged
+  '(
+    ;; Avoid HTML parts.
+    "text/html"
+    ;; multipart/related usually contain a text/html part and some associated graphics.
+    "multipart/related"
+    ))
+
+(defun notmuch-show-multipart/*-to-list (part)
+  (mapcar '(lambda (inner-part) (plist-get inner-part :content-type))
+         (plist-get part :content)))
+
+(defun notmuch-show-multipart/alternative-choose (types)
+  ;; Based on `mm-preferred-alternative-precedence'.
+  (let ((seq types))
+    (dolist (pref (reverse notmuch-show-multipart/alternative-discouraged))
+      (dolist (elem (copy-sequence seq))
+       (when (string-match pref elem)
+         (setq seq (nconc (delete elem seq) (list elem))))))
+    seq))
+
+(defun notmuch-show-insert-part-multipart/alternative (msg part content-type nth depth declared-type)
+  (notmuch-show-insert-part-header nth declared-type content-type nil)
+  (let ((chosen-type (car (notmuch-show-multipart/alternative-choose (notmuch-show-multipart/*-to-list part))))
+       (inner-parts (plist-get part :content))
+       (start (point)))
+    ;; This inserts all parts of the chosen type rather than just one,
+    ;; but it's not clear that this is the wrong thing to do - which
+    ;; should be chosen if there are more than one that match?
+    (mapc (lambda (inner-part)
+           (let ((inner-type (plist-get inner-part :content-type)))
+             (if (string= chosen-type inner-type)
+                 (notmuch-show-insert-bodypart msg inner-part depth)
+               (notmuch-show-insert-part-header (plist-get inner-part :id) inner-type inner-type nil " (not shown)"))))
+         inner-parts)
+
+    (when notmuch-show-indent-multipart
+      (indent-rigidly start (point) 1)))
+  t)
+
+(defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth declared-type)
+  (notmuch-show-insert-part-header nth declared-type content-type nil)
+  (let ((inner-parts (plist-get part :content))
+       (start (point)))
+    ;; Show all of the parts.
+    (mapc (lambda (inner-part)
+           (notmuch-show-insert-bodypart msg inner-part depth))
+         inner-parts)
+
+    (when notmuch-show-indent-multipart
+      (indent-rigidly start (point) 1)))
+  t)
+
+(defun notmuch-show-insert-part-message/rfc822 (msg part content-type nth depth declared-type)
+  (let* ((message-part (plist-get part :content))
+        (inner-parts (plist-get message-part :content)))
+    (notmuch-show-insert-part-header nth declared-type content-type nil)
+    ;; Override `notmuch-message-headers' to force `From' to be
+    ;; displayed.
+    (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date")))
+      (notmuch-show-insert-headers (plist-get part :headers)))
+    ;; Blank line after headers to be compatible with the normal
+    ;; message display.
+    (insert "\n")
+
+    ;; Show all of the parts.
+    (mapc (lambda (inner-part)
+           (notmuch-show-insert-bodypart msg inner-part depth))
+         inner-parts))
+  t)
+
 (defun notmuch-show-insert-part-text/plain (msg part content-type nth depth declared-type)
   (let ((start (point)))
     ;; If this text/plain part is not the first part in the message,
@@ -948,7 +1026,7 @@ any effects from previous calls to
 
 The given command will be executed with the raw contents of the
 current email message as stdin. Anything printed by the command
-to stdout or stderr will appear in the *Messages* buffer.
+to stdout or stderr will appear in the *notmuch-pipe* buffer.
 
 When invoked with a prefix argument, the command will receive all
 open messages in the current thread (formatted as an mbox) rather
@@ -964,7 +1042,18 @@ than only the current message."
       (setq shell-command
            (concat notmuch-command " show --format=raw "
                    (shell-quote-argument (notmuch-show-get-message-id)) " | " command)))
-    (start-process-shell-command "notmuch-pipe-command" "*notmuch-pipe*" shell-command)))
+    (let ((buf (get-buffer-create (concat "*notmuch-pipe*"))))
+      (with-current-buffer buf
+       (setq buffer-read-only nil)
+       (erase-buffer)
+       (let ((exit-code (call-process-shell-command shell-command nil buf)))
+         (goto-char (point-max))
+         (set-buffer-modified-p nil)
+         (setq buffer-read-only t)
+         (unless (zerop exit-code)
+           (switch-to-buffer-other-window buf)
+           (message (format "Command '%s' exited abnormally with code %d"
+                            shell-command exit-code))))))))
 
 (defun notmuch-show-add-tags-worker (current-tags add-tags)
   "Add to `current-tags' with any tags from `add-tags' not