[elpa] externals/gnorb 20de4ee 104/449: Caching of msg-id to org-id correlations

[Stefan Monnier]

branch: externals/gnorb
commit 20de4ee13286f48169fa7c06bd8389802ed14d76
Author: Eric Abrahamsen <eric@ericabrahamsen.net>
Commit: Eric Abrahamsen <eric@ericabrahamsen.net>

    Caching of msg-id to org-id correlations
    
    lisp/gnorb-utils.el: New variable `gnorb-msg-id-to-heading-table' to
                     hold the hash-table cache. Calling
                     `gnorb-trigger-todo-action' adds an entry to that
                     table.
    
    lisp/gnorb-org.el: Now function `gnorb-org-find-visit-candidates' just
                   queries the cache, or fills it. Filling done by new
                   function `gnorb-org-populate-id-hash', with the help
                   of `gnorb-org-add-id-hash-entry.
    
    lisp/gnorb-gnus.el: Remind users that finding todo candidates only works
                    with `org-id-track-globally' set to t.
---
 lisp/gnorb-gnus.el  | 13 ++++---
 lisp/gnorb-org.el   | 97 ++++++++++++++++++++++++++++-------------------------
 lisp/gnorb-utils.el | 11 ++++--
 3 files changed, 69 insertions(+), 52 deletions(-)

