From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from localhost (localhost [127.0.0.1]) by arlo.cworth.org (Postfix) with ESMTP id DC37F6DE1081 for ; Tue, 9 Apr 2019 09:47:52 -0700 (PDT) X-Virus-Scanned: Debian amavisd-new at cworth.org X-Spam-Flag: NO X-Spam-Score: -0.684 X-Spam-Level: X-Spam-Status: No, score=-0.684 tagged_above=-999 required=5 tests=[AWL=-0.684, RCVD_IN_DNSWL_NONE=-0.0001] autolearn=disabled Received: from arlo.cworth.org ([127.0.0.1]) by localhost (arlo.cworth.org [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id 2fdpHu4NTDDr for ; Tue, 9 Apr 2019 09:47:52 -0700 (PDT) Received: from relay8-d.mail.gandi.net (relay8-d.mail.gandi.net [217.70.183.201]) by arlo.cworth.org (Postfix) with ESMTPS id AAA9C6DE0F51 for ; Tue, 9 Apr 2019 09:47:51 -0700 (PDT) X-Originating-IP: 92.169.116.19 Received: from localhost.localdomain (lfbn-1-4117-19.w92-169.abo.wanadoo.fr [92.169.116.19]) (Authenticated sender: mail@ambrevar.xyz) by relay8-d.mail.gandi.net (Postfix) with ESMTPSA id 304641BF205 for ; Tue, 9 Apr 2019 16:47:46 +0000 (UTC) From: Pierre Neidhardt To: notmuch@notmuchmail.org Subject: [PATCH 2/2] emacs: Allow tagging regions in notmuch-tree Date: Tue, 9 Apr 2019 18:47:45 +0200 Message-Id: <20190409164745.13497-1-mail@ambrevar.xyz> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190409164712.13198-1-mail@ambrevar.xyz> References: <20190409164712.13198-1-mail@ambrevar.xyz> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-GND-Spam-Score: 120 X-GND-Status: SPAM X-BeenThere: notmuch@notmuchmail.org X-Mailman-Version: 2.1.29 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: Tue, 09 Apr 2019 16:47:53 -0000 --- emacs/notmuch-tree.el | 101 +++++++++++++++++++++++++++++++++++------- 1 file changed, 86 insertions(+), 15 deletions(-) diff --git a/emacs/notmuch-tree.el b/emacs/notmuch-tree.el index c00315e8..ff471c19 100644 --- a/emacs/notmuch-tree.el +++ b/emacs/notmuch-tree.el @@ -297,13 +297,15 @@ FUNC." map)) (fset 'notmuch-tree-mode-map notmuch-tree-mode-map) -(defun notmuch-tree-get-message-properties () +(defun notmuch-tree-get-message-properties (&optional pos) "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" + (setq pos (or pos (point))) (save-excursion + (goto-char pos) (beginning-of-line) (get-text-property (point) :notmuch-message-properties))) @@ -332,6 +334,13 @@ Some useful entries are: "Return the tags of the current message." (notmuch-tree-get-prop :tags)) +(defun notmuch-tree-get-tags-region (beg end) + (let (output) + (notmuch-tree-foreach-result beg end + (lambda (pos) + (setq output (append output (notmuch-tree-get-tags))))) + output)) + (defun notmuch-tree-get-message-id (&optional bare) "Return the message id of the current message." (let ((id (notmuch-tree-get-prop :id))) @@ -387,24 +396,86 @@ NOT change the database." (when (string= tree-msg-id (notmuch-show-get-message-id)) (notmuch-show-update-tags new-tags))))))) -(defun notmuch-tree-tag (tag-changes) +(defun notmuch-tree-result-beginning (&optional pos) + "Return the point at the beginning of the message at POS (or point). + +If there is no thread at POS (or point), returns nil." + (when (notmuch-tree-get-message-properties pos) + ;; We pass 1+point because previous-single-property-change starts + ;; searching one before the position we give it. + (previous-single-property-change (1+ (or pos (point))) + :notmuch-message-properties nil (point-min)))) + +(defun notmuch-tree-result-end (&optional pos) + "Return the point at the end of the message at POS (or point). + +The returned point will be just after the newline character that +ends the result line. If there is no thread at POS (or point), +returns nil" + (when (notmuch-tree-get-message-properties pos) + (next-single-property-change (or pos (point)) :notmuch-message-properties + nil (point-max)))) + +(defun notmuch-tree-foreach-result (beg end fn) + "Invoke FN for each result between BEG and END. + +FN should take one argument. It will be applied to the +character position of the beginning of each result that overlaps +the region between points BEG and END. As a special case, if (= +BEG END), FN will be applied to the result containing point +BEG." + + (lexical-let ((pos (notmuch-tree-result-beginning beg)) + ;; End must be a marker in case fn changes the + ;; text. + (end (copy-marker end)) + ;; Make sure we examine at least one result, even if + ;; (= beg end). + (first t)) + ;; We have to be careful if the region extends beyond the results. + ;; In this case, pos could be null or there could be no result at + ;; pos. + (while (and pos (or (< pos end) first)) + (when (notmuch-tree-get-message-properties pos) + (funcall fn pos)) + (setq pos (notmuch-tree-result-end pos) + first nil)))) +(put 'notmuch-tree-foreach-result 'lisp-indent-function 2) + +(defun notmuch-tree-interactive-tag-changes (&optional initial-input) + "Prompt for tag changes for the current message or region. + +Returns (TAG-CHANGES REGION-BEGIN REGION-END)." + (let* ((region (notmuch-interactive-region)) + (beg (first region)) (end (second region)) + (prompt (if (= beg end) "Tag message" "Tag region"))) + (cons (notmuch-read-tag-changes + (notmuch-tree-get-tags-region beg end) prompt initial-input) + region))) + +(defun notmuch-tree-tag (tag-changes &optional beg end) "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) + (interactive (notmuch-tree-interactive-tag-changes)) + (unless (and beg end) + (setq beg (car (notmuch-interactive-region)) + end (cadr (notmuch-interactive-region)))) + (notmuch-tree-foreach-result beg end + (lambda (pos) + (save-mark-and-excursion + (goto-char pos) + (notmuch-tag (notmuch-tree-get-message-id) + tag-changes) + (notmuch-tree-tag-update-display tag-changes))))) + +(defun notmuch-tree-add-tag (tag-changes &optional beg end) "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)) + (interactive (notmuch-tree-interactive-tag-changes "+")) + (notmuch-tree-tag tag-changes beg end)) -(defun notmuch-tree-remove-tag (tag-changes) +(defun notmuch-tree-remove-tag (tag-changes &optional beg end) "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)) + (interactive (notmuch-tree-interactive-tag-changes "-")) + (notmuch-tree-tag tag-changes beg end)) (defun notmuch-tree-resume-message () "Resume EDITING the current draft message." -- 2.21.0