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