emacs: Combine notmuch-combine-face-text-property{, -string}

[notmuch] / emacs / notmuch-lib.el

diff --git a/emacs/notmuch-lib.el b/emacs/notmuch-lib.el
index 17040ed86bd352343c6ce87296ff8ba2bb4c8752..fa7646fecb8bb020c2b06cea1fb5579be19c49f4 100644 (file)
--- a/emacs/notmuch-lib.el
+++ b/emacs/notmuch-lib.el
@@ -80,9 +80,8 @@ search."
   "An external script to incorporate new mail into the notmuch database.
 
 This variable controls the action invoked by
   "An external script to incorporate new mail into the notmuch database.
 
 This variable controls the action invoked by

-`notmuch-search-poll-and-refresh-view' and
-`notmuch-hello-poll-and-update' (each have a default keybinding
-of 'G') to incorporate new mail into the notmuch database.
+`notmuch-poll-and-refresh-this-buffer' (bound by default to 'G')
+to incorporate new mail into the notmuch database.

 
 If set to nil (the default), new mail is processed by invoking
 \"notmuch new\". Otherwise, this should be set to a string that
 
 If set to nil (the default), new mail is processed by invoking
 \"notmuch new\". Otherwise, this should be set to a string that


@@ -169,6 +168,24 @@ Otherwise the output will be returned"
       (notmuch-check-exit-status status (cons notmuch-command args) output)
       output)))
 
       (notmuch-check-exit-status status (cons notmuch-command args) output)
       output)))
 

+(defvar notmuch--cli-sane-p nil
+  "Cache whether the CLI seems to be configured sanely.")
+
+(defun notmuch-cli-sane-p ()
+  "Return t if the cli seems to be configured sanely."
+  (unless notmuch--cli-sane-p
+    (let ((status (call-process notmuch-command nil nil nil
+                               "config" "get" "user.primary_email")))
+      (setq notmuch--cli-sane-p (= status 0))))
+  notmuch--cli-sane-p)
+
+(defun notmuch-assert-cli-sane ()
+  (unless (notmuch-cli-sane-p)
+    (notmuch-logged-error
+     "notmuch cli seems misconfigured or unconfigured."
+"Perhaps you haven't run \"notmuch setup\" yet? Try running this
+on the command line, and then retry your notmuch command")))
+

 (defun notmuch-version ()
   "Return a string with the notmuch version number."
   (let ((long-string
 (defun notmuch-version ()
   "Return a string with the notmuch version number."
   (let ((long-string


@@ -181,8 +198,13 @@ Otherwise the output will be returned"
 
 (defun notmuch-config-get (item)
   "Return a value from the notmuch configuration."
 
 (defun notmuch-config-get (item)
   "Return a value from the notmuch configuration."

-  ;; Trim off the trailing newline
-  (substring (notmuch-command-to-string "config" "get" item) 0 -1))
+  (let* ((val (notmuch-command-to-string "config" "get" item))
+        (len (length val)))
+    ;; Trim off the trailing newline (if the value is empty or not
+    ;; configured, there will be no newline)
+    (if (and (> len 0) (= (aref val (- len 1)) ?\n))
+       (substring val 0 -1)
+      val)))

 
 (defun notmuch-database-path ()
   "Return the database.path value from the notmuch configuration."
 
 (defun notmuch-database-path ()
   "Return the database.path value from the notmuch configuration."


@@ -198,7 +220,7 @@ Otherwise the output will be returned"
 
 (defun notmuch-user-other-email ()
   "Return the user.other_email value (as a list) from the notmuch configuration."
 
 (defun notmuch-user-other-email ()
   "Return the user.other_email value (as a list) from the notmuch configuration."

-  (split-string (notmuch-config-get "user.other_email") "\n"))
+  (split-string (notmuch-config-get "user.other_email") "\n" t))

 
 (defun notmuch-poll ()
   "Run \"notmuch new\" or an external script to import mail.
 
 (defun notmuch-poll ()
   "Run \"notmuch new\" or an external script to import mail.


@@ -232,17 +254,58 @@ depending on the value of `notmuch-poll-script'."
   "Given a prefix key code, return a human-readable string representation.
 
 This is basically just `format-kbd-macro' but we also convert ESC to M-."
   "Given a prefix key code, return a human-readable string representation.
 
 This is basically just `format-kbd-macro' but we also convert ESC to M-."

