7155fe40610af52e3f19ddd54c0fdf505aa48fec
[gnus] / lisp / registry.el
1 ;;; registry.el --- Track and remember data items by various fields
2
3 ;; Copyright (C) 2011-2015 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 (eval-when-compile
99   (unless (fboundp 'cl-remf)
100     (defalias 'cl-remf 'remf)
101     (defalias 'cl-loop 'loop)
102     (defalias 'cl-subseq 'subseq)))
103
104 ;; The version number needs to be kept outside of the class definition
105 ;; itself.  The persistent-save process does *not* write to file any
106 ;; slot values that are equal to the default :initform value.  If a
107 ;; database object is at the most recent version, therefore, its
108 ;; version number will not be written to file.  That makes it
109 ;; difficult to know when a database needs to be upgraded.
110 (defvar registry-db-version 0.2
111   "The current version of the registry format.")
112
113 (eval `
114 (defclass registry-db (eieio-persistent)
115   ((version :initarg :version
116             :initform nil
117             :type (or null float)
118             :documentation "The registry version.")
119    (max-size :initarg :max-size
120              ;; EIEIO's :initform is not 100% compatible with CLOS in
121              ;; that if the form is an atom, it assumes it's constant
122              ;; value rather than an expression, so in order to get the value
123              ;; of `most-positive-fixnum', we need to use an
124              ;; expression that's not just a symbol.
125              :initform ,(symbol-value 'most-positive-fixnum)
126              :type integer
127              :custom integer
128              :documentation "The maximum number of registry entries.")
129    (prune-factor
130     :initarg :prune-factor
131     :initform 0.1
132     :type float
133     :custom float
134     :documentation "Prune to (:max-size * :prune-factor) less
135     than the :max-size limit.  Should be a float between 0 and 1.")
136    (tracked :initarg :tracked
137             :initform nil
138             :type t
139             :documentation "The tracked (indexed) fields, a list of symbols.")
140    (precious :initarg :precious
141              :initform nil
142              :type t
143              :documentation "The precious fields, a list of symbols.")
144    (tracker :initarg :tracker
145             :type hash-table
146             :documentation "The field tracking hashtable.")
147    (data :initarg :data
148          :type hash-table
149          :documentation "The data hashtable.")))
150 )
151
152 (defmethod initialize-instance :BEFORE ((this registry-db) slots)
153   "Check whether a registry object needs to be upgraded."
154   ;; Hardcoded upgrade routines.  Version 0.1 to 0.2 requires the
155   ;; :max-soft slot to disappear, and the :max-hard slot to be renamed
156   ;; :max-size.
157   (let ((current-version
158          (and (plist-member slots :version)
159               (plist-get slots :version))))
160     (when (or (null current-version)
161               (eql current-version 0.1))
162       (setq slots
163             (plist-put slots :max-size (plist-get slots :max-hard)))
164       (setq slots
165             (plist-put slots :version registry-db-version))
166       (cl-remf slots :max-hard)
167       (cl-remf slots :max-soft))))
168
169 (defmethod initialize-instance :AFTER ((this registry-db) slots)
170   "Set value of data slot of THIS after initialization."
171   (with-slots (data tracker) this
172     (unless (member :data slots)
173       (setq data
174             (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
175     (unless (member :tracker slots)
176       (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
177
178 (defmethod registry-lookup ((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           (mapcar
184            (lambda (k)
185              (when (gethash k data)
186                (list k (gethash k data))))
187            keys))))
188
189 (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
190   "Search for KEYS in the registry-db THIS.
191 Returns an alist of the key followed by the entry in a list, not a cons cell."
192   (let ((data (oref db data)))
193     (delq nil
194           (loop for key in keys
195                 when (gethash key data)
196                 collect (list key (gethash key data))))))
197
198 (defmethod registry-lookup-secondary ((db registry-db) tracksym
199                                       &optional create)
200   "Search for TRACKSYM in the registry-db THIS.
201 When CREATE is not nil, create the secondary index hashtable if needed."
202   (let ((h (gethash tracksym (oref db :tracker))))
203     (if h
204         h
205       (when create
206         (puthash tracksym
207                  (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
208                  (oref db tracker))
209         (gethash tracksym (oref db tracker))))))
210
211 (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
212                                             &optional set)
213   "Search for TRACKSYM with value VAL in the registry-db THIS.
214 When SET is not nil, set it for VAL (use t for an empty list)."
215   ;; either we're asked for creation or there should be an existing index
216   (when (or set (registry-lookup-secondary db tracksym))
217     ;; set the entry if requested,
218     (when set
219       (puthash val (if (eq t set) '() set)
220                (registry-lookup-secondary db tracksym t)))
221     (gethash val (registry-lookup-secondary db tracksym))))
222
223 (defun registry--match (mode entry check-list)
224   ;; for all members
225   (when check-list
226     (let ((key (nth 0 (nth 0 check-list)))
227           (vals (cdr-safe (nth 0 check-list)))
228           found)
229       (while (and key vals (not found))
230         (setq found (case mode
231                       (:member
232                        (member (car-safe vals) (cdr-safe (assoc key entry))))
233                       (:regex
234                        (string-match (car vals)
235                                      (mapconcat
236                                       'prin1-to-string
237                                       (cdr-safe (assoc key entry))
238                                       "\0"))))
239               vals (cdr-safe vals)))
240       (or found
241           (registry--match mode entry (cdr-safe check-list))))))
242
243 (defmethod registry-search ((db registry-db) &rest spec)
244   "Search for SPEC across the registry-db THIS.
245 For example calling with `:member \\='(a 1 2)' will match entry \((a 3 1)).
246 Calling with `:all t' (any non-nil value) will match all.
247 Calling with `:regex \\='(a \"h.llo\")' will match entry \(a \"hullo\" \"bye\").
248 The test order is to check :all first, then :member, then :regex."
249   (when db
250     (let ((all (plist-get spec :all))
251           (member (plist-get spec :member))
252           (regex (plist-get spec :regex)))
253       (loop for k being the hash-keys of (oref db data)
254             using (hash-values v)
255             when (or
256                   ;; :all non-nil returns all
257                   all
258                   ;; member matching
259                   (and member (registry--match :member v member))
260                   ;; regex matching
261                   (and regex (registry--match :regex v regex)))
262             collect k))))
263
264 (defmethod registry-delete ((db registry-db) keys assert &rest spec)
265   "Delete KEYS from the registry-db THIS.
266 If KEYS is nil, use SPEC to do a search.
267 Updates the secondary ('tracked') indices as well.
268 With assert non-nil, errors out if the key does not exist already."
269   (let* ((data (oref db data))
270          (keys (or keys
271                    (apply 'registry-search db spec)))
272          (tracked (oref db tracked)))
273
274     (dolist (key keys)
275       (let ((entry (gethash key data)))
276         (when assert
277           (assert entry nil
278                   "Key %s does not exist in database" key))
279         ;; clean entry from the secondary indices
280         (dolist (tr tracked)
281           ;; is this tracked symbol indexed?
282           (when (registry-lookup-secondary db tr)
283             ;; for every value in the entry under that key...
284             (dolist (val (cdr-safe (assq tr entry)))
285               (let* ((value-keys (registry-lookup-secondary-value
286                                   db tr val)))
287                 (when (member key value-keys)
288                   ;; override the previous value
289                   (registry-lookup-secondary-value
290                    db tr val
291                    ;; with the indexed keys MINUS the current key
292                    ;; (we pass t when the list is empty)
293                    (or (delete key value-keys) t)))))))
294         (remhash key data)))
295     keys))
296
297 (defmethod registry-size ((db registry-db))
298   "Returns the size of the registry-db object THIS.
299 This is the key count of the `data' slot."
300   (hash-table-count (oref db data)))
301
302 (defmethod registry-full ((db registry-db))
303   "Checks if registry-db THIS is full."
304   (>= (registry-size db)
305       (oref db max-size)))
306
307 (defmethod registry-insert ((db registry-db) key entry)
308   "Insert ENTRY under KEY into the registry-db THIS.
309 Updates the secondary ('tracked') indices as well.
310 Errors out if the key exists already."
311
312   (assert (not (gethash key (oref db data))) nil
313           "Key already exists in database")
314
315   (assert (not (registry-full db))
316           nil
317           "registry max-size limit reached")
318
319   ;; store the entry
320   (puthash key entry (oref db data))
321
322   ;; store the secondary indices
323   (dolist (tr (oref db tracked))
324     ;; for every value in the entry under that key...
325     (dolist (val (cdr-safe (assq tr entry)))
326       (let* ((value-keys (registry-lookup-secondary-value db tr val)))
327         (pushnew key value-keys :test 'equal)
328         (registry-lookup-secondary-value db tr val value-keys))))
329   entry)
330
331 (defmethod registry-reindex ((db registry-db))
332   "Rebuild the secondary indices of registry-db THIS."
333   (let ((count 0)
334         (expected (* (length (oref db tracked)) (registry-size db))))
335     (dolist (tr (oref db tracked))
336       (let (values)
337         (maphash
338          (lambda (key v)
339            (incf count)
340            (when (and (< 0 expected)
341                       (= 0 (mod count 1000)))
342              (message "reindexing: %d of %d (%.2f%%)"
343                       count expected (/ (* 100.0 count) expected)))
344            (dolist (val (cdr-safe (assq tr v)))
345              (let* ((value-keys (registry-lookup-secondary-value db tr val)))
346                (push key value-keys)
347                (registry-lookup-secondary-value db tr val value-keys))))
348          (oref db data))))))
349
350 (defmethod registry-prune ((db registry-db) &optional sortfunc)
351   "Prunes the registry-db object DB.
352
353 Attempts to prune the number of entries down to \(*
354 :max-size :prune-factor) less than the max-size limit, so
355 pruning doesn't need to happen on every save. Removes only
356 entries without the :precious keys, so it may not be possible to
357 reach the target limit.
358
359 Entries to be pruned are first sorted using SORTFUNC.  Entries
360 from the front of the list are deleted first.
361
362 Returns the number of deleted entries."
363   (let ((size (registry-size db))
364         (target-size
365          (floor (- (oref db max-size)
366                    (* (oref db max-size)
367                       (oref db prune-factor)))))
368         candidates)
369     (if (registry-full db)
370         (progn
371           (setq candidates
372                 (registry-collect-prune-candidates
373                  db (- size target-size) sortfunc))
374           (length (registry-delete db candidates nil)))
375       0)))
376
377 (defmethod registry-collect-prune-candidates ((db registry-db) limit sortfunc)
378   "Collects pruning candidates from the registry-db object DB.
379
380 Proposes only entries without the :precious keys, and attempts to
381 return LIMIT such candidates.  If SORTFUNC is provided, sort
382 entries first and return candidates from beginning of list."
383   (let* ((precious (oref db precious))
384          (precious-p (lambda (entry-key)
385                        (cdr (memq (car entry-key) precious))))
386          (data (oref db data))
387          (candidates (cl-loop for k being the hash-keys of data
388                               using (hash-values v)
389                               when (notany precious-p v)
390                               collect (cons k v))))
391     ;; We want the full entries for sorting, but should only return a
392     ;; list of entry keys.
393     (when sortfunc
394       (setq candidates (sort candidates sortfunc)))
395     (cl-subseq (mapcar #'car candidates) 0 (min limit (length candidates)))))
396
397 (provide 'registry)
398 ;;; registry.el ends here