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

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