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