git.notmuchmail.org Git - notmuch/blob - contrib/notmuch-pick/notmuch-pick.el

   1 ;; notmuch-pick.el --- displaying notmuch forests.
   2 ;;
   3 ;; Copyright © Carl Worth
   4 ;; Copyright © David Edmondson
   5 ;; Copyright © Mark Walters
   6 ;;
   7 ;; This file is part of Notmuch.
   8 ;;
   9 ;; Notmuch is free software: you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13 ;;
  14 ;; Notmuch is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.
  21 ;;
  22 ;; Authors: David Edmondson <dme@dme.org>
  23 ;;          Mark Walters <markwalters1009@gmail.com>
  24
  25 (require 'mail-parse)
  26
  27 (require 'notmuch-lib)
  28 (require 'notmuch-query)
  29 (require 'notmuch-show)
  30 (require 'notmuch) ;; XXX ATM, as notmuch-search-mode-map is defined here
  31
  32 (eval-when-compile (require 'cl))
  33
  34 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
  35 (declare-function notmuch-show "notmuch-show" (&rest args))
  36 (declare-function notmuch-tag "notmuch" (query &rest tags))
  37 (declare-function notmuch-show-strip-re "notmuch-show" (subject))
  38 (declare-function notmuch-show-clean-address "notmuch-show" (parsed-address))
  39 (declare-function notmuch-show-spaces-n "notmuch-show" (n))
  40 (declare-function notmuch-read-query "notmuch" (prompt))
  41 (declare-function notmuch-read-tag-changes "notmuch" (&optional initial-input &rest search-terms))
  42 (declare-function notmuch-update-tags "notmuch" (current-tags tag-changes))
  43 (declare-function notmuch-hello-trim "notmuch-hello" (search))
  44 (declare-function notmuch-search-find-thread-id "notmuch" ())
  45 (declare-function notmuch-search-find-subject "notmuch" ())
  46
  47 ;; the following variable is defined in notmuch.el
  48 (defvar notmuch-search-query-string)
  49
  50 (defgroup notmuch-pick nil
  51   "Showing message and thread structure."
  52   :group 'notmuch)
  53
  54 ;; This is ugly. We can't run setup-show-out until it has been defined
  55 ;; which needs the keymap to be defined. So we defer setting up to
  56 ;; notmuch-pick-init.
  57 (defcustom notmuch-pick-show-out nil
  58   "View selected messages in new window rather than split-pane."
  59   :type 'boolean
  60   :group 'notmuch-pick
  61   :set (lambda (symbol value)
  62          (set-default symbol value)
  63          (when (fboundp 'notmuch-pick-setup-show-out)
  64            (notmuch-pick-setup-show-out))))
  65
  66 (defcustom notmuch-pick-result-format
  67   `(("date" . "%12s  ")
  68     ("authors" . "%-20s")
  69     ("subject" . " %-54s ")
  70     ("tags" . "(%s)"))
  71   "Result formatting for Pick. Supported fields are: date,
  72         authors, subject, tags Note: subject includes the tree
  73         structure graphics, and the author string should not
  74         contain whitespace (put it in the neighbouring fields
  75         instead).  For example:
  76         (setq notmuch-pick-result-format \(\(\"authors\" . \"%-40s\"\)
  77                                              \(\"subject\" . \"%s\"\)\)\)"
  78   :type '(alist :key-type (string) :value-type (string))
  79   :group 'notmuch-pick)
  80
  81 (defcustom notmuch-pick-asynchronous-parser t
  82   "Use the asynchronous parser."
  83   :type 'boolean
  84   :group 'notmuch-pick)
  85
  86 ;; Faces for messages that match the query.
  87 (defface notmuch-pick-match-date-face
  88   '((t :inherit default))
  89   "Face used in pick mode for the date in messages matching the query."
  90   :group 'notmuch-pick
  91   :group 'notmuch-faces)
  92
  93 (defface notmuch-pick-match-author-face
  94   '((((class color)
  95       (background dark))
  96      (:foreground "OliveDrab1"))
  97     (((class color)
  98       (background light))
  99      (:foreground "dark blue"))
 100     (t
 101      (:bold t)))
 102   "Face used in pick mode for the date in messages matching the query."
 103   :group 'notmuch-pick
 104   :group 'notmuch-faces)
 105
 106 (defface notmuch-pick-match-subject-face
 107   '((t :inherit default))
 108   "Face used in pick mode for the subject in messages matching the query."
 109   :group 'notmuch-pick
 110   :group 'notmuch-faces)
 111
 112 (defface notmuch-pick-match-tag-face
 113   '((((class color)
 114       (background dark))
 115      (:foreground "OliveDrab1"))
 116     (((class color)
 117       (background light))
 118      (:foreground "navy blue" :bold t))
 119     (t
 120      (:bold t)))
 121   "Face used in pick mode for tags in messages matching the query."
 122   :group 'notmuch-pick
 123   :group 'notmuch-faces)
 124
 125 ;; Faces for messages that do not match the query.
 126 (defface notmuch-pick-no-match-date-face
 127   '((t (:foreground "gray")))
 128   "Face used in pick mode for non-matching dates."
 129   :group 'notmuch-pick
 130   :group 'notmuch-faces)
 131
 132 (defface notmuch-pick-no-match-subject-face
 133   '((t (:foreground "gray")))
 134   "Face used in pick mode for non-matching subjects."
 135   :group 'notmuch-pick
 136   :group 'notmuch-faces)
 137
 138 (defface notmuch-pick-no-match-author-face
 139   '((t (:foreground "gray")))
 140   "Face used in pick mode for the date in messages matching the query."
 141   :group 'notmuch-pick
 142   :group 'notmuch-faces)
 143
 144 (defface notmuch-pick-no-match-tag-face
 145   '((t (:foreground "gray")))
 146   "Face used in pick mode face for non-matching tags."
 147   :group 'notmuch-pick
 148   :group 'notmuch-faces)
 149
 150 (defvar notmuch-pick-previous-subject "")
 151 (make-variable-buffer-local 'notmuch-pick-previous-subject)
 152
 153 ;; The basic query i.e. the key part of the search request.
 154 (defvar notmuch-pick-basic-query nil)
 155 (make-variable-buffer-local 'notmuch-pick-basic-query)
 156 ;; The context of the search: i.e., useful but can be dropped.
 157 (defvar notmuch-pick-query-context nil)
 158 (make-variable-buffer-local 'notmuch-pick-query-context)
 159 (defvar notmuch-pick-buffer-name nil)
 160 (make-variable-buffer-local 'notmuch-pick-buffer-name)
 161 (defvar notmuch-pick-message-window nil)
 162 (make-variable-buffer-local 'notmuch-pick-message-window)
 163 (put 'notmuch-pick-message-window 'permanent-local t)
 164 (defvar notmuch-pick-message-buffer nil)
 165 (make-variable-buffer-local 'notmuch-pick-message-buffer-name)
 166 (put 'notmuch-pick-message-buffer-name 'permanent-local t)
 167 (defvar notmuch-pick-process-state nil
 168   "Parsing state of the search process filter.")
 169
 170
 171 (defvar notmuch-pick-mode-map
 172   (let ((map (make-sparse-keymap)))
 173     (define-key map [mouse-1] 'notmuch-pick-show-message)
 174     (define-key map "q" 'notmuch-pick-quit)
 175     (define-key map "x" 'notmuch-pick-quit)
 176     (define-key map "?" 'notmuch-help)
 177     (define-key map "a" 'notmuch-pick-archive-message)
 178     (define-key map "=" 'notmuch-pick-refresh-view)
 179     (define-key map "s" 'notmuch-search)
 180     (define-key map "z" 'notmuch-pick)
 181     (define-key map "m" 'notmuch-pick-new-mail)
 182     (define-key map "f" 'notmuch-pick-forward-message)
 183     (define-key map "r" 'notmuch-pick-reply-sender)
 184     (define-key map "R" 'notmuch-pick-reply)
 185     (define-key map "n" 'notmuch-pick-next-matching-message)
 186     (define-key map "p" 'notmuch-pick-prev-matching-message)
 187     (define-key map "N" 'notmuch-pick-next-message)
 188     (define-key map "P" 'notmuch-pick-prev-message)
 189     (define-key map "|" 'notmuch-pick-pipe-message)
 190     (define-key map "-" 'notmuch-pick-remove-tag)
 191     (define-key map "+" 'notmuch-pick-add-tag)
 192     (define-key map " " 'notmuch-pick-scroll-or-next)
 193     (define-key map "b" 'notmuch-pick-scroll-message-window-back)
 194     map))
 195 (fset 'notmuch-pick-mode-map notmuch-pick-mode-map)
 196
 197 (defun notmuch-pick-setup-show-out ()
 198   (let ((map notmuch-pick-mode-map))
 199     (if notmuch-pick-show-out
 200         (progn
 201           (define-key map (kbd "M-RET") 'notmuch-pick-show-message)
 202           (define-key map (kbd "RET") 'notmuch-pick-show-message-out))
 203       (progn
 204         (define-key map (kbd "RET") 'notmuch-pick-show-message)
 205         (define-key map (kbd "M-RET") 'notmuch-pick-show-message-out)))))
 206
 207 (defun notmuch-pick-get-message-properties ()
 208   "Return the properties of the current message as a plist.
 209
 210 Some useful entries are:
 211 :headers - Property list containing the headers :Date, :Subject, :From, etc.
 212 :tags - Tags for this message"
 213   (save-excursion
 214     (beginning-of-line)
 215     (get-text-property (point) :notmuch-message-properties)))
 216
 217 (defun notmuch-pick-set-message-properties (props)
 218   (save-excursion
 219     (beginning-of-line)
 220     (put-text-property (point) (+ (point) 1) :notmuch-message-properties props)))
 221
 222 (defun notmuch-pick-set-prop (prop val &optional props)
 223   (let ((inhibit-read-only t)
 224         (props (or props
 225                    (notmuch-pick-get-message-properties))))
 226     (plist-put props prop val)
 227     (notmuch-pick-set-message-properties props)))
 228
 229 (defun notmuch-pick-get-prop (prop &optional props)
 230   (let ((props (or props
 231                    (notmuch-pick-get-message-properties))))
 232     (plist-get props prop)))
 233
 234 (defun notmuch-pick-set-tags (tags)
 235   "Set the tags of the current message."
 236   (notmuch-pick-set-prop :tags tags))
 237
 238 (defun notmuch-pick-get-tags ()
 239   "Return the tags of the current message."
 240   (notmuch-pick-get-prop :tags))
 241
 242 (defun notmuch-pick-get-message-id ()
 243   "Return the message id of the current message."
 244   (concat "id:\"" (notmuch-pick-get-prop :id) "\""))
 245
 246 (defun notmuch-pick-get-match ()
 247   "Return whether the current message is a match."
 248   (interactive)
 249   (notmuch-pick-get-prop :match))
 250
 251 (defun notmuch-pick-refresh-result ()
 252   (let ((init-point (point))
 253         (end (line-end-position))
 254         (msg (notmuch-pick-get-message-properties))
 255         (inhibit-read-only t))
 256     (beginning-of-line)
 257     (delete-region (point) (1+ (line-end-position)))
 258     (notmuch-pick-insert-msg msg)
 259     (let ((new-end (line-end-position)))
 260       (goto-char (if (= init-point end)
 261                      new-end
 262                    (min init-point (- new-end 1)))))))
 263
 264 (defun notmuch-pick-tag-update-display (&optional tag-changes)
 265   "Update display for TAG-CHANGES to current message.
 266
 267 Does NOT change the database."
 268   (let* ((current-tags (notmuch-pick-get-tags))
 269          (new-tags (notmuch-update-tags current-tags tag-changes)))
 270     (unless (equal current-tags new-tags)
 271       (notmuch-pick-set-tags new-tags)
 272       (notmuch-pick-refresh-result))))
 273
 274 (defun notmuch-pick-tag (&optional tag-changes)
 275   "Change tags for the current message"
 276   (interactive)
 277   (setq tag-changes (funcall 'notmuch-tag (notmuch-pick-get-message-id) tag-changes))
 278   (notmuch-pick-tag-update-display tag-changes))
 279
 280 (defun notmuch-pick-add-tag ()
 281   "Same as `notmuch-pick-tag' but sets initial input to '+'."
 282   (interactive)
 283   (notmuch-pick-tag "+"))
 284
 285 (defun notmuch-pick-remove-tag ()
 286   "Same as `notmuch-pick-tag' but sets initial input to '-'."
 287   (interactive)
 288   (notmuch-pick-tag "-"))
 289
 290 ;; This function should be in notmuch-hello.el but we are trying to
 291 ;; minimise impact on the rest of the codebase.
 292 (defun notmuch-pick-from-hello (&optional search)
 293   "Run a query and display results in experimental notmuch-pick mode"
 294   (interactive)
 295   (unless (null search)
 296     (setq search (notmuch-hello-trim search))
 297     (let ((history-delete-duplicates t))
 298       (add-to-history 'notmuch-search-history search)))
 299   (notmuch-pick search))
 300
 301 ;; This function should be in notmuch-show.el but be we trying to
 302 ;; minimise impact on the rest of the codebase.
 303 (defun notmuch-pick-from-show-current-query ()
 304   "Call notmuch pick with the current query"
 305   (interactive)
 306   (notmuch-pick notmuch-show-thread-id notmuch-show-query-context))
 307
 308 ;; This function should be in notmuch.el but be we trying to minimise
 309 ;; impact on the rest of the codebase.
 310 (defun notmuch-pick-from-search-current-query ()
 311   "Call notmuch pick with the current query"
 312   (interactive)
 313   (notmuch-pick notmuch-search-query-string))
 314
 315 ;; This function should be in notmuch.el but be we trying to minimise
 316 ;; impact on the rest of the codebase.
 317 (defun notmuch-pick-from-search-thread ()
 318   "Show the selected thread with notmuch-pick"
 319   (interactive)
 320   (notmuch-pick (notmuch-search-find-thread-id)
 321                 notmuch-search-query-string
 322                 (notmuch-prettify-subject (notmuch-search-find-subject)))
 323   (notmuch-pick-show-match-message-with-wait))
 324
 325 (defun notmuch-pick-show-message ()
 326   "Show the current message (in split-pane)."
 327   (interactive)
 328   (let ((id (notmuch-pick-get-message-id))
 329         (inhibit-read-only t)
 330         buffer)
 331     (when id
 332       ;; We close and reopen the window to kill off un-needed buffers
 333       ;; this might cause flickering but seems ok.
 334       (notmuch-pick-close-message-window)
 335       (setq notmuch-pick-message-window
 336             (split-window-vertically (/ (window-height) 4)))
 337       (with-selected-window notmuch-pick-message-window
 338         (setq current-prefix-arg '(4))
 339         (setq buffer (notmuch-show id nil nil nil)))
 340       (notmuch-pick-tag-update-display (list "-unread")))
 341     (setq notmuch-pick-message-buffer buffer)))
 342
 343 (defun notmuch-pick-show-message-out ()
 344   "Show the current message (in whole window)."
 345   (interactive)
 346   (let ((id (notmuch-pick-get-message-id))
 347         (inhibit-read-only t)
 348         buffer)
 349     (when id
 350       ;; We close the window to kill off un-needed buffers.
 351       (notmuch-pick-close-message-window)
 352       (notmuch-show id nil nil nil))))
 353
 354 (defun notmuch-pick-scroll-message-window ()
 355   "Scroll the message window (if it exists)"
 356   (interactive)
 357   (when (window-live-p notmuch-pick-message-window)
 358     (with-selected-window notmuch-pick-message-window
 359       (if (pos-visible-in-window-p (point-max))
 360           t
 361         (scroll-up)))))
 362
 363 (defun notmuch-pick-scroll-message-window-back ()
 364   "Scroll the message window back(if it exists)"
 365   (interactive)
 366   (when (window-live-p notmuch-pick-message-window)
 367     (with-selected-window notmuch-pick-message-window
 368       (if (pos-visible-in-window-p (point-min))
 369           t
 370         (scroll-down)))))
 371
 372 (defun notmuch-pick-scroll-or-next ()
 373   "Scroll the message window. If it at end go to next message."
 374   (interactive)
 375   (when (notmuch-pick-scroll-message-window)
 376     (notmuch-pick-next-matching-message)))
 377
 378 (defun notmuch-pick-quit ()
 379   "Close the split view or exit pick."
 380   (interactive)
 381   (unless (notmuch-pick-close-message-window)
 382     (kill-buffer (current-buffer))))
 383
 384 (defun notmuch-pick-close-message-window ()
 385   "Close the message-window. Return t if close succeeds."
 386   (interactive)
 387   (when (and (window-live-p notmuch-pick-message-window)
 388              (eq (window-buffer notmuch-pick-message-window) notmuch-pick-message-buffer))
 389     (delete-window notmuch-pick-message-window)
 390     (unless (get-buffer-window-list notmuch-pick-message-buffer)
 391       (kill-buffer notmuch-pick-message-buffer))
 392     t))
 393
 394 (defun notmuch-pick-archive-message ()
 395   "Archive the current message and move to next matching message."
 396   (interactive)
 397   (notmuch-pick-tag "-inbox")
 398   (notmuch-pick-next-matching-message))
 399
 400 (defun notmuch-pick-next-message ()
 401   "Move to next message."
 402   (interactive)
 403   (forward-line)
 404   (when (window-live-p notmuch-pick-message-window)
 405     (notmuch-pick-show-message)))
 406
 407 (defun notmuch-pick-prev-message ()
 408   "Move to previous message."
 409   (interactive)
 410   (forward-line -1)
 411   (when (window-live-p notmuch-pick-message-window)
 412     (notmuch-pick-show-message)))
 413
 414 (defun notmuch-pick-prev-matching-message ()
 415   "Move to previous matching message."
 416   (interactive)
 417   (forward-line -1)
 418   (while (and (not (bobp)) (not (notmuch-pick-get-match)))
 419     (forward-line -1))
 420   (when (window-live-p notmuch-pick-message-window)
 421     (notmuch-pick-show-message)))
 422
 423 (defun notmuch-pick-next-matching-message ()
 424   "Move to next matching message."
 425   (interactive)
 426   (forward-line)
 427   (while (and (not (eobp)) (not (notmuch-pick-get-match)))
 428     (forward-line))
 429   (when (window-live-p notmuch-pick-message-window)
 430     (notmuch-pick-show-message)))
 431
 432 (defun notmuch-pick-show-match-message-with-wait ()
 433   "Show the first matching message but wait for it to appear or search to finish."
 434   (interactive)
 435   (unless (notmuch-pick-get-match)
 436     (notmuch-pick-next-matching-message))
 437   (while (and (not (notmuch-pick-get-match))
 438               (not (eq notmuch-pick-process-state 'end)))
 439     (message "waiting for message")
 440     (sit-for 0.1)
 441     (goto-char (point-min))
 442     (unless (notmuch-pick-get-match)
 443       (notmuch-pick-next-matching-message)))
 444   (message nil)
 445   (when (notmuch-pick-get-match)
 446     (notmuch-pick-show-message)))
 447
 448 (defun notmuch-pick-refresh-view ()
 449   "Refresh view."
 450   (interactive)
 451   (let ((inhibit-read-only t)
 452         (basic-query notmuch-pick-basic-query)
 453         (query-context notmuch-pick-query-context)
 454         (buffer-name notmuch-pick-buffer-name))
 455     (erase-buffer)
 456     (notmuch-pick-worker basic-query query-context (get-buffer buffer-name))))
 457
 458 (defmacro with-current-notmuch-pick-message (&rest body)
 459   "Evaluate body with current buffer set to the text of current message"
 460   `(save-excursion
 461      (let ((id (notmuch-pick-get-message-id)))
 462        (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*"))))
 463          (with-current-buffer buf
 464             (call-process notmuch-command nil t nil "show" "--format=raw" id)
 465            ,@body)
 466          (kill-buffer buf)))))
 467
 468 (defun notmuch-pick-new-mail (&optional prompt-for-sender)
 469   "Compose new mail."
 470   (interactive "P")
 471   (notmuch-pick-close-message-window)
 472   (notmuch-mua-new-mail prompt-for-sender ))
 473
 474 (defun notmuch-pick-forward-message (&optional prompt-for-sender)
 475   "Forward the current message."
 476   (interactive "P")
 477   (notmuch-pick-close-message-window)
 478   (with-current-notmuch-pick-message
 479    (notmuch-mua-new-forward-message prompt-for-sender)))
 480
 481 (defun notmuch-pick-reply (&optional prompt-for-sender)
 482   "Reply to the sender and all recipients of the current message."
 483   (interactive "P")
 484   (notmuch-pick-close-message-window)
 485   (notmuch-mua-new-reply (notmuch-pick-get-message-id) prompt-for-sender t))
 486
 487 (defun notmuch-pick-reply-sender (&optional prompt-for-sender)
 488   "Reply to the sender of the current message."
 489   (interactive "P")
 490   (notmuch-pick-close-message-window)
 491   (notmuch-mua-new-reply (notmuch-pick-get-message-id) prompt-for-sender nil))
 492
 493 ;; Shamelessly stolen from notmuch-show.el: maybe should be unified.
 494 (defun notmuch-pick-pipe-message (command)
 495   "Pipe the contents of the current message to the given command.
 496
 497 The given command will be executed with the raw contents of the
 498 current email message as stdin. Anything printed by the command
 499 to stdout or stderr will appear in the *notmuch-pipe* buffer.
 500
 501 When invoked with a prefix argument, the command will receive all
 502 open messages in the current thread (formatted as an mbox) rather
 503 than only the current message."
 504   (interactive "sPipe message to command: ")
 505   (let ((shell-command
 506          (concat notmuch-command " show --format=raw "
 507                  (shell-quote-argument (notmuch-pick-get-message-id)) " | " command))
 508          (buf (get-buffer-create (concat "*notmuch-pipe*"))))
 509     (with-current-buffer buf
 510       (setq buffer-read-only nil)
 511       (erase-buffer)
 512       (let ((exit-code (call-process-shell-command shell-command nil buf)))
 513         (goto-char (point-max))
 514         (set-buffer-modified-p nil)
 515         (setq buffer-read-only t)
 516         (unless (zerop exit-code)
 517           (switch-to-buffer-other-window buf)
 518           (message (format "Command '%s' exited abnormally with code %d"
 519                            shell-command exit-code)))))))
 520
 521 ;; Shamelessly stolen from notmuch-show.el: should be unified.
 522 (defun notmuch-pick-clean-address (address)
 523   "Try to clean a single email ADDRESS for display.  Return
 524 unchanged ADDRESS if parsing fails."
 525   (condition-case nil
 526     (let (p-name p-address)
 527       ;; It would be convenient to use `mail-header-parse-address',
 528       ;; but that expects un-decoded mailbox parts, whereas our
 529       ;; mailbox parts are already decoded (and hence may contain
 530       ;; UTF-8). Given that notmuch should handle most of the awkward
 531       ;; cases, some simple string deconstruction should be sufficient
 532       ;; here.
 533       (cond
 534        ;; "User <user@dom.ain>" style.
 535        ((string-match "\\(.*\\) <\\(.*\\)>" address)
 536         (setq p-name (match-string 1 address)
 537               p-address (match-string 2 address)))
 538
 539        ;; "<user@dom.ain>" style.
 540        ((string-match "<\\(.*\\)>" address)
 541         (setq p-address (match-string 1 address)))
 542
 543        ;; Everything else.
 544        (t
 545         (setq p-address address)))
 546
 547       (when p-name
 548         ;; Remove elements of the mailbox part that are not relevant for
 549         ;; display, even if they are required during transport:
 550         ;;
 551         ;; Backslashes.
 552         (setq p-name (replace-regexp-in-string "\\\\" "" p-name))
 553
 554         ;; Outer single and double quotes, which might be nested.
 555         (loop
 556          with start-of-loop
 557          do (setq start-of-loop p-name)
 558
 559          when (string-match "^\"\\(.*\\)\"$" p-name)
 560          do (setq p-name (match-string 1 p-name))
 561
 562          when (string-match "^'\\(.*\\)'$" p-name)
 563          do (setq p-name (match-string 1 p-name))
 564
 565          until (string= start-of-loop p-name)))
 566
 567       ;; If the address is 'foo@bar.com <foo@bar.com>' then show just
 568       ;; 'foo@bar.com'.
 569       (when (string= p-name p-address)
 570         (setq p-name nil))
 571
 572       ;; If we have a name return that otherwise return the address.
 573       (if (not p-name)
 574           p-address
 575         p-name))
 576     (error address)))
 577
 578 (defun notmuch-pick-insert-field (field format-string msg)
 579   (let* ((headers (plist-get msg :headers))
 580         (match (plist-get msg :match)))
 581     (cond
 582      ((string-equal field "date")
 583       (let ((face (if match
 584                       'notmuch-pick-match-date-face
 585                     'notmuch-pick-no-match-date-face)))
 586         (insert (propertize (format format-string (plist-get msg :date_relative))
 587                             'face face))))
 588
 589      ((string-equal field "subject")
 590       (let ((tree-status (plist-get msg :tree-status))
 591             (bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))
 592             (face (if match
 593                       'notmuch-pick-match-subject-face
 594                     'notmuch-pick-no-match-subject-face)))
 595         (insert (propertize (format format-string
 596                                     (concat
 597                                      (mapconcat #'identity (reverse tree-status) "")
 598                                      (if (string= notmuch-pick-previous-subject bare-subject)
 599                                          " ..."
 600                                        bare-subject)))
 601                             'face face))
 602         (setq notmuch-pick-previous-subject bare-subject)))
 603
 604      ((string-equal field "authors")
 605       (let ((author (notmuch-pick-clean-address (plist-get headers :From)))
 606             (len (length (format format-string "")))
 607             (face (if match
 608                       'notmuch-pick-match-author-face
 609                     'notmuch-pick-no-match-author-face)))
 610         (when (> (length author) len)
 611           (setq author (substring author 0 len)))
 612         (insert (propertize (format format-string author)
 613                             'face face))))
 614
 615      ((string-equal field "tags")
 616       (let ((tags (plist-get msg :tags))
 617             (face (if match
 618                           'notmuch-pick-match-tag-face
 619                         'notmuch-pick-no-match-tag-face)))
 620         (when tags
 621           (insert (propertize (format format-string
 622                                       (mapconcat #'identity tags ", "))
 623                               'face face))))))))
 624
 625 (defun notmuch-pick-insert-msg (msg)
 626   "Insert the message MSG according to notmuch-pick-result-format"
 627   (dolist (spec notmuch-pick-result-format)
 628     (notmuch-pick-insert-field (car spec) (cdr spec) msg))
 629   (notmuch-pick-set-message-properties msg)
 630   (insert "\n"))
 631
 632 (defun notmuch-pick-insert-tree (tree depth tree-status first last)
 633   "Insert the message tree TREE at depth DEPTH in the current thread."
 634   (let ((msg (car tree))
 635         (replies (cadr tree)))
 636
 637       (cond
 638        ((and (< 0 depth) (not last))
 639         (push "├" tree-status))
 640        ((and (< 0 depth) last)
 641         (push "╰" tree-status))
 642        ((and (eq 0 depth) first last)
 643 ;;        (push "─" tree-status)) choice between this and next line is matter of taste.
 644         (push " " tree-status))
 645        ((and (eq 0 depth) first (not last))
 646           (push "┬" tree-status))
 647        ((and (eq 0 depth) (not first) last)
 648         (push "╰" tree-status))
 649        ((and (eq 0 depth) (not first) (not last))
 650         (push "├" tree-status)))
 651
 652       (push (concat (if replies "┬" "─") "►") tree-status)
 653       (notmuch-pick-insert-msg (plist-put msg :tree-status tree-status))
 654       (pop tree-status)
 655       (pop tree-status)
 656
 657       (if last
 658           (push " " tree-status)
 659         (push "│" tree-status))
 660
 661     (notmuch-pick-insert-thread replies (1+ depth) tree-status)))
 662
 663 (defun notmuch-pick-insert-thread (thread depth tree-status)
 664   "Insert the thread THREAD at depth DEPTH >= 1 in the current forest."
 665   (let ((n (length thread)))
 666     (loop for tree in thread
 667           for count from 1 to n
 668
 669           do (notmuch-pick-insert-tree tree depth tree-status (eq count 1) (eq count n)))))
 670
 671 (defun notmuch-pick-insert-forest-thread (forest-thread)
 672   (save-excursion
 673     (goto-char (point-max))
 674     (let (tree-status)
 675       ;; Reset at the start of each main thread.
 676       (setq notmuch-pick-previous-subject nil)
 677       (notmuch-pick-insert-thread forest-thread 0 tree-status))))
 678
 679 (defun notmuch-pick-insert-forest (forest)
 680   (mapc 'notmuch-pick-insert-forest-thread forest))
 681
 682 (defun notmuch-pick-mode ()
 683   "Major mode displaying messages (as opposed to threads) of of a notmuch search.
 684
 685 This buffer contains the results of a \"notmuch pick\" of your
 686 email archives. Each line in the buffer represents a single
 687 message giving the relative date, the author, subject, and any
 688 tags.
 689
 690 Pressing \\[notmuch-pick-show-message] on any line displays that message.
 691
 692 Complete list of currently available key bindings:
 693
 694 \\{notmuch-pick-mode-map}"
 695
 696   (interactive)
 697   (kill-all-local-variables)
 698   (use-local-map notmuch-pick-mode-map)
 699   (setq major-mode 'notmuch-pick-mode
 700         mode-name "notmuch-pick")
 701   (hl-line-mode 1)
 702   (setq buffer-read-only t
 703         truncate-lines t))
 704
 705 (defun notmuch-pick-process-sentinel (proc msg)
 706   "Add a message to let user know when \"notmuch pick\" exits"
 707   (let ((buffer (process-buffer proc))
 708         (status (process-status proc))
 709         (exit-status (process-exit-status proc))
 710         (never-found-target-thread nil))
 711     (when (memq status '(exit signal))
 712         (kill-buffer (process-get proc 'parse-buf))
 713         (if (buffer-live-p buffer)
 714             (with-current-buffer buffer
 715               (save-excursion
 716                 (let ((inhibit-read-only t)
 717                       (atbob (bobp)))
 718                   (goto-char (point-max))
 719                   (if (eq status 'signal)
 720                       (insert "Incomplete search results (pick process was killed).\n"))
 721                   (when (eq status 'exit)
 722                     (insert "End of search results.")
 723                     (unless (= exit-status 0)
 724                       (insert (format " (process returned %d)" exit-status)))
 725                     (insert "\n")))))))))
 726
 727
 728 (defun notmuch-pick-show-error (string &rest objects)
 729   (save-excursion
 730     (goto-char (point-max))
 731     (insert "Error: Unexpected output from notmuch search:\n")
 732     (insert (apply #'format string objects))
 733     (insert "\n")))
 734
 735
 736 (defvar notmuch-pick-json-parser nil
 737   "Incremental JSON parser for the search process filter.")
 738
 739 (defun notmuch-pick-process-filter (proc string)
 740   "Process and filter the output of \"notmuch show\" (for pick)"
 741   (let ((results-buf (process-buffer proc))
 742         (parse-buf (process-get proc 'parse-buf))
 743         (inhibit-read-only t)
 744         done)
 745     (if (not (buffer-live-p results-buf))
 746         (delete-process proc)
 747       (with-current-buffer parse-buf
 748         ;; Insert new data
 749         (save-excursion
 750           (goto-char (point-max))
 751           (insert string)))
 752       (with-current-buffer results-buf
 753         (save-excursion
 754           (goto-char (point-max))
 755           (while (not done)
 756             (condition-case nil
 757                 (case notmuch-pick-process-state
 758                       ((begin)
 759                        ;; Enter the results list
 760                        (if (eq (notmuch-json-begin-compound
 761                                 notmuch-pick-json-parser) 'retry)
 762                            (setq done t)
 763                          (setq notmuch-pick-process-state 'result)))
 764                       ((result)
 765                        ;; Parse a result
 766                        (let ((result (notmuch-json-read notmuch-pick-json-parser)))
 767                          (case result
 768                                ((retry) (setq done t))
 769                                ((end) (setq notmuch-pick-process-state 'end))
 770                                (otherwise (notmuch-pick-insert-forest-thread result)))))
 771                       ((end)
 772                        ;; Any trailing data is unexpected
 773                        (with-current-buffer parse-buf
 774                          (skip-chars-forward " \t\r\n")
 775                          (if (eobp)
 776                              (setq done t)
 777                            (signal 'json-error nil)))))
 778               (json-error
 779                ;; Do our best to resynchronize and ensure forward
 780                ;; progress
 781                (notmuch-pick-show-error
 782                 "%s"
 783                 (with-current-buffer parse-buf
 784                   (let ((bad (buffer-substring (line-beginning-position)
 785                                                (line-end-position))))
 786                     (forward-line)
 787                     bad))))))
 788           ;; Clear out what we've parsed
 789           (with-current-buffer parse-buf
 790             (delete-region (point-min) (point))))))))
 791
 792 (defun notmuch-pick-worker (basic-query &optional query-context buffer)
 793   (interactive)
 794   (notmuch-pick-mode)
 795   (setq notmuch-pick-basic-query basic-query)
 796   (setq notmuch-pick-query-context query-context)
 797   (setq notmuch-pick-buffer-name (buffer-name buffer))
 798
 799   (erase-buffer)
 800   (goto-char (point-min))
 801   (let* ((search-args (concat basic-query
 802                        (if query-context (concat " and (" query-context ")"))
 803                        ))
 804          (message-arg "--entire-thread"))
 805     (if (equal (car (process-lines notmuch-command "count" search-args)) "0")
 806         (setq search-args basic-query))
 807     (message "starting parser %s"
 808              (format-time-string "%r"))
 809     (if notmuch-pick-asynchronous-parser
 810         (let ((proc (start-process
 811                      "notmuch-pick" buffer
 812                      notmuch-command "show" "--body=false" "--format=json"
 813                      message-arg search-args))
 814               ;; Use a scratch buffer to accumulate partial output.
 815               ;; This buffer will be killed by the sentinel, which
 816               ;; should be called no matter how the process dies.
 817               (parse-buf (generate-new-buffer " *notmuch pick parse*")))
 818           (set (make-local-variable 'notmuch-pick-process-state) 'begin)
 819           (set (make-local-variable 'notmuch-pick-json-parser)
 820                (notmuch-json-create-parser parse-buf))
 821           (process-put proc 'parse-buf parse-buf)
 822           (set-process-sentinel proc 'notmuch-pick-process-sentinel)
 823           (set-process-filter proc 'notmuch-pick-process-filter)
 824           (set-process-query-on-exit-flag proc nil))
 825       (progn
 826         (notmuch-pick-insert-forest
 827          (notmuch-query-get-threads
 828           (list "--body=false" message-arg search-args)))
 829         (save-excursion
 830           (goto-char (point-max))
 831           (insert "End of search results.\n"))
 832         (message "sync parser finished %s"
 833                  (format-time-string "%r"))))))
 834
 835
 836 (defun notmuch-pick (&optional query query-context buffer-name show-first-match)
 837   "Run notmuch pick with the given `query' and display the results"
 838   (interactive "sNotmuch pick: ")
 839   (if (null query)
 840       (setq query (notmuch-read-query "Notmuch pick: ")))
 841   (let ((buffer (get-buffer-create (generate-new-buffer-name
 842                                     (or buffer-name
 843                                         (concat "*notmuch-pick-" query "*")))))
 844         (inhibit-read-only t))
 845
 846     (switch-to-buffer buffer)
 847     ;; Don't track undo information for this buffer
 848     (set 'buffer-undo-list t)
 849
 850     (notmuch-pick-worker query query-context buffer)
 851
 852     (setq truncate-lines t)
 853     (when show-first-match
 854       (notmuch-pick-show-match-message-with-wait))))
 855
 856
 857 ;; Set up key bindings from the rest of notmuch.
 858 (define-key 'notmuch-search-mode-map "z" 'notmuch-pick)
 859 (define-key 'notmuch-search-mode-map "Z" 'notmuch-pick-from-search-current-query)
 860 (define-key 'notmuch-search-mode-map (kbd "M-RET") 'notmuch-pick-from-search-thread)
 861 (define-key 'notmuch-hello-mode-map "z" 'notmuch-pick-from-hello)
 862 (define-key 'notmuch-show-mode-map "z" 'notmuch-pick)
 863 (define-key 'notmuch-show-mode-map "Z" 'notmuch-pick-from-show-current-query)
 864 (notmuch-pick-setup-show-out)
 865 (message "Initialised notmuch-pick")
 866
 867 (provide 'notmuch-pick)