X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-tag.el;h=42c425ed4624572dad29dad94f672396b06cc365;hp=4fce3a9873a70100d3ef833eb717241529de66d0;hb=7023466ece21b43a62dc0a2502e84bea78b1501c;hpb=1dc7e66ee7186679e7669f045a4d787f36d26860 diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el index 4fce3a98..42c425ed 100644 --- a/emacs/notmuch-tag.el +++ b/emacs/notmuch-tag.el @@ -1,5 +1,6 @@ ;; notmuch-tag.el --- tag messages within emacs ;; +;; Copyright © Damien Cassou ;; Copyright © Carl Worth ;; ;; This file is part of Notmuch. @@ -18,11 +19,176 @@ ;; along with Notmuch. If not, see . ;; ;; Authors: Carl Worth +;; Damien Cassou +;; +;;; Code: +;; -(eval-when-compile (require 'cl)) +(require 'cl) (require 'crm) (require 'notmuch-lib) +(defcustom notmuch-tag-formats + '(("unread" (propertize tag 'face '(:foreground "red"))) + ("flagged" (propertize tag 'face '(:foreground "blue")) + (notmuch-tag-format-image-data tag (notmuch-tag-star-icon)))) + "Custom formats for individual tags. + +This is an association list that maps from tag name regexps to +lists of formatting expressions. The first entry whose car +regexp-matches a tag will be used to format that tag. The regexp +is implicitly anchored, so to match a literal tag name, just use +that tag name (if it contains special regexp characters like +\".\" or \"*\", these have to be escaped). The cdr of the +matching entry gives a list of Elisp expressions that modify the +tag. If the list is empty, the tag will simply be hidden. +Otherwise, each expression will be evaluated in order: for the +first expression, the variable `tag' will be bound to the tag +name; for each later expression, the variable `tag' will be bound +to the result of the previous expression. In this way, each +expression can build on the formatting performed by the previous +expression. The result of the last expression will displayed in +place of the tag. + +For example, to replace a tag with another string, simply use +that string as a formatting expression. To change the foreground +of a tag to red, use the expression + (propertize tag 'face '(:foreground \"red\")) + +See also `notmuch-tag-format-image', which can help replace tags +with images." + + :group 'notmuch-search + :group 'notmuch-show + :type '(alist :key-type (regexp :tag "Tag") + :extra-offset -3 + :value-type + (radio :format "%v" + (const :tag "Hidden" nil) + (set :tag "Modified" + (string :tag "Display as") + (list :tag "Face" :extra-offset -4 + (const :format "" :inline t + (propertize tag 'face)) + (list :format "%v" + (const :format "" quote) + custom-face-edit)) + (list :format "%v" :extra-offset -4 + (const :format "" :inline t + (notmuch-tag-format-image-data tag)) + (choice :tag "Image" + (const :tag "Star" + (notmuch-tag-star-icon)) + (const :tag "Empty star" + (notmuch-tag-star-empty-icon)) + (const :tag "Tag" + (notmuch-tag-tag-icon)) + (string :tag "Custom"))) + (sexp :tag "Custom"))))) + +(defun notmuch-tag-format-image-data (tag data) + "Replace TAG with image DATA, if available. + +This function returns a propertized string that will display image +DATA in place of TAG.This is designed for use in +`notmuch-tag-formats'. + +DATA is the content of an SVG picture (e.g., as returned by +`notmuch-tag-star-icon')." + (propertize tag 'display + `(image :type svg + :data ,data + :ascent center + :mask heuristic))) + +(defun notmuch-tag-star-icon () + "Return SVG data representing a star icon. +This can be used with `notmuch-tag-format-image-data'." +" + + + + +") + +(defun notmuch-tag-star-empty-icon () + "Return SVG data representing an empty star icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defun notmuch-tag-tag-icon () + "Return SVG data representing a tag icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defvar notmuch-tag--format-cache (make-hash-table :test 'equal) + "Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.") + +(defun notmuch-tag-clear-cache () + "Clear the internal cache of tag formats." + (clrhash notmuch-tag--format-cache)) + +(defun notmuch-tag-format-tag (tag) + "Format TAG by according to `notmuch-tag-formats'. + +Callers must ensure that the tag format cache has been recently cleared +via `notmuch-tag-clear-cache' before using this function. For example, +it would be appropriate to clear the cache just prior to filling a +buffer that uses formatted tags." + + (let ((formatted (gethash tag notmuch-tag--format-cache 'missing))) + (when (eq formatted 'missing) + (let* ((formats + (save-match-data + ;; Don't use assoc-default since there's no way to + ;; distinguish a missing key from a present key with a + ;; null cdr:. + (assoc* tag notmuch-tag-formats + :test (lambda (tag key) + (and (eq (string-match key tag) 0) + (= (match-end 0) (length tag)))))))) + (setq formatted + (cond + ((null formats) ;; - Tag not in `notmuch-tag-formats', + tag) ;; the format is the tag itself. + ((null (cdr formats)) ;; - Tag was deliberately hidden, + nil) ;; no format must be returned + (t ;; - Tag was found and has formats, + (let ((tag tag)) ;; we must apply all the formats. + (dolist (format (cdr formats) tag) + (setq tag (eval format))))))) + (puthash tag formatted notmuch-tag--format-cache))) + formatted)) + +(defun notmuch-tag-format-tags (tags &optional face) + "Return a string representing formatted TAGS." + (let ((face (or face 'notmuch-tag-face))) + (notmuch-apply-face + (mapconcat #'identity + ;; nil indicated that the tag was deliberately hidden + (delq nil (mapcar #'notmuch-tag-format-tag tags)) + " ") + face + t))) + (defcustom notmuch-before-tag-hook nil "Hooks that are run before tags of a message are modified. @@ -54,7 +220,10 @@ the messages that were tagged" "Variable to store minibuffer history for `notmuch-read-tag-changes' function.") -(defun notmuch-tag-completions (&optional search-terms) +(defun notmuch-tag-completions (&rest search-terms) + "Return a list of tags for messages matching SEARCH-TERMS. + +Returns all tags if no search terms are given." (if (null search-terms) (setq search-terms (list "*"))) (split-string @@ -65,17 +234,24 @@ the messages that were tagged" "\n+" t)) (defun notmuch-select-tag-with-completion (prompt &rest search-terms) - (let ((tag-list (notmuch-tag-completions search-terms))) + (let ((tag-list (apply #'notmuch-tag-completions search-terms))) (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history))) -(defun notmuch-read-tag-changes (&optional initial-input &rest search-terms) +(defun notmuch-read-tag-changes (current-tags &optional prompt initial-input) + "Prompt for tag changes in the minibuffer. + +CURRENT-TAGS is a list of tags that are present on the message or +messages to be changed. These are offered as tag removal +completions. CURRENT-TAGS may contain duplicates. PROMPT, if +non-nil, is the query string to present in the minibuffer. It +defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the +initial input in the minibuffer." + (let* ((all-tag-list (notmuch-tag-completions)) (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list)) - (remove-tag-list (mapcar (apply-partially 'concat "-") - (if (null search-terms) - all-tag-list - (notmuch-tag-completions search-terms)))) + (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags)) (tag-list (append add-tag-list remove-tag-list)) + (prompt (concat (or prompt "Tags") " (+add -drop): ")) (crm-separator " ") ;; By default, space is bound to "complete word" function. ;; Re-bind it to insert a space instead. Note that @@ -85,8 +261,16 @@ the messages that were tagged" (set-keymap-parent map crm-local-completion-map) (define-key map " " 'self-insert-command) map))) - (delete "" (completing-read-multiple "Tags (+add -drop): " - tag-list nil nil initial-input + (delete "" (completing-read-multiple + prompt + ;; Append the separator to each completion so when the + ;; user completes a tag they can immediately begin + ;; entering another. `completing-read-multiple' + ;; ultimately splits the input on crm-separator, so we + ;; don't need to strip this back off (we just need to + ;; delete "empty" entries caused by trailing spaces). + (mapcar (lambda (tag-op) (concat tag-op crm-separator)) tag-list) + nil nil initial-input 'notmuch-read-tag-changes-history)))) (defun notmuch-update-tags (tags tag-changes) @@ -108,37 +292,38 @@ from TAGS if present." (error "Changed tag must be of the form `+this_tag' or `-that_tag'"))))) (sort result-tags 'string<))) -(defun notmuch-tag (query &optional tag-changes) +(defconst notmuch-tag-argument-limit 1000 + "Use batch tagging if the tagging query is longer than this. + +This limits the length of arguments passed to the notmuch CLI to +avoid system argument length limits and performance problems.") + +(defun notmuch-tag (query tag-changes) "Add/remove tags in TAG-CHANGES to messages matching QUERY. QUERY should be a string containing the search-terms. -TAG-CHANGES can take multiple forms. If TAG-CHANGES is a list of -strings of the form \"+tag\" or \"-tag\" then those are the tag -changes applied. If TAG-CHANGES is a string then it is -interpreted as a single tag change. If TAG-CHANGES is the string -\"-\" or \"+\", or null, then the user is prompted to enter the -tag changes. +TAG-CHANGES is a list of strings of the form \"+tag\" or +\"-tag\" to add or remove tags, respectively. Note: Other code should always use this function alter tags of messages instead of running (notmuch-call-notmuch-process \"tag\" ..) directly, so that hooks specified in notmuch-before-tag-hook and notmuch-after-tag-hook will be run." ;; Perform some validation - (if (string-or-null-p tag-changes) - (if (or (string= tag-changes "-") (string= tag-changes "+") (null tag-changes)) - (setq tag-changes (notmuch-read-tag-changes tag-changes query)) - (setq tag-changes (list tag-changes)))) (mapc (lambda (tag-change) (unless (string-match-p "^[-+]\\S-+$" tag-change) (error "Tag must be of the form `+this_tag' or `-that_tag'"))) tag-changes) (unless (null tag-changes) (run-hooks 'notmuch-before-tag-hook) - (apply 'notmuch-call-notmuch-process "tag" - (append tag-changes (list "--" query))) - (run-hooks 'notmuch-after-tag-hook)) - ;; in all cases we return tag-changes as a list - tag-changes) + (if (<= (length query) notmuch-tag-argument-limit) + (apply 'notmuch-call-notmuch-process "tag" + (append tag-changes (list "--" query))) + ;; Use batch tag mode to avoid argument length limitations + (let ((batch-op (concat (mapconcat #'notmuch-hex-encode tag-changes " ") + " -- " query))) + (notmuch-call-notmuch-process :stdin-string batch-op "tag" "--batch"))) + (run-hooks 'notmuch-after-tag-hook))) (defun notmuch-tag-change-list (tags &optional reverse) "Convert TAGS into a list of tag changes. @@ -158,3 +343,7 @@ begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all ;; (provide 'notmuch-tag) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: