f0b315420487dc75ec06f896764285ccac2ba213
[gnus] / lisp / registry.el
1 ;;; registry.el --- Track and remember data items by various fields
2
3 ;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
4
5 ;; Author: Teodor Zlatanov <tzz@lifelogs.com>
6 ;; Keywords: data
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;; This library provides a general-purpose EIEIO-based registry
26 ;; database with persistence, initialized with these fields:
27
28 ;; version: a float
29
30 ;; max-size: an integer, default most-positive-fixnum
31
32 ;; prune-factor: a float between 0 and 1, default 0.1
33
34 ;; precious: a list of symbols
35
36 ;; tracked: a list of symbols
37
38 ;; tracker: a hashtable tuned for 100 symbols to track (you should
39 ;; only access this with the :lookup2-function and the
40 ;; :lookup2+-function)
41
42 ;; data: a hashtable with default size 10K and resize threshold 2.0
43 ;; (this reflects the expected usage so override it if you know better)
44
45 ;; ...plus methods to do all the work: `registry-search',
46 ;; `registry-lookup', `registry-lookup-secondary',
47 ;; `registry-lookup-secondary-value', `registry-insert',
48 ;; `registry-delete', `registry-prune', `registry-size' which see
49
50 ;; and with the following properties:
51
52 ;; Every piece of data has a unique ID and some general-purpose fields
53 ;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g.
54
55 ;; ((F1 D1) (F2 D2) (F3 a b c))
56
57 ;; Note that whether a field has one or many pieces of data, the data
58 ;; is always a list of values.
59
60 ;; The user decides which fields are "precious", F2 for example.  When
61 ;; the registry is pruned, any entries without the F2 field will be
62 ;; removed until the size is :max-size * :prune-factor _less_ than the
63 ;; maximum database size. No entries with the F2 field will be removed
64 ;; at PRUNE TIME, which means it may not be possible to prune back all
65 ;; the way to the target size.
66
67 ;; When an entry is inserted, the registry will reject new entries if
68 ;; they bring it over the :max-size limit, even if they have the F2
69 ;; field.
70
71 ;; The user decides which fields are "tracked", F1 for example.  Any
72 ;; new entry is then indexed by all the tracked fields so it can be
73 ;; quickly looked up that way.  The data is always a list (see example
74 ;; above) and each list element is indexed.
75
76 ;; Precious and tracked field names must be symbols.  All other
77 ;; fields can be any other Emacs Lisp types.
78
79 ;;; Code:
80
81 (eval-when-compile (require 'cl))
82
83 (eval-and-compile
84   (or (ignore-errors (progn
85                        (require 'eieio)
86                        (require 'eieio-base)))
87       ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
88       (ignore-errors
89         (let ((load-path (cons (expand-file-name
90                                 "gnus-fallback-lib/eieio"
91                                 (file-name-directory (locate-library "gnus")))
92                                load-path)))
93           (require 'eieio)
94           (require 'eieio-base)))
95       (error
96        "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
97
98 ;; The version number needs to be kept outside of the class definition
99 ;; itself.  The persistent-save process does *not* write to file any
100 ;; slot values that are equal to the default :initform value.  If a
101 ;; database object is at the most recent version, therefore, its
102 ;; version number will not be written to file.  That makes it
103 ;; difficult to know when a database needs to be upgraded.
104 (defvar registry-db-version 0.2
105   "The current version of the registry format.")
106
107 (defclass registry-db (eieio-persistent)
108   ((version :initarg :version
109             :initform nil
110             :type (or null float)
111             :documentation "The registry version.")
112    (max-size :initarg :max-size
113              ;; :initform most-positive-fixnum ;; see below
114              :type integer
115              :custom integer
116              :documentation "The maximum number of registry entries.")
117    (prune-factor
118     :initarg :prune-factor
119     :initform 0.1
120     :type float
121     :custom float
122     :documentation "Prune to \(:max-size * :prune-factor\) less
123     than the :max-size limit.  Should be a float between 0 and 1.")
124    (tracked :initarg :tracked
125             :initform nil
126             :type t
127             :documentation "The tracked (indexed) fields, a list of symbols.")
128    (precious :initarg :precious
129              :initform nil
130              :type t
131              :documentation "The precious fields, a list of symbols.")
132    (tracker :initarg :tracker
133             :type hash-table
134             :documentation "The field tracking hashtable.")
135    (data :initarg :data
136          :type hash-table
137          :documentation "The data hashtable.")))
138 ;; Do this separately, since defclass doesn't allow expressions in :initform.
139 (oset-default registry-db max-size most-positive-fixnum)
140
141 (defmethod initialize-instance :BEFORE ((this registry-db) slots)
142   "Check whether a registry object needs to be upgraded."
143   ;; Hardcoded upgrade routines.  Version 0.1 to 0.2 requires the
144   ;; :max-soft slot to disappear, and the :max-hard slot to be renamed
145   ;; :max-size.
146   (let ((current-version
147          (and (plist-member slots :version)
148               (plist-get slots :version))))
149     (when (or (null current-version)
150               (eql current-version 0.1))
151       (setq slots
152             (plist-put slots :max-size (plist-get slots :max-hard)))
153       (setq slots
154             (plist-put slots :version registry-db-version))
155       (cl-remf slots :max-hard)
156       (cl-remf slots :max-soft))))
157
158 (defmethod initialize-instance :AFTER ((this registry-db) slots)
159   "Set value of data slot of THIS after initialization."
160   (with-slots (data tracker) this
161     (unless (member :data slots)
162       (setq data
163             (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
164     (unless (member :tracker slots)
165       (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
166
167 (defmethod registry-lookup ((db registry-db) keys)
168   "Search for KEYS in the registry-db THIS.
169 Returns an alist of the key followed by the entry in a list, not a cons cell."
170   (let ((data (oref db :data)))
171     (delq nil
172           (mapcar
173            (lambda (k)
174              (when (gethash k data)
175                (list k (gethash k data))))
176            keys))))
177
178 (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
179   "Search for KEYS in the registry-db THIS.
180 Returns an alist of the key followed by the entry in a list, not a cons cell."
181   (let ((data (oref db :data)))
182     (delq nil
183           (loop for key in keys
184                 when (gethash key data)
185                 collect (list key (gethash key data))))))
186
187 (defmethod registry-lookup-secondary ((db registry-db) tracksym
188                                       &optional create)
189   "Search for TRACKSYM in the registry-db THIS.
190 When CREATE is not nil, create the secondary index hashtable if needed."
191   (let ((h (gethash tracksym (oref db :tracker))))
192     (if h
193         h
194       (when create
195         (puthash tracksym
196                  (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
197                  (oref db :tracker))
198         (gethash tracksym (oref db :tracker))))))
199
200 (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
201                                             &optional set)
202   "Search for TRACKSYM with value VAL in the registry-db THIS.
203 When SET is not nil, set it for VAL (use t for an empty list)."
204   ;; either we're asked for creation or there should be an existing index
205   (when (or set (registry-lookup-secondary db tracksym))
206     ;; set the entry if requested,
207     (when set
208       (puthash val (if (eq t set) '() set)
209                (registry-lookup-secondary db tracksym t)))
210     (gethash val (registry-lookup-secondary db tracksym))))
211
212 (defun registry--match (mode entry check-list)
213   ;; for all members
214   (when check-list
215     (let ((key (nth 0 (nth 0 check-list)))
216           (vals (cdr-safe (nth 0 check-list)))
217           found)
218       (while (and key vals (not found))
219         (setq found (case mode
220                       (:member
221                        (member (car-safe vals) (cdr-safe (assoc key entry))))
222                       (:regex
223                        (string-match (car vals)
224                                      (mapconcat
225                                       'prin1-to-string
226                                       (cdr-safe (assoc key entry))
227                                       "\0"))))
228               vals (cdr-safe vals)))
229       (or found
230           (registry--match mode entry (cdr-safe check-list))))))
231
232 (defmethod registry-search ((db registry-db) &rest spec)
233   "Search for SPEC across the registry-db THIS.
234 For example calling with :member '(a 1 2) will match entry '((a 3 1)).
235 Calling with :all t (any non-nil value) will match all.
236 Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\").
237 The test order is to check :all first, then :member, then :regex."
238   (when db
239     (let ((all (plist-get spec :all))
240           (member (plist-get spec :member))
241           (regex (plist-get spec :regex)))
242       (loop for k being the hash-keys of (oref db :data)
243             using (hash-values v)
244             when (or
245                   ;; :all non-nil returns all
246                   all
247                   ;; member matching
248                   (and member (registry--match :member v member))
249                   ;; regex matching
250                   (and regex (registry--match :regex v regex)))
251             collect k))))
252
253 (defmethod registry-delete ((db registry-db) keys assert &rest spec)
254   "Delete KEYS from the registry-db THIS.
255 If KEYS is nil, use SPEC to do a search.
256 Updates the secondary ('tracked') indices as well.
257 With assert non-nil, errors out if the key does not exist already."
258   (let* ((data (oref db :data))
259          (keys (or keys
260                    (apply 'registry-search db spec)))
261          (tracked (oref db :tracked)))
262
263     (dolist (key keys)
264       (let ((entry (gethash key data)))
265         (when assert
266           (assert entry nil
267                   "Key %s does not exist in database" key))
268         ;; clean entry from the secondary indices
269         (dolist (tr tracked)
270           ;; is this tracked symbol indexed?
271           (when (registry-lookup-secondary db tr)
272             ;; for every value in the entry under that key...
273             (dolist (val (cdr-safe (assq tr entry)))
274               (let* ((value-keys (registry-lookup-secondary-value
275                                   db tr val)))
276                 (when (member key value-keys)
277                   ;; override the previous value
278                   (registry-lookup-secondary-value
279                    db tr val
280                    ;; with the indexed keys MINUS the current key
281                    ;; (we pass t when the list is empty)
282                    (or (delete key value-keys) t)))))))
283         (remhash key data)))
284     keys))
285
286 (defmethod registry-size ((db registry-db))
287   "Returns the size of the registry-db object THIS.
288 This is the key count of the :data slot."
289   (hash-table-count (oref db :data)))
290
291 (defmethod registry-full ((db registry-db))
292   "Checks if registry-db THIS is full."
293   (>= (registry-size db)
294       (oref db :max-size)))
295
296 (defmethod registry-insert ((db registry-db) key entry)
297   "Insert ENTRY under KEY into the registry-db THIS.
298 Updates the secondary ('tracked') indices as well.
299 Errors out if the key exists already."
300
301   (assert (not (gethash key (oref db :data))) nil
302           "Key already exists in database")
303
304   (assert (not (registry-full db))
305           nil
306           "registry max-size limit reached")
307
308   ;; store the entry
309   (puthash key entry (oref db :data))
310
311   ;; store the secondary indices
312   (dolist (tr (oref db :tracked))
313     ;; for every value in the entry under that key...
314     (dolist (val (cdr-safe (assq tr entry)))
315       (let* ((value-keys (registry-lookup-secondary-value db tr val)))
316         (pushnew key value-keys :test 'equal)
317         (registry-lookup-secondary-value db tr val value-keys))))
318   entry)
319
320 (defmethod registry-reindex ((db registry-db))
321   "Rebuild the secondary indices of registry-db THIS."
322   (let ((count 0)
323         (expected (* (length (oref db :tracked)) (registry-size db))))
324     (dolist (tr (oref db :tracked))
325       (let (values)
326         (maphash
327          (lambda (key v)
328            (incf count)
329            (when (and (< 0 expected)
330                       (= 0 (mod count 1000)))
331              (message "reindexing: %d of %d (%.2f%%)"
332                       count expected (/ (* 100 count) expected)))
333            (dolist (val (cdr-safe (assq tr v)))
334              (let* ((value-keys (registry-lookup-secondary-value db tr val)))
335                (push key value-keys)
336                (registry-lookup-secondary-value db tr val value-keys))))
337          (oref db :data))))))
338
339 (defmethod registry-prune ((db registry-db) &optional sortfunc)
340   "Prunes the registry-db object DB.
341
342 Attempts to prune the number of entries down to \(*
343 :max-size :prune-factor\) less than the max-size limit, so
344 pruning doesn't need to happen on every save. Removes only
345 entries without the :precious keys, so it may not be possible to
346 reach the target limit.
347
348 Entries to be pruned are first sorted using SORTFUNC.  Entries
349 from the front of the list are deleted first.
350
351 Returns the number of deleted entries."
352   (let ((size (registry-size db))
353         (target-size (- (oref db :max-size)
354                         (* (oref db :max-size)
355                            (oref db :prune-factor))))
356         candidates)
357     (if (> size target-size)
358         (progn
359           (setq candidates
360                 (registry-collect-prune-candidates
361                  db (- size target-size) sortfunc))
362           (length (registry-delete db candidates nil)))
363       0)))
364
365 (defmethod registry-collect-prune-candidates ((db registry-db) limit sortfunc)
366   "Collects pruning candidates from the registry-db object DB.
367
368 Proposes only entries without the :precious keys, and attempts to
369 return LIMIT such candidates.  If SORTFUNC is provided, sort
370 entries first and return candidates from beginning of list."
371   (let* ((precious (oref db :precious))
372          (precious-p (lambda (entry-key)
373                        (cdr (memq (car entry-key) precious))))
374          (data (oref db :data))
375          (candidates (cl-loop for k being the hash-keys of data
376                               using (hash-values v)
377                               when (notany precious-p v)
378                               collect (cons k v))))
379     ;; We want the full entries for sorting, but should only return a
380     ;; list of entry keys.
381     (when sortfunc
382       (setq candidates (sort candidates sortfunc)))
383     (delq nil (cl-subseq (mapcar #'car candidates) 0 limit))))
384
385 (provide 'registry)
386 ;;; registry.el ends here