-  (let ((desc (format-kbd-macro (vector key))))
+  (let* ((key-vector (if (vectorp key) key (vector key)))
+        (desc (format-kbd-macro key-vector)))

     (if (string= desc "ESC")
        "M-"
       (concat desc " "))))
 
     (if (string= desc "ESC")
        "M-"
       (concat desc " "))))
 

-(defun notmuch-describe-keymap (keymap ua-keys &optional prefix tail)
-  "Return a list of strings, each describing one binding in KEYMAP.

 
 

-Each string gives a human-readable description of the key and a
-one-line description of the bound function.  See `notmuch-help'
-for an overview of how this documentation is extracted.
+(defun notmuch-describe-key (actual-key binding prefix ua-keys tail)
+  "Prepend cons cells describing prefix-arg ACTUAL-KEY and ACTUAL-KEY to TAIL
+
+It does not prepend if ACTUAL-KEY is already listed in TAIL."
+  (let ((key-string (concat prefix (format-kbd-macro actual-key))))
+    ;; We don't include documentation if the key-binding is
+    ;; over-ridden. Note, over-riding a binding automatically hides the
+    ;; prefixed version too.
+    (unless (assoc key-string tail)
+      (when (and ua-keys (symbolp binding)
+                (get binding 'notmuch-prefix-doc))
+       ;; Documentation for prefixed command
+       (let ((ua-desc (key-description ua-keys)))
+         (push (cons (concat ua-desc " " prefix (format-kbd-macro actual-key))
+                     (get binding 'notmuch-prefix-doc))
+               tail)))
+      ;; Documentation for command
+      (push (cons key-string
+                 (or (and (symbolp binding) (get binding 'notmuch-doc))
+                     (notmuch-documentation-first-line binding)))
+           tail)))
+    tail)
+
+(defun notmuch-describe-remaps (remap-keymap ua-keys base-keymap prefix tail)
+  ;; Remappings are represented as a binding whose first "event" is
+  ;; 'remap.  Hence, if the keymap has any remappings, it will have a
+  ;; binding whose "key" is 'remap, and whose "binding" is itself a
+  ;; keymap that maps not from keys to commands, but from old (remapped)
+  ;; functions to the commands to use in their stead.
+  (map-keymap
+   (lambda (command binding)
+     (mapc
+      (lambda (actual-key)
+       (setq tail (notmuch-describe-key actual-key binding prefix ua-keys tail)))
+      (where-is-internal command base-keymap)))
+   remap-keymap)
+  tail)
+
+(defun notmuch-describe-keymap (keymap ua-keys base-keymap &optional prefix tail)
+  "Return a list of cons cells, each describing one binding in KEYMAP.
+
+Each cons cell consists of a string giving a human-readable
+description of the key, and a one-line description of the bound
+function.  See `notmuch-help' for an overview of how this
+documentation is extracted.

 
 UA-KEYS should be a key sequence bound to `universal-argument'.
 It will be used to describe bindings of commands that support a
 
 UA-KEYS should be a key sequence bound to `universal-argument'.
 It will be used to describe bindings of commands that support a


@@ -252,21 +315,13 @@ prefix argument.  PREFIX and TAIL are used internally."
      (cond ((mouse-event-p key) nil)
           ((keymapp binding)
            (setq tail
      (cond ((mouse-event-p key) nil)
           ((keymapp binding)
            (setq tail

-                 (notmuch-describe-keymap
-                  binding ua-keys (notmuch-prefix-key-description key) tail)))
-          (t
-           (when (and ua-keys (symbolp binding)
-                      (get binding 'notmuch-prefix-doc))
-             ;; Documentation for prefixed command
-             (let ((ua-desc (key-description ua-keys)))
-               (push (concat ua-desc " " prefix (format-kbd-macro (vector key))
-                             "\t" (get binding 'notmuch-prefix-doc))
-                     tail)))
-           ;; Documentation for command
-           (push (concat prefix (format-kbd-macro (vector key)) "\t"
-                         (or (and (symbolp binding) (get binding 'notmuch-doc))
-                             (notmuch-documentation-first-line binding)))
-                 tail))))
+                 (if (eq key 'remap)
+                     (notmuch-describe-remaps
+                      binding ua-keys base-keymap prefix tail)
+                   (notmuch-describe-keymap
+                    binding ua-keys base-keymap (notmuch-prefix-key-description key) tail))))
+          (binding
+           (setq tail (notmuch-describe-key (vector key) binding prefix ua-keys tail)))))

    keymap)
   tail)
 
    keymap)
   tail)
 


@@ -274,11 +329,14 @@ prefix argument.  PREFIX and TAIL are used internally."
   "Like `substitute-command-keys' but with documentation, not function names."
   (let ((beg 0))
     (while (string-match "\\\\{\\([^}[:space:]]*\\)}" doc beg)
   "Like `substitute-command-keys' but with documentation, not function names."
   (let ((beg 0))
     (while (string-match "\\\\{\\([^}[:space:]]*\\)}" doc beg)

-      (let* ((keymap-name (substring doc (match-beginning 1) (match-end 1)))
-            (keymap (symbol-value (intern keymap-name)))
-            (ua-keys (where-is-internal 'universal-argument keymap t))
-            (desc-list (notmuch-describe-keymap keymap ua-keys))
-            (desc (mapconcat #'identity desc-list "\n")))
+      (let ((desc
+            (save-match-data
+              (let* ((keymap-name (substring doc (match-beginning 1) (match-end 1)))
+                     (keymap (symbol-value (intern keymap-name)))
+                     (ua-keys (where-is-internal 'universal-argument keymap t))
+                     (desc-alist (notmuch-describe-keymap keymap ua-keys keymap))
+                     (desc-list (mapcar (lambda (arg) (concat (car arg) "\t" (cdr arg))) desc-alist)))
+                (mapconcat #'identity desc-list "\n")))))

        (setq doc (replace-match desc 1 1 doc)))
       (setq beg (match-end 0)))
     doc))
        (setq doc (replace-match desc 1 1 doc)))
       (setq beg (match-end 0)))
     doc))


@@ -303,6 +361,28 @@ of its command symbol."
       (set-buffer-modified-p nil)
       (view-buffer (current-buffer) 'kill-buffer-if-not-modified))))
 
       (set-buffer-modified-p nil)
       (view-buffer (current-buffer) 'kill-buffer-if-not-modified))))
 

+(defun notmuch-subkeymap-help ()
+  "Show help for a subkeymap."
+  (interactive)
+  (let* ((key (this-command-keys-vector))
+       (prefix (make-vector (1- (length key)) nil))
+       (i 0))
+    (while (< i (length prefix))
+      (aset prefix i (aref key i))
+      (setq i (1+ i)))
+
+    (let* ((subkeymap (key-binding prefix))
+          (ua-keys (where-is-internal 'universal-argument nil t))
+          (prefix-string (notmuch-prefix-key-description prefix))
+          (desc-alist (notmuch-describe-keymap subkeymap ua-keys subkeymap prefix-string))
+          (desc-list (mapcar (lambda (arg) (concat (car arg) "\t" (cdr arg))) desc-alist))
+          (desc (mapconcat #'identity desc-list "\n")))
+      (with-help-window (help-buffer)
+       (with-current-buffer standard-output
+         (insert "\nPress 'q' to quit this window.\n\n")
+         (insert desc)))
+      (pop-to-buffer (help-buffer)))))
+

 (defvar notmuch-buffer-refresh-function nil
   "Function to call to refresh the current buffer.")
 (make-variable-buffer-local 'notmuch-buffer-refresh-function)
 (defvar notmuch-buffer-refresh-function nil
   "Function to call to refresh the current buffer.")
 (make-variable-buffer-local 'notmuch-buffer-refresh-function)


@@ -355,6 +435,14 @@ user-friendly queries."
   "Return a query that matches the message with id ID."
   (concat "id:" (notmuch-escape-boolean-term id)))
 
   "Return a query that matches the message with id ID."
   (concat "id:" (notmuch-escape-boolean-term id)))
 

+(defun notmuch-hex-encode (str)
+  "Hex-encode STR (e.g., as used by batch tagging).
+
+This replaces spaces, percents, and double quotes in STR with
+%NN where NN is the hexadecimal value of the character."
+  (replace-regexp-in-string
+   "[ %\"]" (lambda (match) (format "%%%02x" (aref match 0))) str))
+

 ;;
 
 (defun notmuch-common-do-stash (text)
 ;;
 
 (defun notmuch-common-do-stash (text)


@@ -448,7 +536,8 @@ the given type."
 (if (>= emacs-major-version 24)
     (defadvice mm-shr (before load-gnus-arts activate)
       (require 'gnus-art nil t)
 (if (>= emacs-major-version 24)
     (defadvice mm-shr (before load-gnus-arts activate)
       (require 'gnus-art nil t)

-      (ad-disable-advice 'mm-shr 'before 'load-gnus-arts)))
+      (ad-disable-advice 'mm-shr 'before 'load-gnus-arts)
+      (ad-activate 'mm-shr)))

 
 (defun notmuch-mm-display-part-inline (msg part nth content-type process-crypto)
   "Use the mm-decode/mm-view functions to display a part in the
 
 (defun notmuch-mm-display-part-inline (msg part nth content-type process-crypto)
   "Use the mm-decode/mm-view functions to display a part in the


@@ -489,23 +578,32 @@ single element face list."
       face
     (list face)))
 
       face
     (list face)))
 

-(defun notmuch-combine-face-text-property (start end face &optional below object)
-  "Combine FACE into the 'face text property between START and END.
+(defun notmuch-apply-face (object face &optional below start end)
+  "Combine FACE into the 'face text property of OBJECT between START and END.

 
 This function combines FACE with any existing faces between START
 
 This function combines FACE with any existing faces between START

-and END in OBJECT (which defaults to the current buffer).
-Attributes specified by FACE take precedence over existing
-attributes unless BELOW is non-nil.  FACE must be a face name (a
-symbol or string), a property list of face attributes, or a list
-of these.  For convenience when applied to strings, this returns
-OBJECT."
+and END in OBJECT.  Attributes specified by FACE take precedence
+over existing attributes unless BELOW is non-nil.
+
+OBJECT may be a string, a buffer, or nil (which means the current
+buffer).  If object is a string, START and END are 0-based;
+otherwise they are buffer positions (integers or markers).  FACE
+must be a face name (a symbol or string), a property list of face
+attributes, or a list of these.  If START and/or END are omitted,
+they default to the beginning/end of OBJECT.  For convenience
+when applied to strings, this returns OBJECT."

 
   ;; A face property can have three forms: a face name (a string or
   ;; symbol), a property list, or a list of these two forms.  In the
   ;; list case, the faces will be combined, with the earlier faces
   ;; taking precedent.  Here we canonicalize everything to list form
   ;; to make it easy to combine.
 
   ;; A face property can have three forms: a face name (a string or
   ;; symbol), a property list, or a list of these two forms.  In the
   ;; list case, the faces will be combined, with the earlier faces
   ;; taking precedent.  Here we canonicalize everything to list form
   ;; to make it easy to combine.

-  (let ((pos start)
+  (let ((pos (cond (start start)
+                  ((stringp object) 0)
+                  (t 1)))
+       (end (cond (end end)
+                  ((stringp object) (length object))
+                  (t (1+ (buffer-size object)))))

        (face-list (notmuch-face-ensure-list-form face)))
     (while (< pos end)
       (let* ((cur (get-text-property pos 'face object))
        (face-list (notmuch-face-ensure-list-form face)))
     (while (< pos end)
       (let* ((cur (get-text-property pos 'face object))


@@ -518,14 +616,6 @@ OBJECT."
        (setq pos next))))
   object)
 
        (setq pos next))))
   object)
 

-(defun notmuch-combine-face-text-property-string (string face &optional below)
-  (notmuch-combine-face-text-property
-   0
-   (length string)
-   face
-   below
-   string))
-

 (defun notmuch-map-text-property (start end prop func &optional object)
   "Transform text property PROP using FUNC.
 
 (defun notmuch-map-text-property (start end prop func &optional object)
   "Transform text property PROP using FUNC.