diff --git a/lisp/gnorb-gnus.el b/lisp/gnorb-gnus.el
index f06f9da..4f4dbac 100644
--- a/lisp/gnorb-gnus.el
+++ b/lisp/gnorb-gnus.el
@@ -364,11 +364,14 @@ if any of the IDs there match the value of the
                  (gnus-extract-message-id-from-in-reply-to all-refs)))))
           (offer-heading
            (when (and (not id) ref-msg-ids)
-             ;; for now we're basically ignoring the fact that
-             ;; multiple candidates could exist; just do the first
-             ;; one.
-             (car (gnorb-org-find-visit-candidates
-                   (list ref-msg-ids)))))
+             (if org-id-track-globally
+                 ;; for now we're basically ignoring the fact that
+                 ;; multiple candidates could exist; just do the first
+                 ;; one.
+                 (car (gnorb-org-find-visit-candidates
+                       ref-msg-ids))
+               (message "Gnorb can't check for relevant headings unless 
`org-id-track-globally' is t")
+               (sit-for 1))))
           targ)
       ;; offer to attach attachments!
       (if id
diff --git a/lisp/gnorb-org.el b/lisp/gnorb-org.el
index 30029cf..9a4e6d5 100644
--- a/lisp/gnorb-org.el
+++ b/lisp/gnorb-org.el
@@ -409,57 +409,64 @@ current heading."
        (first mail-stuff) (second mail-stuff)
        from cc bcc
        attachments nil org-id))))
+(defun gnorb-org-add-id-hash-entry (msg-id)
+  (let ((old-val (gethash msg-id gnorb-msg-id-to-heading-table))
+       (new-val (list
+                 (org-id-get-create)
+                 (append
+                  (list
+                   (file-name-nondirectory
+                    (buffer-file-name
+                     (current-buffer))))
+                  (org-get-outline-path)
+                  (list
+                   (org-no-properties
+                    (replace-regexp-in-string
+                     org-bracket-link-regexp
+                     "\\3"
+                     (nth 4 (org-heading-components)))))))))
+    (unless (member (car new-val) old-val)
+      (puthash msg-id
+             (if old-val
+                 (append (list new-val) old-val)
+               (list new-val))
+             gnorb-msg-id-to-heading-table))))
+
+(defun gnorb-org-populate-id-hash ()
+  "Scan all agenda files for headings with the
+  `gnorb-org-msg-id-key' property, and construct a hash table of
+  message-ids as keys, and org headings as values -- actually
+  two-element lists representing the heading's id and outline
+  path."
+  ;; where are all the places where we might conceivably want to
+  ;; refresh this?
+  (interactive)
+  (setq gnorb-msg-id-to-heading-table
+       (make-hash-table
+        :test 'equal :size 100))
+  (let (props)
+    (org-map-entries
+     (lambda ()
+       (setq props
+            (org-entry-get-multivalued-property
+             (point) gnorb-org-msg-id-key))
+       (dolist (p props)
+        (gnorb-org-add-id-hash-entry p)))
+     gnorb-org-find-candidates-match
+     'agenda 'archive 'comment)))
 
 (defun gnorb-org-find-visit-candidates (ids)
   "For all message-ids in IDS (which should be a list of
 Message-ID strings, with angle brackets), produce a list of Org
 ids (and ol-paths) for headings that contain one of those id
 values in their `gnorb-org-org-msg-id-key' property."
-  ;; org-id actually uses an external file to make this whole process
-  ;; faster, but we don't really need that kind of efficiency, I don't
-  ;; think. Visiting `org-agenda-files' and collecting property values
-  ;; should be okay. Speedups later, if and when needed. Right now
-  ;; this only happens on an interactive function call by the user, so
-  ;; a little pause is acceptable. Later we might try to add it to a
-  ;; notice-message type of hook, in which case I'll think about some
-  ;; sort of primitive caching. Since all we need is a mapping between
-  ;; Org ids and lists of message ids, maybe a hash table with Org id
-  ;; keys. It would need to be refreshed whenever the
-  ;; `gnorb-org-msg-id-key' was set. Deletions we could ignore: visit
-  ;; the ID, and if it doesn't exist or doesn't have the msg-id-key
-  ;; property, then refresh the cache and start over.
-
-  ;; Or see how org-id does it -- since the whole things relies on
-  ;; org-id, we could maybe just refresh our table when org-id
-  ;; refreshes.
-
-  ;; use `org-format-outline-path' to show the path at the other end.
-
-  ;; Probably I should have this function return a value that can be
-  ;; pushed to the front of org-refile-history, so that it's just
-  ;; offered as a default. Then things like
-  ;; `org-refile-goto-last-stored' and all that will work without my
-  ;; having to write new equivalents.
-  (let (ret-val)
-    (setq ret-val
-         (append
-          (org-map-entries
-           (lambda ()
-             (catch 'done
-               (dolist (id ids)
-                 (when
-                     (org-entry-member-in-multivalued-property
-                      (point) gnorb-org-msg-id-key id)
-                   (throw 'done
-                          (list (org-id-get-create)
-                                (append
-                                 (org-get-outline-path)
-                                 (list (org-get-heading t nil)))))))))
-           gnorb-org-find-candidates-match
-           'agenda 'archive 'comment)
-          ret-val))
-    (setq ret-val (delete-dups
-                  (delq nil ret-val)))))
+  (let (ret-val sub-val)
+    (unless gnorb-msg-id-to-heading-table
+      (gnorb-org-populate-id-hash))
+    (dolist (id ids)
+      (when (setq sub-val (gethash id gnorb-msg-id-to-heading-table))
+       (push sub-val ret-val)))
+    ret-val))
 
 ;;; Email subtree
 
diff --git a/lisp/gnorb-utils.el b/lisp/gnorb-utils.el
index 1c4a37c..34a51e7 100644
--- a/lisp/gnorb-utils.el
+++ b/lisp/gnorb-utils.el
@@ -66,13 +66,19 @@
 (defvar gnorb-tmp-dir (make-temp-file "emacs-gnorb" t)
   "Temporary directory where attachments etc are saved.")
 
+(defvar gnorb-msg-id-to-heading-table nil
+  "Hash table where keys are message-ids, and values are lists of
+  org headings which have that message-id in their GNORB_MSG_ID
+  property. Values are actually two-element lists: the heading's
+  id, and its outline path.")
+
 (defvar gnorb-message-org-ids nil
   "List of Org heading IDs from the outgoing Gnus message, used
   to mark mail TODOs as done once the message is sent."
   ;; The send hook either populates this, or sets it to nil, depending
   ;; on whether the message in question has an Org id header. Then
   ;; `gnorb-org-restore-after-send' checks for it and acts
-  ;; appropriately.
+  ;; appropriately, then sets it to nil.
 )
 
 (defcustom gnorb-mail-header "X-Org-ID"
@@ -124,7 +130,8 @@ the prefix arg."
          (sent-id (plist-get gnorb-gnus-sending-message-info :msg-id)))
       (when sent-id
        (org-entry-add-to-multivalued-property
-        root-marker gnorb-org-msg-id-key sent-id))
+        root-marker gnorb-org-msg-id-key sent-id)
+       (gnorb-org-add-id-hash-entry sent-id))
       (setq action (cond ((not
                           (or (and ret-dest-todo
                                    (null gnorb-org-mail-todos))