code.delx.au - gnu-emacs-elpa/blob - gnorb-registry.el

   1 ;;; gnorb-registry.el --- Registry implementation for Gnorb
   2
   3 ;; This file is in the public domain.
   4
   5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net.>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; Early on, Gnorb's message/todo tracking was done by relying on the
  25 ;; user to insert links to received messages into an Org heading, and
  26 ;; by automatically storing the Message-Ids of sent messages in a
  27 ;; property (`gnorb-org-msg-id-key', defaulting to GNORB_MSG_ID) on
  28 ;; the same heading. The heading could find all relevant messages by
  29 ;; combining the links (incoming) and the IDs of the Gnorb-specific
  30 ;; property (outgoing).
  31 ;;
  32 ;; In the end, this proved to be fragile and messy. Enter the
  33 ;; registry. The Gnus registry is a specialization of a general
  34 ;; "registry" library -- it's possible to roll your own. If you want
  35 ;; to track connections between messages and Org headings, it's an
  36 ;; obvious choice: Each relevant message is stored in the registry,
  37 ;; keyed on its Message-ID, and the org-ids of all relevant headings
  38 ;; are stored in a custom property, in our case gnorb-ids. This allows
  39 ;; us to keep all Gnorb-specific data in one place, without polluting
  40 ;; Org files or Gnus messages, persistent on disk, and with the added
  41 ;; bonus of providing a place to keep arbitrary additional metadata.
  42 ;;
  43 ;; The drawback is that the connections are no longer readily visible
  44 ;; to the user (they need to query the registry to see them), and it
  45 ;; becomes perhaps a bit more difficult (but only a bit) to keep
  46 ;; registry data in sync with the current state of the user's Gnus and
  47 ;; Org files. But a clear win, in the end.
  48
  49 ;;; Code:
  50
  51 (require 'gnus-registry)
  52
  53 (defgroup gnorb-registry nil
  54   "Gnorb's use of the Gnus registry."
  55   :tag "Gnorb Registry"
  56   :group 'gnorb)
  57
  58 (defun gnorb-registry-make-entry (msg-id sender subject org-id group)
  59   "Create a Gnus registry entry for a message, either received or
  60 sent. Save the relevant Org ids in the 'gnorb-ids key."
  61   ;; This set-id-key stuff is actually horribly
  62   ;; inefficient.
  63   (when gnorb-tracking-enabled
  64     (gnus-registry-get-or-make-entry msg-id)
  65     (when sender
  66       (gnus-registry-set-id-key msg-id 'sender (list sender)))
  67     (when subject
  68       (gnus-registry-set-id-key msg-id 'subject (list subject)))
  69     (when org-id
  70       (let ((ids (gnus-registry-get-id-key msg-id 'gnorb-ids)))
  71         (unless (member org-id ids)
  72          (gnus-registry-set-id-key msg-id 'gnorb-ids (if (stringp org-id)
  73                                                          (cons org-id ids)
  74                                                        (append org-id ids))))))
  75     (when group
  76       (gnus-registry-set-id-key msg-id 'group (list group)))
  77     (gnus-registry-get-or-make-entry msg-id)))
  78
  79 (defun gnorb-registry-capture ()
  80   "When capturing from a Gnus message, add our new Org heading id
  81 to the message's registry entry, under the 'gnorb-ids key."
  82   (when (and (with-current-buffer
  83                  (org-capture-get :original-buffer)
  84                (memq major-mode '(gnus-summary-mode gnus-article-mode)))
  85              (not org-note-abort))
  86     (let* ((msg-id
  87             (format "<%s>" (plist-get org-store-link-plist :message-id)))
  88            (entry (gnus-registry-get-or-make-entry msg-id))
  89            (org-ids
  90             (gnus-registry-get-id-key msg-id 'gnorb-ids))
  91            (new-org-id (org-id-get-create)))
  92       (plist-put org-capture-plist :gnorb-id new-org-id)
  93       (setq org-ids (cons new-org-id org-ids))
  94       (setq org-ids (delete-dups org-ids))
  95       (gnus-registry-set-id-key msg-id 'gnorb-ids org-ids))))
  96
  97
  98 (defun gnorb-registry-capture-abort-cleanup ()
  99   (when (and (org-capture-get :gnorb-id)
 100              org-note-abort)
 101     (with-no-warnings ; For `abort-note'
 102       (condition-case error
 103           (let* ((msg-id (format "<%s>" (plist-get org-store-link-plist :message-id)))
 104                  (existing-org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids))
 105                  (org-id (org-capture-get :gnorb-id)))
 106             (when (member org-id existing-org-ids)
 107               (gnus-registry-set-id-key msg-id 'gnorb-ids
 108                                         (remove org-id existing-org-ids)))
 109             (setq abort-note 'clean))
 110         (error
 111          (setq abort-note 'dirty))))))
 112
 113 (defun gnorb-find-visit-candidates (ids &optional include-zombies)
 114   "For all message-ids in IDS (which should be a list of
 115 Message-ID strings, with angle brackets, or a single string of
 116 Message-IDs), produce a list of Org ids for headings that are
 117 relevant to that message.
 118
 119 If optional argument INCLUDE_ZOMBIES is non-nil, return ID values
 120 even for headings that appear to no longer exist."
 121   (let (ret-val sub-val)
 122     (when (stringp ids)
 123       (setq ids (gnus-extract-references ids)))
 124     (when gnorb-tracking-enabled
 125       (setq ids (delete-dups ids))
 126       (progn
 127         (dolist (id ids)
 128           (when
 129               (setq sub-val
 130                     (gnus-registry-get-id-key id 'gnorb-ids))
 131             (setq ret-val (append sub-val ret-val))))))
 132     ;; This lets us be reasonably confident that the
 133     ;; headings still exist.
 134     (unless include-zombies
 135       (cl-remove-if-not
 136        (lambda (org-id)
 137          (org-id-find-id-file org-id))
 138        ret-val))
 139     (delete-dups ret-val)))
 140
 141 (defun gnorb-delete-association (msg-id org-id)
 142   "Disassociate a message and a headline.
 143
 144 This removes an Org heading's ORG-ID from the 'gnorb-ids key of
 145 the MSG-ID."
 146   (let ((org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids)))
 147     (when (member org-id org-ids)
 148       (gnus-registry-set-id-key msg-id 'gnorb-ids
 149                                 (remove org-id org-ids)))))
 150
 151 (defun gnorb-delete-all-assocations (org-id)
 152   "Delete all message associations for an Org heading.
 153
 154 The heading is identified by ORG-ID. This is suitable for use
 155 after an Org heading is deleted, for instance."
 156   (let ((assoc-msgs (gnorb-registry-org-id-search org-id)))
 157     (mapcar
 158      (lambda (msg-id)
 159        (let ((org-ids
 160               (gnus-registry-get-id-key msg-id 'gnorb-ids)))
 161          (gnus-registry-set-id-key
 162           msg-id 'gnorb-ids (remove org-id org-ids))))
 163      assoc-msgs)))
 164
 165 (defun gnorb-registry-org-id-search (id)
 166   "Find all messages that have the org ID in their 'gnorb-ids
 167 key."
 168   (registry-search gnus-registry-db :member `((gnorb-ids ,id))))
 169
 170 (defun gnorb-registry-transition-from-props (arg)
 171   "Helper function for transitioning the old tracking system to the new.
 172
 173 The old system relied on storing sent message ids on relevant Org
 174 headings, in the `gnorb-org-msg-id-key' property. The new system
 175 uses the gnus registry to track relations between messages and
 176 Org headings. This function will go through your agenda files,
 177 find headings that have the `gnorb-org-msg-id-key' property set,
 178 and create new registry entries that reflect that connection.
 179
 180 Call with a prefix arg to additionally delete the
 181 `gnorb-org-msg-id-key' altogether from your Org headings. As this
 182 function will not create duplicate registry entries, it's safe to
 183 run it once with no prefix arg, to keep the properties in place,
 184 and then once you're sure everything's working okay, run it again
 185 with a prefix arg, to clean the Gnorb-specific properties from
 186 your Org files."
 187   (interactive "P")
 188   (let ((count 0))
 189     (message "Collecting all relevant Org headings, this could take a while...")
 190     (org-map-entries
 191      (lambda ()
 192        (let ((id (org-id-get))
 193              (props (org-entry-get-multivalued-property
 194                (point) gnorb-org-msg-id-key))
 195              links group id)
 196         (when props
 197           ;; If the property is set, we should probably assume that any
 198           ;; Gnus links in the subtree are relevant, and should also be
 199           ;; collected and associated.
 200           (setq links (gnorb-scan-links
 201                        (org-element-property :end (org-element-at-point))
 202                        'gnus))
 203           (dolist (l (plist-get links :gnus))
 204             (gnorb-registry-make-entry
 205              (second (split-string l "#")) nil nil
 206              id (first (split-string l "#"))))
 207           (dolist (p props)
 208             (setq id )
 209             (gnorb-registry-make-entry p nil nil id nil)
 210             ;; This function will try to find the group for the message
 211             ;; and set that value on the registry entry if it can find
 212             ;; it.
 213             (unless (gnus-registry-get-id-key p 'group)
 214               (gnorb-msg-id-to-group p))
 215             (incf count)))))
 216      gnorb-org-find-candidates-match
 217      'agenda 'archive 'comment)
 218     (message "Collecting all relevant Org headings, this could take a while... done")
 219     ;; Delete the properties if the user has asked us to do so.
 220     (if (equal arg '(4))
 221         (progn
 222           (dolist (f (org-agenda-files))
 223             (with-current-buffer (get-file-buffer f)
 224               (org-delete-property-globally gnorb-org-msg-id-key)))
 225           (message "%d entries created; all Gnorb-specific properties deleted."
 226                    count))
 227       (message "%d entries created." count))))
 228
 229 (provide 'gnorb-registry)