git.notmuchmail.org Git - notmuch/blob - emacs/notmuch-show.el

   1 ;; notmuch-show.el --- displaying notmuch forests.
   2 ;;
   3 ;; Copyright © Carl Worth
   4 ;; Copyright © David Edmondson
   5 ;;
   6 ;; This file is part of Notmuch.
   7 ;;
   8 ;; Notmuch is free software: you can redistribute it and/or modify it
   9 ;; under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12 ;;
  13 ;; Notmuch is distributed in the hope that it will be useful, but
  14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 ;; General Public License for more details.
  17 ;;
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.
  20 ;;
  21 ;; Authors: Carl Worth <cworth@cworth.org>
  22 ;;          David Edmondson <dme@dme.org>
  23
  24 (eval-when-compile (require 'cl))
  25 (require 'mm-view)
  26 (require 'message)
  27 (require 'mm-decode)
  28 (require 'mailcap)
  29 (require 'icalendar)
  30
  31 (require 'notmuch-lib)
  32 (require 'notmuch-query)
  33 (require 'notmuch-wash)
  34 (require 'notmuch-mua)
  35
  36 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
  37 (declare-function notmuch-fontify-headers "notmuch" nil)
  38 (declare-function notmuch-select-tag-with-completion "notmuch" (prompt &rest search-terms))
  39 (declare-function notmuch-search-show-thread "notmuch" nil)
  40
  41 (defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date")
  42   "Headers that should be shown in a message, in this order.
  43
  44 For an open message, all of these headers will be made visible
  45 according to `notmuch-message-headers-visible' or can be toggled
  46 with `notmuch-show-toggle-headers'. For a closed message, only
  47 the first header in the list will be visible."
  48   :group 'notmuch
  49   :type '(repeat string))
  50
  51 (defcustom notmuch-message-headers-visible t
  52   "Should the headers be visible by default?
  53
  54 If this value is non-nil, then all of the headers defined in
  55 `notmuch-message-headers' will be visible by default in the display
  56 of each message. Otherwise, these headers will be hidden and
  57 `notmuch-show-toggle-headers' can be used to make the visible for
  58 any given message."
  59   :group 'notmuch
  60   :type 'boolean)
  61
  62 (defcustom notmuch-show-relative-dates t
  63   "Display relative dates in the message summary line."
  64   :group 'notmuch
  65   :type 'boolean)
  66
  67 (defcustom notmuch-show-elide-same-subject nil
  68   "Do not show the subject of a collapsed message if it is the
  69 same as that of the previous message."
  70   :group 'notmuch
  71   :type 'boolean)
  72
  73 (defcustom notmuch-show-always-show-subject t
  74   "Should a collapsed message show the `Subject:' line?"
  75   :group 'notmuch
  76   :type 'boolean)
  77
  78 (defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers)
  79   "A list of functions called to decorate the headers listed in
  80 `notmuch-message-headers'.")
  81
  82 (defcustom notmuch-show-hook nil
  83   "Functions called after populating a `notmuch-show' buffer."
  84   :group 'notmuch
  85   :type 'hook)
  86
  87 (defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-excerpt-citations)
  88   "Functions used to improve the display of text/plain parts."
  89   :group 'notmuch
  90   :type 'hook
  91   :options '(notmuch-wash-convert-inline-patch-to-part
  92              notmuch-wash-wrap-long-lines
  93              notmuch-wash-tidy-citations
  94              notmuch-wash-elide-blank-lines
  95              notmuch-wash-excerpt-citations))
  96
  97 ;; Mostly useful for debugging.
  98 (defcustom notmuch-show-all-multipart/alternative-parts nil
  99   "Should all parts of multipart/alternative parts be shown?"
 100   :group 'notmuch
 101   :type 'boolean)
 102
 103 (defcustom notmuch-show-indent-multipart nil
 104   "Should the sub-parts of a multipart/* part be indented?"
 105   ;; dme: Not sure which is a good default.
 106   :group 'notmuch
 107   :type 'boolean)
 108
 109 (defmacro with-current-notmuch-show-message (&rest body)
 110   "Evaluate body with current buffer set to the text of current message"
 111   `(save-excursion
 112      (let ((id (notmuch-show-get-message-id)))
 113        (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*"))))
 114          (with-current-buffer buf
 115             (call-process notmuch-command nil t nil "show" "--format=raw" id)
 116            ,@body)
 117          (kill-buffer buf)))))
 118
 119 (defun notmuch-show-view-all-mime-parts ()
 120   "Use external viewers to view all attachments from the current message."
 121   (interactive)
 122   (with-current-notmuch-show-message
 123    ; We ovverride the mm-inline-media-tests to indicate which message
 124    ; parts are already sufficiently handled by the original
 125    ; presentation of the message in notmuch-show mode. These parts
 126    ; will be inserted directly into the temporary buffer of
 127    ; with-current-notmuch-show-message and silently discarded.
 128    ;
 129    ; Any MIME part not explicitly mentioned here will be handled by an
 130    ; external viewer as configured in the various mailcap files.
 131    (let ((mm-inline-media-tests '(
 132                                   ("text/.*" ignore identity)
 133                                   ("application/pgp-signature" ignore identity)
 134                                   ("multipart/alternative" ignore identity)
 135                                   ("multipart/mixed" ignore identity)
 136                                   ("multipart/related" ignore identity)
 137                                  )))
 138      (mm-display-parts (mm-dissect-buffer)))))
 139
 140 (defun notmuch-foreach-mime-part (function mm-handle)
 141   (cond ((stringp (car mm-handle))
 142          (dolist (part (cdr mm-handle))
 143            (notmuch-foreach-mime-part function part)))
 144         ((bufferp (car mm-handle))
 145          (funcall function mm-handle))
 146         (t (dolist (part mm-handle)
 147              (notmuch-foreach-mime-part function part)))))
 148
 149 (defun notmuch-count-attachments (mm-handle)
 150   (let ((count 0))
 151     (notmuch-foreach-mime-part
 152      (lambda (p)
 153        (let ((disposition (mm-handle-disposition p)))
 154          (and (listp disposition)
 155               (or (equal (car disposition) "attachment")
 156                   (and (equal (car disposition) "inline")
 157                        (assq 'filename disposition)))
 158               (incf count))))
 159      mm-handle)
 160     count))
 161
 162 (defun notmuch-save-attachments (mm-handle &optional queryp)
 163   (notmuch-foreach-mime-part
 164    (lambda (p)
 165      (let ((disposition (mm-handle-disposition p)))
 166        (and (listp disposition)
 167             (or (equal (car disposition) "attachment")
 168                 (and (equal (car disposition) "inline")
 169                      (assq 'filename disposition)))
 170             (or (not queryp)
 171                 (y-or-n-p
 172                  (concat "Save '" (cdr (assq 'filename disposition)) "' ")))
 173             (mm-save-part p))))
 174    mm-handle))
 175
 176 (defun notmuch-show-save-attachments ()
 177   "Save all attachments from the current message."
 178   (interactive)
 179   (with-current-notmuch-show-message
 180    (let ((mm-handle (mm-dissect-buffer)))
 181      (notmuch-save-attachments
 182       mm-handle (> (notmuch-count-attachments mm-handle) 1))))
 183   (message "Done"))
 184
 185 (defun notmuch-show-fontify-header ()
 186   (let ((face (cond
 187                ((looking-at "[Tt]o:")
 188                 'message-header-to)
 189                ((looking-at "[Bb]?[Cc][Cc]:")
 190                 'message-header-cc)
 191                ((looking-at "[Ss]ubject:")
 192                 'message-header-subject)
 193                ((looking-at "[Ff]rom:")
 194                 'message-header-from)
 195                (t
 196                 'message-header-other))))
 197
 198     (overlay-put (make-overlay (point) (re-search-forward ":"))
 199                  'face 'message-header-name)
 200     (overlay-put (make-overlay (point) (re-search-forward ".*$"))
 201                  'face face)))
 202
 203 (defun notmuch-show-colour-headers ()
 204   "Apply some colouring to the current headers."
 205   (goto-char (point-min))
 206   (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:")
 207     (notmuch-show-fontify-header)
 208     (forward-line)))
 209
 210 (defun notmuch-show-spaces-n (n)
 211   "Return a string comprised of `n' spaces."
 212   (make-string n ? ))
 213
 214 (defun notmuch-show-update-tags (tags)
 215   "Update the displayed tags of the current message."
 216   (save-excursion
 217     (goto-char (notmuch-show-message-top))
 218     (if (re-search-forward "(\\([^()]*\\))$" (line-end-position) t)
 219         (let ((inhibit-read-only t))
 220           (replace-match (concat "("
 221                                  (propertize (mapconcat 'identity tags " ")
 222                                              'face 'notmuch-tag-face)
 223                                  ")"))))))
 224
 225 (defun notmuch-show-clean-address (address)
 226   "Clean a single email address for display."
 227   (let* ((parsed (mail-header-parse-address address))
 228          (address (car parsed))
 229          (name (cdr parsed)))
 230     ;; Remove double quotes. They might be required during transport,
 231     ;; but we don't need to see them.
 232     (when name
 233       (setq name (replace-regexp-in-string "\"" "" name)))
 234     ;; If the address is 'foo@bar.com <foo@bar.com>' then show just
 235     ;; 'foo@bar.com'.
 236     (when (string= name address)
 237       (setq name nil))
 238
 239     (if (not name)
 240         address
 241       (concat name " <" address ">"))))
 242
 243 (defun notmuch-show-insert-headerline (headers date tags depth)
 244   "Insert a notmuch style headerline based on HEADERS for a
 245 message at DEPTH in the current thread."
 246   (let ((start (point)))
 247     (insert (notmuch-show-spaces-n depth)
 248             (notmuch-show-clean-address (plist-get headers :From))
 249             " ("
 250             date
 251             ") ("
 252             (propertize (mapconcat 'identity tags " ")
 253                         'face 'notmuch-tag-face)
 254             ")\n")
 255     (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face)))
 256
 257 (defun notmuch-show-insert-header (header header-value)
 258   "Insert a single header."
 259   (insert header ": " header-value "\n"))
 260
 261 (defun notmuch-show-insert-headers (headers)
 262   "Insert the headers of the current message."
 263   (let ((start (point)))
 264     (mapc '(lambda (header)
 265              (let* ((header-symbol (intern (concat ":" header)))
 266                     (header-value (plist-get headers header-symbol)))
 267                (if (and header-value
 268                         (not (string-equal "" header-value)))
 269                    (notmuch-show-insert-header header header-value))))
 270           notmuch-message-headers)
 271     (save-excursion
 272       (save-restriction
 273         (narrow-to-region start (point-max))
 274         (run-hooks 'notmuch-show-markup-headers-hook)))))
 275
 276 (define-button-type 'notmuch-show-part-button-type
 277   'action 'notmuch-show-part-button-action
 278   'follow-link t
 279   'face 'message-mml)
 280
 281 (defun notmuch-show-insert-part-header (nth content-type declared-type &optional name comment)
 282   (insert-button
 283    (concat "[ "
 284            (if name (concat name ": ") "")
 285            declared-type
 286            (if (not (string-equal declared-type content-type))
 287                (concat " (as " content-type ")")
 288              "")
 289            (or comment "")
 290            " ]\n")
 291    :type 'notmuch-show-part-button-type
 292    :notmuch-part nth
 293    :notmuch-filename name))
 294
 295 ;; Functions handling particular MIME parts.
 296
 297 (defun notmuch-show-save-part (message-id nth &optional filename)
 298   (with-temp-buffer
 299     ;; Always acquires the part via `notmuch part', even if it is
 300     ;; available in the JSON output.
 301     (insert (notmuch-show-get-bodypart-internal message-id nth))
 302     (let ((file (read-file-name
 303                  "Filename to save as: "
 304                  (or mailcap-download-directory "~/")
 305                  nil nil
 306                  filename))
 307           (require-final-newline nil)
 308           (coding-system-for-write 'no-conversion))
 309       (write-region (point-min) (point-max) file))))
 310
 311 (defun notmuch-show-mm-display-part-inline (msg part content-type content)
 312   "Use the mm-decode/mm-view functions to display a part in the
 313 current buffer, if possible."
 314   (let ((display-buffer (current-buffer)))
 315     (with-temp-buffer
 316       (insert content)
 317       (let ((handle (mm-make-handle (current-buffer) (list content-type))))
 318         (set-buffer display-buffer)
 319         (if (and (mm-inlinable-p handle)
 320                  (mm-inlined-p handle))
 321             (progn
 322               (mm-display-part handle)
 323               t)
 324           nil)))))
 325
 326 (defvar notmuch-show-multipart/alternative-discouraged
 327   '(
 328     ;; Avoid HTML parts.
 329     "text/html"
 330     ;; multipart/related usually contain a text/html part and some associated graphics.
 331     "multipart/related"
 332     ))
 333
 334 (defun notmuch-show-multipart/*-to-list (part)
 335   (mapcar '(lambda (inner-part) (plist-get inner-part :content-type))
 336           (plist-get part :content)))
 337
 338 (defun notmuch-show-multipart/alternative-choose (types)
 339   ;; Based on `mm-preferred-alternative-precedence'.
 340   (let ((seq types))
 341     (dolist (pref (reverse notmuch-show-multipart/alternative-discouraged))
 342       (dolist (elem (copy-sequence seq))
 343         (when (string-match pref elem)
 344           (setq seq (nconc (delete elem seq) (list elem))))))
 345     seq))
 346
 347 (defun notmuch-show-insert-part-multipart/alternative (msg part content-type nth depth declared-type)
 348   (notmuch-show-insert-part-header nth declared-type content-type nil)
 349   (let ((chosen-type (car (notmuch-show-multipart/alternative-choose (notmuch-show-multipart/*-to-list part))))
 350         (inner-parts (plist-get part :content))
 351         (start (point)))
 352     ;; This inserts all parts of the chosen type rather than just one,
 353     ;; but it's not clear that this is the wrong thing to do - which
 354     ;; should be chosen if there are more than one that match?
 355     (mapc (lambda (inner-part)
 356             (let ((inner-type (plist-get inner-part :content-type)))
 357               (if (or notmuch-show-all-multipart/alternative-parts
 358                       (string= chosen-type inner-type))
 359                   (notmuch-show-insert-bodypart msg inner-part depth)
 360                 (notmuch-show-insert-part-header (plist-get inner-part :id) inner-type inner-type nil " (not shown)"))))
 361           inner-parts)
 362
 363     (when notmuch-show-indent-multipart
 364       (indent-rigidly start (point) 1)))
 365   t)
 366
 367 (defun notmuch-show-setup-w3m ()
 368   "Instruct w3m how to retrieve content from a \"related\" part of a message."
 369   (interactive)
 370   (if (boundp 'w3m-cid-retrieve-function-alist)
 371     (unless (assq 'notmuch-show-mode w3m-cid-retrieve-function-alist)
 372       (push (cons 'notmuch-show-mode 'notmuch-show-w3m-cid-retrieve)
 373             w3m-cid-retrieve-function-alist)))
 374   (setq mm-inline-text-html-with-images t))
 375
 376 (defvar w3m-current-buffer) ;; From `w3m.el'.
 377 (defvar notmuch-show-w3m-cid-store nil)
 378 (make-variable-buffer-local 'notmuch-show-w3m-cid-store)
 379
 380 (defun notmuch-show-w3m-cid-store-internal (content-id
 381                                             message-id
 382                                             part-number
 383                                             content-type
 384                                             content)
 385   (push (list content-id
 386               message-id
 387               part-number
 388               content-type
 389               content)
 390         notmuch-show-w3m-cid-store))
 391
 392 (defun notmuch-show-w3m-cid-store (msg part)
 393   (let ((content-id (plist-get part :content-id)))
 394     (when content-id
 395       (notmuch-show-w3m-cid-store-internal (concat "cid:" content-id)
 396                                            (plist-get msg :id)
 397                                            (plist-get part :id)
 398                                            (plist-get part :content-type)
 399                                            nil))))
 400
 401 (defun notmuch-show-w3m-cid-retrieve (url &rest args)
 402   (let ((matching-part (with-current-buffer w3m-current-buffer
 403                          (assoc url notmuch-show-w3m-cid-store))))
 404     (if matching-part
 405         (let ((message-id (nth 1 matching-part))
 406               (part-number (nth 2 matching-part))
 407               (content-type (nth 3 matching-part))
 408               (content (nth 4 matching-part)))
 409           ;; If we don't already have the content, get it and cache
 410           ;; it, as some messages reference the same cid: part many
 411           ;; times (hundreds!), which results in many calls to
 412           ;; `notmuch part'.
 413           (unless content
 414             (setq content (notmuch-show-get-bodypart-internal (concat "id:" message-id)
 415                                                               part-number))
 416             (with-current-buffer w3m-current-buffer
 417               (notmuch-show-w3m-cid-store-internal url
 418                                                    message-id
 419                                                    part-number
 420                                                    content-type
 421                                                    content)))
 422           (insert content)
 423           content-type)
 424       nil)))
 425
 426 (defun notmuch-show-insert-part-multipart/related (msg part content-type nth depth declared-type)
 427   (notmuch-show-insert-part-header nth declared-type content-type nil)
 428   (let ((inner-parts (plist-get part :content))
 429         (start (point)))
 430
 431     ;; We assume that the first part is text/html and the remainder
 432     ;; things that it references.
 433
 434     ;; Stash the non-primary parts.
 435     (mapc (lambda (part)
 436             (notmuch-show-w3m-cid-store msg part))
 437           (cdr inner-parts))
 438
 439     ;; Render the primary part.
 440     (notmuch-show-insert-bodypart msg (car inner-parts) depth)
 441
 442     (when notmuch-show-indent-multipart
 443       (indent-rigidly start (point) 1)))
 444   t)
 445
 446 (defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth declared-type)
 447   (notmuch-show-insert-part-header nth declared-type content-type nil)
 448   (let ((inner-parts (plist-get part :content))
 449         (start (point)))
 450     ;; Show all of the parts.
 451     (mapc (lambda (inner-part)
 452             (notmuch-show-insert-bodypart msg inner-part depth))
 453           inner-parts)
 454
 455     (when notmuch-show-indent-multipart
 456       (indent-rigidly start (point) 1)))
 457   t)
 458
 459 (defun notmuch-show-insert-part-message/rfc822 (msg part content-type nth depth declared-type)
 460   (let* ((message-part (plist-get part :content))
 461          (inner-parts (plist-get message-part :content)))
 462     (notmuch-show-insert-part-header nth declared-type content-type nil)
 463     ;; Override `notmuch-message-headers' to force `From' to be
 464     ;; displayed.
 465     (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date")))
 466       (notmuch-show-insert-headers (plist-get part :headers)))
 467     ;; Blank line after headers to be compatible with the normal
 468     ;; message display.
 469     (insert "\n")
 470
 471     ;; Show all of the parts.
 472     (mapc (lambda (inner-part)
 473             (notmuch-show-insert-bodypart msg inner-part depth))
 474           inner-parts))
 475   t)
 476
 477 (defun notmuch-show-insert-part-text/plain (msg part content-type nth depth declared-type)
 478   (let ((start (point)))
 479     ;; If this text/plain part is not the first part in the message,
 480     ;; insert a header to make this clear.
 481     (if (> nth 1)
 482         (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)))
 483     (insert (notmuch-show-get-bodypart-content msg part nth))
 484     (save-excursion
 485       (save-restriction
 486         (narrow-to-region start (point-max))
 487         (run-hook-with-args 'notmuch-show-insert-text/plain-hook depth))))
 488   t)
 489
 490 (defun notmuch-show-insert-part-text/x-vcalendar (msg part content-type nth depth declared-type)
 491   (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename))
 492   (insert (with-temp-buffer
 493             (insert (notmuch-show-get-bodypart-content msg part nth))
 494             (goto-char (point-min))
 495             (let ((file (make-temp-file "notmuch-ical"))
 496                   result)
 497               (icalendar--convert-ical-to-diary
 498                (icalendar--read-element nil nil)
 499                file t)
 500               (set-buffer (get-file-buffer file))
 501               (setq result (buffer-substring (point-min) (point-max)))
 502               (set-buffer-modified-p nil)
 503               (kill-buffer (current-buffer))
 504               (delete-file file)
 505               result)))
 506   t)
 507
 508 (defun notmuch-show-insert-part-application/octet-stream (msg part content-type nth depth declared-type)
 509   ;; If we can deduce a MIME type from the filename of the attachment,
 510   ;; do so and pass it on to the handler for that type.
 511   (if (plist-get part :filename)
 512       (let ((extension (file-name-extension (plist-get part :filename)))
 513             mime-type)
 514         (if extension
 515             (progn
 516               (mailcap-parse-mimetypes)
 517               (setq mime-type (mailcap-extension-to-mime extension))
 518               (if (and mime-type
 519                        (not (string-equal mime-type "application/octet-stream")))
 520                   (notmuch-show-insert-bodypart-internal msg part mime-type nth depth content-type)
 521                 nil))
 522           nil))))
 523
 524 (defun notmuch-show-insert-part-*/* (msg part content-type nth depth declared-type)
 525   ;; This handler _must_ succeed - it is the handler of last resort.
 526   (notmuch-show-insert-part-header nth content-type declared-type (plist-get part :filename))
 527   (let ((content (notmuch-show-get-bodypart-content msg part nth)))
 528     (if content
 529         (notmuch-show-mm-display-part-inline msg part content-type content)))
 530   t)
 531
 532 ;; Functions for determining how to handle MIME parts.
 533
 534 (defun notmuch-show-split-content-type (content-type)
 535   (split-string content-type "/"))
 536
 537 (defun notmuch-show-handlers-for (content-type)
 538   "Return a list of content handlers for a part of type CONTENT-TYPE."
 539   (let (result)
 540     (mapc (lambda (func)
 541             (if (functionp func)
 542                 (push func result)))
 543           ;; Reverse order of prefrence.
 544           (list (intern (concat "notmuch-show-insert-part-*/*"))
 545                 (intern (concat
 546                          "notmuch-show-insert-part-"
 547                          (car (notmuch-show-split-content-type content-type))
 548                          "/*"))
 549                 (intern (concat "notmuch-show-insert-part-" content-type))))
 550     result))
 551
 552 ;; Helper for parts which are generally not included in the default
 553 ;; JSON output.
 554
 555 (defun notmuch-show-get-bodypart-internal (message-id part-number)
 556   (with-temp-buffer
 557     (let ((coding-system-for-read 'no-conversion))
 558       (call-process notmuch-command nil t nil
 559                     "part" (format "--part=%s" part-number) message-id)
 560       (buffer-string))))
 561
 562 (defun notmuch-show-get-bodypart-content (msg part nth)
 563   (or (plist-get part :content)
 564       (notmuch-show-get-bodypart-internal (concat "id:" (plist-get msg :id)) nth)))
 565
 566 ;; \f
 567
 568 (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type)
 569   (let ((handlers (notmuch-show-handlers-for content-type)))
 570     ;; Run the content handlers until one of them returns a non-nil
 571     ;; value.
 572     (while (and handlers
 573                 (not (funcall (car handlers) msg part content-type nth depth declared-type)))
 574       (setq handlers (cdr handlers))))
 575   t)
 576
 577 (defun notmuch-show-insert-bodypart (msg part depth)
 578   "Insert the body part PART at depth DEPTH in the current thread."
 579   (let ((content-type (downcase (plist-get part :content-type)))
 580         (nth (plist-get part :id)))
 581     (notmuch-show-insert-bodypart-internal msg part content-type nth depth content-type))
 582   ;; Some of the body part handlers leave point somewhere up in the
 583   ;; part, so we make sure that we're down at the end.
 584   (goto-char (point-max))
 585   ;; Ensure that the part ends with a carriage return.
 586   (if (not (bolp))
 587       (insert "\n")))
 588
 589 (defun notmuch-show-insert-body (msg body depth)
 590   "Insert the body BODY at depth DEPTH in the current thread."
 591   (mapc '(lambda (part) (notmuch-show-insert-bodypart msg part depth)) body))
 592
 593 (defun notmuch-show-make-symbol (type)
 594   (make-symbol (concat "notmuch-show-" type)))
 595
 596 (defun notmuch-show-strip-re (string)
 597   (replace-regexp-in-string "\\([Rr]e: *\\)+" "" string))
 598
 599 (defvar notmuch-show-previous-subject "")
 600 (make-variable-buffer-local 'notmuch-show-previous-subject)
 601
 602 (defun notmuch-show-insert-msg (msg depth)
 603   "Insert the message MSG at depth DEPTH in the current thread."
 604   (let* ((headers (plist-get msg :headers))
 605          ;; Indentation causes the buffer offset of the start/end
 606          ;; points to move, so we must use markers.
 607          message-start message-end
 608          content-start content-end
 609          headers-start headers-end
 610          body-start body-end
 611          (headers-invis-spec (notmuch-show-make-symbol "header"))
 612          (message-invis-spec (notmuch-show-make-symbol "message"))
 613          (bare-subject (notmuch-show-strip-re (plist-get headers :Subject))))
 614
 615     ;; Set `buffer-invisibility-spec' to `nil' (a list), otherwise
 616     ;; removing items from `buffer-invisibility-spec' (which is what
 617     ;; `notmuch-show-headers-visible' and
 618     ;; `notmuch-show-message-visible' do) is a no-op and has no
 619     ;; effect. This caused threads with only matching messages to have
 620     ;; those messages hidden initially because
 621     ;; `buffer-invisibility-spec' stayed `t'.
 622     ;;
 623     ;; This needs to be set here (rather than just above the call to
 624     ;; `notmuch-show-headers-visible') because some of the part
 625     ;; rendering or body washing functions
 626     ;; (e.g. `notmuch-wash-text/plain-citations') manipulate
 627     ;; `buffer-invisibility-spec').
 628     (when (eq buffer-invisibility-spec t)
 629       (setq buffer-invisibility-spec nil))
 630
 631     (setq message-start (point-marker))
 632
 633     (notmuch-show-insert-headerline headers
 634                                     (or (if notmuch-show-relative-dates
 635                                             (plist-get msg :date_relative)
 636                                           nil)
 637                                         (plist-get headers :Date))
 638                                     (plist-get msg :tags) depth)
 639
 640     (setq content-start (point-marker))
 641
 642     ;; Set `headers-start' to point after the 'Subject:' header to be
 643     ;; compatible with the existing implementation. This just sets it
 644     ;; to after the first header.
 645     (notmuch-show-insert-headers headers)
 646     ;; Headers should include a blank line (backwards compatibility).
 647     (insert "\n")
 648     (save-excursion
 649       (goto-char content-start)
 650       ;; If the subject of this message is the same as that of the
 651       ;; previous message, don't display it when this message is
 652       ;; collapsed.
 653       (when (and notmuch-show-elide-same-subject
 654                  (not (string= notmuch-show-previous-subject
 655                                bare-subject)))
 656         (forward-line 1))
 657       (setq headers-start (point-marker)))
 658     (setq headers-end (point-marker))
 659
 660     (setq notmuch-show-previous-subject bare-subject)
 661
 662     (setq body-start (point-marker))
 663     (notmuch-show-insert-body msg (plist-get msg :body) depth)
 664     ;; Ensure that the body ends with a newline.
 665     (if (not (bolp))
 666         (insert "\n"))
 667     (setq body-end (point-marker))
 668     (setq content-end (point-marker))
 669
 670     ;; Indent according to the depth in the thread.
 671     (indent-rigidly content-start content-end depth)
 672
 673     (setq message-end (point-max-marker))
 674
 675     ;; Save the extents of this message over the whole text of the
 676     ;; message.
 677     (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end))
 678
 679     (plist-put msg :headers-invis-spec headers-invis-spec)
 680     (overlay-put (make-overlay headers-start headers-end) 'invisible headers-invis-spec)
 681
 682     (plist-put msg :message-invis-spec message-invis-spec)
 683     (overlay-put (make-overlay body-start body-end) 'invisible message-invis-spec)
 684
 685     ;; Save the properties for this message. Currently this saves the
 686     ;; entire message (augmented it with other stuff), which seems
 687     ;; like overkill. We might save a reduced subset (for example, not
 688     ;; the content).
 689     (notmuch-show-set-message-properties msg)
 690
 691     ;; Set header visibility.
 692     (notmuch-show-headers-visible msg notmuch-message-headers-visible)
 693
 694     ;; Message visibility depends on whether it matched the search
 695     ;; criteria.
 696     (notmuch-show-message-visible msg (plist-get msg :match))))
 697
 698 (defun notmuch-show-insert-tree (tree depth)
 699   "Insert the message tree TREE at depth DEPTH in the current thread."
 700   (let ((msg (car tree))
 701         (replies (cadr tree)))
 702     (notmuch-show-insert-msg msg depth)
 703     (notmuch-show-insert-thread replies (1+ depth))))
 704
 705 (defun notmuch-show-insert-thread (thread depth)
 706   "Insert the thread THREAD at depth DEPTH in the current forest."
 707   (mapc '(lambda (tree) (notmuch-show-insert-tree tree depth)) thread))
 708
 709 (defun notmuch-show-insert-forest (forest)
 710   "Insert the forest of threads FOREST."
 711   (mapc '(lambda (thread) (notmuch-show-insert-thread thread 0)) forest))
 712
 713 (defvar notmuch-show-parent-buffer nil)
 714
 715 ;;;###autoload
 716 (defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name)
 717   "Run \"notmuch show\" with the given thread ID and display results.
 718
 719 The optional PARENT-BUFFER is the notmuch-search buffer from
 720 which this notmuch-show command was executed, (so that the
 721 next thread from that buffer can be show when done with this
 722 one).
 723
 724 The optional QUERY-CONTEXT is a notmuch search term. Only
 725 messages from the thread matching this search term are shown if
 726 non-nil.
 727
 728 The optional BUFFER-NAME provides the neame of the buffer in
 729 which the message thread is shown. If it is nil (which occurs
 730 when the command is called interactively) the argument to the
 731 function is used. "
 732   (interactive "sNotmuch show: ")
 733   (let ((buffer (get-buffer-create (generate-new-buffer-name
 734                                     (or buffer-name
 735                                         (concat "*notmuch-" thread-id "*")))))
 736         (inhibit-read-only t))
 737     (switch-to-buffer buffer)
 738     (notmuch-show-mode)
 739     (set (make-local-variable 'notmuch-show-parent-buffer) parent-buffer)
 740     (erase-buffer)
 741     (goto-char (point-min))
 742     (save-excursion
 743       (let* ((basic-args (list thread-id))
 744              (args (if query-context
 745                        (append (list "\'") basic-args (list "and (" query-context ")\'"))
 746                      (append (list "\'") basic-args (list "\'")))))
 747         (notmuch-show-insert-forest (notmuch-query-get-threads args))
 748         ;; If the query context reduced the results to nothing, run
 749         ;; the basic query.
 750         (when (and (eq (buffer-size) 0)
 751                    query-context)
 752           (notmuch-show-insert-forest
 753            (notmuch-query-get-threads basic-args))))
 754
 755       ;; Enable buttonisation of URLs and email addresses in the
 756       ;; buffer.
 757       (goto-address-mode t)
 758       ;; Act on visual lines rather than logical lines.
 759       (visual-line-mode t)
 760
 761       (run-hooks 'notmuch-show-hook))
 762
 763     ;; Move straight to the first open message
 764     (if (not (notmuch-show-message-visible-p))
 765         (notmuch-show-next-open-message))
 766
 767     ;; Set the header line to the subject of the first open message.
 768     (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject)))
 769
 770     (notmuch-show-mark-read)))
 771
 772 (defvar notmuch-show-stash-map
 773   (let ((map (make-sparse-keymap)))
 774     (define-key map "c" 'notmuch-show-stash-cc)
 775     (define-key map "d" 'notmuch-show-stash-date)
 776     (define-key map "F" 'notmuch-show-stash-filename)
 777     (define-key map "f" 'notmuch-show-stash-from)
 778     (define-key map "i" 'notmuch-show-stash-message-id)
 779     (define-key map "s" 'notmuch-show-stash-subject)
 780     (define-key map "T" 'notmuch-show-stash-tags)
 781     (define-key map "t" 'notmuch-show-stash-to)
 782     map)
 783   "Submap for stash commands")
 784 (fset 'notmuch-show-stash-map notmuch-show-stash-map)
 785
 786 (defvar notmuch-show-mode-map
 787       (let ((map (make-sparse-keymap)))
 788         (define-key map "?" 'notmuch-help)
 789         (define-key map "q" 'notmuch-kill-this-buffer)
 790         (define-key map (kbd "<C-tab>") 'widget-backward)
 791         (define-key map (kbd "M-TAB") 'notmuch-show-previous-button)
 792         (define-key map (kbd "<backtab>") 'notmuch-show-previous-button)
 793         (define-key map (kbd "TAB") 'notmuch-show-next-button)
 794         (define-key map "s" 'notmuch-search)
 795         (define-key map "m" 'notmuch-mua-mail)
 796         (define-key map "f" 'notmuch-show-forward-message)
 797         (define-key map "r" 'notmuch-show-reply)
 798         (define-key map "|" 'notmuch-show-pipe-message)
 799         (define-key map "w" 'notmuch-show-save-attachments)
 800         (define-key map "V" 'notmuch-show-view-raw-message)
 801         (define-key map "v" 'notmuch-show-view-all-mime-parts)
 802         (define-key map "c" 'notmuch-show-stash-map)
 803         (define-key map "h" 'notmuch-show-toggle-headers)
 804         (define-key map "-" 'notmuch-show-remove-tag)
 805         (define-key map "+" 'notmuch-show-add-tag)
 806         (define-key map "x" 'notmuch-show-archive-thread-then-exit)
 807         (define-key map "a" 'notmuch-show-archive-thread)
 808         (define-key map "N" 'notmuch-show-next-message)
 809         (define-key map "P" 'notmuch-show-previous-message)
 810         (define-key map "n" 'notmuch-show-next-open-message)
 811         (define-key map "p" 'notmuch-show-previous-open-message)
 812         (define-key map (kbd "DEL") 'notmuch-show-rewind)
 813         (define-key map " " 'notmuch-show-advance-and-archive)
 814         (define-key map (kbd "M-RET") 'notmuch-show-open-or-close-all)
 815         (define-key map (kbd "RET") 'notmuch-show-toggle-message)
 816         map)
 817       "Keymap for \"notmuch show\" buffers.")
 818 (fset 'notmuch-show-mode-map notmuch-show-mode-map)
 819
 820 (defun notmuch-show-mode ()
 821   "Major mode for viewing a thread with notmuch.
 822
 823 This buffer contains the results of the \"notmuch show\" command
 824 for displaying a single thread of email from your email archives.
 825
 826 By default, various components of email messages, (citations,
 827 signatures, already-read messages), are hidden. You can make
 828 these parts visible by clicking with the mouse button or by
 829 pressing RET after positioning the cursor on a hidden part, (for
 830 which \\[notmuch-show-next-button] and \\[notmuch-show-previous-button] are helpful).
 831
 832 Reading the thread sequentially is well-supported by pressing
 833 \\[notmuch-show-advance-and-archive]. This will scroll the current message (if necessary), advance
 834 to the next message, or advance to the next thread (if already on
 835 the last message of a thread).
 836
 837 Other commands are available to read or manipulate the thread
 838 more selectively, (such as '\\[notmuch-show-next-message]' and '\\[notmuch-show-previous-message]' to advance to messages
 839 without removing any tags, and '\\[notmuch-show-archive-thread]' to archive an entire thread
 840 without scrolling through with \\[notmuch-show-advance-and-archive]).
 841
 842 You can add or remove arbitary tags from the current message with
 843 '\\[notmuch-show-add-tag]' or '\\[notmuch-show-remove-tag]'.
 844
 845 All currently available key bindings:
 846
 847 \\{notmuch-show-mode-map}"
 848   (interactive)
 849   (kill-all-local-variables)
 850   (use-local-map notmuch-show-mode-map)
 851   (setq major-mode 'notmuch-show-mode
 852         mode-name "notmuch-show")
 853   (setq buffer-read-only t))
 854
 855 (defun notmuch-show-move-to-message-top ()
 856   (goto-char (notmuch-show-message-top)))
 857
 858 (defun notmuch-show-move-to-message-bottom ()
 859   (goto-char (notmuch-show-message-bottom)))
 860
 861 (defun notmuch-show-message-adjust ()
 862   (recenter 0))
 863
 864 ;; Movement related functions.
 865
 866 ;; There's some strangeness here where a text property applied to a
 867 ;; region a->b is not found when point is at b. We walk backwards
 868 ;; until finding the property.
 869 (defun notmuch-show-message-extent ()
 870   (let (r)
 871     (save-excursion
 872       (while (not (setq r (get-text-property (point) :notmuch-message-extent)))
 873         (backward-char)))
 874     r))
 875
 876 (defun notmuch-show-message-top ()
 877   (car (notmuch-show-message-extent)))
 878
 879 (defun notmuch-show-message-bottom ()
 880   (cdr (notmuch-show-message-extent)))
 881
 882 (defun notmuch-show-goto-message-next ()
 883   (let ((start (point)))
 884     (notmuch-show-move-to-message-bottom)
 885     (if (not (eobp))
 886         t
 887       (goto-char start)
 888       nil)))
 889
 890 (defun notmuch-show-goto-message-previous ()
 891   (notmuch-show-move-to-message-top)
 892   (if (bobp)
 893       nil
 894     (backward-char)
 895     (notmuch-show-move-to-message-top)
 896     t))
 897
 898 (defun notmuch-show-move-past-invisible-forward ()
 899   (while (point-invisible-p)
 900     (forward-char)))
 901
 902 (defun notmuch-show-move-past-invisible-backward ()
 903   (while (point-invisible-p)
 904     (backward-char)))
 905
 906 ;; Functions relating to the visibility of messages and their
 907 ;; components.
 908
 909 (defun notmuch-show-element-visible (props visible-p spec-property)
 910   (let ((spec (plist-get props spec-property)))
 911     (if visible-p
 912         (remove-from-invisibility-spec spec)
 913       (add-to-invisibility-spec spec))))
 914
 915 (defun notmuch-show-message-visible (props visible-p)
 916   (if visible-p
 917       ;; When making the message visible, the headers may or not be
 918       ;; visible. So we check that property separately.
 919       (let ((headers-visible (plist-get props :headers-visible)))
 920         (notmuch-show-element-visible props headers-visible :headers-invis-spec)
 921         (notmuch-show-element-visible props t :message-invis-spec))
 922     (notmuch-show-element-visible props nil :headers-invis-spec)
 923     (notmuch-show-element-visible props nil :message-invis-spec))
 924
 925   (notmuch-show-set-prop :message-visible visible-p props))
 926
 927 (defun notmuch-show-headers-visible (props visible-p)
 928   (if (plist-get props :message-visible)
 929       (notmuch-show-element-visible props visible-p :headers-invis-spec))
 930   (notmuch-show-set-prop :headers-visible visible-p props))
 931
 932 ;; Functions for setting and getting attributes of the current
 933 ;; message.
 934
 935 (defun notmuch-show-set-message-properties (props)
 936   (save-excursion
 937     (notmuch-show-move-to-message-top)
 938     (put-text-property (point) (+ (point) 1) :notmuch-message-properties props)))
 939
 940 (defun notmuch-show-get-message-properties ()
 941   (save-excursion
 942     (notmuch-show-move-to-message-top)
 943     (get-text-property (point) :notmuch-message-properties)))
 944
 945 (defun notmuch-show-set-prop (prop val &optional props)
 946   (let ((inhibit-read-only t)
 947         (props (or props
 948                    (notmuch-show-get-message-properties))))
 949     (plist-put props prop val)
 950     (notmuch-show-set-message-properties props)))
 951
 952 (defun notmuch-show-get-prop (prop &optional props)
 953   (let ((props (or props
 954                    (notmuch-show-get-message-properties))))
 955     (plist-get props prop)))
 956
 957 (defun notmuch-show-get-message-id ()
 958   "Return the message id of the current message."
 959   (concat "id:\"" (notmuch-show-get-prop :id) "\""))
 960
 961 ;; dme: Would it make sense to use a macro for many of these?
 962
 963 (defun notmuch-show-get-filename ()
 964   "Return the filename of the current message."
 965   (notmuch-show-get-prop :filename))
 966
 967 (defun notmuch-show-get-header (header)
 968   "Return the named header of the current message, if any."
 969   (plist-get (notmuch-show-get-prop :headers) header))
 970
 971 (defun notmuch-show-get-cc ()
 972   (notmuch-show-get-header :Cc))
 973
 974 (defun notmuch-show-get-date ()
 975   (notmuch-show-get-header :Date))
 976
 977 (defun notmuch-show-get-from ()
 978   (notmuch-show-get-header :From))
 979
 980 (defun notmuch-show-get-subject ()
 981   (notmuch-show-get-header :Subject))
 982
 983 (defun notmuch-show-get-to ()
 984   (notmuch-show-get-header :To))
 985
 986 (defun notmuch-show-set-tags (tags)
 987   "Set the tags of the current message."
 988   (notmuch-show-set-prop :tags tags)
 989   (notmuch-show-update-tags tags))
 990
 991 (defun notmuch-show-get-tags ()
 992   "Return the tags of the current message."
 993   (notmuch-show-get-prop :tags))
 994
 995 (defun notmuch-show-message-visible-p ()
 996   "Is the current message visible?"
 997   (notmuch-show-get-prop :message-visible))
 998
 999 (defun notmuch-show-headers-visible-p ()
1000   "Are the headers of the current message visible?"
1001   (notmuch-show-get-prop :headers-visible))
1002
1003 (defun notmuch-show-mark-read ()
1004   "Mark the current message as read."
1005   (notmuch-show-remove-tag "unread"))
1006
1007 ;; Functions for getting attributes of several messages in the current
1008 ;; thread.
1009
1010 (defun notmuch-show-get-message-ids-for-open-messages ()
1011   "Return a list of all message IDs for open messages in the current thread."
1012   (save-excursion
1013     (let (message-ids done)
1014       (goto-char (point-min))
1015       (while (not done)
1016         (if (notmuch-show-message-visible-p)
1017             (setq message-ids (append message-ids (list (notmuch-show-get-message-id)))))
1018         (setq done (not (notmuch-show-goto-message-next)))
1019         )
1020       message-ids
1021       )))
1022
1023 ;; Commands typically bound to keys.
1024
1025 (defun notmuch-show-advance-and-archive ()
1026   "Advance through thread and archive.
1027
1028 This command is intended to be one of the simplest ways to
1029 process a thread of email. It does the following:
1030
1031 If the current message in the thread is not yet fully visible,
1032 scroll by a near screenful to read more of the message.
1033
1034 Otherwise, (the end of the current message is already within the
1035 current window), advance to the next open message.
1036
1037 Finally, if there is no further message to advance to, and this
1038 last message is already read, then archive the entire current
1039 thread, (remove the \"inbox\" tag from each message). Also kill
1040 this buffer, and display the next thread from the search from
1041 which this thread was originally shown."
1042   (interactive)
1043   (let ((end-of-this-message (notmuch-show-message-bottom)))
1044     (cond
1045      ;; Ideally we would test `end-of-this-message' against the result
1046      ;; of `window-end', but that doesn't account for the fact that
1047      ;; the end of the message might be hidden, so we have to actually
1048      ;; go to the end, walk back over invisible text and then see if
1049      ;; point is visible.
1050      ((save-excursion
1051         (goto-char (- end-of-this-message 1))
1052         (notmuch-show-move-past-invisible-backward)
1053         (> (point) (window-end)))
1054       ;; The bottom of this message is not visible - scroll.
1055       (scroll-up nil))
1056
1057      ((not (= end-of-this-message (point-max)))
1058       ;; This is not the last message - move to the next visible one.
1059       (notmuch-show-next-open-message))
1060
1061      (t
1062       ;; This is the last message - archive the thread.
1063       (notmuch-show-archive-thread)))))
1064
1065 (defun notmuch-show-rewind ()
1066   "Backup through the thread, (reverse scrolling compared to \\[notmuch-show-advance-and-archive]).
1067
1068 Specifically, if the beginning of the previous email is fewer
1069 than `window-height' lines from the current point, move to it
1070 just like `notmuch-show-previous-message'.
1071
1072 Otherwise, just scroll down a screenful of the current message.
1073
1074 This command does not modify any message tags, (it does not undo
1075 any effects from previous calls to
1076 `notmuch-show-advance-and-archive'."
1077   (interactive)
1078   (let ((start-of-message (notmuch-show-message-top))
1079         (start-of-window (window-start)))
1080     (cond
1081       ;; Either this message is properly aligned with the start of the
1082       ;; window or the start of this message is not visible on the
1083       ;; screen - scroll.
1084      ((or (= start-of-message start-of-window)
1085           (< start-of-message start-of-window))
1086       (scroll-down)
1087       ;; If a small number of lines from the previous message are
1088       ;; visible, realign so that the top of the current message is at
1089       ;; the top of the screen.
1090       (if (<= (count-screen-lines (window-start) start-of-message)
1091               next-screen-context-lines)
1092           (progn
1093             (goto-char (notmuch-show-message-top))
1094             (notmuch-show-message-adjust)))
1095       ;; Move to the top left of the window.
1096       (goto-char (window-start)))
1097      (t
1098       ;; Move to the previous message.
1099       (notmuch-show-previous-message)))))
1100
1101 (defun notmuch-show-reply ()
1102   "Reply to the current message."
1103   (interactive)
1104   (notmuch-mua-reply (notmuch-show-get-message-id)))
1105
1106 (defun notmuch-show-forward-message ()
1107   "Forward the current message."
1108   (interactive)
1109   (with-current-notmuch-show-message
1110    (notmuch-mua-forward-message)))
1111
1112 (defun notmuch-show-next-message ()
1113   "Show the next message."
1114   (interactive)
1115   (if (notmuch-show-goto-message-next)
1116       (progn
1117         (notmuch-show-mark-read)
1118         (notmuch-show-message-adjust))
1119     (goto-char (point-max))))
1120
1121 (defun notmuch-show-previous-message ()
1122   "Show the previous message."
1123   (interactive)
1124   (notmuch-show-goto-message-previous)
1125   (notmuch-show-mark-read)
1126   (notmuch-show-message-adjust))
1127
1128 (defun notmuch-show-next-open-message ()
1129   "Show the next message."
1130   (interactive)
1131   (let (r)
1132     (while (and (setq r (notmuch-show-goto-message-next))
1133                 (not (notmuch-show-message-visible-p))))
1134     (if r
1135         (progn
1136           (notmuch-show-mark-read)
1137           (notmuch-show-message-adjust))
1138       (goto-char (point-max)))))
1139
1140 (defun notmuch-show-previous-open-message ()
1141   "Show the previous message."
1142   (interactive)
1143   (while (and (notmuch-show-goto-message-previous)
1144               (not (notmuch-show-message-visible-p))))
1145   (notmuch-show-mark-read)
1146   (notmuch-show-message-adjust))
1147
1148 (defun notmuch-show-view-raw-message ()
1149   "View the file holding the current message."
1150   (interactive)
1151   (let* ((id (notmuch-show-get-message-id))
1152          (buf (get-buffer-create (concat "*notmuch-raw-" id "*"))))
1153     (call-process notmuch-command nil buf nil "show" "--format=raw" id)
1154     (switch-to-buffer buf)
1155     (goto-char (point-min))
1156     (set-buffer-modified-p nil)
1157     (view-buffer buf 'kill-buffer-if-not-modified)))
1158
1159 (defun notmuch-show-pipe-message (entire-thread command)
1160   "Pipe the contents of the current message (or thread) to the given command.
1161
1162 The given command will be executed with the raw contents of the
1163 current email message as stdin. Anything printed by the command
1164 to stdout or stderr will appear in the *notmuch-pipe* buffer.
1165
1166 When invoked with a prefix argument, the command will receive all
1167 open messages in the current thread (formatted as an mbox) rather
1168 than only the current message."
1169   (interactive "P\nsPipe message to command: ")
1170   (let (shell-command)
1171     (if entire-thread
1172         (setq shell-command
1173               (concat notmuch-command " show --format=mbox "
1174                       (shell-quote-argument
1175                        (mapconcat 'identity (notmuch-show-get-message-ids-for-open-messages) " OR "))
1176                       " | " command))
1177       (setq shell-command
1178             (concat notmuch-command " show --format=raw "
1179                     (shell-quote-argument (notmuch-show-get-message-id)) " | " command)))
1180     (let ((buf (get-buffer-create (concat "*notmuch-pipe*"))))
1181       (with-current-buffer buf
1182         (setq buffer-read-only nil)
1183         (erase-buffer)
1184         (let ((exit-code (call-process-shell-command shell-command nil buf)))
1185           (goto-char (point-max))
1186           (set-buffer-modified-p nil)
1187           (setq buffer-read-only t)
1188           (unless (zerop exit-code)
1189             (switch-to-buffer-other-window buf)
1190             (message (format "Command '%s' exited abnormally with code %d"
1191                              shell-command exit-code))))))))
1192
1193 (defun notmuch-show-add-tags-worker (current-tags add-tags)
1194   "Add to `current-tags' with any tags from `add-tags' not
1195 currently present and return the result."
1196   (let ((result-tags (copy-sequence current-tags)))
1197     (mapc (lambda (add-tag)
1198             (unless (member add-tag current-tags)
1199               (setq result-tags (push add-tag result-tags))))
1200             add-tags)
1201     (sort result-tags 'string<)))
1202
1203 (defun notmuch-show-del-tags-worker (current-tags del-tags)
1204   "Remove any tags in `del-tags' from `current-tags' and return
1205 the result."
1206   (let ((result-tags (copy-sequence current-tags)))
1207     (mapc (lambda (del-tag)
1208             (setq result-tags (delete del-tag result-tags)))
1209           del-tags)
1210     result-tags))
1211
1212 (defun notmuch-show-add-tag (&rest toadd)
1213   "Add a tag to the current message."
1214   (interactive
1215    (list (notmuch-select-tag-with-completion "Tag to add: ")))
1216
1217   (let* ((current-tags (notmuch-show-get-tags))
1218          (new-tags (notmuch-show-add-tags-worker current-tags toadd)))
1219
1220     (unless (equal current-tags new-tags)
1221       (apply 'notmuch-call-notmuch-process
1222              (append (cons "tag"
1223                            (mapcar (lambda (s) (concat "+" s)) toadd))
1224                      (cons (notmuch-show-get-message-id) nil)))
1225       (notmuch-show-set-tags new-tags))))
1226
1227 (defun notmuch-show-remove-tag (&rest toremove)
1228   "Remove a tag from the current message."
1229   (interactive
1230    (list (notmuch-select-tag-with-completion
1231           "Tag to remove: " (notmuch-show-get-message-id))))
1232
1233   (let* ((current-tags (notmuch-show-get-tags))
1234          (new-tags (notmuch-show-del-tags-worker current-tags toremove)))
1235
1236     (unless (equal current-tags new-tags)
1237       (apply 'notmuch-call-notmuch-process
1238              (append (cons "tag"
1239                            (mapcar (lambda (s) (concat "-" s)) toremove))
1240                      (cons (notmuch-show-get-message-id) nil)))
1241       (notmuch-show-set-tags new-tags))))
1242
1243 (defun notmuch-show-toggle-headers ()
1244   "Toggle the visibility of the current message headers."
1245   (interactive)
1246   (let ((props (notmuch-show-get-message-properties)))
1247     (notmuch-show-headers-visible
1248      props
1249      (not (plist-get props :headers-visible))))
1250   (force-window-update))
1251
1252 (defun notmuch-show-toggle-message ()
1253   "Toggle the visibility of the current message."
1254   (interactive)
1255   (let ((props (notmuch-show-get-message-properties)))
1256     (notmuch-show-message-visible
1257      props
1258      (not (plist-get props :message-visible))))
1259   (force-window-update))
1260
1261 (defun notmuch-show-open-or-close-all ()
1262   "Set the visibility all of the messages in the current thread.
1263 By default make all of the messages visible. With a prefix
1264 argument, hide all of the messages."
1265   (interactive)
1266   (save-excursion
1267     (goto-char (point-min))
1268     (loop do (notmuch-show-message-visible (notmuch-show-get-message-properties)
1269                                            (not current-prefix-arg))
1270           until (not (notmuch-show-goto-message-next))))
1271   (force-window-update))
1272
1273 (defun notmuch-show-next-button ()
1274   "Advance point to the next button in the buffer."
1275   (interactive)
1276   (forward-button 1))
1277
1278 (defun notmuch-show-previous-button ()
1279   "Move point back to the previous button in the buffer."
1280   (interactive)
1281   (backward-button 1))
1282
1283 (defun notmuch-show-archive-thread-internal (show-next)
1284   ;; Remove the tag from the current set of messages.
1285   (goto-char (point-min))
1286   (loop do (notmuch-show-remove-tag "inbox")
1287         until (not (notmuch-show-goto-message-next)))
1288   ;; Move to the next item in the search results, if any.
1289   (let ((parent-buffer notmuch-show-parent-buffer))
1290     (notmuch-kill-this-buffer)
1291     (if parent-buffer
1292         (progn
1293           (switch-to-buffer parent-buffer)
1294           (forward-line)
1295           (if show-next
1296               (notmuch-search-show-thread))))))
1297
1298 (defun notmuch-show-archive-thread ()
1299   "Archive each message in thread, then show next thread from search.
1300
1301 Archive each message currently shown by removing the \"inbox\"
1302 tag from each. Then kill this buffer and show the next thread
1303 from the search from which this thread was originally shown.
1304
1305 Note: This command is safe from any race condition of new messages
1306 being delivered to the same thread. It does not archive the
1307 entire thread, but only the messages shown in the current
1308 buffer."
1309   (interactive)
1310   (notmuch-show-archive-thread-internal t))
1311
1312 (defun notmuch-show-archive-thread-then-exit ()
1313   "Archive each message in thread, then exit back to search results."
1314   (interactive)
1315   (notmuch-show-archive-thread-internal nil))
1316
1317 (defun notmuch-show-stash-cc ()
1318   "Copy CC field of current message to kill-ring."
1319   (interactive)
1320   (notmuch-common-do-stash (notmuch-show-get-cc)))
1321
1322 (defun notmuch-show-stash-date ()
1323   "Copy date of current message to kill-ring."
1324   (interactive)
1325   (notmuch-common-do-stash (notmuch-show-get-date)))
1326
1327 (defun notmuch-show-stash-filename ()
1328   "Copy filename of current message to kill-ring."
1329   (interactive)
1330   (notmuch-common-do-stash (notmuch-show-get-filename)))
1331
1332 (defun notmuch-show-stash-from ()
1333   "Copy From address of current message to kill-ring."
1334   (interactive)
1335   (notmuch-common-do-stash (notmuch-show-get-from)))
1336
1337 (defun notmuch-show-stash-message-id ()
1338   "Copy message ID of current message to kill-ring."
1339   (interactive)
1340   (notmuch-common-do-stash (notmuch-show-get-message-id)))
1341
1342 (defun notmuch-show-stash-subject ()
1343   "Copy Subject field of current message to kill-ring."
1344   (interactive)
1345   (notmuch-common-do-stash (notmuch-show-get-subject)))
1346
1347 (defun notmuch-show-stash-tags ()
1348   "Copy tags of current message to kill-ring as a comma separated list."
1349   (interactive)
1350   (notmuch-common-do-stash (mapconcat 'identity (notmuch-show-get-tags) ",")))
1351
1352 (defun notmuch-show-stash-to ()
1353   "Copy To address of current message to kill-ring."
1354   (interactive)
1355   (notmuch-common-do-stash (notmuch-show-get-to)))
1356
1357 ;; Commands typically bound to buttons.
1358
1359 (defun notmuch-show-part-button-action (button)
1360   (let ((nth (button-get button :notmuch-part)))
1361     (if nth
1362         (notmuch-show-save-part (notmuch-show-get-message-id) nth
1363                                 (button-get button :notmuch-filename))
1364       (message "Not a valid part (is it a fake part?)."))))
1365
1366 ;;
1367
1368 (provide 'notmuch-show)