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 (require 'cl)
  25 (require 'mm-view)
  26 (require 'message)
  27 (require 'mm-decode)
  28 (require 'mailcap)
  29
  30 (require 'notmuch-lib)
  31 (require 'notmuch-query)
  32 (require 'notmuch-wash)
  33 (require 'notmuch-mua)
  34
  35 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
  36 (declare-function notmuch-fontify-headers "notmuch" nil)
  37 (declare-function notmuch-select-tag-with-completion "notmuch" (prompt &rest search-terms))
  38 (declare-function notmuch-search-show-thread "notmuch" nil)
  39
  40 (defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date")
  41   "Headers that should be shown in a message, in this order.
  42
  43 For an open message, all of these headers will be made visible
  44 according to `notmuch-message-headers-visible' or can be toggled
  45 with `notmuch-show-toggle-headers'. For a closed message, only
  46 the first header in the list will be visible."
  47   :group 'notmuch
  48   :type '(repeat string))
  49
  50 (defcustom notmuch-message-headers-visible t
  51   "Should the headers be visible by default?
  52
  53 If this value is non-nil, then all of the headers defined in
  54 `notmuch-message-headers' will be visible by default in the display
  55 of each message. Otherwise, these headers will be hidden and
  56 `notmuch-show-toggle-headers' can be used to make the visible for
  57 any given message."
  58   :group 'notmuch
  59   :type 'boolean)
  60
  61 (defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers)
  62   "A list of functions called to decorate the headers listed in
  63 `notmuch-message-headers'.")
  64
  65 (defcustom notmuch-show-hook nil
  66   "Functions called after populating a `notmuch-show' buffer."
  67   :group 'notmuch
  68   :type 'hook)
  69
  70 (defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-excerpt-citations)
  71   "Functions used to improve the display of text/plain parts."
  72   :group 'notmuch
  73   :type 'hook
  74   :options '(notmuch-wash-wrap-long-lines
  75              notmuch-wash-tidy-citations
  76              notmuch-wash-elide-blank-lines
  77              notmuch-wash-excerpt-citations))
  78
  79 (defmacro with-current-notmuch-show-message (&rest body)
  80   "Evaluate body with current buffer set to the text of current message"
  81   `(save-excursion
  82      (let ((filename (notmuch-show-get-filename)))
  83        (let ((buf (generate-new-buffer (concat "*notmuch-msg-" filename "*"))))
  84          (with-current-buffer buf
  85            (insert-file-contents filename nil nil nil t)
  86            ,@body)
  87          (kill-buffer buf)))))
  88
  89 (defun notmuch-show-view-all-mime-parts ()
  90   "Use external viewers to view all attachments from the current message."
  91   (interactive)
  92   (with-current-notmuch-show-message
  93    ; We ovverride the mm-inline-media-tests to indicate which message
  94    ; parts are already sufficiently handled by the original
  95    ; presentation of the message in notmuch-show mode. These parts
  96    ; will be inserted directly into the temporary buffer of
  97    ; with-current-notmuch-show-message and silently discarded.
  98    ;
  99    ; Any MIME part not explicitly mentioned here will be handled by an
 100    ; external viewer as configured in the various mailcap files.
 101    (let ((mm-inline-media-tests '(
 102                                   ("text/.*" ignore identity)
 103                                   ("application/pgp-signature" ignore identity)
 104                                   ("multipart/alternative" ignore identity)
 105                                   ("multipart/mixed" ignore identity)
 106                                   ("multipart/related" ignore identity)
 107                                  )))
 108      (mm-display-parts (mm-dissect-buffer)))))
 109
 110 (defun notmuch-foreach-mime-part (function mm-handle)
 111   (cond ((stringp (car mm-handle))
 112          (dolist (part (cdr mm-handle))
 113            (notmuch-foreach-mime-part function part)))
 114         ((bufferp (car mm-handle))
 115          (funcall function mm-handle))
 116         (t (dolist (part mm-handle)
 117              (notmuch-foreach-mime-part function part)))))
 118
 119 (defun notmuch-count-attachments (mm-handle)
 120   (let ((count 0))
 121     (notmuch-foreach-mime-part
 122      (lambda (p)
 123        (let ((disposition (mm-handle-disposition p)))
 124          (and (listp disposition)
 125               (or (equal (car disposition) "attachment")
 126                   (and (equal (car disposition) "inline")
 127                        (assq 'filename disposition)))
 128               (incf count))))
 129      mm-handle)
 130     count))
 131
 132 (defun notmuch-save-attachments (mm-handle &optional queryp)
 133   (notmuch-foreach-mime-part
 134    (lambda (p)
 135      (let ((disposition (mm-handle-disposition p)))
 136        (and (listp disposition)
 137             (or (equal (car disposition) "attachment")
 138                 (and (equal (car disposition) "inline")
 139                      (assq 'filename disposition)))
 140             (or (not queryp)
 141                 (y-or-n-p
 142                  (concat "Save '" (cdr (assq 'filename disposition)) "' ")))
 143             (mm-save-part p))))
 144    mm-handle))
 145
 146 (defun notmuch-show-save-attachments ()
 147   "Save all attachments from the current message."
 148   (interactive)
 149   (with-current-notmuch-show-message
 150    (let ((mm-handle (mm-dissect-buffer)))
 151      (notmuch-save-attachments
 152       mm-handle (> (notmuch-count-attachments mm-handle) 1))))
 153   (message "Done"))
 154
 155 (defun notmuch-show-fontify-header ()
 156   (let ((face (cond
 157                ((looking-at "[Tt]o:")
 158                 'message-header-to)
 159                ((looking-at "[Bb]?[Cc][Cc]:")
 160                 'message-header-cc)
 161                ((looking-at "[Ss]ubject:")
 162                 'message-header-subject)
 163                ((looking-at "[Ff]rom:")
 164                 'message-header-from)
 165                (t
 166                 'message-header-other))))
 167
 168     (overlay-put (make-overlay (point) (re-search-forward ":"))
 169                  'face 'message-header-name)
 170     (overlay-put (make-overlay (point) (re-search-forward ".*$"))
 171                  'face face)))
 172
 173 (defun notmuch-show-colour-headers ()
 174   "Apply some colouring to the current headers."
 175   (goto-char (point-min))
 176   (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:")
 177     (notmuch-show-fontify-header)
 178     (forward-line)))
 179
 180 (defun notmuch-show-spaces-n (n)
 181   "Return a string comprised of `n' spaces."
 182   (make-string n ? ))
 183
 184 (defun notmuch-show-update-tags (tags)
 185   "Update the displayed tags of the current message."
 186   (save-excursion
 187     (goto-char (notmuch-show-message-top))
 188     (if (re-search-forward "(\\([^()]*\\))$" (line-end-position) t)
 189         (let ((inhibit-read-only t))
 190           (replace-match (concat "("
 191                                  (mapconcat 'identity tags " ")
 192                                  ")"))))))
 193
 194 (defun notmuch-show-insert-headerline (headers date tags depth)
 195   "Insert a notmuch style headerline based on HEADERS for a
 196 message at DEPTH in the current thread."
 197   (let ((start (point)))
 198     (insert (notmuch-show-spaces-n depth)
 199             (plist-get headers :From)
 200             " ("
 201             date
 202             ") ("
 203             (mapconcat 'identity tags " ")
 204             ")\n")
 205     (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face)))
 206
 207 (defun notmuch-show-insert-header (header header-value)
 208   "Insert a single header."
 209   (insert header ": " header-value "\n"))
 210
 211 (defun notmuch-show-insert-headers (headers)
 212   "Insert the headers of the current message."
 213   (let ((start (point)))
 214     (mapc '(lambda (header)
 215              (let* ((header-symbol (intern (concat ":" header)))
 216                     (header-value (plist-get headers header-symbol)))
 217                (if (and header-value
 218                         (not (string-equal "" header-value)))
 219                    (notmuch-show-insert-header header header-value))))
 220           notmuch-message-headers)
 221     (save-excursion
 222       (save-restriction
 223         (narrow-to-region start (point-max))
 224         (run-hooks 'notmuch-show-markup-headers-hook)))))
 225
 226 (define-button-type 'notmuch-show-part-button-type
 227   'action 'notmuch-show-part-button-action
 228   'follow-link t
 229   'face 'message-mml)
 230
 231 (defun notmuch-show-insert-part-header (nth content-type declared-type &optional name)
 232   (insert-button
 233    (concat "[ "
 234            (if name (concat name ": ") "")
 235            declared-type
 236            (if (not (string-equal declared-type content-type))
 237                (concat " (as " content-type ")")
 238              "")
 239            " ]\n")
 240    :type 'notmuch-show-part-button-type
 241    :notmuch-part nth
 242    :notmuch-filename name))
 243
 244 ;; Functions handling particular MIME parts.
 245
 246 (defun notmuch-show-save-part (message-id nth &optional filename)
 247   (with-temp-buffer
 248     ;; Always acquires the part via `notmuch part', even if it is
 249     ;; available in the JSON output.
 250     (insert (notmuch-show-get-bodypart-internal message-id nth))
 251     (let ((file (read-file-name
 252                  "Filename to save as: "
 253                  (or mailcap-download-directory "~/")
 254                  nil nil
 255                  filename))
 256           (require-final-newline nil)
 257           (coding-system-for-write 'no-conversion))
 258       (write-region (point-min) (point-max) file))))
 259
 260 (defun notmuch-show-mm-display-part-inline (msg part content-type content)
 261   "Use the mm-decode/mm-view functions to display a part in the
 262 current buffer, if possible."
 263   (let ((display-buffer (current-buffer)))
 264     (with-temp-buffer
 265       (insert content)
 266       (let ((handle (mm-make-handle (current-buffer) (list content-type))))
 267         (set-buffer display-buffer)
 268         (if (and (mm-inlinable-p handle)
 269                  (mm-inlined-p handle))
 270             (progn
 271               (mm-display-part handle)
 272               t)
 273           nil)))))
 274
 275 (defun notmuch-show-insert-part-text/plain (msg part content-type nth depth declared-type)
 276   (let ((start (point)))
 277     ;; If this text/plain part is not the first part in the message,
 278     ;; insert a header to make this clear.
 279     (if (> nth 1)
 280         (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)))
 281     (insert (notmuch-show-get-bodypart-content msg part nth))
 282     (save-excursion
 283       (save-restriction
 284         (narrow-to-region start (point-max))
 285         (run-hook-with-args 'notmuch-show-insert-text/plain-hook depth))))
 286   t)
 287
 288 (defun notmuch-show-insert-part-application/octet-stream (msg part content-type nth depth declared-type)
 289   ;; If we can deduce a MIME type from the filename of the attachment,
 290   ;; do so and pass it on to the handler for that type.
 291   (if (plist-get part :filename)
 292       (let ((extension (file-name-extension (plist-get part :filename)))
 293             mime-type)
 294         (if extension
 295             (progn
 296               (mailcap-parse-mimetypes)
 297               (setq mime-type (mailcap-extension-to-mime extension))
 298               (if (and mime-type
 299                        (not (string-equal mime-type "application/octet-stream")))
 300                   (notmuch-show-insert-bodypart-internal msg part mime-type nth depth content-type)
 301                 nil))
 302           nil))))
 303
 304 (defun notmuch-show-insert-part-*/* (msg part content-type nth depth declared-type)
 305   ;; This handler _must_ succeed - it is the handler of last resort.
 306   (notmuch-show-insert-part-header nth content-type declared-type (plist-get part :filename))
 307   (let ((content (notmuch-show-get-bodypart-content msg part nth)))
 308     (if content
 309         (notmuch-show-mm-display-part-inline msg part content-type content)))
 310   t)
 311
 312 ;; Functions for determining how to handle MIME parts.
 313
 314 (defun notmuch-show-split-content-type (content-type)
 315   (split-string content-type "/"))
 316
 317 (defun notmuch-show-handlers-for (content-type)
 318   "Return a list of content handlers for a part of type CONTENT-TYPE."
 319   (let (result)
 320     (mapc (lambda (func)
 321             (if (functionp func)
 322                 (push func result)))
 323           ;; Reverse order of prefrence.
 324           (list (intern (concat "notmuch-show-insert-part-*/*"))
 325                 (intern (concat
 326                          "notmuch-show-insert-part-"
 327                          (car (notmuch-show-split-content-type content-type))
 328                          "/*"))
 329                 (intern (concat "notmuch-show-insert-part-" content-type))))
 330     result))
 331
 332 ;; Helper for parts which are generally not included in the default
 333 ;; JSON output.
 334
 335 (defun notmuch-show-get-bodypart-internal (message-id part-number)
 336   (with-temp-buffer
 337     (let ((coding-system-for-read 'no-conversion))
 338       (call-process notmuch-command nil t nil
 339                     "part" (format "--part=%s" part-number) message-id)
 340       (buffer-string))))
 341
 342 (defun notmuch-show-get-bodypart-content (msg part nth)
 343   (or (plist-get part :content)
 344       (notmuch-show-get-bodypart-internal (concat "id:" (plist-get msg :id)) nth)))
 345
 346 ;; \f
 347
 348 (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type)
 349   (let ((handlers (notmuch-show-handlers-for content-type)))
 350     ;; Run the content handlers until one of them returns a non-nil
 351     ;; value.
 352     (while (and handlers
 353                 (not (funcall (car handlers) msg part content-type nth depth declared-type)))
 354       (setq handlers (cdr handlers))))
 355   t)
 356
 357 (defun notmuch-show-insert-bodypart (msg part depth)
 358   "Insert the body part PART at depth DEPTH in the current thread."
 359   (let ((content-type (downcase (plist-get part :content-type)))
 360         (nth (plist-get part :id)))
 361     (notmuch-show-insert-bodypart-internal msg part content-type nth depth content-type))
 362   ;; Some of the body part handlers leave point somewhere up in the
 363   ;; part, so we make sure that we're down at the end.
 364   (goto-char (point-max))
 365   ;; Ensure that the part ends with a carriage return.
 366   (if (not (bolp))
 367       (insert "\n")))
 368
 369 (defun notmuch-show-insert-body (msg body depth)
 370   "Insert the body BODY at depth DEPTH in the current thread."
 371   (mapc '(lambda (part) (notmuch-show-insert-bodypart msg part depth)) body))
 372
 373 (defun notmuch-show-make-symbol (type)
 374   (make-symbol (concat "notmuch-show-" type)))
 375
 376 (defun notmuch-show-insert-msg (msg depth)
 377   "Insert the message MSG at depth DEPTH in the current thread."
 378   (let ((headers (plist-get msg :headers))
 379         ;; Indentation causes the buffer offset of the start/end
 380         ;; points to move, so we must use markers.
 381         message-start message-end
 382         content-start content-end
 383         headers-start headers-end
 384         body-start body-end
 385         (headers-invis-spec (notmuch-show-make-symbol "header"))
 386         (message-invis-spec (notmuch-show-make-symbol "message")))
 387
 388     ;; Set `buffer-invisibility-spec' to `nil' (a list), otherwise
 389     ;; removing items from `buffer-invisibility-spec' (which is what
 390     ;; `notmuch-show-headers-visible' and
 391     ;; `notmuch-show-message-visible' do) is a no-op and has no
 392     ;; effect. This caused threads with only matching messages to have
 393     ;; those messages hidden initially because
 394     ;; `buffer-invisibility-spec' stayed `t'.
 395     ;;
 396     ;; This needs to be set here (rather than just above the call to
 397     ;; `notmuch-show-headers-visible') because some of the part
 398     ;; rendering or body washing functions
 399     ;; (e.g. `notmuch-wash-text/plain-citations') manipulate
 400     ;; `buffer-invisibility-spec').
 401     (when (eq buffer-invisibility-spec t)
 402       (setq buffer-invisibility-spec nil))
 403
 404     (setq message-start (point-marker))
 405
 406     (notmuch-show-insert-headerline headers
 407                                     (or (plist-get msg :date_relative)
 408                                         (plist-get headers :Date))
 409                                     (plist-get msg :tags) depth)
 410
 411     (setq content-start (point-marker))
 412
 413     ;; Set `headers-start' to point after the 'Subject:' header to be
 414     ;; compatible with the existing implementation. This just sets it
 415     ;; to after the first header.
 416     (notmuch-show-insert-headers headers)
 417     ;; Headers should include a blank line (backwards compatibility).
 418     (insert "\n")
 419     (save-excursion
 420       (goto-char content-start)
 421       (forward-line 1)
 422       (setq headers-start (point-marker)))
 423     (setq headers-end (point-marker))
 424
 425     (setq body-start (point-marker))
 426     (notmuch-show-insert-body msg (plist-get msg :body) depth)
 427     ;; Ensure that the body ends with a newline.
 428     (if (not (bolp))
 429         (insert "\n"))
 430     (setq body-end (point-marker))
 431     (setq content-end (point-marker))
 432
 433     ;; Indent according to the depth in the thread.
 434     (indent-rigidly content-start content-end depth)
 435
 436     (setq message-end (point-max-marker))
 437
 438     ;; Save the extents of this message over the whole text of the
 439     ;; message.
 440     (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end))
 441
 442     (plist-put msg :headers-invis-spec headers-invis-spec)
 443     (overlay-put (make-overlay headers-start headers-end) 'invisible headers-invis-spec)
 444
 445     (plist-put msg :message-invis-spec message-invis-spec)
 446     (overlay-put (make-overlay body-start body-end) 'invisible message-invis-spec)
 447
 448     ;; Save the properties for this message. Currently this saves the
 449     ;; entire message (augmented it with other stuff), which seems
 450     ;; like overkill. We might save a reduced subset (for example, not
 451     ;; the content).
 452     (notmuch-show-set-message-properties msg)
 453
 454     ;; Set header visibility.
 455     (notmuch-show-headers-visible msg notmuch-message-headers-visible)
 456
 457     ;; Message visibility depends on whether it matched the search
 458     ;; criteria.
 459     (notmuch-show-message-visible msg (plist-get msg :match))))
 460
 461 (defun notmuch-show-insert-tree (tree depth)
 462   "Insert the message tree TREE at depth DEPTH in the current thread."
 463   (let ((msg (car tree))
 464         (replies (cadr tree)))
 465     (notmuch-show-insert-msg msg depth)
 466     (notmuch-show-insert-thread replies (1+ depth))))
 467
 468 (defun notmuch-show-insert-thread (thread depth)
 469   "Insert the thread THREAD at depth DEPTH in the current forest."
 470   (mapc '(lambda (tree) (notmuch-show-insert-tree tree depth)) thread))
 471
 472 (defun notmuch-show-insert-forest (forest)
 473   "Insert the forest of threads FOREST."
 474   (mapc '(lambda (thread) (notmuch-show-insert-thread thread 0)) forest))
 475
 476 (defvar notmuch-show-parent-buffer nil)
 477
 478 ;;;###autoload
 479 (defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name)
 480   "Run \"notmuch show\" with the given thread ID and display results.
 481
 482 The optional PARENT-BUFFER is the notmuch-search buffer from
 483 which this notmuch-show command was executed, (so that the
 484 next thread from that buffer can be show when done with this
 485 one).
 486
 487 The optional QUERY-CONTEXT is a notmuch search term. Only
 488 messages from the thread matching this search term are shown if
 489 non-nil.
 490
 491 The optional BUFFER-NAME provides the neame of the buffer in
 492 which the message thread is shown. If it is nil (which occurs
 493 when the command is called interactively) the argument to the
 494 function is used. "
 495   (interactive "sNotmuch show: ")
 496   (let ((buffer (get-buffer-create (generate-new-buffer-name
 497                                     (or buffer-name
 498                                         (concat "*notmuch-" thread-id "*")))))
 499         (inhibit-read-only t))
 500     (switch-to-buffer buffer)
 501     (notmuch-show-mode)
 502     (set (make-local-variable 'notmuch-show-parent-buffer) parent-buffer)
 503     (erase-buffer)
 504     (goto-char (point-min))
 505     (save-excursion
 506       (let* ((basic-args (list thread-id))
 507              (args (if query-context
 508                        (append (list "\'") basic-args (list "and (" query-context ")\'"))
 509                      (append (list "\'") basic-args (list "\'")))))
 510         (notmuch-show-insert-forest (notmuch-query-get-threads args))
 511         ;; If the query context reduced the results to nothing, run
 512         ;; the basic query.
 513         (when (and (eq (buffer-size) 0)
 514                    query-context)
 515           (notmuch-show-insert-forest
 516            (notmuch-query-get-threads basic-args))))
 517
 518       ;; Enable buttonisation of URLs and email addresses in the
 519       ;; buffer.
 520       (goto-address-mode t)
 521       ;; Act on visual lines rather than logical lines.
 522       (visual-line-mode t)
 523
 524       (run-hooks 'notmuch-show-hook))
 525
 526     ;; Move straight to the first open message
 527     (if (not (notmuch-show-message-visible-p))
 528         (notmuch-show-next-open-message))
 529     (notmuch-show-mark-read)))
 530
 531 (defvar notmuch-show-stash-map
 532   (let ((map (make-sparse-keymap)))
 533     (define-key map "c" 'notmuch-show-stash-cc)
 534     (define-key map "d" 'notmuch-show-stash-date)
 535     (define-key map "F" 'notmuch-show-stash-filename)
 536     (define-key map "f" 'notmuch-show-stash-from)
 537     (define-key map "i" 'notmuch-show-stash-message-id)
 538     (define-key map "s" 'notmuch-show-stash-subject)
 539     (define-key map "T" 'notmuch-show-stash-tags)
 540     (define-key map "t" 'notmuch-show-stash-to)
 541     map)
 542   "Submap for stash commands")
 543 (fset 'notmuch-show-stash-map notmuch-show-stash-map)
 544
 545 (defvar notmuch-show-mode-map
 546       (let ((map (make-sparse-keymap)))
 547         (define-key map "?" 'notmuch-help)
 548         (define-key map "q" 'kill-this-buffer)
 549         (define-key map (kbd "M-TAB") 'notmuch-show-previous-button)
 550         (define-key map (kbd "TAB") 'notmuch-show-next-button)
 551         (define-key map "s" 'notmuch-search)
 552         (define-key map "m" 'notmuch-mua-mail)
 553         (define-key map "f" 'notmuch-show-forward-message)
 554         (define-key map "r" 'notmuch-show-reply)
 555         (define-key map "|" 'notmuch-show-pipe-message)
 556         (define-key map "w" 'notmuch-show-save-attachments)
 557         (define-key map "V" 'notmuch-show-view-raw-message)
 558         (define-key map "v" 'notmuch-show-view-all-mime-parts)
 559         (define-key map "c" 'notmuch-show-stash-map)
 560         (define-key map "h" 'notmuch-show-toggle-headers)
 561         (define-key map "-" 'notmuch-show-remove-tag)
 562         (define-key map "+" 'notmuch-show-add-tag)
 563         (define-key map "x" 'notmuch-show-archive-thread-then-exit)
 564         (define-key map "a" 'notmuch-show-archive-thread)
 565         (define-key map "N" 'notmuch-show-next-message)
 566         (define-key map "P" 'notmuch-show-previous-message)
 567         (define-key map "n" 'notmuch-show-next-open-message)
 568         (define-key map "p" 'notmuch-show-previous-open-message)
 569         (define-key map (kbd "DEL") 'notmuch-show-rewind)
 570         (define-key map " " 'notmuch-show-advance-and-archive)
 571         (define-key map (kbd "M-RET") 'notmuch-show-open-or-close-all)
 572         (define-key map (kbd "RET") 'notmuch-show-toggle-message)
 573         map)
 574       "Keymap for \"notmuch show\" buffers.")
 575 (fset 'notmuch-show-mode-map notmuch-show-mode-map)
 576
 577 ;;;###autoload
 578 (defun notmuch-show-mode ()
 579   "Major mode for viewing a thread with notmuch.
 580
 581 This buffer contains the results of the \"notmuch show\" command
 582 for displaying a single thread of email from your email archives.
 583
 584 By default, various components of email messages, (citations,
 585 signatures, already-read messages), are hidden. You can make
 586 these parts visible by clicking with the mouse button or by
 587 pressing RET after positioning the cursor on a hidden part, (for
 588 which \\[notmuch-show-next-button] and
 589 \\[notmuch-show-previous-button] are helpful).
 590
 591 Reading the thread sequentially is well-supported by pressing
 592 \\[notmuch-show-advance-and-archive]. This will scroll the
 593 current message (if necessary), advance to the next message, or
 594 advance to the next thread (if already on the last message of a
 595 thread).
 596
 597 Other commands are available to read or manipulate the thread
 598 more selectively, (such as '\\[notmuch-show-next-message]' and
 599 '\\[notmuch-show-previous-message]' to advance to messages
 600 without removing any tags, and '\\[notmuch-show-archive-thread]'
 601 to archive an entire thread without scrolling through with
 602 \\[notmuch-show-advance-and-archive]).
 603
 604 You can add or remove arbitary tags from the current message with
 605 '\\[notmuch-show-add-tag]' or '\\[notmuch-show-remove-tag]'.
 606
 607 All currently available key bindings:
 608
 609 \\{notmuch-show-mode-map}"
 610   (interactive)
 611   (kill-all-local-variables)
 612   (use-local-map notmuch-show-mode-map)
 613   (setq major-mode 'notmuch-show-mode
 614         mode-name "notmuch-show")
 615   (setq buffer-read-only t))
 616
 617 (defun notmuch-show-move-to-message-top ()
 618   (goto-char (notmuch-show-message-top)))
 619
 620 (defun notmuch-show-move-to-message-bottom ()
 621   (goto-char (notmuch-show-message-bottom)))
 622
 623 (defun notmuch-show-message-adjust ()
 624   (recenter 0))
 625
 626 ;; Movement related functions.
 627
 628 ;; There's some strangeness here where a text property applied to a
 629 ;; region a->b is not found when point is at b. We walk backwards
 630 ;; until finding the property.
 631 (defun notmuch-show-message-extent ()
 632   (let (r)
 633     (save-excursion
 634       (while (not (setq r (get-text-property (point) :notmuch-message-extent)))
 635         (backward-char)))
 636     r))
 637
 638 (defun notmuch-show-message-top ()
 639   (car (notmuch-show-message-extent)))
 640
 641 (defun notmuch-show-message-bottom ()
 642   (cdr (notmuch-show-message-extent)))
 643
 644 (defun notmuch-show-goto-message-next ()
 645   (let ((start (point)))
 646     (notmuch-show-move-to-message-bottom)
 647     (if (not (eobp))
 648         t
 649       (goto-char start)
 650       nil)))
 651
 652 (defun notmuch-show-goto-message-previous ()
 653   (notmuch-show-move-to-message-top)
 654   (if (bobp)
 655       nil
 656     (backward-char)
 657     (notmuch-show-move-to-message-top)
 658     t))
 659
 660 (defun notmuch-show-move-past-invisible-forward ()
 661   (while (point-invisible-p)
 662     (forward-char)))
 663
 664 (defun notmuch-show-move-past-invisible-backward ()
 665   (while (point-invisible-p)
 666     (backward-char)))
 667
 668 ;; Functions relating to the visibility of messages and their
 669 ;; components.
 670
 671 (defun notmuch-show-element-visible (props visible-p spec-property)
 672   (let ((spec (plist-get props spec-property)))
 673     (if visible-p
 674         (remove-from-invisibility-spec spec)
 675       (add-to-invisibility-spec spec))))
 676
 677 (defun notmuch-show-message-visible (props visible-p)
 678   (if visible-p
 679       ;; When making the message visible, the headers may or not be
 680       ;; visible. So we check that property separately.
 681       (let ((headers-visible (plist-get props :headers-visible)))
 682         (notmuch-show-element-visible props headers-visible :headers-invis-spec)
 683         (notmuch-show-element-visible props t :message-invis-spec))
 684     (notmuch-show-element-visible props nil :headers-invis-spec)
 685     (notmuch-show-element-visible props nil :message-invis-spec))
 686
 687   (notmuch-show-set-prop :message-visible visible-p props))
 688
 689 (defun notmuch-show-headers-visible (props visible-p)
 690   (if (plist-get props :message-visible)
 691       (notmuch-show-element-visible props visible-p :headers-invis-spec))
 692   (notmuch-show-set-prop :headers-visible visible-p props))
 693
 694 ;; Functions for setting and getting attributes of the current
 695 ;; message.
 696
 697 (defun notmuch-show-set-message-properties (props)
 698   (save-excursion
 699     (notmuch-show-move-to-message-top)
 700     (put-text-property (point) (+ (point) 1) :notmuch-message-properties props)))
 701
 702 (defun notmuch-show-get-message-properties ()
 703   (save-excursion
 704     (notmuch-show-move-to-message-top)
 705     (get-text-property (point) :notmuch-message-properties)))
 706
 707 (defun notmuch-show-set-prop (prop val &optional props)
 708   (let ((inhibit-read-only t)
 709         (props (or props
 710                    (notmuch-show-get-message-properties))))
 711     (plist-put props prop val)
 712     (notmuch-show-set-message-properties props)))
 713
 714 (defun notmuch-show-get-prop (prop &optional props)
 715   (let ((props (or props
 716                    (notmuch-show-get-message-properties))))
 717     (plist-get props prop)))
 718
 719 (defun notmuch-show-get-message-id ()
 720   "Return the message id of the current message."
 721   (concat "id:" (notmuch-show-get-prop :id)))
 722
 723 ;; dme: Would it make sense to use a macro for many of these?
 724
 725 (defun notmuch-show-get-filename ()
 726   "Return the filename of the current message."
 727   (notmuch-show-get-prop :filename))
 728
 729 (defun notmuch-show-get-header (header)
 730   "Return the named header of the current message, if any."
 731   (plist-get (notmuch-show-get-prop :headers) header))
 732
 733 (defun notmuch-show-get-cc ()
 734   (notmuch-show-get-header :Cc))
 735
 736 (defun notmuch-show-get-date ()
 737   (notmuch-show-get-header :Date))
 738
 739 (defun notmuch-show-get-from ()
 740   (notmuch-show-get-header :From))
 741
 742 (defun notmuch-show-get-subject ()
 743   (notmuch-show-get-header :Subject))
 744
 745 (defun notmuch-show-get-to ()
 746   (notmuch-show-get-header :To))
 747
 748 (defun notmuch-show-set-tags (tags)
 749   "Set the tags of the current message."
 750   (notmuch-show-set-prop :tags tags)
 751   (notmuch-show-update-tags tags))
 752
 753 (defun notmuch-show-get-tags ()
 754   "Return the tags of the current message."
 755   (notmuch-show-get-prop :tags))
 756
 757 (defun notmuch-show-message-visible-p ()
 758   "Is the current message visible?"
 759   (notmuch-show-get-prop :message-visible))
 760
 761 (defun notmuch-show-headers-visible-p ()
 762   "Are the headers of the current message visible?"
 763   (notmuch-show-get-prop :headers-visible))
 764
 765 (defun notmuch-show-mark-read ()
 766   "Mark the current message as read."
 767   (notmuch-show-remove-tag "unread"))
 768
 769 ;; Commands typically bound to keys.
 770
 771 (defun notmuch-show-advance-and-archive ()
 772   "Advance through thread and archive.
 773
 774 This command is intended to be one of the simplest ways to
 775 process a thread of email. It does the following:
 776
 777 If the current message in the thread is not yet fully visible,
 778 scroll by a near screenful to read more of the message.
 779
 780 Otherwise, (the end of the current message is already within the
 781 current window), advance to the next open message.
 782
 783 Finally, if there is no further message to advance to, and this
 784 last message is already read, then archive the entire current
 785 thread, (remove the \"inbox\" tag from each message). Also kill
 786 this buffer, and display the next thread from the search from
 787 which this thread was originally shown."
 788   (interactive)
 789   (let ((end-of-this-message (notmuch-show-message-bottom)))
 790     (cond
 791      ;; Ideally we would test `end-of-this-message' against the result
 792      ;; of `window-end', but that doesn't account for the fact that
 793      ;; the end of the message might be hidden, so we have to actually
 794      ;; go to the end, walk back over invisible text and then see if
 795      ;; point is visible.
 796      ((save-excursion
 797         (goto-char (- end-of-this-message 1))
 798         (notmuch-show-move-past-invisible-backward)
 799         (> (point) (window-end)))
 800       ;; The bottom of this message is not visible - scroll.
 801       (scroll-up nil))
 802
 803      ((not (= end-of-this-message (point-max)))
 804       ;; This is not the last message - move to the next visible one.
 805       (notmuch-show-next-open-message))
 806
 807      (t
 808       ;; This is the last message - archive the thread.
 809       (notmuch-show-archive-thread)))))
 810
 811 (defun notmuch-show-rewind ()
 812   "Backup through the thread, (reverse scrolling compared to \\[notmuch-show-advance-and-archive]).
 813
 814 Specifically, if the beginning of the previous email is fewer
 815 than `window-height' lines from the current point, move to it
 816 just like `notmuch-show-previous-message'.
 817
 818 Otherwise, just scroll down a screenful of the current message.
 819
 820 This command does not modify any message tags, (it does not undo
 821 any effects from previous calls to
 822 `notmuch-show-advance-and-archive'."
 823   (interactive)
 824   (let ((start-of-message (notmuch-show-message-top))
 825         (start-of-window (window-start)))
 826     (cond
 827       ;; Either this message is properly aligned with the start of the
 828       ;; window or the start of this message is not visible on the
 829       ;; screen - scroll.
 830      ((or (= start-of-message start-of-window)
 831           (< start-of-message start-of-window))
 832       (scroll-down)
 833       ;; If a small number of lines from the previous message are
 834       ;; visible, realign so that the top of the current message is at
 835       ;; the top of the screen.
 836       (if (<= (count-screen-lines (window-start) start-of-message)
 837               next-screen-context-lines)
 838           (progn
 839             (goto-char (notmuch-show-message-top))
 840             (notmuch-show-message-adjust)))
 841       ;; Move to the top left of the window.
 842       (goto-char (window-start)))
 843      (t
 844       ;; Move to the previous message.
 845       (notmuch-show-previous-message)))))
 846
 847 (defun notmuch-show-reply ()
 848   "Reply to the current message."
 849   (interactive)
 850   (notmuch-mua-reply (notmuch-show-get-message-id)))
 851
 852 (defun notmuch-show-forward-message ()
 853   "Forward the current message."
 854   (interactive)
 855   (with-current-notmuch-show-message
 856    (notmuch-mua-forward-message)))
 857
 858 (defun notmuch-show-next-message ()
 859   "Show the next message."
 860   (interactive)
 861   (if (notmuch-show-goto-message-next)
 862       (progn
 863         (notmuch-show-mark-read)
 864         (notmuch-show-message-adjust))
 865     (goto-char (point-max))))
 866
 867 (defun notmuch-show-previous-message ()
 868   "Show the previous message."
 869   (interactive)
 870   (notmuch-show-goto-message-previous)
 871   (notmuch-show-mark-read)
 872   (notmuch-show-message-adjust))
 873
 874 (defun notmuch-show-next-open-message ()
 875   "Show the next message."
 876   (interactive)
 877   (let (r)
 878     (while (and (setq r (notmuch-show-goto-message-next))
 879                 (not (notmuch-show-message-visible-p))))
 880     (if r
 881         (progn
 882           (notmuch-show-mark-read)
 883           (notmuch-show-message-adjust))
 884       (goto-char (point-max)))))
 885
 886 (defun notmuch-show-previous-open-message ()
 887   "Show the previous message."
 888   (interactive)
 889   (while (and (notmuch-show-goto-message-previous)
 890               (not (notmuch-show-message-visible-p))))
 891   (notmuch-show-mark-read)
 892   (notmuch-show-message-adjust))
 893
 894 (defun notmuch-show-view-raw-message ()
 895   "View the file holding the current message."
 896   (interactive)
 897   (view-file (notmuch-show-get-filename)))
 898
 899 (defun notmuch-show-pipe-message (command)
 900   "Pipe the contents of the current message to the given command.
 901
 902 The given command will be executed with the raw contents of the
 903 current email message as stdin. Anything printed by the command
 904 to stdout or stderr will appear in the *Messages* buffer."
 905   (interactive "sPipe message to command: ")
 906   (apply 'start-process-shell-command "notmuch-pipe-command" "*notmuch-pipe*"
 907          (list command " < "
 908                (shell-quote-argument (notmuch-show-get-filename)))))
 909
 910 (defun notmuch-show-add-tag (&rest toadd)
 911   "Add a tag to the current message."
 912   (interactive
 913    (list (notmuch-select-tag-with-completion "Tag to add: ")))
 914   (apply 'notmuch-call-notmuch-process
 915          (append (cons "tag"
 916                        (mapcar (lambda (s) (concat "+" s)) toadd))
 917                  (cons (notmuch-show-get-message-id) nil)))
 918   (notmuch-show-set-tags (sort (union toadd (notmuch-show-get-tags) :test 'string=) 'string<)))
 919
 920 (defun notmuch-show-remove-tag (&rest toremove)
 921   "Remove a tag from the current message."
 922   (interactive
 923    (list (notmuch-select-tag-with-completion
 924           "Tag to remove: " (notmuch-show-get-message-id))))
 925   (let ((tags (notmuch-show-get-tags)))
 926     (if (intersection tags toremove :test 'string=)
 927         (progn
 928           (apply 'notmuch-call-notmuch-process
 929                  (append (cons "tag"
 930                                (mapcar (lambda (s) (concat "-" s)) toremove))
 931                          (cons (notmuch-show-get-message-id) nil)))
 932           (notmuch-show-set-tags (sort (set-difference tags toremove :test 'string=) 'string<))))))
 933
 934 (defun notmuch-show-toggle-headers ()
 935   "Toggle the visibility of the current message headers."
 936   (interactive)
 937   (let ((props (notmuch-show-get-message-properties)))
 938     (notmuch-show-headers-visible
 939      props
 940      (not (plist-get props :headers-visible))))
 941   (force-window-update))
 942
 943 (defun notmuch-show-toggle-message ()
 944   "Toggle the visibility of the current message."
 945   (interactive)
 946   (let ((props (notmuch-show-get-message-properties)))
 947     (notmuch-show-message-visible
 948      props
 949      (not (plist-get props :message-visible))))
 950   (force-window-update))
 951
 952 (defun notmuch-show-open-or-close-all ()
 953   "Set the visibility all of the messages in the current thread.
 954 By default make all of the messages visible. With a prefix
 955 argument, hide all of the messages."
 956   (interactive)
 957   (save-excursion
 958     (goto-char (point-min))
 959     (loop do (notmuch-show-message-visible (notmuch-show-get-message-properties)
 960                                            (not current-prefix-arg))
 961           until (not (notmuch-show-goto-message-next))))
 962   (force-window-update))
 963
 964 (defun notmuch-show-next-button ()
 965   "Advance point to the next button in the buffer."
 966   (interactive)
 967   (forward-button 1))
 968
 969 (defun notmuch-show-previous-button ()
 970   "Move point back to the previous button in the buffer."
 971   (interactive)
 972   (backward-button 1))
 973
 974 (defun notmuch-show-archive-thread-internal (show-next)
 975   ;; Remove the tag from the current set of messages.
 976   (goto-char (point-min))
 977   (loop do (notmuch-show-remove-tag "inbox")
 978         until (not (notmuch-show-goto-message-next)))
 979   ;; Move to the next item in the search results, if any.
 980   (let ((parent-buffer notmuch-show-parent-buffer))
 981     (kill-this-buffer)
 982     (if parent-buffer
 983         (progn
 984           (switch-to-buffer parent-buffer)
 985           (forward-line)
 986           (if show-next
 987               (notmuch-search-show-thread))))))
 988
 989 (defun notmuch-show-archive-thread ()
 990   "Archive each message in thread, then show next thread from search.
 991
 992 Archive each message currently shown by removing the \"inbox\"
 993 tag from each. Then kill this buffer and show the next thread
 994 from the search from which this thread was originally shown.
 995
 996 Note: This command is safe from any race condition of new messages
 997 being delivered to the same thread. It does not archive the
 998 entire thread, but only the messages shown in the current
 999 buffer."
1000   (interactive)
1001   (notmuch-show-archive-thread-internal t))
1002
1003 (defun notmuch-show-archive-thread-then-exit ()
1004   "Archive each message in thread, then exit back to search results."
1005   (interactive)
1006   (notmuch-show-archive-thread-internal nil))
1007
1008 (defun notmuch-show-do-stash (text)
1009   (kill-new text)
1010   (message "Saved: %s" text))
1011
1012 (defun notmuch-show-stash-cc ()
1013   "Copy CC field of current message to kill-ring."
1014   (interactive)
1015   (notmuch-show-do-stash (notmuch-show-get-cc)))
1016
1017 (defun notmuch-show-stash-date ()
1018   "Copy date of current message to kill-ring."
1019   (interactive)
1020   (notmuch-show-do-stash (notmuch-show-get-date)))
1021
1022 (defun notmuch-show-stash-filename ()
1023   "Copy filename of current message to kill-ring."
1024   (interactive)
1025   (notmuch-show-do-stash (notmuch-show-get-filename)))
1026
1027 (defun notmuch-show-stash-from ()
1028   "Copy From address of current message to kill-ring."
1029   (interactive)
1030   (notmuch-show-do-stash (notmuch-show-get-from)))
1031
1032 (defun notmuch-show-stash-message-id ()
1033   "Copy message ID of current message to kill-ring."
1034   (interactive)
1035   (notmuch-show-do-stash (notmuch-show-get-message-id)))
1036
1037 (defun notmuch-show-stash-subject ()
1038   "Copy Subject field of current message to kill-ring."
1039   (interactive)
1040   (notmuch-show-do-stash (notmuch-show-get-subject)))
1041
1042 (defun notmuch-show-stash-tags ()
1043   "Copy tags of current message to kill-ring as a comma separated list."
1044   (interactive)
1045   (notmuch-show-do-stash (mapconcat 'identity (notmuch-show-get-tags) ",")))
1046
1047 (defun notmuch-show-stash-to ()
1048   "Copy To address of current message to kill-ring."
1049   (interactive)
1050   (notmuch-show-do-stash (notmuch-show-get-to)))
1051
1052 ;; Commands typically bound to buttons.
1053
1054 (defun notmuch-show-part-button-action (button)
1055   (let ((nth (button-get button :notmuch-part)))
1056     (if nth
1057         (notmuch-show-save-part (notmuch-show-get-message-id) nth
1058                                 (button-get button :notmuch-filename))
1059       (message "Not a valid part (is it a fake part?)."))))
1060
1061 ;;
1062
1063 (provide 'notmuch-show)