1 ;;; registry.el --- Track and remember data items by various fields
3 ;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
5 ;; Author: Teodor Zlatanov <tzz@lifelogs.com>
8 ;; This file is part of GNU Emacs.
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.
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.
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/>.
25 ;; This library provides a general-purpose EIEIO-based registry
26 ;; database with persistence, initialized with these fields:
28 ;; version: a float, 0.1 currently (don't change it)
30 ;; max-hard: an integer, default 5000000
32 ;; max-soft: an integer, default 50000
34 ;; precious: a list of symbols
36 ;; tracked: a list of symbols
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)
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)
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
50 ;; and with the following properties:
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.
55 ;; ((F1 D1) (F2 D2) (F3 a b c))
57 ;; Note that whether a field has one or many pieces of data, the data
58 ;; is always a list of values.
60 ;; The user decides which fields are "precious", F2 for example. At
61 ;; PRUNE TIME (when the :prune-function is called), the registry will
62 ;; trim any entries without the F2 field until the size is :max-soft
63 ;; or less. No entries with the F2 field will be removed at PRUNE
66 ;; When an entry is inserted, the registry will reject new entries
67 ;; if they bring it over the max-hard limit, even if they have the F2
70 ;; The user decides which fields are "tracked", F1 for example. Any
71 ;; new entry is then indexed by all the tracked fields so it can be
72 ;; quickly looked up that way. The data is always a list (see example
73 ;; above) and each list element is indexed.
75 ;; Precious and tracked field names must be symbols. All other
76 ;; fields can be any other Emacs Lisp types.
80 (eval-when-compile (require 'cl))
83 (or (ignore-errors (progn
85 (require 'eieio-base)))
86 ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
88 (let ((load-path (cons (expand-file-name
89 "gnus-fallback-lib/eieio"
90 (file-name-directory (locate-library "gnus")))
93 (require 'eieio-base)))
95 "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
97 (defclass registry-db (eieio-persistent)
98 ((version :initarg :version
102 :documentation "The registry version.")
103 (max-hard :initarg :max-hard
107 :documentation "Never accept more than this many elements.")
108 (max-soft :initarg :max-soft
112 :documentation "Prune as much as possible to get to this size.")
114 :initarg :prune-factor
118 :documentation "At the max-hard limit, prune size * this entries.")
119 (tracked :initarg :tracked
122 :documentation "The tracked (indexed) fields, a list of symbols.")
123 (precious :initarg :precious
126 :documentation "The precious fields, a list of symbols.")
127 (tracker :initarg :tracker
129 :documentation "The field tracking hashtable.")
132 :documentation "The data hashtable.")))
134 (defmethod initialize-instance :AFTER ((this registry-db) slots)
135 "Set value of data slot of THIS after initialization."
136 (with-slots (data tracker) this
137 (unless (member :data slots)
139 (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
140 (unless (member :tracker slots)
141 (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
143 (defmethod registry-lookup ((db registry-db) keys)
144 "Search for KEYS in the registry-db THIS.
145 Returns an alist of the key followed by the entry in a list, not a cons cell."
146 (let ((data (oref db :data)))
150 (when (gethash k data)
151 (list k (gethash k data))))
154 (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
155 "Search for KEYS in the registry-db THIS.
156 Returns an alist of the key followed by the entry in a list, not a cons cell."
157 (let ((data (oref db :data)))
159 (loop for key in keys
160 when (gethash key data)
161 collect (list key (gethash key data))))))
163 (defmethod registry-lookup-secondary ((db registry-db) tracksym
165 "Search for TRACKSYM in the registry-db THIS.
166 When CREATE is not nil, create the secondary index hashtable if needed."
167 (let ((h (gethash tracksym (oref db :tracker))))
172 (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
174 (gethash tracksym (oref db :tracker))))))
176 (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
178 "Search for TRACKSYM with value VAL in the registry-db THIS.
179 When SET is not nil, set it for VAL (use t for an empty list)."
180 ;; either we're asked for creation or there should be an existing index
181 (when (or set (registry-lookup-secondary db tracksym))
182 ;; set the entry if requested,
184 (puthash val (if (eq t set) '() set)
185 (registry-lookup-secondary db tracksym t)))
186 (gethash val (registry-lookup-secondary db tracksym))))
188 (defun registry--match (mode entry check-list)
191 (let ((key (nth 0 (nth 0 check-list)))
192 (vals (cdr-safe (nth 0 check-list)))
194 (while (and key vals (not found))
195 (setq found (case mode
197 (member (car-safe vals) (cdr-safe (assoc key entry))))
199 (string-match (car vals)
202 (cdr-safe (assoc key entry))
204 vals (cdr-safe vals)))
206 (registry--match mode entry (cdr-safe check-list))))))
208 (defmethod registry-search ((db registry-db) &rest spec)
209 "Search for SPEC across the registry-db THIS.
210 For example calling with :member '(a 1 2) will match entry '((a 3 1)).
211 Calling with :all t (any non-nil value) will match all.
212 Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\").
213 The test order is to check :all first, then :member, then :regex."
215 (let ((all (plist-get spec :all))
216 (member (plist-get spec :member))
217 (regex (plist-get spec :regex)))
218 (loop for k being the hash-keys of (oref db :data)
219 using (hash-values v)
221 ;; :all non-nil returns all
224 (and member (registry--match :member v member))
226 (and regex (registry--match :regex v regex)))
229 (defmethod registry-delete ((db registry-db) keys assert &rest spec)
230 "Delete KEYS from the registry-db THIS.
231 If KEYS is nil, use SPEC to do a search.
232 Updates the secondary ('tracked') indices as well.
233 With assert non-nil, errors out if the key does not exist already."
234 (let* ((data (oref db :data))
236 (apply 'registry-search db spec)))
237 (tracked (oref db :tracked)))
240 (let ((entry (gethash key data)))
243 "Key %s does not exist in database" key))
244 ;; clean entry from the secondary indices
246 ;; is this tracked symbol indexed?
247 (when (registry-lookup-secondary db tr)
248 ;; for every value in the entry under that key...
249 (dolist (val (cdr-safe (assq tr entry)))
250 (let* ((value-keys (registry-lookup-secondary-value
252 (when (member key value-keys)
253 ;; override the previous value
254 (registry-lookup-secondary-value
256 ;; with the indexed keys MINUS the current key
257 ;; (we pass t when the list is empty)
258 (or (delete key value-keys) t)))))))
262 (defmethod registry-size ((db registry-db))
263 "Returns the size of the registry-db object THIS.
264 This is the key count of the :data slot."
265 (hash-table-count (oref db :data)))
267 (defmethod registry-full ((db registry-db))
268 "Checks if registry-db THIS is full."
269 (>= (registry-size db)
270 (oref db :max-hard)))
272 (defmethod registry-insert ((db registry-db) key entry)
273 "Insert ENTRY under KEY into the registry-db THIS.
274 Updates the secondary ('tracked') indices as well.
275 Errors out if the key exists already."
277 (assert (not (gethash key (oref db :data))) nil
278 "Key already exists in database")
280 (assert (not (registry-full db))
282 "registry max-hard size limit reached")
285 (puthash key entry (oref db :data))
287 ;; store the secondary indices
288 (dolist (tr (oref db :tracked))
289 ;; for every value in the entry under that key...
290 (dolist (val (cdr-safe (assq tr entry)))
291 (let* ((value-keys (registry-lookup-secondary-value db tr val)))
292 (pushnew key value-keys :test 'equal)
293 (registry-lookup-secondary-value db tr val value-keys))))
296 (defmethod registry-reindex ((db registry-db))
297 "Rebuild the secondary indices of registry-db THIS."
299 (expected (* (length (oref db :tracked)) (registry-size db))))
300 (dolist (tr (oref db :tracked))
305 (when (and (< 0 expected)
306 (= 0 (mod count 1000)))
307 (message "reindexing: %d of %d (%.2f%%)"
308 count expected (/ (* 100 count) expected)))
309 (dolist (val (cdr-safe (assq tr v)))
310 (let* ((value-keys (registry-lookup-secondary-value db tr val)))
311 (push key value-keys)
312 (registry-lookup-secondary-value db tr val value-keys))))
315 (defmethod registry-prune ((db registry-db) &optional sortfun)
316 "Prunes the registry-db object THIS.
317 Removes only entries without the :precious keys if it can,
318 then removes oldest entries first.
319 Returns the number of deleted entries.
320 If SORTFUN is given, tries to keep entries that sort *higher*.
321 SORTFUN is passed only the two keys so it must look them up directly."
322 (dolist (collector '(registry-prune-soft-candidates
323 registry-prune-hard-candidates))
324 (let* ((size (registry-size db))
325 (collected (funcall collector db))
326 (limit (nth 0 collected))
327 (candidates (nth 1 collected))
328 ;; sort the candidates if SORTFUN was given
329 (candidates (if sortfun (sort candidates sortfun) candidates))
330 (candidates-count (length candidates))
331 ;; are we over max-soft?
332 (prune-needed (> size limit)))
334 ;; while we have more candidates than we need to remove...
335 (while (and (> candidates-count (- size limit)) candidates)
336 (decf candidates-count)
337 (setq candidates (cdr candidates)))
339 (registry-delete db candidates nil)
340 (length candidates))))
342 (defmethod registry-prune-soft-candidates ((db registry-db))
343 "Collects pruning candidates from the registry-db object THIS.
344 Proposes only entries without the :precious keys."
345 (let* ((precious (oref db :precious))
346 (precious-p (lambda (entry-key)
347 (cdr (memq (car entry-key) precious))))
348 (data (oref db :data))
349 (limit (oref db :max-soft))
350 (candidates (loop for k being the hash-keys of data
351 using (hash-values v)
352 when (notany precious-p v)
354 (list limit candidates)))
356 (defmethod registry-prune-hard-candidates ((db registry-db))
357 "Collects pruning candidates from the registry-db object THIS.
358 Proposes any entries over the max-hard limit minus size * prune-factor."
359 (let* ((data (oref db :data))
360 ;; prune to (size * prune-factor) below the max-hard limit so
361 ;; we're not pruning all the time
362 (limit (max 0 (- (oref db :max-hard)
363 (* (registry-size db) (oref db :prune-factor)))))
364 (candidates (loop for k being the hash-keys of data
366 (list limit candidates)))
369 ;;; registry.el ends here