cgit.sxemacs.org Git - gnus/blob - 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, 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 (require 'cl))
  81
  82 (eval-and-compile
  83   (or (ignore-errors (progn
  84                        (require 'eieio)
  85                        (require 'eieio-base)))
  86       ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
  87       (ignore-errors
  88         (let ((load-path (cons (expand-file-name
  89                                 "gnus-fallback-lib/eieio"
  90                                 (file-name-directory (locate-library "gnus")))
  91                                load-path)))
  92           (require 'eieio)
  93           (require 'eieio-base)))
  94       (error
  95        "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
  96
  97 (defclass registry-db (eieio-persistent)
  98   ((version :initarg :version
  99             :initform 0.1
 100             :type float
 101             :custom float
 102             :documentation "The registry version.")
 103    (max-hard :initarg :max-hard
 104              :initform 5000000
 105              :type integer
 106              :custom integer
 107              :documentation "Never accept more than this many elements.")
 108    (max-soft :initarg :max-soft
 109              :initform 50000
 110              :type integer
 111              :custom integer
 112              :documentation "Prune as much as possible to get to this size.")
 113    (prune-factor
 114     :initarg :prune-factor
 115     :initform 0.1
 116     :type float
 117     :custom float
 118     :documentation "At the max-hard limit, prune size * this entries.")
 119    (tracked :initarg :tracked
 120             :initform nil
 121             :type t
 122             :documentation "The tracked (indexed) fields, a list of symbols.")
 123    (precious :initarg :precious
 124              :initform nil
 125              :type t
 126              :documentation "The precious fields, a list of symbols.")
 127    (tracker :initarg :tracker
 128             :type hash-table
 129             :documentation "The field tracking hashtable.")
 130    (data :initarg :data
 131          :type hash-table
 132          :documentation "The data hashtable.")))
 133
 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)
 138       (setq data
 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)))))
 142
 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)))
 147     (delq nil
 148           (mapcar
 149            (lambda (k)
 150              (when (gethash k data)
 151                (list k (gethash k data))))
 152            keys))))
 153
 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)))
 158     (delq nil
 159           (loop for key in keys
 160                 when (gethash key data)
 161                 collect (list key (gethash key data))))))
 162
 163 (defmethod registry-lookup-secondary ((db registry-db) tracksym
 164                                       &optional create)
 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))))
 168     (if h
 169         h
 170       (when create
 171         (puthash tracksym
 172                  (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
 173                  (oref db :tracker))
 174         (gethash tracksym (oref db :tracker))))))
 175
 176 (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
 177                                             &optional set)
 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,
 183     (when set
 184       (puthash val (if (eq t set) '() set)
 185                (registry-lookup-secondary db tracksym t)))
 186     (gethash val (registry-lookup-secondary db tracksym))))
 187
 188 (defun registry--match (mode entry check-list)
 189   ;; for all members
 190   (when check-list
 191     (let ((key (nth 0 (nth 0 check-list)))
 192           (vals (cdr-safe (nth 0 check-list)))
 193           found)
 194       (while (and key vals (not found))
 195         (setq found (case mode
 196                       (:member
 197                        (member (car-safe vals) (cdr-safe (assoc key entry))))
 198                       (:regex
 199                        (string-match (car vals)
 200                                      (mapconcat
 201                                       'prin1-to-string
 202                                       (cdr-safe (assoc key entry))
 203                                       "\0"))))
 204               vals (cdr-safe vals)))
 205       (or found
 206           (registry--match mode entry (cdr-safe check-list))))))
 207
 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."
 214   (when db
 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)
 220             when (or
 221                   ;; :all non-nil returns all
 222                   all
 223                   ;; member matching
 224                   (and member (registry--match :member v member))
 225                   ;; regex matching
 226                   (and regex (registry--match :regex v regex)))
 227             collect k))))
 228
 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))
 235          (keys (or keys
 236                    (apply 'registry-search db spec)))
 237          (tracked (oref db :tracked)))
 238
 239     (dolist (key keys)
 240       (let ((entry (gethash key data)))
 241         (when assert
 242           (assert entry nil
 243                   "Key %s does not exist in database" key))
 244         ;; clean entry from the secondary indices
 245         (dolist (tr tracked)
 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
 251                                   db tr val)))
 252                 (when (member key value-keys)
 253                   ;; override the previous value
 254                   (registry-lookup-secondary-value
 255                    db tr val
 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)))))))
 259         (remhash key data)))
 260     keys))
 261
 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)))
 266
 267 (defmethod registry-full ((db registry-db))
 268   "Checks if registry-db THIS is full."
 269   (>= (registry-size db)
 270       (oref db :max-hard)))
 271
 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."
 276
 277   (assert (not (gethash key (oref db :data))) nil
 278           "Key already exists in database")
 279
 280   (assert (not (registry-full db))
 281           nil
 282           "registry max-hard size limit reached")
 283
 284   ;; store the entry
 285   (puthash key entry (oref db :data))
 286
 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))))
 294   entry)
 295
 296 (defmethod registry-reindex ((db registry-db))
 297   "Rebuild the secondary indices of registry-db THIS."
 298   (let ((count 0)
 299         (expected (* (length (oref db :tracked)) (registry-size db))))
 300     (dolist (tr (oref db :tracked))
 301       (let (values)
 302         (maphash
 303          (lambda (key v)
 304            (incf count)
 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))))
 313          (oref db :data))))))
 314
 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)))
 333
 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)))
 338
 339       (registry-delete db candidates nil)
 340       (length candidates))))
 341
 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)
 353                            collect k)))
 354     (list limit candidates)))
 355
 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
 365                            collect k)))
 366     (list limit candidates)))
 367
 368 (provide 'registry)
 369 ;;; registry.el ends here