f390c2809ec352f9d598b2bf4cc00bbad95271c1
[gnus] / lisp / registry.el
1 ;;; registry.el --- Track and remember data items by various fields
2
3 ;; Copyright (C) 2011  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, 0.1 currently (don't change it)
29
30 ;; max-hard: an integer, default 5000000
31
32 ;; max-soft: an integer, default 50000
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.  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
64 ;; TIME.
65
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
68 ;; field.
69
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.
74
75 ;; Precious and tracked field names must be symbols.  All other
76 ;; fields can be any other Emacs Lisp types.
77
78 ;;; Code:
79
80 (eval-when-compile
81   (when (null (require 'ert nil t))
82     (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
83
84 (require 'ert nil t)
85
86 (eval-when-compile (require 'cl))
87 (eval-and-compile
88   (or (ignore-errors (progn
89                        (require 'eieio)
90                        (require 'eieio-base)))
91       ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
92       (ignore-errors
93         (let ((load-path (cons (expand-file-name
94                                 "gnus-fallback-lib/eieio"
95                                 (file-name-directory (locate-library "gnus")))
96                                load-path)))
97           (require 'eieio)
98           (require 'eieio-base)))
99       (error
100        "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
101
102 (defclass registry-db (eieio-persistent)
103   ((version :initarg :version
104             :initform 0.1
105             :type float
106             :custom float
107             :documentation "The registry version.")
108    (max-hard :initarg :max-hard
109              :initform 5000000
110              :type integer
111              :custom integer
112              :documentation "Never accept more than this many elements.")
113    (max-soft :initarg :max-soft
114              :initform 50000
115              :type integer
116              :custom integer
117              :documentation "Prune as much as possible to get to this size.")
118    (tracked :initarg :tracked
119             :initform nil
120             :type t
121             :documentation "The tracked (indexed) fields, a list of symbols.")
122    (precious :initarg :precious
123              :initform nil
124              :type t
125              :documentation "The precious fields, a list of symbols.")
126    (tracker :initarg :tracker
127             :type hash-table
128             :documentation "The field tracking hashtable.")
129    (data :initarg :data
130          :type hash-table
131          :documentation "The data hashtable.")))
132
133 (defmethod initialize-instance :AFTER ((this registry-db) slots)
134   "Set value of data slot of THIS after initialization."
135   (with-slots (data tracker) this
136     (unless (member :data slots)
137       (setq data (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
138     (unless (member :tracker slots)
139       (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
140
141 (defmethod registry-lookup ((db registry-db) keys)
142   "Search for KEYS in the registry-db THIS.
143 Returns a alist of the key followed by the entry in a list, not a cons cell."
144   (let ((data (oref db :data)))
145     (delq nil
146           (mapcar
147            (lambda (k)
148              (when (gethash k data)
149                (list k (gethash k data))))
150            keys))))
151
152 (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
153   "Search for KEYS in the registry-db THIS.
154 Returns a alist of the key followed by the entry in a list, not a cons cell."
155   (let ((data (oref db :data)))
156     (delq nil
157           (loop for key in keys
158                 when (gethash key data)
159                 collect (list key (gethash key data))))))
160
161 (defmethod registry-lookup-secondary ((db registry-db) tracksym
162                                       &optional create)
163   "Search for TRACKSYM in the registry-db THIS.
164 When CREATE is not nil, create the secondary index hashtable if needed."
165   (let ((h (gethash tracksym (oref db :tracker))))
166     (if h
167         h
168       (when create
169         (puthash tracksym
170                  (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
171                  (oref db :tracker))
172         (gethash tracksym (oref db :tracker))))))
173
174 (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
175                                             &optional set)
176   "Search for TRACKSYM with value VAL in the registry-db THIS.
177 When SET is not nil, set it for VAL (use t for an empty list)."
178   ;; either we're asked for creation or there should be an existing index
179   (when (or set (registry-lookup-secondary db tracksym))
180     ;; set the entry if requested,
181     (when set
182       (puthash val (if (eq t set) '() set)
183                (registry-lookup-secondary db tracksym t)))
184     (gethash val (registry-lookup-secondary db tracksym))))
185
186 (defun registry--match (mode entry check-list)
187   ;; for all members
188   (when check-list
189     (let ((key (nth 0 (nth 0 check-list)))
190           (vals (cdr-safe (nth 0 check-list)))
191           found)
192       (while (and key vals (not found))
193         (setq found (case mode
194                       (:member
195                        (member (car-safe vals) (cdr-safe (assoc key entry))))
196                       (:regex
197                        (string-match (car vals)
198                                      (mapconcat
199                                       'prin1-to-string
200                                       (cdr-safe (assoc key entry))
201                                       "\0"))))
202               vals (cdr-safe vals)))
203       (or found
204           (registry--match mode entry (cdr-safe check-list))))))
205
206 (defmethod registry-search ((db registry-db) &rest spec)
207   "Search for SPEC across the registry-db THIS.
208 For example calling with :member '(a 1 2) will match entry '((a 3 1)).
209 Calling with :all t (any non-nil value) will match all.
210 Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\").
211 The test order is to check :all first, then :member, then :regex."
212   (when db
213     (let ((all (plist-get spec :all))
214           (member (plist-get spec :member))
215           (regex (plist-get spec :regex)))
216       (loop for k being the hash-keys of (oref db :data) using (hash-values v)
217             when (or
218                   ;; :all non-nil returns all
219                   all
220                   ;; member matching
221                   (and member (registry--match :member v member))
222                   ;; regex matching
223                   (and regex (registry--match :regex v regex)))
224             collect k))))
225
226 (defmethod registry-delete ((db registry-db) keys assert &rest spec)
227   "Delete KEYS from the registry-db THIS.
228 If KEYS is nil, use SPEC to do a search.
229 Updates the secondary ('tracked') indices as well.
230 With assert non-nil, errors out if the key does not exist already."
231   (let* ((data (oref db :data))
232          (keys (or keys
233                    (apply 'registry-search db spec)))
234          (tracked (oref db :tracked)))
235
236     (dolist (key keys)
237       (let ((entry (gethash key data)))
238         (when assert
239           (assert entry nil
240                   "Key %s does not exists in database" key))
241         ;; clean entry from the secondary indices
242         (dolist (tr tracked)
243           ;; is this tracked symbol indexed?
244           (when (registry-lookup-secondary db tr)
245             ;; for every value in the entry under that key...
246             (dolist (val (cdr-safe (assq tr entry)))
247               (let* ((value-keys (registry-lookup-secondary-value db tr val)))
248               (when (member key value-keys)
249                 ;; override the previous value
250                 (registry-lookup-secondary-value
251                  db tr val
252                  ;; with the indexed keys MINUS the current key
253                  ;; (we pass t when the list is empty)
254                  (or (delete key value-keys) t)))))))
255         (remhash key data)))
256     keys))
257
258 (defmethod registry-insert ((db registry-db) key entry)
259   "Insert ENTRY under KEY into the registry-db THIS.
260 Updates the secondary ('tracked') indices as well.
261 Errors out if the key exists already."
262
263   (assert (not (gethash key (oref db :data))) nil
264           "Key already exists in database")
265
266   (assert (< (registry-size db)
267              (oref db :max-hard))
268           nil
269           "max-hard size limit reached")
270
271   ;; store the entry
272   (puthash key entry (oref db :data))
273
274   ;; store the secondary indices
275   (dolist (tr (oref db :tracked))
276     ;; for every value in the entry under that key...
277     (dolist (val (cdr-safe (assq tr entry)))
278       (let* ((value-keys (registry-lookup-secondary-value db tr val)))
279         (pushnew key value-keys :test 'equal)
280         (registry-lookup-secondary-value db tr val value-keys))))
281   entry)
282
283 (defmethod registry-size ((db registry-db))
284   "Returns the size of the registry-db object THIS.
285 This is the key count of the :data slot."
286   (hash-table-count (oref db :data)))
287
288 (defmethod registry-prune ((db registry-db))
289   "Prunes the registry-db object THIS.
290 Removes only entries without the :precious keys."
291   (let* ((precious (oref db :precious))
292          (precious-p (lambda (entry-key) (cdr (memq (car entry-key) precious))))
293          (data (oref db :data))
294          (limit (oref db :max-soft))
295          (size (registry-size db))
296          (candidates (loop for k being the hash-keys of data
297                            using (hash-values v)
298                            when (notany precious-p v)
299                            collect k))
300          (candidates-count (length candidates))
301          ;; are we over max-soft?
302          (prune-needed (> size limit)))
303
304     ;; while we have more candidates than we need to remove...
305     (while (and (> candidates-count (- size limit)) candidates)
306       (decf candidates-count)
307       (setq candidates (cdr candidates)))
308
309     (registry-delete db candidates nil)))
310
311 (ert-deftest registry-instantiation-test ()
312   (should (registry-db "Testing")))
313
314 (ert-deftest registry-match-test ()
315   (let ((entry '((hello "goodbye" "bye") (blank))))
316
317     (message "Testing :regex matching")
318     (should (registry--match :regex entry '((hello "nye" "bye"))))
319     (should (registry--match :regex entry '((hello "good"))))
320     (should-not (registry--match :regex entry '((hello "nye"))))
321     (should-not (registry--match :regex entry '((hello))))
322
323     (message "Testing :member matching")
324     (should (registry--match :member entry '((hello "bye"))))
325     (should (registry--match :member entry '((hello "goodbye"))))
326     (should-not (registry--match :member entry '((hello "good"))))
327     (should-not (registry--match :member entry '((hello "nye"))))
328     (should-not (registry--match :member entry '((hello)))))
329   (message "Done with matching testing."))
330
331 (defun registry-make-testable-db (n &optional name file)
332   (let* ((db (registry-db
333               (or name "Testing")
334               :file (or file "unused")
335               :max-hard n
336               :max-soft 0               ; keep nothing not precious
337               :precious '(extra more-extra)
338               :tracked '(sender subject groups))))
339     (dotimes (i n)
340       (registry-insert db i `((sender "me")
341                               (subject "about you")
342                               (more-extra) ; empty data key should be pruned
343                               ;; first 5 entries will NOT have this extra data
344                               ,@(when (< 5 i) (list (list 'extra "more data")))
345                               (groups ,(number-to-string i)))))
346     db))
347
348 (ert-deftest registry-usage-test ()
349   (let* ((n 100)
350          (db (registry-make-testable-db n)))
351     (message "size %d" n)
352     (should (= n (registry-size db)))
353     (message "max-hard test")
354     (should-error (registry-insert db "new" '()))
355     (message "Individual lookup")
356     (should (= 58 (caadr (registry-lookup db '(1 58 99)))))
357     (message "Grouped individual lookup")
358     (should (= 3 (length (registry-lookup db '(1 58 99)))))
359     (message "Individual lookup (breaks before lexbind)")
360     (should (= 58
361                (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99)))))
362     (message "Grouped individual lookup (breaks before lexbind)")
363     (should (= 3
364                (length (registry-lookup-breaks-before-lexbind db '(1 58 99)))))
365     (message "Search")
366     (should (= n (length (registry-search db :all t))))
367     (should (= n (length (registry-search db :member '((sender "me"))))))
368     (message "Secondary index search")
369     (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
370     (should (equal '(74) (registry-lookup-secondary-value db 'groups "74")))
371     (message "Delete")
372     (should (registry-delete db '(1) t))
373     (decf n)
374     (message "Search after delete")
375     (should (= n (length (registry-search db :all t))))
376     (message "Secondary search after delete")
377     (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
378     (message "Pruning")
379     (let* ((tokeep (registry-search db :member '((extra "more data"))))
380            (count (- n (length tokeep)))
381            (pruned (registry-prune db))
382            (prune-count (length pruned)))
383       (message "Expecting to prune %d entries and pruned %d"
384                count prune-count)
385       (should (and (= count 5)
386                    (= count prune-count))))
387     (message "Done with usage testing.")))
388
389 (ert-deftest registry-persistence-test ()
390   (let* ((n 100)
391          (tempfile (make-temp-file "registry-persistence-"))
392          (name "persistence tester")
393          (db (registry-make-testable-db n name tempfile))
394          size back)
395     (message "Saving to %s" tempfile)
396     (eieio-persistent-save db)
397     (setq size (nth 7 (file-attributes tempfile)))
398     (message "Saved to %s: size %d" tempfile size)
399     (should (< 0 size))
400     (with-temp-buffer
401       (insert-file-contents-literally tempfile)
402       (should (looking-at (concat ";; Object "
403                                   name
404                                   "\n;; EIEIO PERSISTENT OBJECT"))))
405     (message "Reading object back")
406     (setq back (eieio-persistent-read tempfile))
407     (should back)
408     (message "Read object back: %d keys, expected %d==%d"
409              (registry-size back) n (registry-size db))
410     (should (= (registry-size back) n))
411     (should (= (registry-size back) (registry-size db)))
412     (delete-file tempfile))
413   (message "Done with persistence testing."))
414
415 (provide 'registry)
416 ;;; registry.el ends here