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

   1 ;;; notmuch-show.el --- displaying notmuch forests  -*- lexical-binding: t -*-
   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 <https://www.gnu.org/licenses/>.
  20 ;;
  21 ;; Authors: Carl Worth <cworth@cworth.org>
  22 ;;          David Edmondson <dme@dme.org>
  23
  24 ;;; Code:
  25
  26 (require 'mm-view)
  27 (require 'message)
  28 (require 'mm-decode)
  29 (require 'mailcap)
  30 (require 'icalendar)
  31 (require 'goto-addr)
  32
  33 (require 'notmuch-lib)
  34 (require 'notmuch-tag)
  35 (require 'notmuch-wash)
  36 (require 'notmuch-mua)
  37 (require 'notmuch-crypto)
  38 (require 'notmuch-print)
  39 (require 'notmuch-draft)
  40
  41 (declare-function notmuch-call-notmuch-process "notmuch-lib" (&rest args))
  42 (declare-function notmuch-search-next-thread "notmuch" nil)
  43 (declare-function notmuch-search-previous-thread "notmuch" nil)
  44 (declare-function notmuch-search-show-thread "notmuch")
  45 (declare-function notmuch-foreach-mime-part "notmuch" (function mm-handle))
  46 (declare-function notmuch-count-attachments "notmuch" (mm-handle))
  47 (declare-function notmuch-save-attachments "notmuch" (mm-handle &optional queryp))
  48 (declare-function notmuch-tree "notmuch-tree"
  49                   (&optional query query-context target buffer-name
  50                              open-target unthreaded parent-buffer))
  51 (declare-function notmuch-tree-get-message-properties "notmuch-tree" nil)
  52 (declare-function notmuch-unthreaded "notmuch-tree"
  53                   (&optional query query-context target buffer-name
  54                              open-target))
  55 (declare-function notmuch-read-query "notmuch" (prompt))
  56 (declare-function notmuch-draft-resume "notmuch-draft" (id))
  57
  58 (defvar shr-blocked-images)
  59 (defvar gnus-blocked-images)
  60 (defvar shr-content-function)
  61 (defvar w3m-ignored-image-url-regexp)
  62
  63 ;;; Options
  64
  65 (defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date")
  66   "Headers that should be shown in a message, in this order.
  67
  68 For an open message, all of these headers will be made visible
  69 according to `notmuch-message-headers-visible' or can be toggled
  70 with `notmuch-show-toggle-visibility-headers'. For a closed message,
  71 only the first header in the list will be visible."
  72   :type '(repeat string)
  73   :group 'notmuch-show)
  74
  75 (defcustom notmuch-message-headers-visible t
  76   "Should the headers be visible by default?
  77
  78 If this value is non-nil, then all of the headers defined in
  79 `notmuch-message-headers' will be visible by default in the display
  80 of each message. Otherwise, these headers will be hidden and
  81 `notmuch-show-toggle-visibility-headers' can be used to make them
  82 visible for any given message."
  83   :type 'boolean
  84   :group 'notmuch-show)
  85
  86 (defcustom notmuch-show-header-line t
  87   "Show a header line in notmuch show buffers.
  88
  89 If t (the default), the header line will contain the current
  90 message's subject.
  91
  92 If a string, this value is interpreted as a format string to be
  93 passed to `format-spec` with `%s` as the substitution variable
  94 for the message's subject.  E.g., to display the subject trimmed
  95 to a maximum of 80 columns, you could use \"%>-80s\" as format.
  96
  97 If you assign to this variable a function, it will be called with
  98 the subject as argument, and the return value will be used as the
  99 header line format.  Since the function is called with the
 100 message buffer as the current buffer, it is also possible to
 101 access any other properties of the message, using for instance
 102 notmuch-show functions such as
 103 `notmuch-show-get-message-properties'.
 104
 105 Finally, if this variable is set to nil, no header is
 106 displayed."
 107   :type '(choice (const :tag "No header" ni)
 108                  (const :tag "Subject" t)
 109                  (string :tag "Format")
 110                  (function :tag "Function"))
 111   :group 'notmuch-show)
 112
 113 (defcustom notmuch-show-depth-limit nil
 114   "Depth beyond which message bodies are displayed lazily.
 115
 116 If bound to an integer, any message with tree depth greater than
 117 this will have its body display lazily, initially
 118 inserting only a button.
 119
 120 If this variable is set to nil (the default) no such lazy
 121 insertion is done."
 122   :type '(choice (const :tag "No limit" nil)
 123                  (number :tag "Limit" 10))
 124   :group 'notmuch-show)
 125
 126 (defcustom notmuch-show-height-limit nil
 127   "Height (from leaves) beyond which message bodies are displayed lazily.
 128
 129 If bound to an integer, any message with height in the message
 130 tree greater than this will have its body displayed lazily,
 131 initially only a button.
 132
 133 If this variable is set to nil (the default) no such lazy
 134 display is done."
 135   :type '(choice (const :tag "No limit" nil)
 136                  (number :tag "Limit" 10))
 137   :group 'notmuch-show)
 138
 139 (defcustom notmuch-show-relative-dates t
 140   "Display relative dates in the message summary line."
 141   :type 'boolean
 142   :group 'notmuch-show)
 143
 144 (defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers)
 145   "A list of functions called to decorate the headers listed in
 146 `notmuch-message-headers'.")
 147
 148 (defcustom notmuch-show-hook '(notmuch-show-turn-on-visual-line-mode)
 149   "Functions called after populating a `notmuch-show' buffer."
 150   :type 'hook
 151   :options '(notmuch-show-turn-on-visual-line-mode)
 152   :group 'notmuch-show
 153   :group 'notmuch-hooks)
 154
 155 (defcustom notmuch-show-insert-text/plain-hook
 156   '(notmuch-wash-wrap-long-lines
 157     notmuch-wash-tidy-citations
 158     notmuch-wash-elide-blank-lines
 159     notmuch-wash-excerpt-citations)
 160   "Functions used to improve the display of text/plain parts."
 161   :type 'hook
 162   :options '(notmuch-wash-convert-inline-patch-to-part
 163              notmuch-wash-wrap-long-lines
 164              notmuch-wash-tidy-citations
 165              notmuch-wash-elide-blank-lines
 166              notmuch-wash-excerpt-citations)
 167   :group 'notmuch-show
 168   :group 'notmuch-hooks)
 169
 170 (defcustom notmuch-show-max-text-part-size 100000
 171   "Maximum size of a text part to be shown by default in characters.
 172
 173 Set to 0 to show the part regardless of size."
 174   :type 'integer
 175   :group 'notmuch-show)
 176
 177 ;; Mostly useful for debugging.
 178 (defcustom notmuch-show-all-multipart/alternative-parts nil
 179   "Should all parts of multipart/alternative parts be shown?"
 180   :type 'boolean
 181   :group 'notmuch-show)
 182
 183 (defcustom notmuch-show-indent-messages-width 1
 184   "Width of message indentation in threads.
 185
 186 Messages are shown indented according to their depth in a thread.
 187 This variable determines the width of this indentation measured
 188 in number of blanks.  Defaults to `1', choose `0' to disable
 189 indentation."
 190   :type 'integer
 191   :group 'notmuch-show)
 192
 193 (defcustom notmuch-show-indent-multipart nil
 194   "Should the sub-parts of a multipart/* part be indented?"
 195   ;; dme: Not sure which is a good default.
 196   :type 'boolean
 197   :group 'notmuch-show)
 198
 199 (defcustom notmuch-show-part-button-default-action 'notmuch-show-save-part
 200   "Default part header button action (on ENTER or mouse click)."
 201   :group 'notmuch-show
 202   :type '(choice (const :tag "Save part"
 203                         notmuch-show-save-part)
 204                  (const :tag "View part"
 205                         notmuch-show-view-part)
 206                  (const :tag "View interactively"
 207                         notmuch-show-interactively-view-part)))
 208
 209 (defcustom notmuch-show-only-matching-messages nil
 210   "Only matching messages are shown by default."
 211   :type 'boolean
 212   :group 'notmuch-show)
 213
 214 ;; By default, block all external images to prevent privacy leaks and
 215 ;; potential attacks.
 216 (defcustom notmuch-show-text/html-blocked-images "."
 217   "Remote images that have URLs matching this regexp will be blocked."
 218   :type '(choice (const nil) regexp)
 219   :group 'notmuch-show)
 220
 221 ;;; Variables
 222
 223 (defvar-local notmuch-show-thread-id nil)
 224
 225 (defvar-local notmuch-show-parent-buffer nil)
 226
 227 (defvar-local notmuch-show-query-context nil)
 228
 229 (defvar-local notmuch-show-process-crypto nil)
 230
 231 (defvar-local notmuch-show-elide-non-matching-messages nil)
 232
 233 (defvar-local notmuch-show-indent-content t)
 234
 235 (defvar-local notmuch-show-single-message nil)
 236
 237 (defvar notmuch-show-attachment-debug nil
 238   "If t log stdout and stderr from attachment handlers.
 239
 240 When set to nil (the default) stdout and stderr from attachment
 241 handlers is discarded. When set to t the stdout and stderr from
 242 each attachment handler is logged in buffers with names beginning
 243 \" *notmuch-part*\".")
 244
 245 ;;; Options
 246
 247 (defcustom notmuch-show-stash-mlarchive-link-alist
 248   '(("MARC" . "https://marc.info/?i=")
 249     ("Mail Archive, The" . "https://mid.mail-archive.com/")
 250     ("Lore" . "https://lore.kernel.org/r/")
 251     ("Notmuch" . "https://nmbug.notmuchmail.org/nmweb/show/")
 252     ;; FIXME: can these services be searched by `Message-Id' ?
 253     ;; ("MarkMail" . "http://markmail.org/")
 254     ;; ("Nabble" . "http://nabble.com/")
 255     ;; ("opensubscriber" . "http://opensubscriber.com/")
 256     )
 257   "List of Mailing List Archives to use when stashing links.
 258
 259 This list is used for generating a Mailing List Archive reference
 260 URI with the current message's Message-Id in
 261 `notmuch-show-stash-mlarchive-link'.
 262
 263 If the cdr of the alist element is not a function, the cdr is
 264 expected to contain a URI that is concatenated with the current
 265 message's Message-Id to create a ML archive reference URI.
 266
 267 If the cdr is a function, the function is called with the
 268 Message-Id as the argument, and the function is expected to
 269 return the ML archive reference URI."
 270   :type '(alist :key-type (string :tag "Name")
 271                 :value-type (choice
 272                              (string :tag "URL")
 273                              (function :tag "Function returning the URL")))
 274   :group 'notmuch-show)
 275
 276 (defcustom notmuch-show-stash-mlarchive-link-default "MARC"
 277   "Default Mailing List Archive to use when stashing links.
 278
 279 This is used when `notmuch-show-stash-mlarchive-link' isn't
 280 provided with an MLA argument nor `completing-read' input."
 281   :type `(choice
 282           ,@(mapcar
 283              (lambda (mla)
 284                (list 'const :tag (car mla) :value (car mla)))
 285              notmuch-show-stash-mlarchive-link-alist))
 286   :group 'notmuch-show)
 287
 288 (defcustom notmuch-show-mark-read-tags '("-unread")
 289   "List of tag changes to apply to a message when it is marked as read.
 290
 291 Tags starting with \"+\" (or not starting with either \"+\" or
 292 \"-\") in the list will be added, and tags starting with \"-\"
 293 will be removed from the message being marked as read.
 294
 295 For example, if you wanted to remove an \"unread\" tag and add a
 296 \"read\" tag (which would make little sense), you would set:
 297     (\"-unread\" \"+read\")"
 298   :type '(repeat string)
 299   :group 'notmuch-show)
 300
 301 (defcustom notmuch-show-mark-read-function #'notmuch-show-seen-current-message
 302   "Function to control which messages are marked read.
 303
 304 The function should take two arguments START and END which will
 305 be the start and end of the visible portion of the buffer and
 306 should mark the appropriate messages read by applying
 307 `notmuch-show-mark-read'. This function will be called after
 308 every user interaction with notmuch."
 309   :type 'function
 310   :group 'notmuch-show)
 311
 312 (defcustom notmuch-show-imenu-indent nil
 313   "Should Imenu display messages indented.
 314
 315 By default, Imenu (see Info node `(emacs) Imenu') in a
 316 notmuch-show buffer displays all messages straight.  This is
 317 because the default Emacs frontend for Imenu makes it difficult
 318 to select an Imenu entry with spaces in front.  Other imenu
 319 frontends such as counsel-imenu does not have this limitation.
 320 In these cases, Imenu entries can be indented to reflect the
 321 position of the message in the thread."
 322   :type 'boolean
 323   :group 'notmuch-show)
 324
 325 ;;; Utilities
 326
 327 (defmacro with-current-notmuch-show-message (&rest body)
 328   "Evaluate body with current buffer set to the text of current message."
 329   `(save-excursion
 330      (let ((id (notmuch-show-get-message-id)))
 331        (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*"))))
 332          (with-current-buffer buf
 333            (let ((coding-system-for-read 'no-conversion))
 334              (notmuch--call-process notmuch-command nil t nil "show" "--format=raw" id))
 335            ,@body)
 336          (kill-buffer buf)))))
 337
 338 (defun notmuch-show-turn-on-visual-line-mode ()
 339   "Enable Visual Line mode."
 340   (visual-line-mode t))
 341
 342 ;;; Commands
 343
 344 ;; DEPRECATED in Notmuch 0.16 since we now have convenient part
 345 ;; commands.  We'll keep the command around for a version or two in
 346 ;; case people want to bind it themselves.
 347 (defun notmuch-show-view-all-mime-parts ()
 348   "Use external viewers to view all attachments from the current message."
 349   (interactive)
 350   (with-current-notmuch-show-message
 351    ;; We override the mm-inline-media-tests to indicate which message
 352    ;; parts are already sufficiently handled by the original
 353    ;; presentation of the message in notmuch-show mode. These parts
 354    ;; will be inserted directly into the temporary buffer of
 355    ;; with-current-notmuch-show-message and silently discarded.
 356    ;;
 357    ;; Any MIME part not explicitly mentioned here will be handled by an
 358    ;; external viewer as configured in the various mailcap files.
 359    (let ((mm-inline-media-tests
 360           '(("text/.*" ignore identity)
 361             ("application/pgp-signature" ignore identity)
 362             ("multipart/alternative" ignore identity)
 363             ("multipart/mixed" ignore identity)
 364             ("multipart/related" ignore identity))))
 365      (mm-display-parts (mm-dissect-buffer)))))
 366
 367 (defun notmuch-show-save-attachments ()
 368   "Save all attachments from the current message."
 369   (interactive)
 370   (with-current-notmuch-show-message
 371    (let ((mm-handle (mm-dissect-buffer)))
 372      (notmuch-save-attachments
 373       mm-handle (> (notmuch-count-attachments mm-handle) 1))))
 374   (message "Done"))
 375
 376 (defun notmuch-show-with-message-as-text (fn)
 377   "Apply FN to a text representation of the current message.
 378
 379 FN is called with one argument, the message properties. It should
 380 operation on the contents of the current buffer."
 381   ;; Remake the header to ensure that all information is available.
 382   (let* ((to (notmuch-show-get-to))
 383          (cc (notmuch-show-get-cc))
 384          (from (notmuch-show-get-from))
 385          (subject (notmuch-show-get-subject))
 386          (date (notmuch-show-get-date))
 387          (tags (notmuch-show-get-tags))
 388          (depth (notmuch-show-get-depth))
 389          (header (concat
 390                   "Subject: " subject "\n"
 391                   "To: " to "\n"
 392                   (if (not (string-empty-p cc))
 393                       (concat "Cc: " cc "\n")
 394                     "")
 395                   "From: " from "\n"
 396                   "Date: " date "\n"
 397                   (if tags
 398                       (concat "Tags: "
 399                               (mapconcat #'identity tags ", ") "\n")
 400                     "")))
 401          (all (buffer-substring (notmuch-show-message-top)
 402                                 (notmuch-show-message-bottom)))
 403
 404          (props (notmuch-show-get-message-properties))
 405          (indenting notmuch-show-indent-content))
 406     (with-temp-buffer
 407       (insert all)
 408       (when indenting
 409         (indent-rigidly (point-min)
 410                         (point-max)
 411                         (- (* notmuch-show-indent-messages-width depth))))
 412       ;; Remove the original header.
 413       (goto-char (point-min))
 414       (re-search-forward "^$" (point-max) nil)
 415       (delete-region (point-min) (point))
 416       (insert header)
 417       (funcall fn props))))
 418
 419 (defun notmuch-show-print-message ()
 420   "Print the current message."
 421   (interactive)
 422   (notmuch-show-with-message-as-text 'notmuch-print-message))
 423
 424 ;;; Headers
 425
 426 (defun notmuch-show-fontify-header ()
 427   (let ((face (cond
 428                ((looking-at "[Tt]o:")
 429                 'message-header-to)
 430                ((looking-at "[Bb]?[Cc][Cc]:")
 431                 'message-header-cc)
 432                ((looking-at "[Ss]ubject:")
 433                 'message-header-subject)
 434                (t
 435                 'message-header-other))))
 436     (overlay-put (make-overlay (point) (re-search-forward ":"))
 437                  'face 'message-header-name)
 438     (overlay-put (make-overlay (point) (re-search-forward ".*$"))
 439                  'face face)))
 440
 441 (defun notmuch-show-colour-headers ()
 442   "Apply some colouring to the current headers."
 443   (goto-char (point-min))
 444   (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:")
 445     (notmuch-show-fontify-header)
 446     (forward-line)))
 447
 448 (defun notmuch-show-spaces-n (n)
 449   "Return a string comprised of `n' spaces."
 450   (make-string n ? ))
 451
 452 (defun notmuch-show-update-tags (tags)
 453   "Update the displayed tags of the current message."
 454   (save-excursion
 455     (goto-char (notmuch-show-message-top))
 456     (when (re-search-forward "(\\([^()]*\\))$" (line-end-position) t)
 457       (let ((inhibit-read-only t))
 458         (replace-match (concat "("
 459                                (notmuch-tag-format-tags
 460                                 tags
 461                                 (notmuch-show-get-prop :orig-tags))
 462                                ")"))))))
 463
 464 (defun notmuch-clean-address (address)
 465   "Try to clean a single email ADDRESS for display. Return a cons
 466 cell of (AUTHOR_EMAIL AUTHOR_NAME). Return (ADDRESS nil) if
 467 parsing fails."
 468   (condition-case nil
 469       (let (p-name p-address)
 470         ;; It would be convenient to use `mail-header-parse-address',
 471         ;; but that expects un-decoded mailbox parts, whereas our
 472         ;; mailbox parts are already decoded (and hence may contain
 473         ;; UTF-8). Given that notmuch should handle most of the awkward
 474         ;; cases, some simple string deconstruction should be sufficient
 475         ;; here.
 476         (cond
 477          ;; "User <user@dom.ain>" style.
 478          ((string-match "\\(.*\\) <\\(.*\\)>" address)
 479           (setq p-name (match-string 1 address))
 480           (setq p-address (match-string 2 address)))
 481
 482          ;; "<user@dom.ain>" style.
 483          ((string-match "<\\(.*\\)>" address)
 484           (setq p-address (match-string 1 address)))
 485          ;; Everything else.
 486          (t
 487           (setq p-address address)))
 488         (when p-name
 489           ;; Remove elements of the mailbox part that are not relevant for
 490           ;; display, even if they are required during transport:
 491           ;;
 492           ;; Backslashes.
 493           (setq p-name (replace-regexp-in-string "\\\\" "" p-name))
 494           ;; Outer single and double quotes, which might be nested.
 495           (cl-loop with start-of-loop
 496                    do   (setq start-of-loop p-name)
 497                    when (string-match "^\"\\(.*\\)\"$" p-name)
 498                    do   (setq p-name (match-string 1 p-name))
 499                    when (string-match "^'\\(.*\\)'$" p-name)
 500                    do   (setq p-name (match-string 1 p-name))
 501                    until (string= start-of-loop p-name)))
 502         ;; If the address is 'foo@bar.com <foo@bar.com>' then show just
 503         ;; 'foo@bar.com'.
 504         (when (string= p-name p-address)
 505           (setq p-name nil))
 506         (cons p-address p-name))
 507     (error (cons address nil))))
 508
 509 (defun notmuch-show-clean-address (address)
 510   "Try to clean a single email ADDRESS for display.
 511 Return unchanged ADDRESS if parsing fails."
 512   (let* ((clean-address (notmuch-clean-address address))
 513          (p-address (car clean-address))
 514          (p-name (cdr clean-address)))
 515     ;; If no name, return just the address.
 516     (if (not p-name)
 517         p-address
 518       ;; Otherwise format the name and address together.
 519       (concat p-name " <" p-address ">"))))
 520
 521 (defun notmuch-show--mark-height (tree)
 522   "Calculate and cache height (distance from deepest descendent)"
 523   (let* ((msg (car tree))
 524          (children (cadr tree))
 525          (cached-height (plist-get msg :height)))
 526     (or cached-height
 527         (let ((height
 528                (if (null children) 0
 529                  (1+ (apply #'max (mapcar #'notmuch-show--mark-height children))))))
 530           (plist-put msg :height height)
 531           height))))
 532
 533 (defun notmuch-show-insert-headerline (headers date tags depth duplicate file-count)
 534   "Insert a notmuch style headerline based on HEADERS for a
 535 message at DEPTH in the current thread."
 536   (let ((start (point))
 537         (from (notmuch-sanitize
 538                (notmuch-show-clean-address (plist-get headers :From)))))
 539     (when (string-match "\\cR" from)
 540       ;; If the From header has a right-to-left character add
 541       ;; invisible U+200E LEFT-TO-RIGHT MARK character which forces
 542       ;; the header paragraph as left-to-right text.
 543       (insert (propertize (string ?\x200e) 'invisible t)))
 544     (insert (if notmuch-show-indent-content
 545                 (notmuch-show-spaces-n (* notmuch-show-indent-messages-width
 546                                           depth))
 547               "")
 548             from
 549             " ("
 550             date
 551             ") ("
 552             (notmuch-tag-format-tags tags tags)
 553             ")")
 554     (insert
 555      (if (> file-count 1)
 556          (let ((txt (format "%d/%d\n" duplicate file-count)))
 557            (concat
 558             (notmuch-show-spaces-n (max 0 (- (window-width) (+ (current-column) (length txt)))))
 559             txt))
 560        "\n"))
 561     (overlay-put (make-overlay start (point))
 562                  'face 'notmuch-message-summary-face)))
 563
 564 (defun notmuch-show-insert-header (header header-value)
 565   "Insert a single header."
 566   (insert header ": " (notmuch-sanitize header-value) "\n"))
 567
 568 (defun notmuch-show-insert-headers (headers)
 569   "Insert the headers of the current message."
 570   (let ((start (point)))
 571     (mapc (lambda (header)
 572             (let* ((header-symbol (intern (concat ":" header)))
 573                    (header-value (plist-get headers header-symbol)))
 574               (when (and header-value
 575                          (not (string-equal "" header-value)))
 576                 (notmuch-show-insert-header header header-value))))
 577           notmuch-message-headers)
 578     (save-excursion
 579       (save-restriction
 580         (narrow-to-region start (point-max))
 581         (run-hooks 'notmuch-show-markup-headers-hook)))))
 582
 583 ;;; Parts
 584
 585 (define-button-type 'notmuch-show-part-button-type
 586   'action 'notmuch-show-part-button-default
 587   'follow-link t
 588   'face 'message-mml
 589   :supertype 'notmuch-button-type)
 590
 591 (defun notmuch-show-insert-part-header (_nth content-type declared-type
 592                                             &optional name comment)
 593   (let ((base-label (concat (and name (concat name ": "))
 594                             declared-type
 595                             (and (not (string-equal declared-type content-type))
 596                                  (concat " (as " content-type ")"))
 597                             comment)))
 598     (prog1 (insert-button
 599             (concat "[ " base-label " ]")
 600             :base-label base-label
 601             :type 'notmuch-show-part-button-type
 602             :notmuch-part-hidden nil)
 603       (insert "\n"))))
 604
 605 (defun notmuch-show-toggle-part-invisibility (&optional button)
 606   (interactive)
 607   (let ((button (or button (button-at (point)))))
 608     (when button
 609       (let ((overlay (button-get button 'overlay))
 610             (lazy-part (button-get button :notmuch-lazy-part)))
 611         ;; We have a part to toggle if there is an overlay or if there
 612         ;; is a lazy part.  If neither is present we cannot toggle the
 613         ;; part so we just return nil.
 614         (when (or overlay lazy-part)
 615           (let* ((show (button-get button :notmuch-part-hidden))
 616                  (new-start (button-start button))
 617                  (button-label (button-get button :base-label))
 618                  (old-point (point))
 619                  (properties (text-properties-at (button-start button)))
 620                  (inhibit-read-only t))
 621             ;; Toggle the button itself.
 622             (button-put button :notmuch-part-hidden (not show))
 623             (goto-char new-start)
 624             (insert "[ " button-label (if show " ]" " (hidden) ]"))
 625             (set-text-properties new-start (point) properties)
 626             (let ((old-end (button-end button)))
 627               (move-overlay button new-start (point))
 628               (delete-region (point) old-end))
 629             (goto-char (min old-point (1- (button-end button))))
 630             ;; Return nil if there is a lazy-part, it is empty, and we are
 631             ;; trying to show it.  In all other cases return t.
 632             (if lazy-part
 633                 (when show
 634                   (button-put button :notmuch-lazy-part nil)
 635                   (notmuch-show-lazy-part lazy-part button))
 636               ;; else there must be an overlay.
 637               (overlay-put overlay 'invisible (not show))
 638               t)))))))
 639
 640 ;;; Part content ID handling
 641
 642 (defvar notmuch-show--cids nil
 643   "Alist from raw content ID to (MSG PART).")
 644 (make-variable-buffer-local 'notmuch-show--cids)
 645
 646 (defun notmuch-show--register-cids (msg part)
 647   "Register content-IDs in PART and all of PART's sub-parts."
 648   (let ((content-id (plist-get part :content-id)))
 649     (when content-id
 650       ;; Note that content-IDs are globally unique, except when they
 651       ;; aren't: RFC 2046 section 5.1.4 permits children of a
 652       ;; multipart/alternative to have the same content-ID, in which
 653       ;; case the MUA is supposed to pick the best one it can render.
 654       ;; We simply add the content-ID to the beginning of our alist;
 655       ;; so if this happens, we'll take the last (and "best")
 656       ;; alternative (even if we can't render it).
 657       (push (list content-id msg part) notmuch-show--cids)))
 658   ;; Recurse on sub-parts
 659   (when-let ((type (plist-get part :content-type)))
 660     (pcase-let ((`(,type ,subtype)
 661                  (split-string (downcase type) "/")))
 662       (cond ((equal type "multipart")
 663              (mapc (apply-partially #'notmuch-show--register-cids msg)
 664                    (plist-get part :content)))
 665             ((and (equal type "message")
 666                   (equal subtype "rfc822"))
 667              (notmuch-show--register-cids
 668               msg
 669               (car (plist-get (car (plist-get part :content)) :body))))))))
 670
 671 (defun notmuch-show--get-cid-content (cid)
 672   "Return a list (CID-content content-type) or nil.
 673
 674 This will only find parts from messages that have been inserted
 675 into the current buffer.  CID must be a raw content ID, without
 676 enclosing angle brackets, a cid: prefix, or URL encoding.  This
 677 will return nil if the CID is unknown or cannot be retrieved."
 678   (when-let ((descriptor (cdr (assoc cid notmuch-show--cids))))
 679     (pcase-let ((`(,msg ,part) descriptor))
 680       ;; Request caching for this content, as some messages
 681       ;; reference the same cid: part many times (hundreds!).
 682       (list (notmuch-get-bodypart-binary
 683              msg part notmuch-show-process-crypto 'cache)
 684             (plist-get part :content-type)))))
 685
 686 (defun notmuch-show-setup-w3m ()
 687   "Instruct w3m how to retrieve content from a \"related\" part of a message."
 688   (interactive)
 689   (when (and (boundp 'w3m-cid-retrieve-function-alist)
 690              (not (assq 'notmuch-show-mode w3m-cid-retrieve-function-alist)))
 691     (push (cons 'notmuch-show-mode #'notmuch-show--cid-w3m-retrieve)
 692           w3m-cid-retrieve-function-alist))
 693   (setq mm-html-inhibit-images nil))
 694
 695 (defvar w3m-current-buffer) ;; From `w3m.el'.
 696 (defun notmuch-show--cid-w3m-retrieve (url &rest _args)
 697   ;; url includes the cid: prefix and is URL encoded (see RFC 2392).
 698   (let* ((cid (url-unhex-string (substring url 4)))
 699          (content-and-type
 700           (with-current-buffer w3m-current-buffer
 701             (notmuch-show--get-cid-content cid))))
 702     (when content-and-type
 703       (insert (car content-and-type))
 704       (cadr content-and-type))))
 705
 706 ;; MIME part renderers
 707
 708 (defun notmuch-show-multipart/*-to-list (part)
 709   (mapcar (lambda (inner-part) (plist-get inner-part :content-type))
 710           (plist-get part :content)))
 711
 712 (defun notmuch-show-insert-part-multipart/alternative (msg part _content-type _nth depth _button)
 713   (let ((chosen-type (car (notmuch-multipart/alternative-choose
 714                            msg (notmuch-show-multipart/*-to-list part))))
 715         (inner-parts (plist-get part :content))
 716         (start (point)))
 717     ;; This inserts all parts of the chosen type rather than just one,
 718     ;; but it's not clear that this is the wrong thing to do - which
 719     ;; should be chosen if there are more than one that match?
 720     (mapc (lambda (inner-part)
 721             (let* ((inner-type (plist-get inner-part :content-type))
 722                    (hide (not (or notmuch-show-all-multipart/alternative-parts
 723                                   (string= chosen-type inner-type)))))
 724               (notmuch-show-insert-bodypart msg inner-part depth hide)))
 725           inner-parts)
 726
 727     (when notmuch-show-indent-multipart
 728       (indent-rigidly start (point) 1)))
 729   t)
 730
 731 (defun notmuch-show-insert-part-multipart/related (msg part _content-type _nth depth _button)
 732   (let ((inner-parts (plist-get part :content))
 733         (start (point)))
 734     ;; Render the primary part.  FIXME: Support RFC 2387 Start header.
 735     (notmuch-show-insert-bodypart msg (car inner-parts) depth)
 736     ;; Add hidden buttons for the rest
 737     (mapc (lambda (inner-part)
 738             (notmuch-show-insert-bodypart msg inner-part depth t))
 739           (cdr inner-parts))
 740     (when notmuch-show-indent-multipart
 741       (indent-rigidly start (point) 1)))
 742   t)
 743
 744 (defun notmuch-show-insert-part-multipart/signed (msg part _content-type _nth depth button)
 745   (when button
 746     (button-put button 'face 'notmuch-crypto-part-header))
 747   ;; Insert a button detailing the signature status.
 748   (notmuch-crypto-insert-sigstatus-button (car (plist-get part :sigstatus))
 749                                           (notmuch-show-get-header :From msg))
 750   (let ((inner-parts (plist-get part :content))
 751         (start (point)))
 752     ;; Show all of the parts.
 753     (mapc (lambda (inner-part)
 754             (notmuch-show-insert-bodypart msg inner-part depth))
 755           inner-parts)
 756     (when notmuch-show-indent-multipart
 757       (indent-rigidly start (point) 1)))
 758   t)
 759
 760 (defun notmuch-show-insert-part-multipart/encrypted (msg part _content-type _nth depth button)
 761   (when button
 762     (button-put button 'face 'notmuch-crypto-part-header))
 763   ;; Insert a button detailing the encryption status.
 764   (notmuch-crypto-insert-encstatus-button (car (plist-get part :encstatus)))
 765   ;; Insert a button detailing the signature status.
 766   (notmuch-crypto-insert-sigstatus-button (car (plist-get part :sigstatus))
 767                                           (notmuch-show-get-header :From msg))
 768   (let ((inner-parts (plist-get part :content))
 769         (start (point)))
 770     ;; Show all of the parts.
 771     (mapc (lambda (inner-part)
 772             (notmuch-show-insert-bodypart msg inner-part depth))
 773           inner-parts)
 774     (when notmuch-show-indent-multipart
 775       (indent-rigidly start (point) 1)))
 776   t)
 777
 778 (defun notmuch-show-insert-part-application/pgp-encrypted (_msg _part _content-type _nth _depth _button)
 779   t)
 780
 781 (defun notmuch-show-insert-part-multipart/* (msg part _content-type _nth depth _button)
 782   (let ((inner-parts (plist-get part :content))
 783         (start (point)))
 784     ;; Show all of the parts.
 785     (mapc (lambda (inner-part)
 786             (notmuch-show-insert-bodypart msg inner-part depth))
 787           inner-parts)
 788     (when notmuch-show-indent-multipart
 789       (indent-rigidly start (point) 1)))
 790   t)
 791
 792 (defun notmuch-show-insert-part-message/rfc822 (msg part _content-type _nth depth _button)
 793   (let ((message (car (plist-get part :content))))
 794     (and
 795      message
 796      (let ((body (car (plist-get message :body)))
 797            (start (point)))
 798        ;; Override `notmuch-message-headers' to force `From' to be
 799        ;; displayed.
 800        (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date")))
 801          (notmuch-show-insert-headers (plist-get message :headers)))
 802        ;; Blank line after headers to be compatible with the normal
 803        ;; message display.
 804        (insert "\n")
 805        ;; Show the body
 806        (notmuch-show-insert-bodypart msg body depth)
 807        (when notmuch-show-indent-multipart
 808          (indent-rigidly start (point) 1))
 809        t))))
 810
 811 (defun notmuch-show-insert-part-text/plain (msg part _content-type _nth depth button)
 812   ;; For backward compatibility we want to apply the text/plain hook
 813   ;; to the whole of the part including the part button if there is
 814   ;; one.
 815   (let ((start (if button
 816                    (button-start button)
 817                  (point))))
 818     (insert (notmuch-get-bodypart-text msg part notmuch-show-process-crypto))
 819     (save-excursion
 820       (save-restriction
 821         (narrow-to-region start (point-max))
 822         (run-hook-with-args 'notmuch-show-insert-text/plain-hook msg depth))))
 823   t)
 824
 825 (defun notmuch-show-insert-part-text/calendar (msg part _content-type _nth _depth _button)
 826   (insert (with-temp-buffer
 827             (insert (notmuch-get-bodypart-text msg part notmuch-show-process-crypto))
 828             ;; notmuch-get-bodypart-text does no newline conversion.
 829             ;; Replace CRLF with LF before icalendar can use it.
 830             (goto-char (point-min))
 831             (while (re-search-forward "\r\n" nil t)
 832               (replace-match "\n" nil nil))
 833             (let ((file (make-temp-file "notmuch-ical"))
 834                   result)
 835               (unwind-protect
 836                   (progn
 837                     (unless (icalendar-import-buffer file t)
 838                       (error "Icalendar import error. %s"
 839                              "See *icalendar-errors* for more information"))
 840                     (set-buffer (get-file-buffer file))
 841                     (setq result (buffer-substring (point-min) (point-max)))
 842                     (set-buffer-modified-p nil)
 843                     (kill-buffer (current-buffer)))
 844                 (delete-file file))
 845               result)))
 846   t)
 847
 848 ;; For backwards compatibility.
 849 (defun notmuch-show-insert-part-text/x-vcalendar (msg part _content-type _nth depth _button)
 850   (notmuch-show-insert-part-text/calendar msg part nil nil depth nil))
 851
 852 (when (version< emacs-version "25.3")
 853   ;; https://bugs.gnu.org/28350
 854   ;;
 855   ;; For newer emacs, we fall back to notmuch-show-insert-part-*/*
 856   ;; (see notmuch-show-handlers-for)
 857   (defun notmuch-show-insert-part-text/enriched
 858       (msg part content-type nth depth button)
 859     ;; By requiring enriched below, we ensure that the function
 860     ;; enriched-decode-display-prop is defined before it will be
 861     ;; shadowed by the letf below. Otherwise the version in
 862     ;; enriched.el may be loaded a bit later and used instead (for
 863     ;; the first time).
 864     (require 'enriched)
 865     (cl-letf (((symbol-function 'enriched-decode-display-prop)
 866                (lambda (start end &optional _param) (list start end))))
 867       (notmuch-show-insert-part-*/* msg part content-type nth depth button))))
 868
 869 (defun notmuch-show-get-mime-type-of-application/octet-stream (part)
 870   ;; If we can deduce a MIME type from the filename of the attachment,
 871   ;; we return that.
 872   (and (plist-get part :filename)
 873        (let ((extension (file-name-extension (plist-get part :filename))))
 874          (and extension
 875               (progn
 876                 (mailcap-parse-mimetypes)
 877                 (let ((mime-type (mailcap-extension-to-mime extension)))
 878                   (and mime-type
 879                        (not (string-equal mime-type "application/octet-stream"))
 880                        mime-type)))))))
 881
 882 (defun notmuch-show-insert-part-text/html (msg part content-type nth depth button)
 883   (if (eq mm-text-html-renderer 'shr)
 884       ;; It's easier to drive shr ourselves than to work around the
 885       ;; goofy things `mm-shr' does (like irreversibly taking over
 886       ;; content ID handling).
 887       ;; FIXME: If we block an image, offer a button to load external
 888       ;; images.
 889       (let ((shr-blocked-images notmuch-show-text/html-blocked-images))
 890         (notmuch-show--insert-part-text/html-shr msg part))
 891     ;; Otherwise, let message-mode do the heavy lifting
 892     ;;
 893     ;; w3m sets up a keymap which "leaks" outside the invisible region
 894     ;; and causes strange effects in notmuch. We set
 895     ;; mm-inline-text-html-with-w3m-keymap to nil to tell w3m not to
 896     ;; set a keymap (so the normal notmuch-show-mode-map remains).
 897     (let ((mm-inline-text-html-with-w3m-keymap nil)
 898           ;; FIXME: If we block an image, offer a button to load external
 899           ;; images.
 900           (gnus-blocked-images notmuch-show-text/html-blocked-images)
 901           (w3m-ignored-image-url-regexp notmuch-show-text/html-blocked-images))
 902       (notmuch-show-insert-part-*/* msg part content-type nth depth button))))
 903
 904 ;;; Functions used by notmuch-show--insert-part-text/html-shr
 905
 906 (declare-function libxml-parse-html-region "xml.c")
 907 (declare-function shr-insert-document "shr")
 908
 909 (defun notmuch-show--insert-part-text/html-shr (msg part)
 910   ;; Make sure shr is loaded before we start let-binding its globals
 911   (require 'shr)
 912   (let ((dom (let ((process-crypto notmuch-show-process-crypto))
 913                (with-temp-buffer
 914                  (insert (notmuch-get-bodypart-text msg part process-crypto))
 915                  (libxml-parse-html-region (point-min) (point-max)))))
 916         (shr-content-function
 917          (lambda (url)
 918            ;; shr strips the "cid:" part of URL, but doesn't
 919            ;; URL-decode it (see RFC 2392).
 920            (let ((cid (url-unhex-string url)))
 921              (car (notmuch-show--get-cid-content cid))))))
 922     (shr-insert-document dom)
 923     t))
 924
 925 (defun notmuch-show-insert-part-*/* (msg part content-type _nth _depth _button)
 926   ;; This handler _must_ succeed - it is the handler of last resort.
 927   (notmuch-mm-display-part-inline msg part content-type notmuch-show-process-crypto)
 928   t)
 929
 930 ;;; Functions for determining how to handle MIME parts.
 931
 932 (defun notmuch-show-handlers-for (content-type)
 933   "Return a list of content handlers for a part of type CONTENT-TYPE."
 934   (let (result)
 935     (mapc (lambda (func)
 936             (when (functionp func)
 937               (push func result)))
 938           ;; Reverse order of prefrence.
 939           (list (intern (concat "notmuch-show-insert-part-*/*"))
 940                 (intern (concat "notmuch-show-insert-part-"
 941                                 (car (split-string content-type "/"))
 942                                 "/*"))
 943                 (intern (concat "notmuch-show-insert-part-" content-type))))
 944     result))
 945
 946 ;;; Parts
 947
 948 (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth button)
 949   ;; Run the handlers until one of them succeeds.
 950   (cl-loop for handler in (notmuch-show-handlers-for content-type)
 951            until (condition-case err
 952                      (funcall handler msg part content-type nth depth button)
 953                    ;; Specifying `debug' here lets the debugger run if
 954                    ;; `debug-on-error' is non-nil.
 955                    ((debug error)
 956                     (insert "!!! Bodypart handler `" (prin1-to-string handler)
 957                             "' threw an error:\n"
 958                             "!!! " (error-message-string err) "\n")
 959                     nil))))
 960
 961 (defun notmuch-show-create-part-overlays (button beg end)
 962   "Add an overlay to the part between BEG and END."
 963   ;; If there is no button (i.e., the part is text/plain and the first
 964   ;; part) or if the part has no content then we don't make the part
 965   ;; toggleable.
 966   (when (and button (/= beg end))
 967     (button-put button 'overlay (make-overlay beg end))
 968     ;; Return true if we created an overlay.
 969     t))
 970
 971 (defun notmuch-show-record-part-information (part beg end)
 972   "Store PART as a text property from BEG to END."
 973   ;; Record part information.  Since we already inserted subparts,
 974   ;; don't override existing :notmuch-part properties.
 975   (notmuch-map-text-property beg end :notmuch-part
 976                              (lambda (v) (or v part)))
 977   ;; Make :notmuch-part front sticky and rear non-sticky so it stays
 978   ;; applied to the beginning of each line when we indent the
 979   ;; message.  Since we're operating on arbitrary renderer output,
 980   ;; watch out for sticky specs of t, which means all properties are
 981   ;; front-sticky/rear-nonsticky.
 982   (notmuch-map-text-property beg end 'front-sticky
 983                              (lambda (v)
 984                                (if (listp v)
 985                                    (cl-pushnew :notmuch-part v)
 986                                  v)))
 987   (notmuch-map-text-property beg end 'rear-nonsticky
 988                              (lambda (v)
 989                                (if (listp v)
 990                                    (cl-pushnew :notmuch-part v)
 991                                  v))))
 992
 993 (defun notmuch-show-lazy-part (part-args button)
 994   ;; Insert the lazy part after the button for the part. We would just
 995   ;; move to the start of the new line following the button and insert
 996   ;; the part but that point might have text properties (eg colours
 997   ;; from a message header etc) so instead we start from the last
 998   ;; character of the button by adding a newline and finish by
 999   ;; removing the extra newline from the end of the part.
1000   (save-excursion
1001     (goto-char (button-end button))
1002     (insert "\n")
1003     (let* ((inhibit-read-only t)
1004            ;; We need to use markers for the start and end of the part
1005            ;; because the part insertion functions do not guarantee
1006            ;; to leave point at the end of the part.
1007            (part-beg (copy-marker (point) nil))
1008            (part-end (copy-marker (point) t))
1009            ;; We have to save the depth as we can't find the depth
1010            ;; when narrowed.
1011            (depth (notmuch-show-get-depth)))
1012       (save-restriction
1013         (narrow-to-region part-beg part-end)
1014         (delete-region part-beg part-end)
1015         (apply #'notmuch-show-insert-bodypart-internal part-args)
1016         (indent-rigidly part-beg
1017                         part-end
1018                         (* notmuch-show-indent-messages-width depth)))
1019       (goto-char part-end)
1020       (delete-char 1)
1021       (notmuch-show-record-part-information (cadr part-args)
1022                                             (button-start button)
1023                                             part-end)
1024       ;; Create the overlay. If the lazy-part turned out to be empty/not
1025       ;; showable this returns nil.
1026       (notmuch-show-create-part-overlays button part-beg part-end))))
1027
1028 (defun notmuch-show-mime-type (part)
1029   "Return the correct mime-type to use for PART."
1030   (when-let ((content-type (plist-get part :content-type)))
1031     (setq content-type (downcase content-type))
1032     (or (and (string= content-type "application/octet-stream")
1033              (notmuch-show-get-mime-type-of-application/octet-stream part))
1034         (and (string= content-type "inline patch")
1035              "text/x-diff")
1036         content-type)))
1037
1038 ;; The following variable can be overridden by let bindings.
1039 (defvar notmuch-show-insert-header-p-function 'notmuch-show-insert-header-p
1040   "Specify which function decides which part headers get inserted.
1041
1042 The function should take two parameters, PART and HIDE, and
1043 should return non-NIL if a header button should be inserted for
1044 this part.")
1045
1046 (defun notmuch-show-insert-header-p (part _hide)
1047   ;; Show all part buttons except for the first part if it is text/plain.
1048   (let ((mime-type (notmuch-show-mime-type part)))
1049     (not (and (string= mime-type "text/plain")
1050               (<= (plist-get part :id) 1)))))
1051
1052 (defun notmuch-show-reply-insert-header-p-never (_part _hide)
1053   nil)
1054
1055 (defun notmuch-show-reply-insert-header-p-trimmed (part hide)
1056   (let ((mime-type (notmuch-show-mime-type part)))
1057     (and (not (notmuch-match-content-type mime-type "multipart/*"))
1058          (not hide))))
1059
1060 (defun notmuch-show-reply-insert-header-p-minimal (part hide)
1061   (let ((mime-type (notmuch-show-mime-type part)))
1062     (and (notmuch-match-content-type mime-type "text/*")
1063          (not hide))))
1064
1065 (defun notmuch-show-insert-bodypart (msg part depth &optional hide)
1066   "Insert the body part PART at depth DEPTH in the current thread.
1067
1068 HIDE determines whether to show or hide the part and the button
1069 as follows: If HIDE is nil, show the part and the button. If HIDE
1070 is t, hide the part initially and show the button."
1071   (let* ((content-type (plist-get part :content-type))
1072          (mime-type (notmuch-show-mime-type part))
1073          (nth (plist-get part :id))
1074          (height (plist-get msg :height))
1075          (long (and (notmuch-match-content-type mime-type "text/*")
1076                     (> notmuch-show-max-text-part-size 0)
1077                     (> (length (plist-get part :content))
1078                        notmuch-show-max-text-part-size)))
1079          (deep (and notmuch-show-depth-limit
1080                     (> depth notmuch-show-depth-limit)))
1081          (high (and notmuch-show-height-limit
1082                     (> height notmuch-show-height-limit)))
1083          (beg (point))
1084          ;; This default header-p function omits the part button for
1085          ;; the first (or only) part if this is text/plain.
1086          (button (and (or deep long high
1087                           (funcall notmuch-show-insert-header-p-function part hide))
1088                       (notmuch-show-insert-part-header
1089                        nth mime-type
1090                        (and content-type (downcase content-type))
1091                        (plist-get part :filename))))
1092          ;; Hide the part initially if HIDE is t, or if it is too long/deep
1093          ;; and we have a button to allow toggling.
1094          (show-part (not (or (equal hide t)
1095                              (and deep button)
1096                              (and high button)
1097                              (and long button))))
1098          (content-beg (point)))
1099     ;; Store the computed mime-type for later use (e.g. by attachment handlers).
1100     (plist-put part :computed-type mime-type)
1101     (if show-part
1102         (notmuch-show-insert-bodypart-internal msg part mime-type nth depth button)
1103       (when button
1104         (button-put button :notmuch-lazy-part
1105                     (list msg part mime-type nth depth button))))
1106     ;; Some of the body part handlers leave point somewhere up in the
1107     ;; part, so we make sure that we're down at the end.
1108     (goto-char (point-max))
1109     ;; Ensure that the part ends with a carriage return.
1110     (unless (bolp)
1111       (insert "\n"))
1112     ;; We do not create the overlay for hidden (lazy) parts until
1113     ;; they are inserted.
1114     (if show-part
1115         (notmuch-show-create-part-overlays button content-beg (point))
1116       (save-excursion
1117         (notmuch-show-toggle-part-invisibility button)))
1118     (notmuch-show-record-part-information part beg (point))))
1119
1120 (defun notmuch-show-insert-body (msg body depth)
1121   "Insert the body BODY at depth DEPTH in the current thread."
1122   ;; Register all content IDs for this message.  According to RFC
1123   ;; 2392, content IDs are *global*, but it's okay if an MUA treats
1124   ;; them as only global within a message.
1125   (notmuch-show--register-cids msg (car body))
1126   (mapc (lambda (part) (notmuch-show-insert-bodypart msg part depth)) body))
1127
1128 (defun notmuch-show-make-symbol (type)
1129   (make-symbol (concat "notmuch-show-" type)))
1130
1131 (defun notmuch-show-strip-re (string)
1132   (replace-regexp-in-string "^\\([Rr]e: *\\)+" "" string))
1133
1134 (defvar notmuch-show-previous-subject "")
1135 (make-variable-buffer-local 'notmuch-show-previous-subject)
1136
1137 (defun notmuch-show-choose-duplicate (duplicate)
1138   (interactive "Nduplicate: ")
1139   (let ((count (length (notmuch-show-get-prop :filename))))
1140     (when (or (> duplicate count)
1141               (< duplicate 1))
1142       (error "Duplicate %d out of range [1,%d]" duplicate count)))
1143   (notmuch-show-move-to-message-top)
1144   (save-excursion
1145     (let* ((extent (notmuch-show-message-extent))
1146            (id (notmuch-show-get-message-id))
1147            (depth (notmuch-show-get-depth))
1148            (inhibit-read-only t)
1149            (new-msg (notmuch--run-show (list id) duplicate)))
1150       ;; clean up existing overlays to avoid extending them.
1151       (dolist (o (overlays-in (car extent) (cdr extent)))
1152         (delete-overlay o))
1153       ;; pretend insertion is happening at end of buffer
1154       (narrow-to-region (point-min) (car extent))
1155       ;; Insert first, then delete, to avoid marker for start of next
1156       ;; message being in same place as the start of this one.
1157       (notmuch-show-insert-msg new-msg depth)
1158       (widen)
1159       (delete-region (point) (cdr extent)))))
1160
1161 (defun notmuch-show-insert-msg (msg depth)
1162   "Insert the message MSG at depth DEPTH in the current thread."
1163   (let* ((headers (plist-get msg :headers))
1164          (duplicate (or (plist-get msg :duplicate) 0))
1165          (files (length (plist-get msg :filename)))
1166          ;; Indentation causes the buffer offset of the start/end
1167          ;; points to move, so we must use markers.
1168          message-start message-end
1169          content-start content-end
1170          headers-start headers-end
1171          (bare-subject (notmuch-show-strip-re (plist-get headers :Subject))))
1172     (setq message-start (point-marker))
1173     (notmuch-show-insert-headerline headers
1174                                     (or (and notmuch-show-relative-dates
1175                                              (plist-get msg :date_relative))
1176                                         (plist-get headers :Date))
1177                                     (plist-get msg :tags) depth duplicate files)
1178     (setq content-start (point-marker))
1179     ;; Set `headers-start' to point after the 'Subject:' header to be
1180     ;; compatible with the existing implementation. This just sets it
1181     ;; to after the first header.
1182     (notmuch-show-insert-headers headers)
1183     (save-excursion
1184       (goto-char content-start)
1185       ;; If the subject of this message is the same as that of the
1186       ;; previous message, don't display it when this message is
1187       ;; collapsed.
1188       (unless (string= notmuch-show-previous-subject bare-subject)
1189         (forward-line 1))
1190       (setq headers-start (point-marker)))
1191     (setq headers-end (point-marker))
1192     (setq notmuch-show-previous-subject bare-subject)
1193     ;; A blank line between the headers and the body.
1194     (insert "\n")
1195     (notmuch-show-insert-body msg (plist-get msg :body)
1196                               (if notmuch-show-indent-content depth 0))
1197     ;; Ensure that the body ends with a newline.
1198     (unless (bolp)
1199       (insert "\n"))
1200     (setq content-end (point-marker))
1201     ;; Indent according to the depth in the thread.
1202     (when notmuch-show-indent-content
1203       (indent-rigidly content-start
1204                       content-end
1205                       (* notmuch-show-indent-messages-width depth)))
1206     (setq message-end (point-max-marker))
1207     ;; Save the extents of this message over the whole text of the
1208     ;; message.
1209     (put-text-property message-start message-end
1210                        :notmuch-message-extent
1211                        (cons message-start message-end))
1212     ;; Create overlays used to control visibility
1213     (plist-put msg :headers-overlay (make-overlay headers-start headers-end))
1214     (plist-put msg :message-overlay (make-overlay headers-start content-end))
1215     (plist-put msg :depth depth)
1216     ;; Save the properties for this message. Currently this saves the
1217     ;; entire message (augmented it with other stuff), which seems
1218     ;; like overkill. We might save a reduced subset (for example, not
1219     ;; the content).
1220     (notmuch-show-set-message-properties msg)
1221     ;; Set header visibility.
1222     (notmuch-show-headers-visible msg notmuch-message-headers-visible)
1223     ;; Message visibility depends on whether it matched the search
1224     ;; criteria.
1225     (notmuch-show-message-visible msg (and (plist-get msg :match)
1226                                            (not (plist-get msg :excluded))))))
1227
1228 ;;; Toggle commands
1229
1230 (defun notmuch-show-toggle-process-crypto ()
1231   "Toggle the processing of cryptographic MIME parts."
1232   (interactive)
1233   (setq notmuch-show-process-crypto (not notmuch-show-process-crypto))
1234   (message (if notmuch-show-process-crypto
1235                "Processing cryptographic MIME parts."
1236              "Not processing cryptographic MIME parts."))
1237   (notmuch-show-refresh-view))
1238
1239 (defun notmuch-show-toggle-elide-non-matching ()
1240   "Toggle the display of non-matching messages."
1241   (interactive)
1242   (setq notmuch-show-elide-non-matching-messages
1243         (not notmuch-show-elide-non-matching-messages))
1244   (message (if notmuch-show-elide-non-matching-messages
1245                "Showing matching messages only."
1246              "Showing all messages."))
1247   (notmuch-show-refresh-view))
1248
1249 (defun notmuch-show-toggle-thread-indentation ()
1250   "Toggle the indentation of threads."
1251   (interactive)
1252   (setq notmuch-show-indent-content (not notmuch-show-indent-content))
1253   (message (if notmuch-show-indent-content
1254                "Content is indented."
1255              "Content is not indented."))
1256   (notmuch-show-refresh-view))
1257
1258 ;;; Main insert functions
1259
1260 (defun notmuch-show-insert-tree (tree depth)
1261   "Insert the message tree TREE at depth DEPTH in the current thread."
1262   (let ((msg (car tree))
1263         (replies (cadr tree)))
1264     ;; We test whether there is a message or just some replies.
1265     (when msg
1266       (notmuch-show--mark-height tree)
1267       (notmuch-show-insert-msg msg depth))
1268     (notmuch-show-insert-thread replies (1+ depth))))
1269
1270 (defun notmuch-show-insert-thread (thread depth)
1271   "Insert the thread THREAD at depth DEPTH in the current forest."
1272   (mapc (lambda (tree) (notmuch-show-insert-tree tree depth)) thread))
1273
1274 (defun notmuch-show-insert-forest (forest)
1275   "Insert the forest of threads FOREST."
1276   (mapc (lambda (thread) (notmuch-show-insert-thread thread 0)) forest))
1277
1278 ;;; Link buttons
1279
1280 (defvar notmuch-id-regexp
1281   (concat
1282    ;; Match the id: prefix only if it begins a word (to disallow, for
1283    ;; example, matching cid:).
1284    "\\<id:\\("
1285    ;; If the term starts with a ", then parse Xapian's quoted boolean
1286    ;; term syntax, which allows for anything as long as embedded
1287    ;; double quotes escaped by doubling them.  We also disallow
1288    ;; newlines (which Xapian allows) to prevent runaway terms.
1289    "\"\\([^\"\n]\\|\"\"\\)*\""
1290    ;; Otherwise, parse Xapian's unquoted syntax, which goes up to the
1291    ;; next space or ).  We disallow [.,;] as the last character
1292    ;; because these are probably part of the surrounding text, and not
1293    ;; part of the id.  This doesn't match single character ids; meh.
1294    "\\|[^\"[:space:])][^[:space:])]*[^])[:space:].,:;?!]"
1295    "\\)")
1296   "The regexp used to match id: links in messages.")
1297
1298 (defvar notmuch-mid-regexp
1299   ;; goto-address-url-regexp matched cid: links, which have the same
1300   ;; grammar as the message ID part of a mid: link.  Construct the
1301   ;; regexp using the same technique as goto-address-url-regexp.
1302   (concat "\\<mid:\\(" thing-at-point-url-path-regexp "\\)")
1303   "The regexp used to match mid: links in messages.
1304
1305 See RFC 2392.")
1306
1307 (defun notmuch-show-buttonise-links (start end)
1308   "Buttonise URLs and mail addresses between START and END.
1309
1310 This also turns id:\"<message id>\"-parts and mid: links into
1311 buttons for a corresponding notmuch search."
1312   (goto-address-fontify-region start end)
1313   (save-excursion
1314     (let (links
1315           (beg-line (progn (goto-char start) (line-beginning-position)))
1316           (end-line (progn (goto-char end) (line-end-position))))
1317       (goto-char beg-line)
1318       (while (re-search-forward notmuch-id-regexp end-line t)
1319         (push (list (match-beginning 0) (match-end 0)
1320                     (match-string-no-properties 0)) links))
1321       (goto-char beg-line)
1322       (while (re-search-forward notmuch-mid-regexp end-line t)
1323         (let* ((mid-cid (match-string-no-properties 1))
1324                (mid (save-match-data
1325                       (string-match "^[^/]*" mid-cid)
1326                       (url-unhex-string (match-string 0 mid-cid)))))
1327           (push (list (match-beginning 0) (match-end 0)
1328                       (notmuch-id-to-query mid)) links)))
1329       (pcase-dolist (`(,beg ,end ,link) links)
1330         ;; Remove the overlay created by goto-address-mode
1331         (remove-overlays beg end 'goto-address t)
1332         (make-text-button beg end
1333                           :type 'notmuch-button-type
1334                           'action `(lambda (arg)
1335                                      (notmuch-show ,link current-prefix-arg))
1336                           'follow-link t
1337                           'help-echo "Mouse-1, RET: search for this message"
1338                           'face goto-address-mail-face)))))
1339
1340 ;;; Show command
1341
1342 ;;;###autoload
1343 (defun notmuch-show (thread-id &optional elide-toggle parent-buffer query-context buffer-name)
1344   "Run \"notmuch show\" with the given thread ID and display results.
1345
1346 ELIDE-TOGGLE, if non-nil, inverts the default elide behavior.
1347
1348 The optional PARENT-BUFFER is the notmuch-search buffer from
1349 which this notmuch-show command was executed, (so that the
1350 next thread from that buffer can be show when done with this
1351 one).
1352
1353 The optional QUERY-CONTEXT is a notmuch search term. Only
1354 messages from the thread matching this search term are shown if
1355 non-nil.
1356
1357 The optional BUFFER-NAME provides the name of the buffer in
1358 which the message thread is shown. If it is nil (which occurs
1359 when the command is called interactively) the argument to the
1360 function is used.
1361
1362 Returns the buffer containing the messages, or NIL if no messages
1363 matched."
1364   (interactive "sNotmuch show: \nP")
1365   (let ((buffer-name (generate-new-buffer-name
1366                       (or buffer-name
1367                           (concat "*notmuch-" thread-id "*"))))
1368         (mm-inline-override-types (notmuch--inline-override-types)))
1369
1370     (pop-to-buffer-same-window (get-buffer-create buffer-name))
1371     ;; No need to track undo information for this buffer.
1372     (setq buffer-undo-list t)
1373     (notmuch-show-mode)
1374     ;; Set various buffer local variables to their appropriate initial
1375     ;; state. Do this after enabling `notmuch-show-mode' so that they
1376     ;; aren't wiped out.
1377     (setq notmuch-show-thread-id thread-id)
1378     (setq notmuch-show-parent-buffer parent-buffer)
1379     (setq notmuch-show-query-context
1380           (if (or (string= query-context "")
1381                   (string= query-context "*"))
1382               nil
1383             query-context))
1384     (setq notmuch-show-process-crypto notmuch-crypto-process-mime)
1385     ;; If `elide-toggle', invert the default value.
1386     (setq notmuch-show-elide-non-matching-messages
1387           (if elide-toggle
1388               (not notmuch-show-only-matching-messages)
1389             notmuch-show-only-matching-messages))
1390     (add-hook 'post-command-hook #'notmuch-show-command-hook nil t)
1391     (jit-lock-register #'notmuch-show-buttonise-links)
1392     (notmuch-tag-clear-cache)
1393     (let ((inhibit-read-only t))
1394       (if (notmuch-show--build-buffer)
1395           ;; Messages were inserted into the buffer.
1396           (current-buffer)
1397         ;; No messages were inserted - presumably none matched the
1398         ;; query.
1399         (kill-buffer (current-buffer))
1400         (ding)
1401         (message "No messages matched the query!")
1402         nil))))
1403
1404 (defun notmuch-show--build-queries (thread context)
1405   "Return a list of queries to try for this search.
1406
1407 THREAD and CONTEXT are both strings, though CONTEXT may be nil.
1408 When CONTEXT is not nil, the first query is the conjunction of it
1409 and THREAD.  The next query is THREAD alone, and serves as a
1410 fallback if the prior matches no messages."
1411   (let (queries)
1412     (push (list thread) queries)
1413     (when context
1414       (push (list thread "and (" context ")") queries))
1415     queries))
1416
1417 (defun notmuch-show--header-line-format ()
1418   "Compute the header line format of a notmuch-show buffer."
1419   (when notmuch-show-header-line
1420     (let* ((s (notmuch-sanitize
1421                (notmuch-show-strip-re (notmuch-show-get-subject))))
1422            (subject (replace-regexp-in-string "%" "%%" s)))
1423       (cond ((stringp notmuch-show-header-line)
1424              (format-spec notmuch-show-header-line `((?s . ,subject))))
1425             ((functionp notmuch-show-header-line)
1426              (funcall notmuch-show-header-line subject))
1427             (notmuch-show-header-line subject)))))
1428
1429 (defun notmuch-show--build-buffer (&optional state)
1430   "Display messages matching the current buffer context.
1431
1432 Apply the previously saved STATE if supplied, otherwise show the
1433 first relevant message.
1434
1435 If no messages match the query return NIL."
1436   (let* ((cli-args (list "--exclude=false"))
1437          (cli-args (if notmuch-show-elide-non-matching-messages (cons "--entire-thread=false" cli-args) cli-args))
1438          ;; "part 0 is the whole message (headers and body)" notmuch-show(1)
1439          (cli-args (if notmuch-show-single-message (cons "--part=0" cli-args) cli-args))
1440          (queries (notmuch-show--build-queries
1441                    notmuch-show-thread-id notmuch-show-query-context))
1442          (forest nil)
1443          ;; Must be reset every time we are going to start inserting
1444          ;; messages into the buffer.
1445          (notmuch-show-previous-subject ""))
1446     ;; Use results from the first query that returns some.
1447     (while (and (not forest) queries)
1448       (setq forest (notmuch--run-show
1449                     (append cli-args (list "'") (car queries) (list "'"))))
1450       (when (and forest notmuch-show-single-message)
1451         (setq forest (list (list (list forest)))))
1452       (setq queries (cdr queries)))
1453     (when forest
1454       (notmuch-show-insert-forest forest)
1455       ;; Store the original tags for each message so that we can
1456       ;; display changes.
1457       (notmuch-show-mapc
1458        (lambda () (notmuch-show-set-prop :orig-tags (notmuch-show-get-tags))))
1459       (setq header-line-format (notmuch-show--header-line-format))
1460       (run-hooks 'notmuch-show-hook)
1461       (if state
1462           (notmuch-show-apply-state state)
1463         ;; With no state to apply, just go to the first message.
1464         (notmuch-show-goto-first-wanted-message)))
1465     ;; Report back to the caller whether any messages matched.
1466     forest))
1467
1468 ;;; Refresh command
1469
1470 (defun notmuch-show-capture-state ()
1471   "Capture the state of the current buffer.
1472
1473 This includes:
1474  - the list of open messages,
1475  - the combination of current message id with/for each visible window."
1476   (let* ((win-list (get-buffer-window-list (current-buffer) nil t))
1477          (win-id-combo (mapcar (lambda (win)
1478                                  (with-selected-window win
1479                                    (list win (notmuch-show-get-message-id))))
1480                                win-list)))
1481     (list win-id-combo (notmuch-show-get-message-ids-for-open-messages))))
1482
1483 (defun notmuch-show-get-query ()
1484   "Return the current query in this show buffer."
1485   (if notmuch-show-query-context
1486       (concat notmuch-show-thread-id
1487               " and ("
1488               notmuch-show-query-context
1489               ")")
1490     notmuch-show-thread-id))
1491
1492 (defun notmuch-show-goto-message (msg-id)
1493   "Go to message with msg-id."
1494   (goto-char (point-min))
1495   (unless (cl-loop if (string= msg-id (notmuch-show-get-message-id))
1496                    return t
1497                    until (not (notmuch-show-goto-message-next)))
1498     (goto-char (point-min))
1499     (message "Message-id not found."))
1500   (notmuch-show-message-adjust))
1501
1502 (defun notmuch-show-apply-state (state)
1503   "Apply STATE to the current buffer.
1504
1505 This includes:
1506  - opening the messages previously opened,
1507  - closing all other messages,
1508  - moving to the correct current message in every displayed window."
1509   (let ((win-msg-alist (car state))
1510         (open (cadr state)))
1511     ;; Open those that were open.
1512     (goto-char (point-min))
1513     (cl-loop do (notmuch-show-message-visible
1514                  (notmuch-show-get-message-properties)
1515                  (member (notmuch-show-get-message-id) open))
1516              until (not (notmuch-show-goto-message-next)))
1517     (dolist (win-msg-pair win-msg-alist)
1518       (with-selected-window (car win-msg-pair)
1519         ;; Go to the previously open message in this window
1520         (notmuch-show-goto-message (cadr win-msg-pair))))))
1521
1522 (defun notmuch-show-refresh-view (&optional reset-state)
1523   "Refresh the current view.
1524
1525 Refreshes the current view, observing changes in display
1526 preferences. If invoked with a prefix argument (or RESET-STATE is
1527 non-nil) then the state of the buffer (open/closed messages) is
1528 reset based on the original query."
1529   (interactive "P")
1530   (let ((inhibit-read-only t)
1531         (mm-inline-override-types (notmuch--inline-override-types))
1532         (state (unless reset-state
1533                  (notmuch-show-capture-state))))
1534     ;; `erase-buffer' does not seem to remove overlays, which can lead
1535     ;; to weird effects such as remaining images, so remove them
1536     ;; manually.
1537     (remove-overlays)
1538     (erase-buffer)
1539     (unless (notmuch-show--build-buffer state)
1540       ;; No messages were inserted.
1541       (kill-buffer (current-buffer))
1542       (ding)
1543       (message "Refreshing the buffer resulted in no messages!"))))
1544
1545 ;;; Keymaps
1546
1547 (defvar notmuch-show-stash-map
1548   (let ((map (make-sparse-keymap)))
1549     (define-key map "c" 'notmuch-show-stash-cc)
1550     (define-key map "d" 'notmuch-show-stash-date)
1551     (define-key map "F" 'notmuch-show-stash-filename)
1552     (define-key map "f" 'notmuch-show-stash-from)
1553     (define-key map "i" 'notmuch-show-stash-message-id)
1554     (define-key map "I" 'notmuch-show-stash-message-id-stripped)
1555     (define-key map "s" 'notmuch-show-stash-subject)
1556     (define-key map "T" 'notmuch-show-stash-tags)
1557     (define-key map "t" 'notmuch-show-stash-to)
1558     (define-key map "l" 'notmuch-show-stash-mlarchive-link)
1559     (define-key map "L" 'notmuch-show-stash-mlarchive-link-and-go)
1560     (define-key map "G" 'notmuch-show-stash-git-send-email)
1561     (define-key map "?" 'notmuch-subkeymap-help)
1562     map)
1563   "Submap for stash commands.")
1564 (fset 'notmuch-show-stash-map notmuch-show-stash-map)
1565
1566 (defvar notmuch-show-part-map
1567   (let ((map (make-sparse-keymap)))
1568     (define-key map "s" 'notmuch-show-save-part)
1569     (define-key map "v" 'notmuch-show-view-part)
1570     (define-key map "o" 'notmuch-show-interactively-view-part)
1571     (define-key map "|" 'notmuch-show-pipe-part)
1572     (define-key map "m" 'notmuch-show-choose-mime-of-part)
1573     (define-key map "?" 'notmuch-subkeymap-help)
1574     map)
1575   "Submap for part commands.")
1576 (fset 'notmuch-show-part-map notmuch-show-part-map)
1577
1578 (defvar notmuch-show-mode-map
1579   (let ((map (make-sparse-keymap)))
1580     (set-keymap-parent map notmuch-common-keymap)
1581     (define-key map "Z" 'notmuch-tree-from-show-current-query)
1582     (define-key map "U" 'notmuch-unthreaded-from-show-current-query)
1583     (define-key map (kbd "<C-tab>") 'widget-backward)
1584     (define-key map (kbd "M-TAB") 'notmuch-show-previous-button)
1585     (define-key map (kbd "<backtab>") 'notmuch-show-previous-button)
1586     (define-key map (kbd "TAB") 'notmuch-show-next-button)
1587     (define-key map "f" 'notmuch-show-forward-message)
1588     (define-key map "F" 'notmuch-show-forward-open-messages)
1589     (define-key map "b" 'notmuch-show-resend-message)
1590     (define-key map "l" 'notmuch-show-filter-thread)
1591     (define-key map "r" 'notmuch-show-reply-sender)
1592     (define-key map "R" 'notmuch-show-reply)
1593     (define-key map "|" 'notmuch-show-pipe-message)
1594     (define-key map "w" 'notmuch-show-save-attachments)
1595     (define-key map "V" 'notmuch-show-view-raw-message)
1596     (define-key map "e" 'notmuch-show-resume-message)
1597     (define-key map "c" 'notmuch-show-stash-map)
1598     (define-key map "h" 'notmuch-show-toggle-visibility-headers)
1599     (define-key map "k" 'notmuch-tag-jump)
1600     (define-key map "*" 'notmuch-show-tag-all)
1601     (define-key map "-" 'notmuch-show-remove-tag)
1602     (define-key map "+" 'notmuch-show-add-tag)
1603     (define-key map "X" 'notmuch-show-archive-thread-then-exit)
1604     (define-key map "x" 'notmuch-show-archive-message-then-next-or-exit)
1605     (define-key map "A" 'notmuch-show-archive-thread-then-next)
1606     (define-key map "a" 'notmuch-show-archive-message-then-next-or-next-thread)
1607     (define-key map "N" 'notmuch-show-next-message)
1608     (define-key map "P" 'notmuch-show-previous-message)
1609     (define-key map "n" 'notmuch-show-next-open-message)
1610     (define-key map "p" 'notmuch-show-previous-open-message)
1611     (define-key map (kbd "M-n") 'notmuch-show-next-thread-show)
1612     (define-key map (kbd "M-p") 'notmuch-show-previous-thread-show)
1613     (define-key map (kbd "DEL") 'notmuch-show-rewind)
1614     (define-key map " " 'notmuch-show-advance-and-archive)
1615     (define-key map (kbd "M-RET") 'notmuch-show-open-or-close-all)
1616     (define-key map (kbd "RET") 'notmuch-show-toggle-message)
1617     (define-key map "#" 'notmuch-show-print-message)
1618     (define-key map "!" 'notmuch-show-toggle-elide-non-matching)
1619     (define-key map "$" 'notmuch-show-toggle-process-crypto)
1620     (define-key map "%" 'notmuch-show-choose-duplicate)
1621     (define-key map "<" 'notmuch-show-toggle-thread-indentation)
1622     (define-key map "t" 'toggle-truncate-lines)
1623     (define-key map "." 'notmuch-show-part-map)
1624     (define-key map "B" 'notmuch-show-browse-urls)
1625     map)
1626   "Keymap for \"notmuch show\" buffers.")
1627
1628 ;;; Mode
1629
1630 (define-derived-mode notmuch-show-mode fundamental-mode "notmuch-show"
1631   "Major mode for viewing a thread with notmuch.
1632
1633 This buffer contains the results of the \"notmuch show\" command
1634 for displaying a single thread of email from your email archives.
1635
1636 By default, various components of email messages, (citations,
1637 signatures, already-read messages), are hidden. You can make
1638 these parts visible by clicking with the mouse button or by
1639 pressing RET after positioning the cursor on a hidden part, (for
1640 which \\[notmuch-show-next-button] and \\[notmuch-show-previous-button] are helpful).
1641
1642 Reading the thread sequentially is well-supported by pressing
1643 \\[notmuch-show-advance-and-archive]. This will scroll the current message (if necessary), advance
1644 to the next message, or advance to the next thread (if already on
1645 the last message of a thread).
1646
1647 Other commands are available to read or manipulate the thread
1648 more selectively, (such as '\\[notmuch-show-next-message]' and '\\[notmuch-show-previous-message]' to advance to messages
1649 without removing any tags, and '\\[notmuch-show-archive-thread]' to archive an entire thread
1650 without scrolling through with \\[notmuch-show-advance-and-archive]).
1651
1652 You can add or remove arbitrary tags from the current message with
1653 '\\[notmuch-show-add-tag]' or '\\[notmuch-show-remove-tag]'.
1654
1655 All currently available key bindings:
1656
1657 \\{notmuch-show-mode-map}"
1658   (setq notmuch-buffer-refresh-function #'notmuch-show-refresh-view)
1659   (setq buffer-read-only t)
1660   (setq truncate-lines t)
1661   (setq imenu-prev-index-position-function
1662         #'notmuch-show-imenu-prev-index-position-function)
1663   (setq imenu-extract-index-name-function
1664         #'notmuch-show-imenu-extract-index-name-function))
1665
1666 ;;; Tree commands
1667
1668 (defun notmuch-tree-from-show-current-query ()
1669   "Call notmuch tree with the current query."
1670   (interactive)
1671   (notmuch-tree notmuch-show-thread-id
1672                 notmuch-show-query-context
1673                 (notmuch-show-get-message-id)))
1674
1675 (defun notmuch-unthreaded-from-show-current-query ()
1676   "Call notmuch unthreaded with the current query."
1677   (interactive)
1678   (notmuch-unthreaded notmuch-show-thread-id
1679                       notmuch-show-query-context
1680                       (notmuch-show-get-message-id)))
1681
1682 ;;; Movement related functions.
1683
1684 (defun notmuch-show-move-to-message-top ()
1685   (goto-char (notmuch-show-message-top)))
1686
1687 (defun notmuch-show-move-to-message-bottom ()
1688   (goto-char (notmuch-show-message-bottom)))
1689
1690 ;; There's some strangeness here where a text property applied to a
1691 ;; region a->b is not found when point is at b. We walk backwards
1692 ;; until finding the property.
1693 (defun notmuch-show-message-extent ()
1694   "Return a cons cell containing the start and end buffer offset
1695 of the current message."
1696   (let (r)
1697     (save-excursion
1698       (while (not (setq r (get-text-property (point) :notmuch-message-extent)))
1699         (backward-char)))
1700     r))
1701
1702 (defun notmuch-show-message-top ()
1703   (car (notmuch-show-message-extent)))
1704
1705 (defun notmuch-show-message-bottom ()
1706   (cdr (notmuch-show-message-extent)))
1707
1708 (defun notmuch-show-goto-message-next ()
1709   (let ((start (point)))
1710     (notmuch-show-move-to-message-bottom)
1711     (if (not (eobp))
1712         t
1713       (goto-char start)
1714       nil)))
1715
1716 (defun notmuch-show-goto-message-previous ()
1717   (notmuch-show-move-to-message-top)
1718   (if (bobp)
1719       nil
1720     (backward-char)
1721     (notmuch-show-move-to-message-top)
1722     t))
1723
1724 (defun notmuch-show-mapc (function)
1725   "Iterate through all messages in the current thread with
1726 `notmuch-show-goto-message-next' and call FUNCTION for side
1727 effects."
1728   (save-excursion
1729     (goto-char (point-min))
1730     (cl-loop do (funcall function)
1731              while (notmuch-show-goto-message-next))))
1732
1733 ;;; Functions relating to the visibility of messages and their components.
1734
1735 (defun notmuch-show-message-visible (props visible-p)
1736   (overlay-put (plist-get props :message-overlay) 'invisible (not visible-p))
1737   (notmuch-show-set-prop :message-visible visible-p props))
1738
1739 (defun notmuch-show-headers-visible (props visible-p)
1740   (overlay-put (plist-get props :headers-overlay) 'invisible (not visible-p))
1741   (notmuch-show-set-prop :headers-visible visible-p props))
1742
1743 ;;; Functions for setting and getting attributes of the current message.
1744
1745 (defun notmuch-show-set-message-properties (props)
1746   (save-excursion
1747     (notmuch-show-move-to-message-top)
1748     (put-text-property (point) (+ (point) 1)
1749                        :notmuch-message-properties props)))
1750
1751 (defun notmuch-show-get-message-properties ()
1752   "Return the properties of the current message as a plist.
1753
1754 Some useful entries are:
1755 :headers - Property list containing the headers :Date, :Subject, :From, etc.
1756 :body - Body of the message
1757 :tags - Tags for this message"
1758   (save-excursion
1759     (notmuch-show-move-to-message-top)
1760     (get-text-property (point) :notmuch-message-properties)))
1761
1762 (defun notmuch-show-get-part-properties ()
1763   "Return the properties of the innermost part containing point.
1764
1765 This is the part property list retrieved from the CLI.  Signals
1766 an error if there is no part containing point."
1767   (or (get-text-property (point) :notmuch-part)
1768       (error "No message part here")))
1769
1770 (defun notmuch-show-set-prop (prop val &optional props)
1771   (let ((inhibit-read-only t)
1772         (props (or props
1773                    (notmuch-show-get-message-properties))))
1774     (plist-put props prop val)
1775     (notmuch-show-set-message-properties props)))
1776
1777 (defun notmuch-show-get-prop (prop &optional props)
1778   "Get property PROP from current message in show or tree mode.
1779
1780 It gets property PROP from PROPS or, if PROPS is nil, the current
1781 message in either tree or show. This means that several utility
1782 functions in notmuch-show can be used directly by notmuch-tree as
1783 they just need the correct message properties."
1784   (plist-get (or props
1785                  (cond ((eq major-mode 'notmuch-show-mode)
1786                         (notmuch-show-get-message-properties))
1787                        ((eq major-mode 'notmuch-tree-mode)
1788                         (notmuch-tree-get-message-properties))
1789                        (t nil)))
1790              prop))
1791
1792 (defun notmuch-show-get-message-id (&optional bare)
1793   "Return an id: query for the Message-Id of the current message.
1794
1795 If optional argument BARE is non-nil, return
1796 the Message-Id without id: prefix and escaping."
1797   (if bare
1798       (notmuch-show-get-prop :id)
1799     (notmuch-id-to-query (notmuch-show-get-prop :id))))
1800
1801 (defun notmuch-show-get-messages-ids ()
1802   "Return all id: queries of messages in the current thread."
1803   (let ((message-ids))
1804     (notmuch-show-mapc
1805      (lambda () (push (notmuch-show-get-message-id) message-ids)))
1806     message-ids))
1807
1808 (defun notmuch-show-get-messages-ids-search ()
1809   "Return a search string for all message ids of messages in the
1810 current thread."
1811   (mapconcat 'identity (notmuch-show-get-messages-ids) " or "))
1812
1813 ;; dme: Would it make sense to use a macro for many of these?
1814
1815 (defun notmuch-show-get-filename ()
1816   "Return the filename of the current message."
1817   (let ((duplicate (notmuch-show-get-duplicate)))
1818     (nth (1- duplicate) (notmuch-show-get-prop :filename))))
1819
1820 (defun notmuch-show-get-header (header &optional props)
1821   "Return the named header of the current message, if any."
1822   (plist-get (notmuch-show-get-prop :headers props) header))
1823
1824 (defun notmuch-show-get-cc ()
1825   (notmuch-show-get-header :Cc))
1826
1827 (defun notmuch-show-get-date ()
1828   (notmuch-show-get-header :Date))
1829
1830 (defun notmuch-show-get-duplicate ()
1831   ;; if no duplicate property exists, assume first file
1832   (or (notmuch-show-get-prop :duplicate) 1))
1833
1834 (defun notmuch-show-get-timestamp ()
1835   (notmuch-show-get-prop :timestamp))
1836
1837 (defun notmuch-show-get-from ()
1838   (notmuch-show-get-header :From))
1839
1840 (defun notmuch-show-get-subject ()
1841   (notmuch-show-get-header :Subject))
1842
1843 (defun notmuch-show-get-to ()
1844   (notmuch-show-get-header :To))
1845
1846 (defun notmuch-show-get-depth ()
1847   (notmuch-show-get-prop :depth))
1848
1849 (defun notmuch-show-set-tags (tags)
1850   "Set the tags of the current message."
1851   (notmuch-show-set-prop :tags tags)
1852   (notmuch-show-update-tags tags))
1853
1854 (defun notmuch-show-get-tags ()
1855   "Return the tags of the current message."
1856   (notmuch-show-get-prop :tags))
1857
1858 (defun notmuch-show-message-visible-p ()
1859   "Is the current message visible?"
1860   (notmuch-show-get-prop :message-visible))
1861
1862 (defun notmuch-show-headers-visible-p ()
1863   "Are the headers of the current message visible?"
1864   (notmuch-show-get-prop :headers-visible))
1865
1866 (put 'notmuch-show-mark-read 'notmuch-prefix-doc
1867      "Mark the current message as unread.")
1868 (defun notmuch-show-mark-read (&optional unread)
1869   "Mark the current message as read.
1870
1871 Mark the current message as read by applying the tag changes in
1872 `notmuch-show-mark-read-tags' to it (remove the \"unread\" tag by
1873 default). If a prefix argument is given, the message will be
1874 marked as unread, i.e. the tag changes in
1875 `notmuch-show-mark-read-tags' will be reversed."
1876   (interactive "P")
1877   (when notmuch-show-mark-read-tags
1878     (apply 'notmuch-show-tag-message
1879            (notmuch-tag-change-list notmuch-show-mark-read-tags unread))))
1880
1881 (defun notmuch-show-seen-current-message (_start _end)
1882   "Mark the current message read if it is open.
1883
1884 We only mark it read once: if it is changed back then that is a
1885 user decision and we should not override it."
1886   (when (and (notmuch-show-message-visible-p)
1887              (not (notmuch-show-get-prop :seen)))
1888     (notmuch-show-mark-read)
1889     (notmuch-show-set-prop :seen t)))
1890
1891 (defvar notmuch-show--seen-has-errored nil)
1892 (make-variable-buffer-local 'notmuch-show--seen-has-errored)
1893
1894 (defun notmuch-show-command-hook ()
1895   (when (eq major-mode 'notmuch-show-mode)
1896     ;; We need to redisplay to get window-start and window-end correct.
1897     (redisplay)
1898     (save-excursion
1899       (condition-case nil
1900           (funcall notmuch-show-mark-read-function (window-start) (window-end))
1901         ((debug error)
1902          (unless notmuch-show--seen-has-errored
1903            (setq notmuch-show--seen-has-errored t)
1904            (setq header-line-format
1905                  (concat header-line-format
1906                          (propertize
1907                           "  [some mark read tag changes may have failed]"
1908                           'face font-lock-warning-face)))))))))
1909
1910 (defun notmuch-show-filter-thread (query)
1911   "Filter or LIMIT the current thread based on a new query string.
1912
1913 Reshows the current thread with matches defined by the new query-string."
1914   (interactive (list (notmuch-read-query "Filter thread: ")))
1915   (let ((msg-id (notmuch-show-get-message-id)))
1916     (setq notmuch-show-query-context (if (string-empty-p query) nil query))
1917     (notmuch-show-refresh-view t)
1918     (notmuch-show-goto-message msg-id)))
1919
1920 ;;; Functions for getting attributes of several messages in the current thread.
1921
1922 (defun notmuch-show-get-message-ids-for-open-messages ()
1923   "Return a list of all id: queries for open messages in the current thread."
1924   (save-excursion
1925     (let (message-ids done)
1926       (goto-char (point-min))
1927       (while (not done)
1928         (when (notmuch-show-message-visible-p)
1929           (setq message-ids
1930                 (append message-ids (list (notmuch-show-get-message-id)))))
1931         (setq done (not (notmuch-show-goto-message-next))))
1932       message-ids)))
1933
1934 ;;; Commands typically bound to keys.
1935
1936 (defun notmuch-show-advance ()
1937   "Advance through thread.
1938
1939 If the current message in the thread is not yet fully visible,
1940 scroll by a near screenful to read more of the message.
1941
1942 Otherwise, (the end of the current message is already within the
1943 current window), advance to the next open message."
1944   (interactive)
1945   (let* ((end-of-this-message (notmuch-show-message-bottom))
1946          (visible-end-of-this-message (1- end-of-this-message))
1947          (ret nil))
1948     (while (invisible-p visible-end-of-this-message)
1949       (setq visible-end-of-this-message
1950             (max (point-min)
1951                  (1- (previous-single-char-property-change
1952                       visible-end-of-this-message 'invisible)))))
1953     (cond
1954      ;; Ideally we would test `end-of-this-message' against the result
1955      ;; of `window-end', but that doesn't account for the fact that
1956      ;; the end of the message might be hidden.
1957      ((and visible-end-of-this-message
1958            (> visible-end-of-this-message (window-end)))
1959       ;; The bottom of this message is not visible - scroll.
1960       (scroll-up nil))
1961      ((not (= end-of-this-message (point-max)))
1962       ;; This is not the last message - move to the next visible one.
1963       (notmuch-show-next-open-message))
1964      ((not (= (point) (point-max)))
1965       ;; This is the last message, but the cursor is not at the end of
1966       ;; the buffer. Move it there.
1967       (goto-char (point-max)))
1968      (t
1969       ;; This is the last message - change the return value
1970       (setq ret t)))
1971     ret))
1972
1973 (defun notmuch-show-advance-and-archive ()
1974   "Advance through thread and archive.
1975
1976 This command is intended to be one of the simplest ways to
1977 process a thread of email. It works exactly like
1978 notmuch-show-advance, in that it scrolls through messages in a
1979 show buffer, except that when it gets to the end of the buffer it
1980 archives the entire current thread, (apply changes in
1981 `notmuch-archive-tags'), kills the buffer, and displays the next
1982 thread from the search from which this thread was originally
1983 shown."
1984   (interactive)
1985   (when (notmuch-show-advance)
1986     (notmuch-show-archive-thread-then-next)))
1987
1988 (defun notmuch-show-rewind ()
1989   "Backup through the thread (reverse scrolling compared to \
1990 \\[notmuch-show-advance-and-archive]).
1991
1992 Specifically, if the beginning of the previous email is fewer
1993 than `window-height' lines from the current point, move to it
1994 just like `notmuch-show-previous-message'.
1995
1996 Otherwise, just scroll down a screenful of the current message.
1997
1998 This command does not modify any message tags, (it does not undo
1999 any effects from previous calls to
2000 `notmuch-show-advance-and-archive'."
2001   (interactive)
2002   (let ((start-of-message (notmuch-show-message-top))
2003         (start-of-window (window-start)))
2004     (cond
2005      ;; Either this message is properly aligned with the start of the
2006      ;; window or the start of this message is not visible on the
2007      ;; screen - scroll.
2008      ((or (= start-of-message start-of-window)
2009           (< start-of-message start-of-window))
2010       (scroll-down)
2011       ;; If a small number of lines from the previous message are
2012       ;; visible, realign so that the top of the current message is at
2013       ;; the top of the screen.
2014       (when (<= (count-screen-lines (window-start) start-of-message)
2015                 next-screen-context-lines)
2016         (goto-char (notmuch-show-message-top))
2017         (notmuch-show-message-adjust))
2018       ;; Move to the top left of the window.
2019       (goto-char (window-start)))
2020      (t
2021       ;; Move to the previous message.
2022       (notmuch-show-previous-message)))))
2023
2024 (put 'notmuch-show-reply 'notmuch-prefix-doc "... and prompt for sender")
2025 (defun notmuch-show-reply (&optional prompt-for-sender)
2026   "Reply to the sender and all recipients of the current message."
2027   (interactive "P")
2028   (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender t
2029                          (notmuch-show-get-prop :duplicate)))
2030
2031 (put 'notmuch-show-reply-sender 'notmuch-prefix-doc "... and prompt for sender")
2032 (defun notmuch-show-reply-sender (&optional prompt-for-sender)
2033   "Reply to the sender of the current message."
2034   (interactive "P")
2035   (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender nil
2036                          (notmuch-show-get-prop :duplicate)))
2037
2038 (put 'notmuch-show-forward-message 'notmuch-prefix-doc
2039      "... and prompt for sender")
2040 (defun notmuch-show-forward-message (&optional prompt-for-sender)
2041   "Forward the current message."
2042   (interactive "P")
2043   (notmuch-mua-new-forward-messages (list (notmuch-show-get-message-id))
2044                                     prompt-for-sender))
2045
2046 (put 'notmuch-show-forward-open-messages 'notmuch-prefix-doc
2047      "... and prompt for sender")
2048 (defun notmuch-show-forward-open-messages (&optional prompt-for-sender)
2049   "Forward the currently open messages."
2050   (interactive "P")
2051   (let ((open-messages (notmuch-show-get-message-ids-for-open-messages)))
2052     (unless open-messages
2053       (error "No open messages to forward."))
2054     (notmuch-mua-new-forward-messages open-messages prompt-for-sender)))
2055
2056 (defun notmuch-show-resend-message (addresses)
2057   "Resend the current message."
2058   (interactive (list (notmuch-address-from-minibuffer "Resend to: ")))
2059   (when (y-or-n-p (concat "Confirm resend to " addresses " "))
2060     (notmuch-show-view-raw-message)
2061     (message-resend addresses)
2062     (notmuch-bury-or-kill-this-buffer)))
2063
2064 (defun notmuch-show-message-adjust ()
2065   (recenter 0))
2066
2067 (defun notmuch-show-next-message (&optional pop-at-end)
2068   "Show the next message.
2069
2070 If a prefix argument is given and this is the last message in the
2071 thread, navigate to the next thread in the parent search buffer."
2072   (interactive "P")
2073   (if (notmuch-show-goto-message-next)
2074       (notmuch-show-message-adjust)
2075     (if pop-at-end
2076         (notmuch-show-next-thread)
2077       (goto-char (point-max)))))
2078
2079 (defun notmuch-show-previous-message ()
2080   "Show the previous message or the start of the current message."
2081   (interactive)
2082   (if (= (point) (notmuch-show-message-top))
2083       (notmuch-show-goto-message-previous)
2084     (notmuch-show-move-to-message-top))
2085   (notmuch-show-message-adjust))
2086
2087 (defun notmuch-show-next-open-message (&optional pop-at-end)
2088   "Show the next open message.
2089
2090 If a prefix argument is given and this is the last open message
2091 in the thread, navigate to the next thread in the parent search
2092 buffer. Return t if there was a next open message in the thread
2093 to show, nil otherwise."
2094   (interactive "P")
2095   (let (r)
2096     (while (and (setq r (notmuch-show-goto-message-next))
2097                 (not (notmuch-show-message-visible-p))))
2098     (if r
2099         (notmuch-show-message-adjust)
2100       (if pop-at-end
2101           (notmuch-show-next-thread)
2102         (goto-char (point-max))))
2103     r))
2104
2105 (defun notmuch-show-next-matching-message ()
2106   "Show the next matching message."
2107   (interactive)
2108   (let (r)
2109     (while (and (setq r (notmuch-show-goto-message-next))
2110                 (not (notmuch-show-get-prop :match))))
2111     (if r
2112         (notmuch-show-message-adjust)
2113       (goto-char (point-max)))))
2114
2115 (defun notmuch-show-open-if-matched ()
2116   "Open a message if it is matched (whether or not excluded)."
2117   (let ((props (notmuch-show-get-message-properties)))
2118     (notmuch-show-message-visible props (plist-get props :match))))
2119
2120 (defun notmuch-show-goto-first-wanted-message ()
2121   "Move to the first open message and mark it read."
2122   (goto-char (point-min))
2123   (unless (notmuch-show-message-visible-p)
2124     (notmuch-show-next-open-message))
2125   (when (eobp)
2126     ;; There are no matched non-excluded messages so open all matched
2127     ;; (necessarily excluded) messages and go to the first.
2128     (notmuch-show-mapc 'notmuch-show-open-if-matched)
2129     (force-window-update)
2130     (goto-char (point-min))
2131     (unless (notmuch-show-message-visible-p)
2132       (notmuch-show-next-open-message))))
2133
2134 (defun notmuch-show-previous-open-message ()
2135   "Show the previous open message."
2136   (interactive)
2137   (while (and (if (= (point) (notmuch-show-message-top))
2138                   (notmuch-show-goto-message-previous)
2139                 (notmuch-show-move-to-message-top))
2140               (not (notmuch-show-message-visible-p))))
2141   (notmuch-show-message-adjust))
2142
2143 (defun notmuch-show-view-raw-message ()
2144   "View the original source of the current message."
2145   (interactive)
2146   (let* ((id (notmuch-show-get-message-id))
2147          (duplicate (notmuch-show-get-duplicate))
2148          (args (if (> duplicate 1)
2149                    (list (format "--duplicate=%d" duplicate) id)
2150                  (list id)))
2151          (buf (get-buffer-create (format "*notmuch-raw-%s-%d*" id duplicate)))
2152          (inhibit-read-only t))
2153     (pop-to-buffer-same-window buf)
2154     (erase-buffer)
2155     (let ((coding-system-for-read 'no-conversion))
2156       (apply #'notmuch--call-process notmuch-command nil t nil "show" "--format=raw" args))
2157     (goto-char (point-min))
2158     (set-buffer-modified-p nil)
2159     (setq buffer-read-only t)
2160     (view-buffer buf 'kill-buffer-if-not-modified)))
2161
2162 (defun notmuch-show-resume-message ()
2163   "Resume EDITING the current draft message."
2164   (interactive)
2165   (notmuch-draft-resume (notmuch-show-get-message-id)))
2166
2167 (put 'notmuch-show-pipe-message 'notmuch-doc
2168      "Pipe the contents of the current message to a command.")
2169 (put 'notmuch-show-pipe-message 'notmuch-prefix-doc
2170      "Pipe the thread as an mbox to a command.")
2171 (defun notmuch-show-pipe-message (entire-thread command)
2172   "Pipe the contents of the current message (or thread) to COMMAND.
2173
2174 COMMAND will be executed with the raw contents of the current
2175 email message as stdin. Anything printed by the command to stdout
2176 or stderr will appear in the *notmuch-pipe* buffer.
2177
2178 If ENTIRE-THREAD is non-nil (or when invoked with a prefix
2179 argument), COMMAND will receive all open messages in the current
2180 thread (formatted as an mbox) rather than only the current
2181 message."
2182   (interactive (let ((query-string (if current-prefix-arg
2183                                        "Pipe all open messages to command: "
2184                                      "Pipe message to command: ")))
2185                  (list current-prefix-arg (read-string query-string))))
2186   (let (shell-command)
2187     (if entire-thread
2188         (setq shell-command
2189               (concat notmuch-command " show --format=mbox --exclude=false "
2190                       (shell-quote-argument
2191                        (mapconcat 'identity
2192                                   (notmuch-show-get-message-ids-for-open-messages)
2193                                   " OR "))
2194                       " | " command))
2195       (setq shell-command
2196             (concat notmuch-command " show --format=raw "
2197                     (shell-quote-argument (notmuch-show-get-message-id))
2198                     " | " command)))
2199     (let ((cwd default-directory)
2200           (buf (get-buffer-create (concat "*notmuch-pipe*"))))
2201       (with-current-buffer buf
2202         (setq buffer-read-only t)
2203         (let ((inhibit-read-only t))
2204           (erase-buffer)
2205           ;; Use the originating buffer's working directory instead of
2206           ;; that of the pipe buffer.
2207           (cd cwd)
2208           (let ((exit-code (call-process-shell-command shell-command nil buf)))
2209             (goto-char (point-max))
2210             (set-buffer-modified-p nil)
2211             (unless (zerop exit-code)
2212               (pop-to-buffer buf)
2213               (message (format "Command '%s' exited abnormally with code %d"
2214                                shell-command exit-code)))))))))
2215
2216 (defun notmuch-show-tag-message (&rest tag-changes)
2217   "Change tags for the current message.
2218
2219 TAG-CHANGES is a list of tag operations for `notmuch-tag'."
2220   (let* ((current-tags (notmuch-show-get-tags))
2221          (new-tags (notmuch-update-tags current-tags tag-changes)))
2222     (unless (equal current-tags new-tags)
2223       (notmuch-tag (notmuch-show-get-message-id) tag-changes)
2224       (notmuch-show-set-tags new-tags))))
2225
2226 (defun notmuch-show-tag (tag-changes)
2227   "Change tags for the current message.
2228
2229 See `notmuch-tag' for information on the format of TAG-CHANGES."
2230   (interactive (list (notmuch-read-tag-changes (notmuch-show-get-tags)
2231                                                "Tag message")))
2232   (notmuch-tag (notmuch-show-get-message-id) tag-changes)
2233   (let* ((current-tags (notmuch-show-get-tags))
2234          (new-tags (notmuch-update-tags current-tags tag-changes)))
2235     (unless (equal current-tags new-tags)
2236       (notmuch-show-set-tags new-tags))))
2237
2238 (defun notmuch-show-tag-all (tag-changes)
2239   "Change tags for all messages in the current show buffer.
2240
2241 See `notmuch-tag' for information on the format of TAG-CHANGES."
2242   (interactive
2243    (list (let (tags)
2244            (notmuch-show-mapc
2245             (lambda () (setq tags (append (notmuch-show-get-tags) tags))))
2246            (notmuch-read-tag-changes tags "Tag thread"))))
2247   (notmuch-tag (notmuch-show-get-messages-ids-search) tag-changes)
2248   (notmuch-show-mapc
2249    (lambda ()
2250      (let* ((current-tags (notmuch-show-get-tags))
2251             (new-tags (notmuch-update-tags current-tags tag-changes)))
2252        (unless (equal current-tags new-tags)
2253          (notmuch-show-set-tags new-tags))))))
2254
2255 (defun notmuch-show-add-tag (tag-changes)
2256   "Change tags for the current message (defaulting to add).
2257
2258 Same as `notmuch-show-tag' but sets initial input to '+'."
2259   (interactive
2260    (list (notmuch-read-tag-changes (notmuch-show-get-tags) "Tag message" "+")))
2261   (notmuch-show-tag tag-changes))
2262
2263 (defun notmuch-show-remove-tag (tag-changes)
2264   "Change tags for the current message (defaulting to remove).
2265
2266 Same as `notmuch-show-tag' but sets initial input to '-'."
2267   (interactive
2268    (list (notmuch-read-tag-changes (notmuch-show-get-tags) "Tag message" "-")))
2269   (notmuch-show-tag tag-changes))
2270
2271 (defun notmuch-show-toggle-visibility-headers ()
2272   "Toggle the visibility of the current message headers."
2273   (interactive)
2274   (let ((props (notmuch-show-get-message-properties)))
2275     (notmuch-show-headers-visible
2276      props
2277      (not (plist-get props :headers-visible))))
2278   (force-window-update))
2279
2280 (defun notmuch-show-toggle-message ()
2281   "Toggle the visibility of the current message."
2282   (interactive)
2283   (let ((props (notmuch-show-get-message-properties)))
2284     (notmuch-show-message-visible
2285      props
2286      (not (plist-get props :message-visible))))
2287   (force-window-update))
2288
2289 (put 'notmuch-show-open-or-close-all 'notmuch-doc "Show all messages.")
2290 (put 'notmuch-show-open-or-close-all 'notmuch-prefix-doc "Hide all messages.")
2291 (defun notmuch-show-open-or-close-all ()
2292   "Set the visibility all of the messages in the current thread.
2293
2294 By default make all of the messages visible. With a prefix
2295 argument, hide all of the messages."
2296   (interactive)
2297   (save-excursion
2298     (goto-char (point-min))
2299     (cl-loop do (notmuch-show-message-visible
2300                  (notmuch-show-get-message-properties)
2301                  (not current-prefix-arg))
2302              until (not (notmuch-show-goto-message-next))))
2303   (force-window-update))
2304
2305 (defun notmuch-show-next-button ()
2306   "Advance point to the next button in the buffer."
2307   (interactive)
2308   (forward-button 1))
2309
2310 (defun notmuch-show-previous-button ()
2311   "Move point back to the previous button in the buffer."
2312   (interactive)
2313   (backward-button 1))
2314
2315 (defun notmuch-show-next-thread (&optional show previous)
2316   "Move to the next item in the search results, if any.
2317
2318 If SHOW is non-nil, open the next item in a show
2319 buffer. Otherwise just highlight the next item in the search
2320 buffer. If PREVIOUS is non-nil, move to the previous item in the
2321 search results instead.
2322
2323 Return non-nil on success."
2324   (interactive "P")
2325   (let ((parent-buffer notmuch-show-parent-buffer))
2326     (notmuch-bury-or-kill-this-buffer)
2327     (when (buffer-live-p parent-buffer)
2328       (switch-to-buffer parent-buffer)
2329       (and (if previous
2330                (notmuch-search-previous-thread)
2331              (notmuch-search-next-thread))
2332            show
2333            (notmuch-search-show-thread)))))
2334
2335 (defun notmuch-show-next-thread-show ()
2336   "Show the next thread in the search results, if any."
2337   (interactive)
2338   (notmuch-show-next-thread t))
2339
2340 (defun notmuch-show-previous-thread-show ()
2341   "Show the previous thread in the search results, if any."
2342   (interactive)
2343   (notmuch-show-next-thread t t))
2344
2345 (put 'notmuch-show-archive-thread 'notmuch-prefix-doc
2346      "Un-archive each message in thread.")
2347 (defun notmuch-show-archive-thread (&optional unarchive)
2348   "Archive each message in thread.
2349
2350 Archive each message currently shown by applying the tag changes
2351 in `notmuch-archive-tags' to each. If a prefix argument is given,
2352 the messages will be \"unarchived\", i.e. the tag changes in
2353 `notmuch-archive-tags' will be reversed.
2354
2355 Note: This command is safe from any race condition of new messages
2356 being delivered to the same thread. It does not archive the
2357 entire thread, but only the messages shown in the current
2358 buffer."
2359   (interactive "P")
2360   (when notmuch-archive-tags
2361     (notmuch-show-tag-all
2362      (notmuch-tag-change-list notmuch-archive-tags unarchive))))
2363
2364 (defun notmuch-show-archive-thread-then-next ()
2365   "Archive all messages in the current buffer, then show next thread from search."
2366   (interactive)
2367   (notmuch-show-archive-thread)
2368   (notmuch-show-next-thread t))
2369
2370 (defun notmuch-show-archive-thread-then-exit ()
2371   "Archive all messages in the current buffer, then exit back to search results."
2372   (interactive)
2373   (notmuch-show-archive-thread)
2374   (notmuch-show-next-thread))
2375
2376 (put 'notmuch-show-archive-message 'notmuch-prefix-doc
2377      "Un-archive the current message.")
2378 (defun notmuch-show-archive-message (&optional unarchive)
2379   "Archive the current message.
2380
2381 Archive the current message by applying the tag changes in
2382 `notmuch-archive-tags' to it. If a prefix argument is given, the
2383 message will be \"unarchived\", i.e. the tag changes in
2384 `notmuch-archive-tags' will be reversed."
2385   (interactive "P")
2386   (when notmuch-archive-tags
2387     (apply 'notmuch-show-tag-message
2388            (notmuch-tag-change-list notmuch-archive-tags unarchive))))
2389
2390 (defun notmuch-show-archive-message-then-next-or-exit ()
2391   "Archive current message, then show next open message in current thread.
2392
2393 If at the last open message in the current thread, then exit back
2394 to search results."
2395   (interactive)
2396   (notmuch-show-archive-message)
2397   (notmuch-show-next-open-message t))
2398
2399 (defun notmuch-show-archive-message-then-next-or-next-thread ()
2400   "Archive current message, then show next open message in current or next thread.
2401
2402 If at the last open message in the current thread, then show next
2403 thread from search."
2404   (interactive)
2405   (notmuch-show-archive-message)
2406   (unless (notmuch-show-next-open-message)
2407     (notmuch-show-next-thread t)))
2408
2409 (defun notmuch-show-stash-cc ()
2410   "Copy CC field of current message to kill-ring."
2411   (interactive)
2412   (notmuch-common-do-stash (notmuch-show-get-cc)))
2413
2414 (put 'notmuch-show-stash-date 'notmuch-prefix-doc
2415      "Copy timestamp of current message to kill-ring.")
2416 (defun notmuch-show-stash-date (&optional stash-timestamp)
2417   "Copy date of current message to kill-ring.
2418
2419 If invoked with a prefix argument, copy timestamp of current
2420 message to kill-ring."
2421   (interactive "P")
2422   (if stash-timestamp
2423       (notmuch-common-do-stash (format "%d" (notmuch-show-get-timestamp)))
2424     (notmuch-common-do-stash (notmuch-show-get-date))))
2425
2426 (defun notmuch-show-stash-filename ()
2427   "Copy filename of current message to kill-ring."
2428   (interactive)
2429   (notmuch-common-do-stash (notmuch-show-get-filename)))
2430
2431 (defun notmuch-show-stash-from ()
2432   "Copy From address of current message to kill-ring."
2433   (interactive)
2434   (notmuch-common-do-stash (notmuch-show-get-from)))
2435
2436 (put 'notmuch-show-stash-message-id 'notmuch-prefix-doc
2437      "Copy thread: query matching current thread to kill-ring.")
2438 (defun notmuch-show-stash-message-id (&optional stash-thread-id)
2439   "Copy id: query matching the current message to kill-ring.
2440
2441 If invoked with a prefix argument (or STASH-THREAD-ID is
2442 non-nil), copy thread: query matching the current thread to
2443 kill-ring."
2444   (interactive "P")
2445   (if stash-thread-id
2446       (notmuch-common-do-stash notmuch-show-thread-id)
2447     (notmuch-common-do-stash (notmuch-show-get-message-id))))
2448
2449 (defun notmuch-show-stash-message-id-stripped ()
2450   "Copy message ID of current message (sans `id:' prefix) to kill-ring."
2451   (interactive)
2452   (notmuch-common-do-stash (notmuch-show-get-message-id t)))
2453
2454 (defun notmuch-show-stash-subject ()
2455   "Copy Subject field of current message to kill-ring."
2456   (interactive)
2457   (notmuch-common-do-stash (notmuch-show-get-subject)))
2458
2459 (defun notmuch-show-stash-tags ()
2460   "Copy tags of current message to kill-ring as a comma separated list."
2461   (interactive)
2462   (notmuch-common-do-stash (mapconcat 'identity (notmuch-show-get-tags) ",")))
2463
2464 (defun notmuch-show-stash-to ()
2465   "Copy To address of current message to kill-ring."
2466   (interactive)
2467   (notmuch-common-do-stash (notmuch-show-get-to)))
2468
2469 (defun notmuch-show-stash-mlarchive-link (&optional mla)
2470   "Copy an ML Archive URI for the current message to the kill-ring.
2471
2472 This presumes that the message is available at the selected Mailing List Archive.
2473
2474 If optional argument MLA is non-nil, use the provided key instead of prompting
2475 the user (see `notmuch-show-stash-mlarchive-link-alist')."
2476   (interactive)
2477   (let ((url (cdr (assoc
2478                    (or mla
2479                        (let ((completion-ignore-case t))
2480                          (completing-read
2481                           "Mailing List Archive: "
2482                           notmuch-show-stash-mlarchive-link-alist
2483                           nil t nil nil
2484                           notmuch-show-stash-mlarchive-link-default)))
2485                    notmuch-show-stash-mlarchive-link-alist))))
2486     (notmuch-common-do-stash
2487      (if (functionp url)
2488          (funcall url (notmuch-show-get-message-id t))
2489        (concat url (notmuch-show-get-message-id t))))))
2490
2491 (defun notmuch-show-stash-mlarchive-link-and-go (&optional mla)
2492   "Copy an ML Archive URI for the current message to the kill-ring and visit it.
2493
2494 This presumes that the message is available at the selected Mailing List Archive.
2495
2496 If optional argument MLA is non-nil, use the provided key instead of prompting
2497 the user (see `notmuch-show-stash-mlarchive-link-alist')."
2498   (interactive)
2499   (notmuch-show-stash-mlarchive-link mla)
2500   (browse-url (current-kill 0 t)))
2501
2502 (defun notmuch-show-stash-git-helper (addresses prefix)
2503   "Normalize all ADDRESSES while adding PREFIX.
2504 Escape, trim, quote and add PREFIX to each address in list
2505 of ADDRESSES, and return the result as a single string."
2506   (mapconcat (lambda (x)
2507                (concat prefix "\""
2508                        ;; escape double-quotes
2509                        (replace-regexp-in-string
2510                         "\"" "\\\\\""
2511                         ;; trim leading and trailing spaces
2512                         (replace-regexp-in-string
2513                          "\\(^ *\\| *$\\)" ""
2514                          x)) "\""))
2515              addresses " "))
2516
2517 (put 'notmuch-show-stash-git-send-email 'notmuch-prefix-doc
2518      "Copy From/To/Cc of current message to kill-ring.
2519 Use a form suitable for pasting to git send-email command line.")
2520
2521 (defun notmuch-show-stash-git-send-email (&optional no-in-reply-to)
2522   "Copy From/To/Cc/Message-Id of current message to kill-ring.
2523 Use a form suitable for pasting to git send-email command line.
2524
2525 If invoked with a prefix argument (or NO-IN-REPLY-TO is non-nil),
2526 omit --in-reply-to=<Message-Id>."
2527   (interactive "P")
2528   (notmuch-common-do-stash
2529    (mapconcat 'identity
2530               (remove ""
2531                       (list
2532                        (notmuch-show-stash-git-helper
2533                         (message-tokenize-header (notmuch-show-get-from)) "--to=")
2534                        (notmuch-show-stash-git-helper
2535                         (message-tokenize-header (notmuch-show-get-to)) "--to=")
2536                        (notmuch-show-stash-git-helper
2537                         (message-tokenize-header (notmuch-show-get-cc)) "--cc=")
2538                        (unless no-in-reply-to
2539                          (notmuch-show-stash-git-helper
2540                           (list (notmuch-show-get-message-id t)) "--in-reply-to="))))
2541               " ")))
2542
2543 ;;; Interactive part functions and their helpers
2544
2545 (defun notmuch-show-generate-part-buffer (msg part)
2546   "Return a temporary buffer containing the specified part's content."
2547   (let ((buf (generate-new-buffer " *notmuch-part*"))
2548         (process-crypto notmuch-show-process-crypto))
2549     (with-current-buffer buf
2550       ;; This is always used in the content of mm handles, which
2551       ;; expect undecoded, binary part content.
2552       (insert (notmuch-get-bodypart-binary msg part process-crypto)))
2553     buf))
2554
2555 (defun notmuch-show-current-part-handle (&optional mime-type)
2556   "Return an mm-handle for the part containing point.
2557
2558 This creates a temporary buffer for the part's content; the
2559 caller is responsible for killing this buffer as appropriate.  If
2560 MIME-TYPE is given then set the handle's mime-type to MIME-TYPE."
2561   (let* ((msg (notmuch-show-get-message-properties))
2562          (part (notmuch-show-get-part-properties))
2563          (buf (notmuch-show-generate-part-buffer msg part))
2564          (computed-type (or mime-type (plist-get part :computed-type)))
2565          (filename (plist-get part :filename))
2566          (disposition (and filename `(attachment (filename . ,filename)))))
2567     (mm-make-handle buf (list computed-type) nil nil disposition)))
2568
2569 (defun notmuch-show-apply-to-current-part-handle (fn &optional mime-type)
2570   "Apply FN to an mm-handle for the part containing point.
2571
2572 This ensures that the temporary buffer created for the mm-handle
2573 is destroyed when FN returns. If MIME-TYPE is given then force
2574 part to be treated as if it had that mime-type."
2575   (let ((handle (notmuch-show-current-part-handle mime-type)))
2576     ;; Emacs puts stdout/stderr into the calling buffer so we call
2577     ;; it from a temp-buffer, unless notmuch-show-attachment-debug
2578     ;; is non-nil, in which case we put it in " *notmuch-part*".
2579     (unwind-protect
2580         (if notmuch-show-attachment-debug
2581             (with-current-buffer (generate-new-buffer " *notmuch-part*")
2582               (funcall fn handle))
2583           (with-temp-buffer
2584             (funcall fn handle)))
2585       (kill-buffer (mm-handle-buffer handle)))))
2586
2587 (defun notmuch-show-part-button-default (&optional button)
2588   (interactive)
2589   (let ((button (or button (button-at (point)))))
2590     ;; Try to toggle the part, if that fails then call the default
2591     ;; action. The toggle fails if the part has no emacs renderable
2592     ;; content.
2593     (unless (notmuch-show-toggle-part-invisibility button)
2594       (call-interactively notmuch-show-part-button-default-action))))
2595
2596 (defun notmuch-show-save-part ()
2597   "Save the MIME part containing point to a file."
2598   (interactive)
2599   (notmuch-show-apply-to-current-part-handle #'mm-save-part))
2600
2601 (defun notmuch-show-view-part ()
2602   "View the MIME part containing point in an external viewer."
2603   (interactive)
2604   ;; Set mm-inlined-types to nil to force an external viewer
2605   (let ((mm-inlined-types nil))
2606     (notmuch-show-apply-to-current-part-handle #'mm-display-part)))
2607
2608 (defun notmuch-show-interactively-view-part ()
2609   "View the MIME part containing point, prompting for a viewer."
2610   (interactive)
2611   (notmuch-show-apply-to-current-part-handle #'mm-interactively-view-part))
2612
2613 (defun notmuch-show-pipe-part ()
2614   "Pipe the MIME part containing point to an external command."
2615   (interactive)
2616   (notmuch-show-apply-to-current-part-handle #'mm-pipe-part))
2617
2618 (defun notmuch-show--mm-display-part (handle)
2619   "Use mm-display-part to display HANDLE in a new buffer.
2620
2621 If the part is displayed in an external application then close
2622 the new buffer."
2623   (let ((buf (get-buffer-create (generate-new-buffer-name
2624                                  (concat " *notmuch-internal-part*")))))
2625     (pop-to-buffer-same-window buf)
2626     (if (eq (mm-display-part handle) 'external)
2627         (kill-buffer buf)
2628       (goto-char (point-min))
2629       (set-buffer-modified-p nil)
2630       (view-buffer buf 'kill-buffer-if-not-modified))))
2631
2632 (defun notmuch-show-choose-mime-of-part (mime-type)
2633   "Choose the mime type to use for displaying part."
2634   (interactive
2635    (list (completing-read "Mime type to use (default text/plain): "
2636                           (mailcap-mime-types) nil nil nil nil "text/plain")))
2637   (notmuch-show-apply-to-current-part-handle #'notmuch-show--mm-display-part
2638                                              mime-type))
2639
2640 (defun notmuch-show-imenu-prev-index-position-function ()
2641   "Move point to previous message in notmuch-show buffer.
2642 This function is used as a value for
2643 `imenu-prev-index-position-function'."
2644   (if (bobp)
2645       nil
2646     (notmuch-show-previous-message)
2647     t))
2648
2649 (defun notmuch-show-imenu-extract-index-name-function ()
2650   "Return imenu name for line at point.
2651 This function is used as a value for
2652 `imenu-extract-index-name-function'.  Point should be at the
2653 beginning of the line."
2654   (back-to-indentation)
2655   (buffer-substring-no-properties (if notmuch-show-imenu-indent
2656                                       (line-beginning-position)
2657                                     (point))
2658                                   (line-end-position)))
2659
2660 (defmacro notmuch-show--with-currently-shown-message (&rest body)
2661   "Evaluate BODY with display restricted to the currently shown
2662 message."
2663   `(save-excursion
2664      (save-restriction
2665        (let ((extent (notmuch-show-message-extent)))
2666          (narrow-to-region (car extent) (cdr extent))
2667          ,@body))))
2668
2669 (defun notmuch-show--gather-urls ()
2670   "Gather any URLs in the current message."
2671   (notmuch-show--with-currently-shown-message
2672    (let (urls)
2673      (goto-char (point-min))
2674      (while (re-search-forward goto-address-url-regexp (point-max) t)
2675        (push (match-string-no-properties 0) urls))
2676      (reverse urls))))
2677
2678 (defun notmuch-show-browse-urls (&optional kill)
2679   "Offer to browse any URLs in the current message.
2680 With a prefix argument, copy the URL to the kill ring rather than
2681 browsing."
2682   (interactive "P")
2683   (let ((urls (notmuch-show--gather-urls))
2684         (prompt (if kill "Copy URL to kill ring: " "Browse URL: "))
2685         (fn (if kill #'kill-new #'browse-url)))
2686     (if urls
2687         (funcall fn (completing-read prompt urls nil nil nil nil (car urls)))
2688       (message "No URLs found."))))
2689
2690 ;;; _
2691
2692 (provide 'notmuch-show)
2693
2694 ;;; notmuch-show.el ends here