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