From: Mark Walters Date: Sat, 26 Oct 2013 22:02:05 +0000 (+0100) Subject: [PATCH 1/4] contrib: pick: move lisp names from pick to tree X-Git-Url: http://git.tremily.us/?a=commitdiff_plain;h=1f2693a82d27d60523c9ba79d8c1865aa3682df3;p=notmuch-archives.git [PATCH 1/4] contrib: pick: move lisp names from pick to tree --- diff --git a/62/e53bddf56448efa4542c1b087b5e5e4e786cfe b/62/e53bddf56448efa4542c1b087b5e5e4e786cfe new file mode 100644 index 000000000..61280801b --- /dev/null +++ b/62/e53bddf56448efa4542c1b087b5e5e4e786cfe @@ -0,0 +1,2190 @@ +Return-Path: +X-Original-To: notmuch@notmuchmail.org +Delivered-To: notmuch@notmuchmail.org +Received: from localhost (localhost [127.0.0.1]) + by olra.theworths.org (Postfix) with ESMTP id 1FEA2429E5A + for ; Sat, 26 Oct 2013 15:02:26 -0700 (PDT) +X-Virus-Scanned: Debian amavisd-new at olra.theworths.org +X-Spam-Flag: NO +X-Spam-Score: 0.201 +X-Spam-Level: +X-Spam-Status: No, score=0.201 tagged_above=-999 required=5 + tests=[DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, + FREEMAIL_ENVFROM_END_DIGIT=1, FREEMAIL_FROM=0.001, + RCVD_IN_DNSWL_LOW=-0.7] autolearn=disabled +Received: from olra.theworths.org ([127.0.0.1]) + by localhost (olra.theworths.org [127.0.0.1]) (amavisd-new, port 10024) + with ESMTP id IfrHPhlGPyMC for ; + Sat, 26 Oct 2013 15:02:16 -0700 (PDT) +Received: from mail-we0-f182.google.com (mail-we0-f182.google.com + [74.125.82.182]) (using TLSv1 with cipher RC4-SHA (128/128 bits)) + (No client certificate requested) + by olra.theworths.org (Postfix) with ESMTPS id AC996431E82 + for ; Sat, 26 Oct 2013 15:02:15 -0700 (PDT) +Received: by mail-we0-f182.google.com with SMTP id t61so5140175wes.41 + for ; Sat, 26 Oct 2013 15:02:14 -0700 (PDT) +DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; + h=from:to:cc:subject:date:message-id:in-reply-to:references + :mime-version:content-type:content-transfer-encoding; + bh=q9OToYi4bYJekOls5fxJxdVCc+zV0mai44oddeKGQw4=; + b=UnuOR2L/uGnQdc5OO+o465pyOkuHncKdjuoOwwl6yzqnEs6uRBcKJyW1UVP348Og/6 + PINKQUZ/KSsn+wiPAyq16VA9y5aVhA5eUxl2n0UWXk10cRyEZtlm+oTlAV+LO2aXJU4H + ihQfchr0uJykboQX1wnM4wg460hdcafY6htD51md79fB8zckdfqxX47rYtryOxAZgi6C + 0zsv5QjPGuzQKc9quIOFaR2EFrVD9Nm1bqMdW8eUwfev+DIFMHRJ16P2PiW0SfFBWlmF + pWjN+qfE8Gurget47jmLDmwfqSyEdC7Oo6ZsYBH4X/Mef/8x9kjmz4Sdo5qOBLh62VVn + zVaA== +X-Received: by 10.180.149.179 with SMTP id ub19mr3397234wib.43.1382824934464; + Sat, 26 Oct 2013 15:02:14 -0700 (PDT) +Received: from localhost (93-97-24-31.zone5.bethere.co.uk. [93.97.24.31]) + by mx.google.com with ESMTPSA id fr4sm19768076wib.0.2013.10.26.15.02.12 + for + (version=TLSv1.2 cipher=RC4-SHA bits=128/128); + Sat, 26 Oct 2013 15:02:14 -0700 (PDT) +From: Mark Walters +To: notmuch@notmuchmail.org +Subject: [PATCH 1/4] contrib: pick: move lisp names from pick to tree +Date: Sat, 26 Oct 2013 23:02:05 +0100 +Message-Id: <1382824928-3771-2-git-send-email-markwalters1009@gmail.com> +X-Mailer: git-send-email 1.7.9.1 +In-Reply-To: <1382824928-3771-1-git-send-email-markwalters1009@gmail.com> +References: <1382824928-3771-1-git-send-email-markwalters1009@gmail.com> +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit +X-BeenThere: notmuch@notmuchmail.org +X-Mailman-Version: 2.1.13 +Precedence: list +List-Id: "Use and development of the notmuch mail system." + +List-Unsubscribe: , + +List-Archive: +List-Post: +List-Help: +List-Subscribe: , + +X-List-Received-Date: Sat, 26 Oct 2013 22:02:26 -0000 + +This changes all the lisp names from pick to tree (variables, +functions etc). It also changes the lisp in the emacs-pick test files +to match the new names. +--- + contrib/notmuch-pick/notmuch-pick.el | 951 ---------------------------------- + contrib/notmuch-pick/notmuch-tree.el | 951 ++++++++++++++++++++++++++++++++++ + contrib/notmuch-pick/test/emacs-pick | 74 ++-- + 3 files changed, 988 insertions(+), 988 deletions(-) + delete mode 100644 contrib/notmuch-pick/notmuch-pick.el + create mode 100644 contrib/notmuch-pick/notmuch-tree.el + +diff --git a/contrib/notmuch-pick/notmuch-pick.el b/contrib/notmuch-pick/notmuch-pick.el +deleted file mode 100644 +index 156ea6d..0000000 +--- a/contrib/notmuch-pick/notmuch-pick.el ++++ /dev/null +@@ -1,951 +0,0 @@ +-;; notmuch-pick.el --- displaying notmuch forests. +-;; +-;; Copyright © Carl Worth +-;; Copyright © David Edmondson +-;; Copyright © Mark Walters +-;; +-;; This file is part of Notmuch. +-;; +-;; Notmuch is free software: you can redistribute it and/or modify it +-;; under the terms of the GNU General Public License as published by +-;; the Free Software Foundation, either version 3 of the License, or +-;; (at your option) any later version. +-;; +-;; Notmuch is distributed in the hope that it will be useful, but +-;; WITHOUT ANY WARRANTY; without even the implied warranty of +-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-;; General Public License for more details. +-;; +-;; You should have received a copy of the GNU General Public License +-;; along with Notmuch. If not, see . +-;; +-;; Authors: David Edmondson +-;; Mark Walters +- +-(require 'mail-parse) +- +-(require 'notmuch-lib) +-(require 'notmuch-query) +-(require 'notmuch-show) +-(require 'notmuch) ;; XXX ATM, as notmuch-search-mode-map is defined here +- +-(eval-when-compile (require 'cl)) +- +-(declare-function notmuch-call-notmuch-process "notmuch" (&rest args)) +-(declare-function notmuch-show "notmuch-show" (&rest args)) +-(declare-function notmuch-tag "notmuch" (query &rest tags)) +-(declare-function notmuch-show-strip-re "notmuch-show" (subject)) +-(declare-function notmuch-show-spaces-n "notmuch-show" (n)) +-(declare-function notmuch-read-query "notmuch" (prompt)) +-(declare-function notmuch-read-tag-changes "notmuch" (current-tags &optional prompt initial-input)) +-(declare-function notmuch-update-tags "notmuch" (current-tags tag-changes)) +-(declare-function notmuch-hello-trim "notmuch-hello" (search)) +-(declare-function notmuch-search-find-thread-id "notmuch" ()) +-(declare-function notmuch-search-find-subject "notmuch" ()) +- +-;; the following variable is defined in notmuch.el +-(defvar notmuch-search-query-string) +- +-(defgroup notmuch-pick nil +- "Showing message and thread structure." +- :group 'notmuch) +- +-(defcustom notmuch-pick-show-out nil +- "View selected messages in new window rather than split-pane." +- :type 'boolean +- :group 'notmuch-pick) +- +-(defcustom notmuch-pick-result-format +- `(("date" . "%12s ") +- ("authors" . "%-20s") +- ((("tree" . "%s")("subject" . "%s")) ." %-54s ") +- ("tags" . "(%s)")) +- "Result formatting for Pick. Supported fields are: date, +- authors, subject, tree, tags. Tree means the thread tree +- box graphics. The field may also be a list in which case +- the formatting rules are applied recursively and then the +- output of all the fields in the list is inserted +- according to format-string. +- +-Note the author string should not contain +- whitespace (put it in the neighbouring fields instead). +- For example: +- (setq notmuch-pick-result-format \(\(\"authors\" . \"%-40s\"\) +- \(\"subject\" . \"%s\"\)\)\)" +- :type '(alist :key-type (string) :value-type (string)) +- :group 'notmuch-pick) +- +-;; Faces for messages that match the query. +-(defface notmuch-pick-match-date-face +- '((t :inherit default)) +- "Face used in pick mode for the date in messages matching the query." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defface notmuch-pick-match-author-face +- '((((class color) +- (background dark)) +- (:foreground "OliveDrab1")) +- (((class color) +- (background light)) +- (:foreground "dark blue")) +- (t +- (:bold t))) +- "Face used in pick mode for the date in messages matching the query." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defface notmuch-pick-match-subject-face +- '((t :inherit default)) +- "Face used in pick mode for the subject in messages matching the query." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defface notmuch-pick-match-tree-face +- '((t :inherit default)) +- "Face used in pick mode for the thread tree block graphics in messages matching the query." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defface notmuch-pick-match-tag-face +- '((((class color) +- (background dark)) +- (:foreground "OliveDrab1")) +- (((class color) +- (background light)) +- (:foreground "navy blue" :bold t)) +- (t +- (:bold t))) +- "Face used in pick mode for tags in messages matching the query." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-;; Faces for messages that do not match the query. +-(defface notmuch-pick-no-match-date-face +- '((t (:foreground "gray"))) +- "Face used in pick mode for non-matching dates." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defface notmuch-pick-no-match-subject-face +- '((t (:foreground "gray"))) +- "Face used in pick mode for non-matching subjects." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defface notmuch-pick-no-match-tree-face +- '((t (:foreground "gray"))) +- "Face used in pick mode for the thread tree block graphics in messages matching the query." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defface notmuch-pick-no-match-author-face +- '((t (:foreground "gray"))) +- "Face used in pick mode for the date in messages matching the query." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defface notmuch-pick-no-match-tag-face +- '((t (:foreground "gray"))) +- "Face used in pick mode face for non-matching tags." +- :group 'notmuch-pick +- :group 'notmuch-faces) +- +-(defvar notmuch-pick-previous-subject +- "The subject of the most recent result shown during the async display") +-(make-variable-buffer-local 'notmuch-pick-previous-subject) +- +-(defvar notmuch-pick-basic-query nil +- "A buffer local copy of argument query to the function notmuch-pick") +-(make-variable-buffer-local 'notmuch-pick-basic-query) +- +-(defvar notmuch-pick-query-context nil +- "A buffer local copy of argument query-context to the function notmuch-pick") +-(make-variable-buffer-local 'notmuch-pick-query-context) +- +-(defvar notmuch-pick-target-msg nil +- "A buffer local copy of argument target to the function notmuch-pick") +-(make-variable-buffer-local 'notmuch-pick-target-msg) +- +-(defvar notmuch-pick-open-target nil +- "A buffer local copy of argument open-target to the function notmuch-pick") +-(make-variable-buffer-local 'notmuch-pick-open-target) +- +-(defvar notmuch-pick-message-window nil +- "The window of the message pane. +- +-It is set in both the pick buffer and the child show buffer. It +-is used to try and close the message pane when quitting pick or +-the child show buffer.") +-(make-variable-buffer-local 'notmuch-pick-message-window) +-(put 'notmuch-pick-message-window 'permanent-local t) +- +-(defvar notmuch-pick-message-buffer nil +- "The buffer name of the show buffer in the message pane. +- +-This is used to try and make sure we don't close the message pane +-if the user has loaded a different buffer in that window.") +-(make-variable-buffer-local 'notmuch-pick-message-buffer) +-(put 'notmuch-pick-message-buffer 'permanent-local t) +- +-(defun notmuch-pick-to-message-pane (func) +- "Execute FUNC in message pane. +- +-This function returns a function (so can be used as a keybinding) +-which executes function FUNC in the message pane if it is +-open (if the message pane is closed it does nothing)." +- `(lambda () +- ,(concat "(In message pane) " (documentation func t)) +- (interactive) +- (when (window-live-p notmuch-pick-message-window) +- (with-selected-window notmuch-pick-message-window +- (call-interactively #',func))))) +- +-(defun notmuch-pick-button-activate (&optional button) +- "Activate BUTTON or button at point +- +-This function does not give an error if there is no button." +- (interactive) +- (let ((button (or button (button-at (point))))) +- (when button (button-activate button)))) +- +-(defun notmuch-pick-close-message-pane-and (func) +- "Close message pane and execute FUNC. +- +-This function returns a function (so can be used as a keybinding) +-which closes the message pane if open and then executes function +-FUNC." +- `(lambda () +- ,(concat "(Close message pane and) " (documentation func t)) +- (interactive) +- (notmuch-pick-close-message-window) +- (call-interactively #',func))) +- +-(defvar notmuch-pick-mode-map +- (let ((map (make-sparse-keymap))) +- (set-keymap-parent map notmuch-common-keymap) +- ;; The following override the global keymap. +- ;; Override because we want to close message pane first. +- (define-key map "?" (notmuch-pick-close-message-pane-and #'notmuch-help)) +- ;; Override because we first close message pane and then close pick buffer. +- (define-key map "q" 'notmuch-pick-quit) +- ;; Override because we close message pane after the search query is entered. +- (define-key map "s" 'notmuch-pick-to-search) +- ;; Override because we want to close message pane first. +- (define-key map "m" (notmuch-pick-close-message-pane-and #'notmuch-mua-new-mail)) +- +- ;; these use notmuch-show functions directly +- (define-key map "|" 'notmuch-show-pipe-message) +- (define-key map "w" 'notmuch-show-save-attachments) +- (define-key map "v" 'notmuch-show-view-all-mime-parts) +- (define-key map "c" 'notmuch-show-stash-map) +- +- ;; these apply to the message pane +- (define-key map (kbd "M-TAB") (notmuch-pick-to-message-pane #'notmuch-show-previous-button)) +- (define-key map (kbd "") (notmuch-pick-to-message-pane #'notmuch-show-previous-button)) +- (define-key map (kbd "TAB") (notmuch-pick-to-message-pane #'notmuch-show-next-button)) +- (define-key map "e" (notmuch-pick-to-message-pane #'notmuch-pick-button-activate)) +- +- ;; bindings from show (or elsewhere) but we close the message pane first. +- (define-key map "f" (notmuch-pick-close-message-pane-and #'notmuch-show-forward-message)) +- (define-key map "r" (notmuch-pick-close-message-pane-and #'notmuch-show-reply-sender)) +- (define-key map "R" (notmuch-pick-close-message-pane-and #'notmuch-show-reply)) +- (define-key map "V" (notmuch-pick-close-message-pane-and #'notmuch-show-view-raw-message)) +- +- ;; The main pick bindings +- (define-key map (kbd "RET") 'notmuch-pick-show-message) +- (define-key map [mouse-1] 'notmuch-pick-show-message) +- (define-key map "x" 'notmuch-pick-quit) +- (define-key map "A" 'notmuch-pick-archive-thread) +- (define-key map "a" 'notmuch-pick-archive-message-then-next) +- (define-key map "=" 'notmuch-pick-refresh-view) +- (define-key map "z" 'notmuch-pick-to-pick) +- (define-key map "n" 'notmuch-pick-next-matching-message) +- (define-key map "p" 'notmuch-pick-prev-matching-message) +- (define-key map "N" 'notmuch-pick-next-message) +- (define-key map "P" 'notmuch-pick-prev-message) +- (define-key map (kbd "M-p") 'notmuch-pick-prev-thread) +- (define-key map (kbd "M-n") 'notmuch-pick-next-thread) +- (define-key map "-" 'notmuch-pick-remove-tag) +- (define-key map "+" 'notmuch-pick-add-tag) +- (define-key map "*" 'notmuch-pick-tag-thread) +- (define-key map " " 'notmuch-pick-scroll-or-next) +- (define-key map "b" 'notmuch-pick-scroll-message-window-back) +- map)) +-(fset 'notmuch-pick-mode-map notmuch-pick-mode-map) +- +-(defun notmuch-pick-get-message-properties () +- "Return the properties of the current message as a plist. +- +-Some useful entries are: +-:headers - Property list containing the headers :Date, :Subject, :From, etc. +-:tags - Tags for this message" +- (save-excursion +- (beginning-of-line) +- (get-text-property (point) :notmuch-message-properties))) +- +-;; XXX This should really be a lib function but we are trying to +-;; reduce impact on the code base. +-(defun notmuch-show-get-prop (prop &optional props) +- "This is a pick overridden version of notmuch-show-get-prop +- +-It gets property PROP from PROPS or, if PROPS is nil, the current +-message in either pick or show. This means that several functions +-in notmuch-show now work unchanged in pick as they just need the +-correct message properties." +- (let ((props (or props +- (cond ((eq major-mode 'notmuch-show-mode) +- (notmuch-show-get-message-properties)) +- ((eq major-mode 'notmuch-pick-mode) +- (notmuch-pick-get-message-properties)))))) +- (plist-get props prop))) +- +-(defun notmuch-pick-set-message-properties (props) +- (save-excursion +- (beginning-of-line) +- (put-text-property (point) (+ (point) 1) :notmuch-message-properties props))) +- +-(defun notmuch-pick-set-prop (prop val &optional props) +- (let ((inhibit-read-only t) +- (props (or props +- (notmuch-pick-get-message-properties)))) +- (plist-put props prop val) +- (notmuch-pick-set-message-properties props))) +- +-(defun notmuch-pick-get-prop (prop &optional props) +- (let ((props (or props +- (notmuch-pick-get-message-properties)))) +- (plist-get props prop))) +- +-(defun notmuch-pick-set-tags (tags) +- "Set the tags of the current message." +- (notmuch-pick-set-prop :tags tags)) +- +-(defun notmuch-pick-get-tags () +- "Return the tags of the current message." +- (notmuch-pick-get-prop :tags)) +- +-(defun notmuch-pick-get-message-id () +- "Return the message id of the current message." +- (let ((id (notmuch-pick-get-prop :id))) +- (if id +- (notmuch-id-to-query id) +- nil))) +- +-(defun notmuch-pick-get-match () +- "Return whether the current message is a match." +- (interactive) +- (notmuch-pick-get-prop :match)) +- +-(defun notmuch-pick-refresh-result () +- "Redisplay the current message line. +- +-This redisplays the current line based on the messages +-properties (as they are now). This is used when tags are +-updated." +- (let ((init-point (point)) +- (end (line-end-position)) +- (msg (notmuch-pick-get-message-properties)) +- (inhibit-read-only t)) +- (beginning-of-line) +- ;; This is a little tricky: we override +- ;; notmuch-pick-previous-subject to get the decision between +- ;; ... and a subject right and it stops notmuch-pick-insert-msg +- ;; from overwriting the buffer local copy of +- ;; notmuch-pick-previous-subject if this is called while the +- ;; buffer is displaying. +- (let ((notmuch-pick-previous-subject (notmuch-pick-get-prop :previous-subject))) +- (delete-region (point) (1+ (line-end-position))) +- (notmuch-pick-insert-msg msg)) +- (let ((new-end (line-end-position))) +- (goto-char (if (= init-point end) +- new-end +- (min init-point (- new-end 1))))))) +- +-(defun notmuch-pick-tag-update-display (&optional tag-changes) +- "Update display for TAG-CHANGES to current message. +- +-Does NOT change the database." +- (let* ((current-tags (notmuch-pick-get-tags)) +- (new-tags (notmuch-update-tags current-tags tag-changes))) +- (unless (equal current-tags new-tags) +- (notmuch-pick-set-tags new-tags) +- (notmuch-pick-refresh-result)))) +- +-(defun notmuch-pick-tag (tag-changes) +- "Change tags for the current message" +- (interactive +- (list (notmuch-read-tag-changes (notmuch-pick-get-tags) "Tag message"))) +- (notmuch-tag (notmuch-pick-get-message-id) tag-changes) +- (notmuch-pick-tag-update-display tag-changes)) +- +-(defun notmuch-pick-add-tag (tag-changes) +- "Same as `notmuch-pick-tag' but sets initial input to '+'." +- (interactive +- (list (notmuch-read-tag-changes (notmuch-pick-get-tags) "Tag message" "+"))) +- (notmuch-pick-tag tag-changes)) +- +-(defun notmuch-pick-remove-tag (tag-changes) +- "Same as `notmuch-pick-tag' but sets initial input to '-'." +- (interactive +- (list (notmuch-read-tag-changes (notmuch-pick-get-tags) "Tag message" "-"))) +- (notmuch-pick-tag tag-changes)) +- +-;; The next two functions close the message window before searching or +-;; picking but they do so after the user has entered the query (in +-;; case the user was basing the query on something in the message +-;; window). +- +-(defun notmuch-pick-to-search () +- "Run \"notmuch search\" with the given `query' and display results." +- (interactive) +- (let ((query (notmuch-read-query "Notmuch search: "))) +- (notmuch-pick-close-message-window) +- (notmuch-search query))) +- +-(defun notmuch-pick-to-pick () +- "Run a query and display results in experimental notmuch-pick mode" +- (interactive) +- (let ((query (notmuch-read-query "Notmuch pick: "))) +- (notmuch-pick-close-message-window) +- (notmuch-pick query))) +- +-;; This function should be in notmuch-show.el but be we trying to +-;; minimise impact on the rest of the codebase. +-(defun notmuch-pick-from-show-current-query () +- "Call notmuch pick with the current query" +- (interactive) +- (notmuch-pick notmuch-show-thread-id +- notmuch-show-query-context +- (notmuch-show-get-message-id))) +- +-;; This function should be in notmuch.el but be we trying to minimise +-;; impact on the rest of the codebase. +-(defun notmuch-pick-from-search-current-query () +- "Call notmuch pick with the current query" +- (interactive) +- (notmuch-pick notmuch-search-query-string)) +- +-;; This function should be in notmuch.el but be we trying to minimise +-;; impact on the rest of the codebase. +-(defun notmuch-pick-from-search-thread () +- "Show the selected thread with notmuch-pick" +- (interactive) +- (notmuch-pick (notmuch-search-find-thread-id) +- notmuch-search-query-string +- nil +- (notmuch-prettify-subject (notmuch-search-find-subject)) +- t)) +- +-(defun notmuch-pick-message-window-kill-hook () +- "Close the message pane when exiting the show buffer." +- (let ((buffer (current-buffer))) +- (when (and (window-live-p notmuch-pick-message-window) +- (eq (window-buffer notmuch-pick-message-window) buffer)) +- ;; We do not want an error if this is the sole window in the +- ;; frame and I do not know how to test for that in emacs pre +- ;; 24. Hence we just ignore-errors. +- (ignore-errors +- (delete-window notmuch-pick-message-window))))) +- +-(defun notmuch-pick-show-message-in () +- "Show the current message (in split-pane)." +- (interactive) +- (let ((id (notmuch-pick-get-message-id)) +- (inhibit-read-only t) +- buffer) +- (when id +- ;; We close and reopen the window to kill off un-needed buffers +- ;; this might cause flickering but seems ok. +- (notmuch-pick-close-message-window) +- (setq notmuch-pick-message-window +- (split-window-vertically (/ (window-height) 4))) +- (with-selected-window notmuch-pick-message-window +- ;; Since we are only displaying one message do not indent. +- (let ((notmuch-show-indent-messages-width 0) +- (notmuch-show-only-matching-messages t)) +- (setq buffer (notmuch-show id)))) +- ;; We need the `let' as notmuch-pick-message-window is buffer local. +- (let ((window notmuch-pick-message-window)) +- (with-current-buffer buffer +- (setq notmuch-pick-message-window window) +- (add-hook 'kill-buffer-hook 'notmuch-pick-message-window-kill-hook))) +- (when notmuch-show-mark-read-tags +- (notmuch-pick-tag-update-display notmuch-show-mark-read-tags)) +- (setq notmuch-pick-message-buffer buffer)))) +- +-(defun notmuch-pick-show-message-out () +- "Show the current message (in whole window)." +- (interactive) +- (let ((id (notmuch-pick-get-message-id)) +- (inhibit-read-only t) +- buffer) +- (when id +- ;; We close the window to kill off un-needed buffers. +- (notmuch-pick-close-message-window) +- (notmuch-show id)))) +- +-(defun notmuch-pick-show-message (arg) +- "Show the current message. +- +-Shows in split pane or whole window according to value of +-`notmuch-pick-show-out'. A prefix argument reverses the choice." +- (interactive "P") +- (if (or (and notmuch-pick-show-out (not arg)) +- (and (not notmuch-pick-show-out) arg)) +- (notmuch-pick-show-message-out) +- (notmuch-pick-show-message-in))) +- +-(defun notmuch-pick-scroll-message-window () +- "Scroll the message window (if it exists)" +- (interactive) +- (when (window-live-p notmuch-pick-message-window) +- (with-selected-window notmuch-pick-message-window +- (if (pos-visible-in-window-p (point-max)) +- t +- (scroll-up))))) +- +-(defun notmuch-pick-scroll-message-window-back () +- "Scroll the message window back(if it exists)" +- (interactive) +- (when (window-live-p notmuch-pick-message-window) +- (with-selected-window notmuch-pick-message-window +- (if (pos-visible-in-window-p (point-min)) +- t +- (scroll-down))))) +- +-(defun notmuch-pick-scroll-or-next () +- "Scroll the message window. If it at end go to next message." +- (interactive) +- (when (notmuch-pick-scroll-message-window) +- (notmuch-pick-next-matching-message))) +- +-(defun notmuch-pick-quit () +- "Close the split view or exit pick." +- (interactive) +- (unless (notmuch-pick-close-message-window) +- (kill-buffer (current-buffer)))) +- +-(defun notmuch-pick-close-message-window () +- "Close the message-window. Return t if close succeeds." +- (interactive) +- (when (and (window-live-p notmuch-pick-message-window) +- (eq (window-buffer notmuch-pick-message-window) notmuch-pick-message-buffer)) +- (delete-window notmuch-pick-message-window) +- (unless (get-buffer-window-list notmuch-pick-message-buffer) +- (kill-buffer notmuch-pick-message-buffer)) +- t)) +- +-(defun notmuch-pick-archive-message (&optional unarchive) +- "Archive the current message. +- +-Archive the current message by applying the tag changes in +-`notmuch-archive-tags' to it. If a prefix argument is given, the +-message will be \"unarchived\", i.e. the tag changes in +-`notmuch-archive-tags' will be reversed." +- (interactive "P") +- (when notmuch-archive-tags +- (notmuch-pick-tag (notmuch-tag-change-list notmuch-archive-tags unarchive)))) +- +-(defun notmuch-pick-archive-message-then-next (&optional unarchive) +- "Archive the current message and move to next matching message." +- (interactive "P") +- (notmuch-pick-archive-message unarchive) +- (notmuch-pick-next-matching-message)) +- +-(defun notmuch-pick-next-message () +- "Move to next message." +- (interactive) +- (forward-line) +- (when (window-live-p notmuch-pick-message-window) +- (notmuch-pick-show-message-in))) +- +-(defun notmuch-pick-prev-message () +- "Move to previous message." +- (interactive) +- (forward-line -1) +- (when (window-live-p notmuch-pick-message-window) +- (notmuch-pick-show-message-in))) +- +-(defun notmuch-pick-prev-matching-message () +- "Move to previous matching message." +- (interactive) +- (forward-line -1) +- (while (and (not (bobp)) (not (notmuch-pick-get-match))) +- (forward-line -1)) +- (when (window-live-p notmuch-pick-message-window) +- (notmuch-pick-show-message-in))) +- +-(defun notmuch-pick-next-matching-message () +- "Move to next matching message." +- (interactive) +- (forward-line) +- (while (and (not (eobp)) (not (notmuch-pick-get-match))) +- (forward-line)) +- (when (window-live-p notmuch-pick-message-window) +- (notmuch-pick-show-message-in))) +- +-(defun notmuch-pick-refresh-view () +- "Refresh view." +- (interactive) +- (let ((inhibit-read-only t) +- (basic-query notmuch-pick-basic-query) +- (query-context notmuch-pick-query-context) +- (target (notmuch-pick-get-message-id))) +- (erase-buffer) +- (notmuch-pick-worker basic-query +- query-context +- target))) +- +-(defun notmuch-pick-thread-top () +- (when (notmuch-pick-get-message-properties) +- (while (not (or (notmuch-pick-get-prop :first) (eobp))) +- (forward-line -1)))) +- +-(defun notmuch-pick-prev-thread () +- (interactive) +- (forward-line -1) +- (notmuch-pick-thread-top)) +- +-(defun notmuch-pick-next-thread () +- (interactive) +- (forward-line 1) +- (while (not (or (notmuch-pick-get-prop :first) (eobp))) +- (forward-line 1))) +- +-(defun notmuch-pick-thread-mapcar (function) +- "Iterate through all messages in the current thread +- and call FUNCTION for side effects." +- (save-excursion +- (notmuch-pick-thread-top) +- (loop collect (funcall function) +- do (forward-line) +- while (and (notmuch-pick-get-message-properties) +- (not (notmuch-pick-get-prop :first)))))) +- +-(defun notmuch-pick-get-messages-ids-thread-search () +- "Return a search string for all message ids of messages in the current thread." +- (mapconcat 'identity +- (notmuch-pick-thread-mapcar 'notmuch-pick-get-message-id) +- " or ")) +- +-(defun notmuch-pick-tag-thread (tag-changes) +- "Tag all messages in the current thread" +- (interactive +- (let ((tags (apply #'append (notmuch-pick-thread-mapcar +- (lambda () (notmuch-pick-get-tags)))))) +- (list (notmuch-read-tag-changes tags "Tag thread")))) +- (when (notmuch-pick-get-message-properties) +- (notmuch-tag (notmuch-pick-get-messages-ids-thread-search) tag-changes) +- (notmuch-pick-thread-mapcar +- (lambda () (notmuch-pick-tag-update-display tag-changes))))) +- +-(defun notmuch-pick-archive-thread (&optional unarchive) +- "Archive each message in thread. +- +-Archive each message currently shown by applying the tag changes +-in `notmuch-archive-tags' to each. If a prefix argument is given, +-the messages will be \"unarchived\", i.e. the tag changes in +-`notmuch-archive-tags' will be reversed. +- +-Note: This command is safe from any race condition of new messages +-being delivered to the same thread. It does not archive the +-entire thread, but only the messages shown in the current +-buffer." +- (interactive "P") +- (when notmuch-archive-tags +- (notmuch-pick-tag-thread +- (notmuch-tag-change-list notmuch-archive-tags unarchive)))) +- +-;; Functions below here display the pick buffer itself. +- +-(defun notmuch-pick-clean-address (address) +- "Try to clean a single email ADDRESS for display. Return +-AUTHOR_NAME if present, otherwise return AUTHOR_EMAIL. Return +-unchanged ADDRESS if parsing fails." +- (let* ((clean-address (notmuch-clean-address address)) +- (p-address (car clean-address)) +- (p-name (cdr clean-address))) +- +- ;; If we have a name return that otherwise return the address. +- (or p-name p-address))) +- +-(defun notmuch-pick-format-field (field format-string msg) +- "Format a FIELD of MSG according to FORMAT-STRING and return string" +- (let* ((headers (plist-get msg :headers)) +- (match (plist-get msg :match))) +- (cond +- ((listp field) +- (format format-string (notmuch-pick-format-field-list field msg))) +- +- ((string-equal field "date") +- (let ((face (if match +- 'notmuch-pick-match-date-face +- 'notmuch-pick-no-match-date-face))) +- (propertize (format format-string (plist-get msg :date_relative)) 'face face))) +- +- ((string-equal field "tree") +- (let ((tree-status (plist-get msg :tree-status)) +- (face (if match +- 'notmuch-pick-match-tree-face +- 'notmuch-pick-no-match-tree-face))) +- +- (propertize (format format-string +- (mapconcat #'identity (reverse tree-status) "")) +- 'face face))) +- +- ((string-equal field "subject") +- (let ((bare-subject (notmuch-show-strip-re (plist-get headers :Subject))) +- (previous-subject notmuch-pick-previous-subject) +- (face (if match +- 'notmuch-pick-match-subject-face +- 'notmuch-pick-no-match-subject-face))) +- +- (setq notmuch-pick-previous-subject bare-subject) +- (propertize (format format-string +- (if (string= previous-subject bare-subject) +- " ..." +- bare-subject)) +- 'face face))) +- +- ((string-equal field "authors") +- (let ((author (notmuch-pick-clean-address (plist-get headers :From))) +- (len (length (format format-string ""))) +- (face (if match +- 'notmuch-pick-match-author-face +- 'notmuch-pick-no-match-author-face))) +- (when (> (length author) len) +- (setq author (substring author 0 len))) +- (propertize (format format-string author) 'face face))) +- +- ((string-equal field "tags") +- (let ((tags (plist-get msg :tags)) +- (face (if match +- 'notmuch-pick-match-tag-face +- 'notmuch-pick-no-match-tag-face))) +- (propertize (format format-string +- (mapconcat #'identity tags ", ")) +- 'face face)))))) +- +- +-(defun notmuch-pick-format-field-list (field-list msg) +- "Format fields of MSG according to FIELD-LIST and return string" +- (let (result-string) +- (dolist (spec field-list result-string) +- (let ((field-string (notmuch-pick-format-field (car spec) (cdr spec) msg))) +- (setq result-string (concat result-string field-string)))))) +- +-(defun notmuch-pick-insert-msg (msg) +- "Insert the message MSG according to notmuch-pick-result-format" +- ;; We need to save the previous subject as it will get overwritten +- ;; by the insert-field calls. +- (let ((previous-subject notmuch-pick-previous-subject)) +- (insert (notmuch-pick-format-field-list notmuch-pick-result-format msg)) +- (notmuch-pick-set-message-properties msg) +- (notmuch-pick-set-prop :previous-subject previous-subject) +- (insert "\n"))) +- +-(defun notmuch-pick-goto-and-insert-msg (msg) +- "Insert msg at the end of the buffer. Move point to msg if it is the target" +- (save-excursion +- (goto-char (point-max)) +- (notmuch-pick-insert-msg msg)) +- (let ((msg-id (notmuch-id-to-query (plist-get msg :id))) +- (target notmuch-pick-target-msg)) +- (when (or (and (not target) (plist-get msg :match)) +- (string= msg-id target)) +- (setq notmuch-pick-target-msg "found") +- (goto-char (point-max)) +- (forward-line -1) +- (when notmuch-pick-open-target +- (notmuch-pick-show-message-in))))) +- +-(defun notmuch-pick-insert-tree (tree depth tree-status first last) +- "Insert the message tree TREE at depth DEPTH in the current thread. +- +-A message tree is another name for a single sub-thread: i.e., a +-message together with all its descendents." +- (let ((msg (car tree)) +- (replies (cadr tree))) +- +- (cond +- ((and (< 0 depth) (not last)) +- (push "├" tree-status)) +- ((and (< 0 depth) last) +- (push "╰" tree-status)) +- ((and (eq 0 depth) first last) +-;; (push "─" tree-status)) choice between this and next line is matter of taste. +- (push " " tree-status)) +- ((and (eq 0 depth) first (not last)) +- (push "┬" tree-status)) +- ((and (eq 0 depth) (not first) last) +- (push "╰" tree-status)) +- ((and (eq 0 depth) (not first) (not last)) +- (push "├" tree-status))) +- +- (push (concat (if replies "┬" "─") "►") tree-status) +- (plist-put msg :first (and first (eq 0 depth))) +- (notmuch-pick-goto-and-insert-msg (plist-put msg :tree-status tree-status)) +- (pop tree-status) +- (pop tree-status) +- +- (if last +- (push " " tree-status) +- (push "│" tree-status)) +- +- (notmuch-pick-insert-thread replies (1+ depth) tree-status))) +- +-(defun notmuch-pick-insert-thread (thread depth tree-status) +- "Insert the collection of sibling sub-threads THREAD at depth DEPTH in the current forest." +- (let ((n (length thread))) +- (loop for tree in thread +- for count from 1 to n +- +- do (notmuch-pick-insert-tree tree depth tree-status (eq count 1) (eq count n))))) +- +-(defun notmuch-pick-insert-forest-thread (forest-thread) +- "Insert a single complete thread." +- (let (tree-status) +- ;; Reset at the start of each main thread. +- (setq notmuch-pick-previous-subject nil) +- (notmuch-pick-insert-thread forest-thread 0 tree-status))) +- +-(defun notmuch-pick-insert-forest (forest) +- "Insert a forest of threads. +- +-This function inserts a collection of several complete threads as +-passed to it by notmuch-pick-process-filter." +- (mapc 'notmuch-pick-insert-forest-thread forest)) +- +-(defun notmuch-pick-mode () +- "Major mode displaying messages (as opposed to threads) of of a notmuch search. +- +-This buffer contains the results of a \"notmuch pick\" of your +-email archives. Each line in the buffer represents a single +-message giving the relative date, the author, subject, and any +-tags. +- +-Pressing \\[notmuch-pick-show-message] on any line displays that message. +- +-Complete list of currently available key bindings: +- +-\\{notmuch-pick-mode-map}" +- +- (interactive) +- (kill-all-local-variables) +- (setq notmuch-buffer-refresh-function #'notmuch-pick-refresh-view) +- (use-local-map notmuch-pick-mode-map) +- (setq major-mode 'notmuch-pick-mode +- mode-name "notmuch-pick") +- (hl-line-mode 1) +- (setq buffer-read-only t +- truncate-lines t)) +- +-(defun notmuch-pick-process-sentinel (proc msg) +- "Add a message to let user know when \"notmuch pick\" exits" +- (let ((buffer (process-buffer proc)) +- (status (process-status proc)) +- (exit-status (process-exit-status proc)) +- (never-found-target-thread nil)) +- (when (memq status '(exit signal)) +- (kill-buffer (process-get proc 'parse-buf)) +- (if (buffer-live-p buffer) +- (with-current-buffer buffer +- (save-excursion +- (let ((inhibit-read-only t) +- (atbob (bobp))) +- (goto-char (point-max)) +- (if (eq status 'signal) +- (insert "Incomplete search results (pick process was killed).\n")) +- (when (eq status 'exit) +- (insert "End of search results.") +- (unless (= exit-status 0) +- (insert (format " (process returned %d)" exit-status))) +- (insert "\n"))))))))) +- +-(defun notmuch-pick-process-filter (proc string) +- "Process and filter the output of \"notmuch show\" (for pick)" +- (let ((results-buf (process-buffer proc)) +- (parse-buf (process-get proc 'parse-buf)) +- (inhibit-read-only t) +- done) +- (if (not (buffer-live-p results-buf)) +- (delete-process proc) +- (with-current-buffer parse-buf +- ;; Insert new data +- (save-excursion +- (goto-char (point-max)) +- (insert string)) +- (notmuch-sexp-parse-partial-list 'notmuch-pick-insert-forest-thread +- results-buf))))) +- +-(defun notmuch-pick-worker (basic-query &optional query-context target open-target) +- "Insert the actual pick search in the current buffer. +- +-This is is a helper function for notmuch-pick. The arguments are +-the same as for the function notmuch-pick." +- (interactive) +- (notmuch-pick-mode) +- (setq notmuch-pick-basic-query basic-query) +- (setq notmuch-pick-query-context query-context) +- (setq notmuch-pick-target-msg target) +- (setq notmuch-pick-open-target open-target) +- +- (erase-buffer) +- (goto-char (point-min)) +- (let* ((search-args (concat basic-query +- (if query-context (concat " and (" query-context ")")) +- )) +- (message-arg "--entire-thread")) +- (if (equal (car (process-lines notmuch-command "count" search-args)) "0") +- (setq search-args basic-query)) +- (let ((proc (notmuch-start-notmuch +- "notmuch-pick" (current-buffer) #'notmuch-pick-process-sentinel +- "show" "--body=false" "--format=sexp" +- message-arg search-args)) +- ;; Use a scratch buffer to accumulate partial output. +- ;; This buffer will be killed by the sentinel, which +- ;; should be called no matter how the process dies. +- (parse-buf (generate-new-buffer " *notmuch pick parse*"))) +- (process-put proc 'parse-buf parse-buf) +- (set-process-filter proc 'notmuch-pick-process-filter) +- (set-process-query-on-exit-flag proc nil)))) +- +-(defun notmuch-pick (&optional query query-context target buffer-name open-target) +- "Run notmuch pick with the given `query' and display the results. +- +-The arguments are: +- QUERY: the main query. This can be any query but in many cases will be +- a single thread. If nil this is read interactively from the minibuffer. +- QUERY-CONTEXT: is an additional term for the query. The query used +- is QUERY and QUERY-CONTEXT unless that does not match any messages +- in which case we fall back to just QUERY. +- TARGET: A message ID (with the id: prefix) that will be made +- current if it appears in the pick results. +- BUFFER-NAME: the name of the buffer to show the pick tree. If +- it is nil \"*notmuch-pick\" followed by QUERY is used. +- OPEN-TARGET: If TRUE open the target message in the message pane." +- (interactive) +- (if (null query) +- (setq query (notmuch-read-query "Notmuch pick: "))) +- (let ((buffer (get-buffer-create (generate-new-buffer-name +- (or buffer-name +- (concat "*notmuch-pick-" query "*"))))) +- (inhibit-read-only t)) +- +- (switch-to-buffer buffer)) +- ;; Don't track undo information for this buffer +- (set 'buffer-undo-list t) +- +- (notmuch-pick-worker query query-context target open-target) +- +- (setq truncate-lines t)) +- +- +-;; Set up key bindings from the rest of notmuch. +-(define-key notmuch-common-keymap "z" 'notmuch-pick) +-(define-key notmuch-search-mode-map "Z" 'notmuch-pick-from-search-current-query) +-(define-key notmuch-show-mode-map "Z" 'notmuch-pick-from-show-current-query) +-(message "Initialised notmuch-pick") +- +-(provide 'notmuch-pick) +diff --git a/contrib/notmuch-pick/notmuch-tree.el b/contrib/notmuch-pick/notmuch-tree.el +new file mode 100644 +index 0000000..512589f +--- /dev/null ++++ b/contrib/notmuch-pick/notmuch-tree.el +@@ -0,0 +1,951 @@ ++;; notmuch-tree.el --- displaying notmuch forests. ++;; ++;; Copyright © Carl Worth ++;; Copyright © David Edmondson ++;; Copyright © Mark Walters ++;; ++;; This file is part of Notmuch. ++;; ++;; Notmuch is free software: you can redistribute it and/or modify it ++;; under the terms of the GNU General Public License as published by ++;; the Free Software Foundation, either version 3 of the License, or ++;; (at your option) any later version. ++;; ++;; Notmuch is distributed in the hope that it will be useful, but ++;; WITHOUT ANY WARRANTY; without even the implied warranty of ++;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ++;; General Public License for more details. ++;; ++;; You should have received a copy of the GNU General Public License ++;; along with Notmuch. If not, see . ++;; ++;; Authors: David Edmondson ++;; Mark Walters ++ ++(require 'mail-parse) ++ ++(require 'notmuch-lib) ++(require 'notmuch-query) ++(require 'notmuch-show) ++(require 'notmuch) ;; XXX ATM, as notmuch-search-mode-map is defined here ++ ++(eval-when-compile (require 'cl)) ++ ++(declare-function notmuch-call-notmuch-process "notmuch" (&rest args)) ++(declare-function notmuch-show "notmuch-show" (&rest args)) ++(declare-function notmuch-tag "notmuch" (query &rest tags)) ++(declare-function notmuch-show-strip-re "notmuch-show" (subject)) ++(declare-function notmuch-show-spaces-n "notmuch-show" (n)) ++(declare-function notmuch-read-query "notmuch" (prompt)) ++(declare-function notmuch-read-tag-changes "notmuch" (current-tags &optional prompt initial-input)) ++(declare-function notmuch-update-tags "notmuch" (current-tags tag-changes)) ++(declare-function notmuch-hello-trim "notmuch-hello" (search)) ++(declare-function notmuch-search-find-thread-id "notmuch" ()) ++(declare-function notmuch-search-find-subject "notmuch" ()) ++ ++;; the following variable is defined in notmuch.el ++(defvar notmuch-search-query-string) ++ ++(defgroup notmuch-tree nil ++ "Showing message and thread structure." ++ :group 'notmuch) ++ ++(defcustom notmuch-tree-show-out nil ++ "View selected messages in new window rather than split-pane." ++ :type 'boolean ++ :group 'notmuch-tree) ++ ++(defcustom notmuch-tree-result-format ++ `(("date" . "%12s ") ++ ("authors" . "%-20s") ++ ((("tree" . "%s")("subject" . "%s")) ." %-54s ") ++ ("tags" . "(%s)")) ++ "Result formatting for Tree view. Supported fields are: date, ++ authors, subject, tree, tags. Tree means the thread tree ++ box graphics. The field may also be a list in which case ++ the formatting rules are applied recursively and then the ++ output of all the fields in the list is inserted ++ according to format-string. ++ ++Note the author string should not contain ++ whitespace (put it in the neighbouring fields instead). ++ For example: ++ (setq notmuch-tree-result-format \(\(\"authors\" . \"%-40s\"\) ++ \(\"subject\" . \"%s\"\)\)\)" ++ :type '(alist :key-type (string) :value-type (string)) ++ :group 'notmuch-tree) ++ ++;; Faces for messages that match the query. ++(defface notmuch-tree-match-date-face ++ '((t :inherit default)) ++ "Face used in tree mode for the date in messages matching the query." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defface notmuch-tree-match-author-face ++ '((((class color) ++ (background dark)) ++ (:foreground "OliveDrab1")) ++ (((class color) ++ (background light)) ++ (:foreground "dark blue")) ++ (t ++ (:bold t))) ++ "Face used in tree mode for the date in messages matching the query." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defface notmuch-tree-match-subject-face ++ '((t :inherit default)) ++ "Face used in tree mode for the subject in messages matching the query." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defface notmuch-tree-match-tree-face ++ '((t :inherit default)) ++ "Face used in tree mode for the thread tree block graphics in messages matching the query." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defface notmuch-tree-match-tag-face ++ '((((class color) ++ (background dark)) ++ (:foreground "OliveDrab1")) ++ (((class color) ++ (background light)) ++ (:foreground "navy blue" :bold t)) ++ (t ++ (:bold t))) ++ "Face used in tree mode for tags in messages matching the query." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++;; Faces for messages that do not match the query. ++(defface notmuch-tree-no-match-date-face ++ '((t (:foreground "gray"))) ++ "Face used in tree mode for non-matching dates." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defface notmuch-tree-no-match-subject-face ++ '((t (:foreground "gray"))) ++ "Face used in tree mode for non-matching subjects." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defface notmuch-tree-no-match-tree-face ++ '((t (:foreground "gray"))) ++ "Face used in tree mode for the thread tree block graphics in messages matching the query." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defface notmuch-tree-no-match-author-face ++ '((t (:foreground "gray"))) ++ "Face used in tree mode for the date in messages matching the query." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defface notmuch-tree-no-match-tag-face ++ '((t (:foreground "gray"))) ++ "Face used in tree mode face for non-matching tags." ++ :group 'notmuch-tree ++ :group 'notmuch-faces) ++ ++(defvar notmuch-tree-previous-subject ++ "The subject of the most recent result shown during the async display") ++(make-variable-buffer-local 'notmuch-tree-previous-subject) ++ ++(defvar notmuch-tree-basic-query nil ++ "A buffer local copy of argument query to the function notmuch-tree") ++(make-variable-buffer-local 'notmuch-tree-basic-query) ++ ++(defvar notmuch-tree-query-context nil ++ "A buffer local copy of argument query-context to the function notmuch-tree") ++(make-variable-buffer-local 'notmuch-tree-query-context) ++ ++(defvar notmuch-tree-target-msg nil ++ "A buffer local copy of argument target to the function notmuch-tree") ++(make-variable-buffer-local 'notmuch-tree-target-msg) ++ ++(defvar notmuch-tree-open-target nil ++ "A buffer local copy of argument open-target to the function notmuch-tree") ++(make-variable-buffer-local 'notmuch-tree-open-target) ++ ++(defvar notmuch-tree-message-window nil ++ "The window of the message pane. ++ ++It is set in both the tree buffer and the child show buffer. It ++is used to try and close the message pane when quitting tree view ++or the child show buffer.") ++(make-variable-buffer-local 'notmuch-tree-message-window) ++(put 'notmuch-tree-message-window 'permanent-local t) ++ ++(defvar notmuch-tree-message-buffer nil ++ "The buffer name of the show buffer in the message pane. ++ ++This is used to try and make sure we don't close the message pane ++if the user has loaded a different buffer in that window.") ++(make-variable-buffer-local 'notmuch-tree-message-buffer) ++(put 'notmuch-tree-message-buffer 'permanent-local t) ++ ++(defun notmuch-tree-to-message-pane (func) ++ "Execute FUNC in message pane. ++ ++This function returns a function (so can be used as a keybinding) ++which executes function FUNC in the message pane if it is ++open (if the message pane is closed it does nothing)." ++ `(lambda () ++ ,(concat "(In message pane) " (documentation func t)) ++ (interactive) ++ (when (window-live-p notmuch-tree-message-window) ++ (with-selected-window notmuch-tree-message-window ++ (call-interactively #',func))))) ++ ++(defun notmuch-tree-button-activate (&optional button) ++ "Activate BUTTON or button at point ++ ++This function does not give an error if there is no button." ++ (interactive) ++ (let ((button (or button (button-at (point))))) ++ (when button (button-activate button)))) ++ ++(defun notmuch-tree-close-message-pane-and (func) ++ "Close message pane and execute FUNC. ++ ++This function returns a function (so can be used as a keybinding) ++which closes the message pane if open and then executes function ++FUNC." ++ `(lambda () ++ ,(concat "(Close message pane and) " (documentation func t)) ++ (interactive) ++ (notmuch-tree-close-message-window) ++ (call-interactively #',func))) ++ ++(defvar notmuch-tree-mode-map ++ (let ((map (make-sparse-keymap))) ++ (set-keymap-parent map notmuch-common-keymap) ++ ;; The following override the global keymap. ++ ;; Override because we want to close message pane first. ++ (define-key map "?" (notmuch-tree-close-message-pane-and #'notmuch-help)) ++ ;; Override because we first close message pane and then close tree buffer. ++ (define-key map "q" 'notmuch-tree-quit) ++ ;; Override because we close message pane after the search query is entered. ++ (define-key map "s" 'notmuch-tree-to-search) ++ ;; Override because we want to close message pane first. ++ (define-key map "m" (notmuch-tree-close-message-pane-and #'notmuch-mua-new-mail)) ++ ++ ;; these use notmuch-show functions directly ++ (define-key map "|" 'notmuch-show-pipe-message) ++ (define-key map "w" 'notmuch-show-save-attachments) ++ (define-key map "v" 'notmuch-show-view-all-mime-parts) ++ (define-key map "c" 'notmuch-show-stash-map) ++ ++ ;; these apply to the message pane ++ (define-key map (kbd "M-TAB") (notmuch-tree-to-message-pane #'notmuch-show-previous-button)) ++ (define-key map (kbd "") (notmuch-tree-to-message-pane #'notmuch-show-previous-button)) ++ (define-key map (kbd "TAB") (notmuch-tree-to-message-pane #'notmuch-show-next-button)) ++ (define-key map "e" (notmuch-tree-to-message-pane #'notmuch-tree-button-activate)) ++ ++ ;; bindings from show (or elsewhere) but we close the message pane first. ++ (define-key map "f" (notmuch-tree-close-message-pane-and #'notmuch-show-forward-message)) ++ (define-key map "r" (notmuch-tree-close-message-pane-and #'notmuch-show-reply-sender)) ++ (define-key map "R" (notmuch-tree-close-message-pane-and #'notmuch-show-reply)) ++ (define-key map "V" (notmuch-tree-close-message-pane-and #'notmuch-show-view-raw-message)) ++ ++ ;; The main tree view bindings ++ (define-key map (kbd "RET") 'notmuch-tree-show-message) ++ (define-key map [mouse-1] 'notmuch-tree-show-message) ++ (define-key map "x" 'notmuch-tree-quit) ++ (define-key map "A" 'notmuch-tree-archive-thread) ++ (define-key map "a" 'notmuch-tree-archive-message-then-next) ++ (define-key map "=" 'notmuch-tree-refresh-view) ++ (define-key map "z" 'notmuch-tree-to-tree) ++ (define-key map "n" 'notmuch-tree-next-matching-message) ++ (define-key map "p" 'notmuch-tree-prev-matching-message) ++ (define-key map "N" 'notmuch-tree-next-message) ++ (define-key map "P" 'notmuch-tree-prev-message) ++ (define-key map (kbd "M-p") 'notmuch-tree-prev-thread) ++ (define-key map (kbd "M-n") 'notmuch-tree-next-thread) ++ (define-key map "-" 'notmuch-tree-remove-tag) ++ (define-key map "+" 'notmuch-tree-add-tag) ++ (define-key map "*" 'notmuch-tree-tag-thread) ++ (define-key map " " 'notmuch-tree-scroll-or-next) ++ (define-key map "b" 'notmuch-tree-scroll-message-window-back) ++ map)) ++(fset 'notmuch-tree-mode-map notmuch-tree-mode-map) ++ ++(defun notmuch-tree-get-message-properties () ++ "Return the properties of the current message as a plist. ++ ++Some useful entries are: ++:headers - Property list containing the headers :Date, :Subject, :From, etc. ++:tags - Tags for this message" ++ (save-excursion ++ (beginning-of-line) ++ (get-text-property (point) :notmuch-message-properties))) ++ ++;; XXX This should really be a lib function but we are trying to ++;; reduce impact on the code base. ++(defun notmuch-show-get-prop (prop &optional props) ++ "This is a tree view overridden version of notmuch-show-get-prop ++ ++It gets property PROP from PROPS or, if PROPS is nil, the current ++message in either tree or show. This means that several functions ++in notmuch-show now work unchanged in tree as they just need the ++correct message properties." ++ (let ((props (or props ++ (cond ((eq major-mode 'notmuch-show-mode) ++ (notmuch-show-get-message-properties)) ++ ((eq major-mode 'notmuch-tree-mode) ++ (notmuch-tree-get-message-properties)))))) ++ (plist-get props prop))) ++ ++(defun notmuch-tree-set-message-properties (props) ++ (save-excursion ++ (beginning-of-line) ++ (put-text-property (point) (+ (point) 1) :notmuch-message-properties props))) ++ ++(defun notmuch-tree-set-prop (prop val &optional props) ++ (let ((inhibit-read-only t) ++ (props (or props ++ (notmuch-tree-get-message-properties)))) ++ (plist-put props prop val) ++ (notmuch-tree-set-message-properties props))) ++ ++(defun notmuch-tree-get-prop (prop &optional props) ++ (let ((props (or props ++ (notmuch-tree-get-message-properties)))) ++ (plist-get props prop))) ++ ++(defun notmuch-tree-set-tags (tags) ++ "Set the tags of the current message." ++ (notmuch-tree-set-prop :tags tags)) ++ ++(defun notmuch-tree-get-tags () ++ "Return the tags of the current message." ++ (notmuch-tree-get-prop :tags)) ++ ++(defun notmuch-tree-get-message-id () ++ "Return the message id of the current message." ++ (let ((id (notmuch-tree-get-prop :id))) ++ (if id ++ (notmuch-id-to-query id) ++ nil))) ++ ++(defun notmuch-tree-get-match () ++ "Return whether the current message is a match." ++ (interactive) ++ (notmuch-tree-get-prop :match)) ++ ++(defun notmuch-tree-refresh-result () ++ "Redisplay the current message line. ++ ++This redisplays the current line based on the messages ++properties (as they are now). This is used when tags are ++updated." ++ (let ((init-point (point)) ++ (end (line-end-position)) ++ (msg (notmuch-tree-get-message-properties)) ++ (inhibit-read-only t)) ++ (beginning-of-line) ++ ;; This is a little tricky: we override ++ ;; notmuch-tree-previous-subject to get the decision between ++ ;; ... and a subject right and it stops notmuch-tree-insert-msg ++ ;; from overwriting the buffer local copy of ++ ;; notmuch-tree-previous-subject if this is called while the ++ ;; buffer is displaying. ++ (let ((notmuch-tree-previous-subject (notmuch-tree-get-prop :previous-subject))) ++ (delete-region (point) (1+ (line-end-position))) ++ (notmuch-tree-insert-msg msg)) ++ (let ((new-end (line-end-position))) ++ (goto-char (if (= init-point end) ++ new-end ++ (min init-point (- new-end 1))))))) ++ ++(defun notmuch-tree-tag-update-display (&optional tag-changes) ++ "Update display for TAG-CHANGES to current message. ++ ++Does NOT change the database." ++ (let* ((current-tags (notmuch-tree-get-tags)) ++ (new-tags (notmuch-update-tags current-tags tag-changes))) ++ (unless (equal current-tags new-tags) ++ (notmuch-tree-set-tags new-tags) ++ (notmuch-tree-refresh-result)))) ++ ++(defun notmuch-tree-tag (tag-changes) ++ "Change tags for the current message" ++ (interactive ++ (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message"))) ++ (notmuch-tag (notmuch-tree-get-message-id) tag-changes) ++ (notmuch-tree-tag-update-display tag-changes)) ++ ++(defun notmuch-tree-add-tag (tag-changes) ++ "Same as `notmuch-tree-tag' but sets initial input to '+'." ++ (interactive ++ (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "+"))) ++ (notmuch-tree-tag tag-changes)) ++ ++(defun notmuch-tree-remove-tag (tag-changes) ++ "Same as `notmuch-tree-tag' but sets initial input to '-'." ++ (interactive ++ (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "-"))) ++ (notmuch-tree-tag tag-changes)) ++ ++;; The next two functions close the message window before calling ++;; notmuch-search or notmuch-tree but they do so after the user has ++;; entered the query (in case the user was basing the query on ++;; something in the message window). ++ ++(defun notmuch-tree-to-search () ++ "Run \"notmuch search\" with the given `query' and display results." ++ (interactive) ++ (let ((query (notmuch-read-query "Notmuch search: "))) ++ (notmuch-tree-close-message-window) ++ (notmuch-search query))) ++ ++(defun notmuch-tree-to-tree () ++ "Run a query and display results in Tree view" ++ (interactive) ++ (let ((query (notmuch-read-query "Notmuch tree view search: "))) ++ (notmuch-tree-close-message-window) ++ (notmuch-tree query))) ++ ++;; This function should be in notmuch-show.el but be we trying to ++;; minimise impact on the rest of the codebase. ++(defun notmuch-tree-from-show-current-query () ++ "Call notmuch tree with the current query" ++ (interactive) ++ (notmuch-tree notmuch-show-thread-id ++ notmuch-show-query-context ++ (notmuch-show-get-message-id))) ++ ++;; This function should be in notmuch.el but be we trying to minimise ++;; impact on the rest of the codebase. ++(defun notmuch-tree-from-search-current-query () ++ "Call notmuch tree with the current query" ++ (interactive) ++ (notmuch-tree notmuch-search-query-string)) ++ ++;; This function should be in notmuch.el but be we trying to minimise ++;; impact on the rest of the codebase. ++(defun notmuch-tree-from-search-thread () ++ "Show the selected thread with notmuch-tree" ++ (interactive) ++ (notmuch-tree (notmuch-search-find-thread-id) ++ notmuch-search-query-string ++ nil ++ (notmuch-prettify-subject (notmuch-search-find-subject)) ++ t)) ++ ++(defun notmuch-tree-message-window-kill-hook () ++ "Close the message pane when exiting the show buffer." ++ (let ((buffer (current-buffer))) ++ (when (and (window-live-p notmuch-tree-message-window) ++ (eq (window-buffer notmuch-tree-message-window) buffer)) ++ ;; We do not want an error if this is the sole window in the ++ ;; frame and I do not know how to test for that in emacs pre ++ ;; 24. Hence we just ignore-errors. ++ (ignore-errors ++ (delete-window notmuch-tree-message-window))))) ++ ++(defun notmuch-tree-show-message-in () ++ "Show the current message (in split-pane)." ++ (interactive) ++ (let ((id (notmuch-tree-get-message-id)) ++ (inhibit-read-only t) ++ buffer) ++ (when id ++ ;; We close and reopen the window to kill off un-needed buffers ++ ;; this might cause flickering but seems ok. ++ (notmuch-tree-close-message-window) ++ (setq notmuch-tree-message-window ++ (split-window-vertically (/ (window-height) 4))) ++ (with-selected-window notmuch-tree-message-window ++ ;; Since we are only displaying one message do not indent. ++ (let ((notmuch-show-indent-messages-width 0) ++ (notmuch-show-only-matching-messages t)) ++ (setq buffer (notmuch-show id)))) ++ ;; We need the `let' as notmuch-tree-message-window is buffer local. ++ (let ((window notmuch-tree-message-window)) ++ (with-current-buffer buffer ++ (setq notmuch-tree-message-window window) ++ (add-hook 'kill-buffer-hook 'notmuch-tree-message-window-kill-hook))) ++ (when notmuch-show-mark-read-tags ++ (notmuch-tree-tag-update-display notmuch-show-mark-read-tags)) ++ (setq notmuch-tree-message-buffer buffer)))) ++ ++(defun notmuch-tree-show-message-out () ++ "Show the current message (in whole window)." ++ (interactive) ++ (let ((id (notmuch-tree-get-message-id)) ++ (inhibit-read-only t) ++ buffer) ++ (when id ++ ;; We close the window to kill off un-needed buffers. ++ (notmuch-tree-close-message-window) ++ (notmuch-show id)))) ++ ++(defun notmuch-tree-show-message (arg) ++ "Show the current message. ++ ++Shows in split pane or whole window according to value of ++`notmuch-tree-show-out'. A prefix argument reverses the choice." ++ (interactive "P") ++ (if (or (and notmuch-tree-show-out (not arg)) ++ (and (not notmuch-tree-show-out) arg)) ++ (notmuch-tree-show-message-out) ++ (notmuch-tree-show-message-in))) ++ ++(defun notmuch-tree-scroll-message-window () ++ "Scroll the message window (if it exists)" ++ (interactive) ++ (when (window-live-p notmuch-tree-message-window) ++ (with-selected-window notmuch-tree-message-window ++ (if (pos-visible-in-window-p (point-max)) ++ t ++ (scroll-up))))) ++ ++(defun notmuch-tree-scroll-message-window-back () ++ "Scroll the message window back(if it exists)" ++ (interactive) ++ (when (window-live-p notmuch-tree-message-window) ++ (with-selected-window notmuch-tree-message-window ++ (if (pos-visible-in-window-p (point-min)) ++ t ++ (scroll-down))))) ++ ++(defun notmuch-tree-scroll-or-next () ++ "Scroll the message window. If it at end go to next message." ++ (interactive) ++ (when (notmuch-tree-scroll-message-window) ++ (notmuch-tree-next-matching-message))) ++ ++(defun notmuch-tree-quit () ++ "Close the split view or exit tree." ++ (interactive) ++ (unless (notmuch-tree-close-message-window) ++ (kill-buffer (current-buffer)))) ++ ++(defun notmuch-tree-close-message-window () ++ "Close the message-window. Return t if close succeeds." ++ (interactive) ++ (when (and (window-live-p notmuch-tree-message-window) ++ (eq (window-buffer notmuch-tree-message-window) notmuch-tree-message-buffer)) ++ (delete-window notmuch-tree-message-window) ++ (unless (get-buffer-window-list notmuch-tree-message-buffer) ++ (kill-buffer notmuch-tree-message-buffer)) ++ t)) ++ ++(defun notmuch-tree-archive-message (&optional unarchive) ++ "Archive the current message. ++ ++Archive the current message by applying the tag changes in ++`notmuch-archive-tags' to it. If a prefix argument is given, the ++message will be \"unarchived\", i.e. the tag changes in ++`notmuch-archive-tags' will be reversed." ++ (interactive "P") ++ (when notmuch-archive-tags ++ (notmuch-tree-tag (notmuch-tag-change-list notmuch-archive-tags unarchive)))) ++ ++(defun notmuch-tree-archive-message-then-next (&optional unarchive) ++ "Archive the current message and move to next matching message." ++ (interactive "P") ++ (notmuch-tree-archive-message unarchive) ++ (notmuch-tree-next-matching-message)) ++ ++(defun notmuch-tree-next-message () ++ "Move to next message." ++ (interactive) ++ (forward-line) ++ (when (window-live-p notmuch-tree-message-window) ++ (notmuch-tree-show-message-in))) ++ ++(defun notmuch-tree-prev-message () ++ "Move to previous message." ++ (interactive) ++ (forward-line -1) ++ (when (window-live-p notmuch-tree-message-window) ++ (notmuch-tree-show-message-in))) ++ ++(defun notmuch-tree-prev-matching-message () ++ "Move to previous matching message." ++ (interactive) ++ (forward-line -1) ++ (while (and (not (bobp)) (not (notmuch-tree-get-match))) ++ (forward-line -1)) ++ (when (window-live-p notmuch-tree-message-window) ++ (notmuch-tree-show-message-in))) ++ ++(defun notmuch-tree-next-matching-message () ++ "Move to next matching message." ++ (interactive) ++ (forward-line) ++ (while (and (not (eobp)) (not (notmuch-tree-get-match))) ++ (forward-line)) ++ (when (window-live-p notmuch-tree-message-window) ++ (notmuch-tree-show-message-in))) ++ ++(defun notmuch-tree-refresh-view () ++ "Refresh view." ++ (interactive) ++ (let ((inhibit-read-only t) ++ (basic-query notmuch-tree-basic-query) ++ (query-context notmuch-tree-query-context) ++ (target (notmuch-tree-get-message-id))) ++ (erase-buffer) ++ (notmuch-tree-worker basic-query ++ query-context ++ target))) ++ ++(defun notmuch-tree-thread-top () ++ (when (notmuch-tree-get-message-properties) ++ (while (not (or (notmuch-tree-get-prop :first) (eobp))) ++ (forward-line -1)))) ++ ++(defun notmuch-tree-prev-thread () ++ (interactive) ++ (forward-line -1) ++ (notmuch-tree-thread-top)) ++ ++(defun notmuch-tree-next-thread () ++ (interactive) ++ (forward-line 1) ++ (while (not (or (notmuch-tree-get-prop :first) (eobp))) ++ (forward-line 1))) ++ ++(defun notmuch-tree-thread-mapcar (function) ++ "Iterate through all messages in the current thread ++ and call FUNCTION for side effects." ++ (save-excursion ++ (notmuch-tree-thread-top) ++ (loop collect (funcall function) ++ do (forward-line) ++ while (and (notmuch-tree-get-message-properties) ++ (not (notmuch-tree-get-prop :first)))))) ++ ++(defun notmuch-tree-get-messages-ids-thread-search () ++ "Return a search string for all message ids of messages in the current thread." ++ (mapconcat 'identity ++ (notmuch-tree-thread-mapcar 'notmuch-tree-get-message-id) ++ " or ")) ++ ++(defun notmuch-tree-tag-thread (tag-changes) ++ "Tag all messages in the current thread" ++ (interactive ++ (let ((tags (apply #'append (notmuch-tree-thread-mapcar ++ (lambda () (notmuch-tree-get-tags)))))) ++ (list (notmuch-read-tag-changes tags "Tag thread")))) ++ (when (notmuch-tree-get-message-properties) ++ (notmuch-tag (notmuch-tree-get-messages-ids-thread-search) tag-changes) ++ (notmuch-tree-thread-mapcar ++ (lambda () (notmuch-tree-tag-update-display tag-changes))))) ++ ++(defun notmuch-tree-archive-thread (&optional unarchive) ++ "Archive each message in thread. ++ ++Archive each message currently shown by applying the tag changes ++in `notmuch-archive-tags' to each. If a prefix argument is given, ++the messages will be \"unarchived\", i.e. the tag changes in ++`notmuch-archive-tags' will be reversed. ++ ++Note: This command is safe from any race condition of new messages ++being delivered to the same thread. It does not archive the ++entire thread, but only the messages shown in the current ++buffer." ++ (interactive "P") ++ (when notmuch-archive-tags ++ (notmuch-tree-tag-thread ++ (notmuch-tag-change-list notmuch-archive-tags unarchive)))) ++ ++;; Functions below here display the tree buffer itself. ++ ++(defun notmuch-tree-clean-address (address) ++ "Try to clean a single email ADDRESS for display. Return ++AUTHOR_NAME if present, otherwise return AUTHOR_EMAIL. Return ++unchanged ADDRESS if parsing fails." ++ (let* ((clean-address (notmuch-clean-address address)) ++ (p-address (car clean-address)) ++ (p-name (cdr clean-address))) ++ ++ ;; If we have a name return that otherwise return the address. ++ (or p-name p-address))) ++ ++(defun notmuch-tree-format-field (field format-string msg) ++ "Format a FIELD of MSG according to FORMAT-STRING and return string" ++ (let* ((headers (plist-get msg :headers)) ++ (match (plist-get msg :match))) ++ (cond ++ ((listp field) ++ (format format-string (notmuch-tree-format-field-list field msg))) ++ ++ ((string-equal field "date") ++ (let ((face (if match ++ 'notmuch-tree-match-date-face ++ 'notmuch-tree-no-match-date-face))) ++ (propertize (format format-string (plist-get msg :date_relative)) 'face face))) ++ ++ ((string-equal field "tree") ++ (let ((tree-status (plist-get msg :tree-status)) ++ (face (if match ++ 'notmuch-tree-match-tree-face ++ 'notmuch-tree-no-match-tree-face))) ++ ++ (propertize (format format-string ++ (mapconcat #'identity (reverse tree-status) "")) ++ 'face face))) ++ ++ ((string-equal field "subject") ++ (let ((bare-subject (notmuch-show-strip-re (plist-get headers :Subject))) ++ (previous-subject notmuch-tree-previous-subject) ++ (face (if match ++ 'notmuch-tree-match-subject-face ++ 'notmuch-tree-no-match-subject-face))) ++ ++ (setq notmuch-tree-previous-subject bare-subject) ++ (propertize (format format-string ++ (if (string= previous-subject bare-subject) ++ " ..." ++ bare-subject)) ++ 'face face))) ++ ++ ((string-equal field "authors") ++ (let ((author (notmuch-tree-clean-address (plist-get headers :From))) ++ (len (length (format format-string ""))) ++ (face (if match ++ 'notmuch-tree-match-author-face ++ 'notmuch-tree-no-match-author-face))) ++ (when (> (length author) len) ++ (setq author (substring author 0 len))) ++ (propertize (format format-string author) 'face face))) ++ ++ ((string-equal field "tags") ++ (let ((tags (plist-get msg :tags)) ++ (face (if match ++ 'notmuch-tree-match-tag-face ++ 'notmuch-tree-no-match-tag-face))) ++ (propertize (format format-string ++ (mapconcat #'identity tags ", ")) ++ 'face face)))))) ++ ++ ++(defun notmuch-tree-format-field-list (field-list msg) ++ "Format fields of MSG according to FIELD-LIST and return string" ++ (let (result-string) ++ (dolist (spec field-list result-string) ++ (let ((field-string (notmuch-tree-format-field (car spec) (cdr spec) msg))) ++ (setq result-string (concat result-string field-string)))))) ++ ++(defun notmuch-tree-insert-msg (msg) ++ "Insert the message MSG according to notmuch-tree-result-format" ++ ;; We need to save the previous subject as it will get overwritten ++ ;; by the insert-field calls. ++ (let ((previous-subject notmuch-tree-previous-subject)) ++ (insert (notmuch-tree-format-field-list notmuch-tree-result-format msg)) ++ (notmuch-tree-set-message-properties msg) ++ (notmuch-tree-set-prop :previous-subject previous-subject) ++ (insert "\n"))) ++ ++(defun notmuch-tree-goto-and-insert-msg (msg) ++ "Insert msg at the end of the buffer. Move point to msg if it is the target" ++ (save-excursion ++ (goto-char (point-max)) ++ (notmuch-tree-insert-msg msg)) ++ (let ((msg-id (notmuch-id-to-query (plist-get msg :id))) ++ (target notmuch-tree-target-msg)) ++ (when (or (and (not target) (plist-get msg :match)) ++ (string= msg-id target)) ++ (setq notmuch-tree-target-msg "found") ++ (goto-char (point-max)) ++ (forward-line -1) ++ (when notmuch-tree-open-target ++ (notmuch-tree-show-message-in))))) ++ ++(defun notmuch-tree-insert-tree (tree depth tree-status first last) ++ "Insert the message tree TREE at depth DEPTH in the current thread. ++ ++A message tree is another name for a single sub-thread: i.e., a ++message together with all its descendents." ++ (let ((msg (car tree)) ++ (replies (cadr tree))) ++ ++ (cond ++ ((and (< 0 depth) (not last)) ++ (push "├" tree-status)) ++ ((and (< 0 depth) last) ++ (push "╰" tree-status)) ++ ((and (eq 0 depth) first last) ++;; (push "─" tree-status)) choice between this and next line is matter of taste. ++ (push " " tree-status)) ++ ((and (eq 0 depth) first (not last)) ++ (push "┬" tree-status)) ++ ((and (eq 0 depth) (not first) last) ++ (push "╰" tree-status)) ++ ((and (eq 0 depth) (not first) (not last)) ++ (push "├" tree-status))) ++ ++ (push (concat (if replies "┬" "─") "►") tree-status) ++ (plist-put msg :first (and first (eq 0 depth))) ++ (notmuch-tree-goto-and-insert-msg (plist-put msg :tree-status tree-status)) ++ (pop tree-status) ++ (pop tree-status) ++ ++ (if last ++ (push " " tree-status) ++ (push "│" tree-status)) ++ ++ (notmuch-tree-insert-thread replies (1+ depth) tree-status))) ++ ++(defun notmuch-tree-insert-thread (thread depth tree-status) ++ "Insert the collection of sibling sub-threads THREAD at depth DEPTH in the current forest." ++ (let ((n (length thread))) ++ (loop for tree in thread ++ for count from 1 to n ++ ++ do (notmuch-tree-insert-tree tree depth tree-status (eq count 1) (eq count n))))) ++ ++(defun notmuch-tree-insert-forest-thread (forest-thread) ++ "Insert a single complete thread." ++ (let (tree-status) ++ ;; Reset at the start of each main thread. ++ (setq notmuch-tree-previous-subject nil) ++ (notmuch-tree-insert-thread forest-thread 0 tree-status))) ++ ++(defun notmuch-tree-insert-forest (forest) ++ "Insert a forest of threads. ++ ++This function inserts a collection of several complete threads as ++passed to it by notmuch-tree-process-filter." ++ (mapc 'notmuch-tree-insert-forest-thread forest)) ++ ++(defun notmuch-tree-mode () ++ "Major mode displaying messages (as opposed to threads) of of a notmuch search. ++ ++This buffer contains the results of a \"notmuch tree\" of your ++email archives. Each line in the buffer represents a single ++message giving the relative date, the author, subject, and any ++tags. ++ ++Pressing \\[notmuch-tree-show-message] on any line displays that message. ++ ++Complete list of currently available key bindings: ++ ++\\{notmuch-tree-mode-map}" ++ ++ (interactive) ++ (kill-all-local-variables) ++ (setq notmuch-buffer-refresh-function #'notmuch-tree-refresh-view) ++ (use-local-map notmuch-tree-mode-map) ++ (setq major-mode 'notmuch-tree-mode ++ mode-name "notmuch-tree") ++ (hl-line-mode 1) ++ (setq buffer-read-only t ++ truncate-lines t)) ++ ++(defun notmuch-tree-process-sentinel (proc msg) ++ "Add a message to let user know when \"notmuch tree\" exits" ++ (let ((buffer (process-buffer proc)) ++ (status (process-status proc)) ++ (exit-status (process-exit-status proc)) ++ (never-found-target-thread nil)) ++ (when (memq status '(exit signal)) ++ (kill-buffer (process-get proc 'parse-buf)) ++ (if (buffer-live-p buffer) ++ (with-current-buffer buffer ++ (save-excursion ++ (let ((inhibit-read-only t) ++ (atbob (bobp))) ++ (goto-char (point-max)) ++ (if (eq status 'signal) ++ (insert "Incomplete search results (tree view process was killed).\n")) ++ (when (eq status 'exit) ++ (insert "End of search results.") ++ (unless (= exit-status 0) ++ (insert (format " (process returned %d)" exit-status))) ++ (insert "\n"))))))))) ++ ++(defun notmuch-tree-process-filter (proc string) ++ "Process and filter the output of \"notmuch show\" for tree view" ++ (let ((results-buf (process-buffer proc)) ++ (parse-buf (process-get proc 'parse-buf)) ++ (inhibit-read-only t) ++ done) ++ (if (not (buffer-live-p results-buf)) ++ (delete-process proc) ++ (with-current-buffer parse-buf ++ ;; Insert new data ++ (save-excursion ++ (goto-char (point-max)) ++ (insert string)) ++ (notmuch-sexp-parse-partial-list 'notmuch-tree-insert-forest-thread ++ results-buf))))) ++ ++(defun notmuch-tree-worker (basic-query &optional query-context target open-target) ++ "Insert the tree view of the search in the current buffer. ++ ++This is is a helper function for notmuch-tree. The arguments are ++the same as for the function notmuch-tree." ++ (interactive) ++ (notmuch-tree-mode) ++ (setq notmuch-tree-basic-query basic-query) ++ (setq notmuch-tree-query-context query-context) ++ (setq notmuch-tree-target-msg target) ++ (setq notmuch-tree-open-target open-target) ++ ++ (erase-buffer) ++ (goto-char (point-min)) ++ (let* ((search-args (concat basic-query ++ (if query-context (concat " and (" query-context ")")) ++ )) ++ (message-arg "--entire-thread")) ++ (if (equal (car (process-lines notmuch-command "count" search-args)) "0") ++ (setq search-args basic-query)) ++ (let ((proc (notmuch-start-notmuch ++ "notmuch-tree" (current-buffer) #'notmuch-tree-process-sentinel ++ "show" "--body=false" "--format=sexp" ++ message-arg search-args)) ++ ;; Use a scratch buffer to accumulate partial output. ++ ;; This buffer will be killed by the sentinel, which ++ ;; should be called no matter how the process dies. ++ (parse-buf (generate-new-buffer " *notmuch tree parse*"))) ++ (process-put proc 'parse-buf parse-buf) ++ (set-process-filter proc 'notmuch-tree-process-filter) ++ (set-process-query-on-exit-flag proc nil)))) ++ ++(defun notmuch-tree (&optional query query-context target buffer-name open-target) ++ "Display threads matching QUERY in Tree View. ++ ++The arguments are: ++ QUERY: the main query. This can be any query but in many cases will be ++ a single thread. If nil this is read interactively from the minibuffer. ++ QUERY-CONTEXT: is an additional term for the query. The query used ++ is QUERY and QUERY-CONTEXT unless that does not match any messages ++ in which case we fall back to just QUERY. ++ TARGET: A message ID (with the id: prefix) that will be made ++ current if it appears in the tree view results. ++ BUFFER-NAME: the name of the buffer to display the tree view. If ++ it is nil \"*notmuch-tree\" followed by QUERY is used. ++ OPEN-TARGET: If TRUE open the target message in the message pane." ++ (interactive) ++ (if (null query) ++ (setq query (notmuch-read-query "Notmuch tree view search: "))) ++ (let ((buffer (get-buffer-create (generate-new-buffer-name ++ (or buffer-name ++ (concat "*notmuch-tree-" query "*"))))) ++ (inhibit-read-only t)) ++ ++ (switch-to-buffer buffer)) ++ ;; Don't track undo information for this buffer ++ (set 'buffer-undo-list t) ++ ++ (notmuch-tree-worker query query-context target open-target) ++ ++ (setq truncate-lines t)) ++ ++ ++;; Set up key bindings from the rest of notmuch. ++(define-key notmuch-common-keymap "z" 'notmuch-tree) ++(define-key notmuch-search-mode-map "Z" 'notmuch-tree-from-search-current-query) ++(define-key notmuch-show-mode-map "Z" 'notmuch-tree-from-show-current-query) ++(message "Initialised notmuch-tree") ++ ++(provide 'notmuch-tree) +diff --git a/contrib/notmuch-pick/test/emacs-pick b/contrib/notmuch-pick/test/emacs-pick +index 40b0738..fae6e9e 100755 +--- a/contrib/notmuch-pick/test/emacs-pick ++++ b/contrib/notmuch-pick/test/emacs-pick +@@ -16,8 +16,8 @@ test_expect_equal_file OUTPUT EXPECTED + + test_begin_subtest "Basic notmuch-pick view in emacs" + test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) + (test-output) + (delete-other-windows)' +@@ -25,10 +25,10 @@ test_expect_equal_file OUTPUT $EXPECTED/notmuch-pick-tag-inbox + + test_begin_subtest "Refreshed notmuch-pick view in emacs" + test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) +- (notmuch-pick-refresh-view) ++ (notmuch-tree-refresh-view) + (notmuch-test-wait) + (test-output) + (delete-other-windows)' +@@ -40,11 +40,11 @@ test_expect_equal_file OUTPUT $EXPECTED/notmuch-pick-tag-inbox + + test_begin_subtest "Tag message in notmuch pick view (display)" + test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) + (forward-line) +- (notmuch-pick-tag (list "+test_tag")) ++ (notmuch-tree-tag (list "+test_tag")) + (test-output) + (delete-other-windows)' + test_expect_equal_file OUTPUT $EXPECTED/notmuch-pick-tag-inbox-tagged +@@ -55,11 +55,11 @@ test_expect_equal "$output" "id:877h1wv7mg.fsf@inf-8657.int-evry.fr" + + test_begin_subtest "Untag message in notmuch pick view" + test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) + (forward-line) +- (notmuch-pick-tag (list "-test_tag")) ++ (notmuch-tree-tag (list "-test_tag")) + (test-output) + (delete-other-windows)' + test_expect_equal_file OUTPUT $EXPECTED/notmuch-pick-tag-inbox +@@ -70,12 +70,12 @@ test_expect_equal "$output" "" + + test_begin_subtest "Tag thread in notmuch pick view" + test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) + ;; move to a sizable thread + (forward-line 26) +- (notmuch-pick-tag-thread (list "+test_thread_tag")) ++ (notmuch-tree-tag-thread (list "+test_thread_tag")) + (test-output) + (delete-other-windows)' + test_expect_equal_file OUTPUT $EXPECTED/notmuch-pick-tag-inbox-thread-tagged +@@ -93,12 +93,12 @@ id:20091117190054.GU3165@dottiness.seas.harvard.edu" + + test_begin_subtest "Untag thread in notmuch pick view" + test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) + ;; move to the same sizable thread as above + (forward-line 26) +- (notmuch-pick-tag-thread (list "-test_thread_tag")) ++ (notmuch-tree-tag-thread (list "-test_thread_tag")) + (test-output) + (delete-other-windows)' + test_expect_equal_file OUTPUT $EXPECTED/notmuch-pick-tag-inbox +@@ -113,7 +113,7 @@ test_emacs '(notmuch-hello) + (re-search-forward "inbox") + (widget-button-press (1- (point))) + (notmuch-test-wait) +- (notmuch-pick-from-search-current-query) ++ (notmuch-tree-from-search-current-query) + (notmuch-test-wait) + (test-output) + (delete-other-windows)' +@@ -125,7 +125,7 @@ test_emacs '(notmuch-hello) + (re-search-forward "inbox") + (widget-button-press (1- (point))) + (notmuch-test-wait) +- (notmuch-pick-from-search-thread) ++ (notmuch-tree-from-search-thread) + (notmuch-test-wait) + (test-output) + (delete-other-windows)' +@@ -138,7 +138,7 @@ test_emacs '(notmuch-hello) + (widget-button-press (1- (point))) + (notmuch-test-wait) + (notmuch-search-show-thread) +- (notmuch-pick-from-show-current-query) ++ (notmuch-tree-from-show-current-query) + (notmuch-test-wait) + (test-output) + (delete-other-windows)' +@@ -151,9 +151,9 @@ test_emacs '(notmuch-hello) + (widget-button-press (1- (point))) + (notmuch-test-wait) + (notmuch-search-next-thread) +- (notmuch-pick-from-search-thread) ++ (notmuch-tree-from-search-thread) + (notmuch-test-wait) +- (select-window notmuch-pick-message-window) ++ (select-window notmuch-tree-message-window) + (test-output) + (delete-other-windows)' + cp OUTPUT /tmp/mjwout +@@ -161,49 +161,49 @@ test_expect_equal_file OUTPUT $EXPECTED/notmuch-pick-show-window + + test_begin_subtest "Stash id" + output=$(test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "id:1258498485-sup-142@elly") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "id:1258498485-sup-142@elly") + (notmuch-test-wait) + (notmuch-show-stash-message-id)') + test_expect_equal "$output" "\"Stashed: id:1258498485-sup-142@elly\"" + + test_begin_subtest "Move to next matching message" + output=$(test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "from:cworth") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "from:cworth") + (notmuch-test-wait) +- (notmuch-pick-next-matching-message) ++ (notmuch-tree-next-matching-message) + (notmuch-show-stash-message-id)') + test_expect_equal "$output" "\"Stashed: id:878we4qdqf.fsf@yoom.home.cworth.org\"" + + test_begin_subtest "Move to next thread" + output=$(test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) + (forward-line 26) +- (notmuch-pick-next-thread) ++ (notmuch-tree-next-thread) + (notmuch-show-stash-message-id)') + test_expect_equal "$output" "\"Stashed: id:1258471718-6781-1-git-send-email-dottedmag@dottedmag.net\"" + + test_begin_subtest "Move to previous thread" + output=$(test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) + (forward-line 26) +- (notmuch-pick-prev-thread) ++ (notmuch-tree-prev-thread) + (notmuch-show-stash-message-id)') + test_expect_equal "$output" "\"Stashed: id:20091117190054.GU3165@dottiness.seas.harvard.edu\"" + + test_begin_subtest "Move to previous previous thread" + output=$(test_emacs '(add-to-list (quote load-path) "'$PICK_DIR'") +- (require (quote notmuch-pick)) +- (notmuch-pick "tag:inbox") ++ (require (quote notmuch-tree)) ++ (notmuch-tree "tag:inbox") + (notmuch-test-wait) + (forward-line 26) +- (notmuch-pick-prev-thread) +- (notmuch-pick-prev-thread) ++ (notmuch-tree-prev-thread) ++ (notmuch-tree-prev-thread) + (notmuch-show-stash-message-id)') + test_expect_equal "$output" "\"Stashed: id:1258493565-13508-1-git-send-email-keithp@keithp.com\"" + +-- +1.7.9.1 +