git.notmuchmail.org Git - notmuch/blob - emacs/notmuch-tag.el

   1 ;; notmuch-tag.el --- tag messages within emacs
   2 ;;
   3 ;; Copyright © Carl Worth
   4 ;;
   5 ;; This file is part of Notmuch.
   6 ;;
   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.
  11 ;;
  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.
  16 ;;
  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/>.
  19 ;;
  20 ;; Authors: Carl Worth <cworth@cworth.org>
  21
  22 (eval-when-compile (require 'cl))
  23 (require 'crm)
  24 (require 'notmuch-lib)
  25
  26 (defcustom notmuch-before-tag-hook nil
  27   "Hooks that are run before tags of a message are modified.
  28
  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"
  33
  34   :type 'hook
  35   :options '(notmuch-hl-line-mode)
  36   :group 'notmuch-hooks)
  37
  38 (defcustom notmuch-after-tag-hook nil
  39   "Hooks that are run after tags of a message are modified.
  40
  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"
  45   :type 'hook
  46   :options '(notmuch-hl-line-mode)
  47   :group 'notmuch-hooks)
  48
  49 (defvar notmuch-select-tag-history nil
  50   "Variable to store minibuffer history for
  51 `notmuch-select-tag-with-completion' function.")
  52
  53 (defvar notmuch-read-tag-changes-history nil
  54   "Variable to store minibuffer history for
  55 `notmuch-read-tag-changes' function.")
  56
  57 (defun notmuch-tag-completions (&optional search-terms)
  58   (if (null search-terms)
  59       (setq search-terms (list "*")))
  60   (split-string
  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)))
  65    "\n+" t))
  66
  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)))
  70
  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)
  76                                       all-tag-list
  77                                     (notmuch-tag-completions search-terms))))
  78          (tag-list (append add-tag-list remove-tag-list))
  79          (crm-separator " ")
  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)
  87             map)))
  88     (delete "" (completing-read-multiple "Tags (+add -drop): "
  89                 tag-list nil nil initial-input
  90                 'notmuch-read-tag-changes-history))))
  91
  92 (defun notmuch-update-tags (tags tag-changes)
  93   "Return a copy of TAGS with additions and removals from TAG-CHANGES.
  94
  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))))
 103         (case op
 104           (?+ (unless (member tag result-tags)
 105                 (push tag result-tags)))
 106           (?- (setq result-tags (delete tag result-tags)))
 107           (otherwise
 108            (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
 109     (sort result-tags 'string<)))
 110
 111 (defun notmuch-tag (query &optional tag-changes)
 112   "Add/remove tags in TAG-CHANGES to messages matching QUERY.
 113
 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
 120 tag changes.
 121
 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'")))
 134         tag-changes)
 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
 141   tag-changes)
 142
 143 (defun notmuch-tag-change-list (tags &optional reverse)
 144   "Convert TAGS into a list of tag changes.
 145
 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))))
 151               (if reverse
 152                   (concat (if (= (string-to-char s) ?-) "+" "-")
 153                           (substring s 1))
 154                 s)))
 155           tags))
 156
 157
 158 ;;
 159
 160 (provide 'notmuch-tag)