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