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     (condition-case error
 102         (let* ((msg-id (format "<%s>" (plist-get org-store-link-plist :message-id)))
 103                (existing-org-ids (gnus-registry-get-id-key msg-id 'gnorb-ids))
 104                (org-id (org-capture-get :gnorb-id)))
 105           (when (member org-id existing-org-ids)
 106             (gnus-registry-set-id-key msg-id 'gnorb-ids
 107                                       (remove org-id existing-org-ids)))
 108           (setq abort-note 'clean))
 109       (error
 110        (setq abort-note 'dirty)))))
 111
 112 (defun gnorb-find-visit-candidates (ids)
 113   "For all message-ids in IDS (which should be a list of
 114 Message-ID strings, with angle brackets, or a single string of
 115 Message-IDs), produce a list of Org ids for headings that are
 116 relevant to that message."
 117   (let (ret-val sub-val)
 118     (when (stringp ids)
 119       (setq ids (gnus-extract-references ids)))
 120     (when gnorb-tracking-enabled
 121       (setq ids (delete-dups ids))
 122       (progn
 123         (dolist (id ids)
 124           (when
 125               (setq sub-val
 126                     (gnus-registry-get-id-key id 'gnorb-ids))
 127             (setq ret-val (append sub-val ret-val))))))
 128     (delete-dups ret-val)))
 129
 130 (defun gnorb-registry-org-id-search (id)
 131   "Find all messages that have the org ID in their 'gnorb-ids
 132 key."
 133   (registry-search gnus-registry-db :member `((gnorb-ids ,id))))
 134
 135 (defun gnorb-registry-transition-from-props (arg)
 136   "Helper function for transitioning the old tracking system to the new.
 137
 138 The old system relied on storing sent message ids on relevant Org
 139 headings, in the `gnorb-org-msg-id-key' property. The new system
 140 uses the gnus registry to track relations between messages and
 141 Org headings. This function will go through your agenda files,
 142 find headings that have the `gnorb-org-msg-id-key' property set,
 143 and create new registry entries that reflect that connection.
 144
 145 Call with a prefix arg to additionally delete the
 146 `gnorb-org-msg-id-key' altogether from your Org headings. As this
 147 function will not create duplicate registry entries, it's safe to
 148 run it once with no prefix arg, to keep the properties in place,
 149 and then once you're sure everything's working okay, run it again
 150 with a prefix arg, to clean the Gnorb-specific properties from
 151 your Org files."
 152   (interactive "P")
 153   (let ((count 0))
 154     (message "Collecting all relevant Org headings, this could take a while...")
 155     (org-map-entries
 156      (lambda ()
 157        (let ((id (org-id-get))
 158              (props (org-entry-get-multivalued-property
 159                (point) gnorb-org-msg-id-key))
 160              links group id)
 161         (when props
 162           ;; If the property is set, we should probably assume that any
 163           ;; Gnus links in the subtree are relevant, and should also be
 164           ;; collected and associated.
 165           (setq links (gnorb-scan-links
 166                        (org-element-property :end (org-element-at-point))
 167                        'gnus))
 168           (dolist (l (plist-get links :gnus))
 169             (gnorb-registry-make-entry
 170              (second (split-string l "#")) nil nil
 171              id (first (split-string l "#"))))
 172           (dolist (p props)
 173             (setq id )
 174             (gnorb-registry-make-entry p nil nil id nil)
 175             ;; This function will try to find the group for the message
 176             ;; and set that value on the registry entry if it can find
 177             ;; it.
 178             (unless (gnus-registry-get-id-key p 'group)
 179               (gnorb-msg-id-to-group p))
 180             (incf count)))))
 181      gnorb-org-find-candidates-match
 182      'agenda 'archive 'comment)
 183     (message "Collecting all relevant Org headings, this could take a while... done")
 184     ;; Delete the properties if the user has asked us to do so.
 185     (if (equal arg '(4))
 186         (progn
 187           (dolist (f (org-agenda-files))
 188             (with-current-buffer (get-file-buffer f)
 189               (org-delete-property-globally gnorb-org-msg-id-key)))
 190           (message "%d entries created; all Gnorb-specific properties deleted."
 191                    count))
 192       (message "%d entries created." count))))
 193
 194 (provide 'gnorb-registry)