1 ;; notmuch-tag.el --- tag messages within emacs
3 ;; Copyright © Carl Worth
5 ;; This file is part of Notmuch.
7 ;; Notmuch is free software: you can redistribute it and/or modify it
8 ;; under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation, either version 3 of the License, or
10 ;; (at your option) any later version.
12 ;; Notmuch is distributed in the hope that it will be useful, but
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;; General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with Notmuch. If not, see <http://www.gnu.org/licenses/>.
20 ;; Authors: Carl Worth <cworth@cworth.org>
22 (eval-when-compile (require 'cl))
24 (require 'notmuch-lib)
26 (defcustom notmuch-before-tag-hook nil
27 "Hooks that are run before tags of a message are modified.
29 'tags' will contain the tags that are about to be added or removed as
30 a list of strings of the form \"+TAG\" or \"-TAG\".
31 'query' will be a string containing the search query that determines
32 the messages that are about to be tagged"
35 :options '(notmuch-hl-line-mode)
36 :group 'notmuch-hooks)
38 (defcustom notmuch-after-tag-hook nil
39 "Hooks that are run after tags of a message are modified.
41 'tags' will contain the tags that were added or removed as
42 a list of strings of the form \"+TAG\" or \"-TAG\".
43 'query' will be a string containing the search query that determines
44 the messages that were tagged"
46 :options '(notmuch-hl-line-mode)
47 :group 'notmuch-hooks)
49 (defvar notmuch-select-tag-history nil
50 "Variable to store minibuffer history for
51 `notmuch-select-tag-with-completion' function.")
53 (defvar notmuch-read-tag-changes-history nil
54 "Variable to store minibuffer history for
55 `notmuch-read-tag-changes' function.")
57 (defun notmuch-tag-completions (&optional search-terms)
58 (if (null search-terms)
59 (setq search-terms (list "*")))
61 (with-output-to-string
62 (with-current-buffer standard-output
63 (apply 'call-process notmuch-command nil t
64 nil "search" "--output=tags" "--exclude=false" search-terms)))
67 (defun notmuch-select-tag-with-completion (prompt &rest search-terms)
68 (let ((tag-list (notmuch-tag-completions search-terms)))
69 (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history)))
71 (defun notmuch-read-tag-changes (&optional initial-input &rest search-terms)
72 (let* ((all-tag-list (notmuch-tag-completions))
73 (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
74 (remove-tag-list (mapcar (apply-partially 'concat "-")
75 (if (null search-terms)
77 (notmuch-tag-completions search-terms))))
78 (tag-list (append add-tag-list remove-tag-list))
80 ;; By default, space is bound to "complete word" function.
81 ;; Re-bind it to insert a space instead. Note that <tab>
82 ;; still does the completion.
83 (crm-local-completion-map
84 (let ((map (make-sparse-keymap)))
85 (set-keymap-parent map crm-local-completion-map)
86 (define-key map " " 'self-insert-command)
88 (delete "" (completing-read-multiple "Tags (+add -drop): "
89 tag-list nil nil initial-input
90 'notmuch-read-tag-changes-history))))
92 (defun notmuch-update-tags (tags tag-changes)
93 "Return a copy of TAGS with additions and removals from TAG-CHANGES.
95 TAG-CHANGES must be a list of tags names, each prefixed with
96 either a \"+\" to indicate the tag should be added to TAGS if not
97 present or a \"-\" to indicate that the tag should be removed
98 from TAGS if present."
99 (let ((result-tags (copy-sequence tags)))
100 (dolist (tag-change tag-changes)
101 (let ((op (string-to-char tag-change))
102 (tag (unless (string= tag-change "") (substring tag-change 1))))
104 (?+ (unless (member tag result-tags)
105 (push tag result-tags)))
106 (?- (setq result-tags (delete tag result-tags)))
108 (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
109 (sort result-tags 'string<)))
111 (defun notmuch-tag (query &optional tag-changes)
112 "Add/remove tags in TAG-CHANGES to messages matching QUERY.
114 QUERY should be a string containing the search-terms.
115 TAG-CHANGES can take multiple forms. If TAG-CHANGES is a list of
116 strings of the form \"+tag\" or \"-tag\" then those are the tag
117 changes applied. If TAG-CHANGES is a string then it is
118 interpreted as a single tag change. If TAG-CHANGES is the string
119 \"-\" or \"+\", or null, then the user is prompted to enter the
122 Note: Other code should always use this function alter tags of
123 messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
124 directly, so that hooks specified in notmuch-before-tag-hook and
125 notmuch-after-tag-hook will be run."
126 ;; Perform some validation
127 (if (string-or-null-p tag-changes)
128 (if (or (string= tag-changes "-") (string= tag-changes "+") (null tag-changes))
129 (setq tag-changes (notmuch-read-tag-changes tag-changes query))
130 (setq tag-changes (list tag-changes))))
131 (mapc (lambda (tag-change)
132 (unless (string-match-p "^[-+]\\S-+$" tag-change)
133 (error "Tag must be of the form `+this_tag' or `-that_tag'")))
135 (unless (null tag-changes)
136 (run-hooks 'notmuch-before-tag-hook)
137 (apply 'notmuch-call-notmuch-process "tag"
138 (append tag-changes (list "--" query)))
139 (run-hooks 'notmuch-after-tag-hook))
140 ;; in all cases we return tag-changes as a list
143 (defun notmuch-tag-change-list (tags &optional reverse)
144 "Convert TAGS into a list of tag changes.
146 Add a \"+\" prefix to any tag in TAGS list that doesn't already
147 begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
148 \"+\" prefixes with \"-\" and vice versa in the result."
149 (mapcar (lambda (str)
150 (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
152 (concat (if (= (string-to-char s) ?-) "+" "-")
160 (provide 'notmuch-tag)