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  Teodor Zlatanov
   4
   5 ;; Author: Teodor Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: data
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; This library provides a general-purpose EIEIO-based registry
  24 ;; database with persistence, initialized with these fields:
  25
  26 ;; version: a float, 0.1 currently (don't change it)
  27
  28 ;; max-hard: an integer, default 5000000
  29
  30 ;; max-soft: an integer, default 50000
  31
  32 ;; precious: a list of symbols
  33
  34 ;; tracked: a list of symbols
  35
  36 ;; tracker: a hashtable tuned for 100 symbols to track (you should
  37 ;; only access this with the :lookup2-function and the
  38 ;; :lookup2+-function)
  39
  40 ;; data: a hashtable with default size 10K and resize threshold 2.0
  41 ;; (this reflects the expected usage so override it if you know better)
  42
  43 ;; ...plus methods to do all the work: `registry-search',
  44 ;; `registry-lookup', `registry-lookup-secondary',
  45 ;; `registry-lookup-secondary-value', `registry-insert',
  46 ;; `registry-delete', `registry-prune', `registry-size' which see
  47
  48 ;; and with the following properties:
  49
  50 ;; Every piece of data has a unique ID and some general-purpose fields
  51 ;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g.
  52
  53 ;; ((F1 D1) (F2 D2) (F3 a b c))
  54
  55 ;; Note that whether a field has one or many pieces of data, the data
  56 ;; is always a list of values.
  57
  58 ;; The user decides which fields are "precious", F2 for example.  At
  59 ;; PRUNE TIME (when the :prune-function is called), the registry will
  60 ;; trim any entries without the F2 field until the size is :max-soft
  61 ;; or less.  No entries with the F2 field will be removed at PRUNE
  62 ;; TIME.
  63
  64 ;; When an entry is inserted, the registry will reject new entries
  65 ;; if they bring it over the max-hard limit, even if they have the F2
  66 ;; field.
  67
  68 ;; The user decides which fields are "tracked", F1 for example.  Any
  69 ;; new entry is then indexed by all the tracked fields so it can be
  70 ;; quickly looked up that way.  The data is always a list (see example
  71 ;; above) and each list element is indexed.
  72
  73 ;; Precious and tracked field names must be symbols.  All other
  74 ;; fields can be any other Emacs Lisp types.
  75
  76 ;;; Code:
  77
  78 (eval-when-compile (require 'ert))
  79 (eval-when-compile (require 'cl))
  80 (eval-and-compile
  81   (or (ignore-errors (progn
  82                        (require 'eieio)
  83                        (require 'eieio-base)))
  84       ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
  85       (ignore-errors
  86         (let ((load-path (cons (expand-file-name
  87                                 "gnus-fallback-lib/eieio"
  88                                 (file-name-directory (locate-library "gnus")))
  89                                load-path)))
  90           (require 'eieio)
  91           (require 'eieio-base)))
  92       (error
  93        "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
  94
  95 (defclass registry-db (eieio-persistent)
  96   ((version :initarg :version
  97             :initform 0.1
  98             :type float
  99             :custom float
 100             :documentation "The registry version.")
 101    (max-hard :initarg :max-hard
 102              :type integer
 103              :custom integer
 104              :documentation "Never accept more than this many elements.")
 105    (max-soft :initarg :max-soft
 106              :type integer
 107              :custom integer
 108              :documentation "Prune as much as possible to get to this size.")
 109    (tracked :initarg :tracked
 110             :type t
 111             :documentation "The tracked (indexed) fields, a list of symbols.")
 112    (precious :initarg :precious
 113              :type t
 114              :documentation "The precious fields, a list of symbols.")
 115    (tracker :initarg :tracker
 116             :type hash-table
 117             :documentation "The field tracking hashtable.")
 118    (data :initarg :data
 119          :type hash-table
 120          :documentation "The data hashtable.")))
 121
 122 (defmethod initialize-instance :after ((this registry-db) slots)
 123   "Set value of data slot of THIS after initialization."
 124   ;; 'data' will already be set if read from file, so don't overwrite it.
 125   (with-slots (data tracker tracked precious max-soft max-hard) this
 126     (unless (member :data slots)
 127       (setq data (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
 128     (unless (member :tracker slots)
 129       (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))
 130     (unless (member :max-soft slots)
 131       (setq max-soft 50000))
 132     (unless (member :max-hard slots)
 133       (setq max-hard 5000000))
 134     (unless (member :tracked slots)
 135       (setq tracked nil))
 136     (unless (member :precious slots)
 137       (setq precious nil))))
 138
 139 (defmethod registry-lookup ((db registry-db) keys)
 140   "Search for KEYS in the registry-db THIS.
 141 Returns a alist of the key followed by the entry in a list, not a cons cell."
 142   (let ((data (oref db :data)))
 143     (delq nil
 144           (mapcar
 145            (lambda (k)
 146              (when (gethash k data)
 147                (list k (gethash k data))))
 148            keys))))
 149
 150 (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
 151   "Search for KEYS in the registry-db THIS.
 152 Returns a alist of the key followed by the entry in a list, not a cons cell."
 153   (let ((data (oref db :data)))
 154     (delq nil
 155           (loop for key in keys
 156                 when (gethash key data)
 157                 collect (list key (gethash key data))))))
 158
 159 (defmethod registry-lookup-secondary ((db registry-db) tracksym
 160                                       &optional create)
 161   "Search for TRACKSYM in the registry-db THIS.
 162 When CREATE is not nil, create the secondary index hashtable if needed."
 163   (let ((h (gethash tracksym (oref db :tracker))))
 164     (if h
 165         h
 166       (when create
 167         (puthash tracksym
 168                  (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
 169                  (oref db :tracker))
 170         (gethash tracksym (oref db :tracker))))))
 171
 172 (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
 173                                             &optional set)
 174   "Search for TRACKSYM with value VAL in the registry-db THIS.
 175 When SET is not nil, set it for VAL (use t for an empty list)."
 176   ;; either we're asked for creation or there should be an existing index
 177   (when (or set (registry-lookup-secondary db tracksym))
 178     ;; set the entry if requested,
 179     (when set
 180       (puthash val (if (eq t set) '() set)
 181                (registry-lookup-secondary db tracksym t)))
 182     (gethash val (registry-lookup-secondary db tracksym))))
 183
 184 (defun registry--match (mode entry check-list)
 185   ;; for all members
 186   (when check-list
 187     (let ((key (nth 0 (nth 0 check-list)))
 188           (vals (cdr-safe (nth 0 check-list)))
 189           found)
 190       (while (and key vals (not found))
 191         (setq found (case mode
 192                       (:member
 193                        (member (car-safe vals) (cdr-safe (assoc key entry))))
 194                       (:regex
 195                        (string-match (car vals)
 196                                      (mapconcat
 197                                       'prin1-to-string
 198                                       (cdr-safe (assoc key entry))
 199                                       "\0"))))
 200               vals (cdr-safe vals)))
 201       (or found
 202           (registry--match mode entry (cdr-safe check-list))))))
 203
 204 (defmethod registry-search ((db registry-db) &rest spec)
 205   "Search for SPEC across the registry-db THIS.
 206 For example calling with :member '(a 1 2) will match entry '((a 3 1)).
 207 Calling with :all t (any non-nil value) will match all.
 208 Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\").
 209 The test order is to check :all first, then :member, then :regex."
 210   (when db
 211     (let ((all (plist-get spec :all))
 212           (member (plist-get spec :member))
 213           (regex (plist-get spec :regex)))
 214       (loop for k being the hash-keys of (oref db :data) using (hash-values v)
 215             when (or
 216                   ;; :all non-nil returns all
 217                   all
 218                   ;; member matching
 219                   (and member (registry--match :member v member))
 220                   ;; regex matching
 221                   (and regex (registry--match :regex v regex)))
 222             collect k))))
 223
 224 (defmethod registry-delete ((db registry-db) keys assert &rest spec)
 225   "Delete KEYS from the registry-db THIS.
 226 If KEYS is nil, use SPEC to do a search.
 227 Updates the secondary ('tracked') indices as well.
 228 With assert non-nil, errors out if the key does not exist already."
 229   (let* ((data (oref db :data))
 230          (keys (or keys
 231                    (apply 'registry-search db spec)))
 232          (tracked (oref db :tracked)))
 233
 234     (dolist (key keys)
 235       (let ((entry (gethash key data)))
 236         (when assert
 237           (assert entry nil
 238                   "Key %s does not exists in database" key))
 239         ;; clean entry from the secondary indices
 240         (dolist (tr tracked)
 241           ;; is this tracked symbol indexed?
 242           (when (registry-lookup-secondary db tr)
 243             ;; for every value in the entry under that key...
 244             (dolist (val (cdr-safe (assq tr entry)))
 245               (let* ((value-keys (registry-lookup-secondary-value db tr val)))
 246               (when (member key value-keys)
 247                 ;; override the previous value
 248                 (registry-lookup-secondary-value
 249                  db tr val
 250                  ;; with the indexed keys MINUS the current key
 251                  ;; (we pass t when the list is empty)
 252                  (or (delete key value-keys) t)))))))
 253         (remhash key data)))
 254     keys))
 255
 256 (defmethod registry-insert ((db registry-db) key entry)
 257   "Insert ENTRY under KEY into the registry-db THIS.
 258 Updates the secondary ('tracked') indices as well.
 259 Errors out if the key exists already."
 260
 261   (assert (not (gethash key (oref db :data))) nil
 262           "Key already exists in database")
 263
 264   (assert (< (registry-size db)
 265              (oref db :max-hard))
 266           nil
 267           "max-hard size limit reached")
 268
 269   ;; store the entry
 270   (puthash key entry (oref db :data))
 271
 272   ;; store the secondary indices
 273   (dolist (tr (oref db :tracked))
 274     ;; for every value in the entry under that key...
 275     (dolist (val (cdr-safe (assq tr entry)))
 276       (let* ((value-keys (registry-lookup-secondary-value db tr val)))
 277         (pushnew key value-keys :test 'equal)
 278         (registry-lookup-secondary-value db tr val value-keys))))
 279   entry)
 280
 281 (defmethod registry-size ((db registry-db))
 282   "Returns the size of the registry-db object THIS.
 283 This is the key count of the :data slot."
 284   (hash-table-count (oref db :data)))
 285
 286 (defmethod registry-prune ((db registry-db))
 287   "Prunes the registry-db object THIS.
 288 Removes only entries without the :precious keys."
 289   (let* ((precious (oref db :precious))
 290          (precious-p (lambda (entry-key) (cdr (memq (car entry-key) precious))))
 291          (data (oref db :data))
 292          (limit (oref db :max-soft))
 293          (size (registry-size db))
 294          (candidates (loop for k being the hash-keys of data
 295                            using (hash-values v)
 296                            when (notany precious-p v)
 297                            collect k))
 298          (candidates-count (length candidates))
 299          ;; are we over max-soft?
 300          (prune-needed (> size limit)))
 301
 302     ;; while we have more candidates than we need to remove...
 303     (while (and (> candidates-count (- size limit)) candidates)
 304       (decf candidates-count)
 305       (setq candidates (cdr candidates)))
 306
 307     (registry-delete db candidates nil)))
 308
 309 (ert-deftest registry-instantiation-test ()
 310   (should (registry-db "Testing")))
 311
 312 (ert-deftest registry-match-test ()
 313   (let ((entry '((hello "goodbye" "bye") (blank))))
 314
 315     (message "Testing :regex matching")
 316     (should (registry--match :regex entry '((hello "nye" "bye"))))
 317     (should (registry--match :regex entry '((hello "good"))))
 318     (should-not (registry--match :regex entry '((hello "nye"))))
 319     (should-not (registry--match :regex entry '((hello))))
 320
 321     (message "Testing :member matching")
 322     (should (registry--match :member entry '((hello "bye"))))
 323     (should (registry--match :member entry '((hello "goodbye"))))
 324     (should-not (registry--match :member entry '((hello "good"))))
 325     (should-not (registry--match :member entry '((hello "nye"))))
 326     (should-not (registry--match :member entry '((hello)))))
 327   (message "Done with matching testing."))
 328
 329 (defun registry-make-testable-db (n &optional name file)
 330   (let* ((db (registry-db
 331               (or name "Testing")
 332               :file (or file "unused")
 333               :max-hard n
 334               :max-soft 0               ; keep nothing not precious
 335               :precious '(extra more-extra)
 336               :tracked '(sender subject groups))))
 337     (dotimes (i n)
 338       (registry-insert db i `((sender "me")
 339                               (subject "about you")
 340                               (more-extra) ; empty data key should be pruned
 341                               ;; first 5 entries will NOT have this extra data
 342                               ,@(when (< 5 i) (list (list 'extra "more data")))
 343                               (groups ,(number-to-string i)))))
 344     db))
 345
 346 (ert-deftest registry-usage-test ()
 347   (let* ((n 100)
 348          (db (registry-make-testable-db n)))
 349     (message "size %d" n)
 350     (should (= n (registry-size db)))
 351     (message "max-hard test")
 352     (should-error (registry-insert db "new" '()))
 353     (message "Individual lookup")
 354     (should (= 58 (caadr (registry-lookup db '(1 58 99)))))
 355     (message "Grouped individual lookup")
 356     (should (= 3 (length (registry-lookup db '(1 58 99)))))
 357     (message "Individual lookup (breaks before lexbind)")
 358     (should (= 58
 359                (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99)))))
 360     (message "Grouped individual lookup (breaks before lexbind)")
 361     (should (= 3
 362                (length (registry-lookup-breaks-before-lexbind db '(1 58 99)))))
 363     (message "Search")
 364     (should (= n (length (registry-search db :all t))))
 365     (should (= n (length (registry-search db :member '((sender "me"))))))
 366     (message "Secondary index search")
 367     (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
 368     (should (equal '(74) (registry-lookup-secondary-value db 'groups "74")))
 369     (message "Delete")
 370     (should (registry-delete db '(1) t))
 371     (decf n)
 372     (message "Search after delete")
 373     (should (= n (length (registry-search db :all t))))
 374     (message "Secondary search after delete")
 375     (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
 376     (message "Pruning")
 377     (let* ((tokeep (registry-search db :member '((extra "more data"))))
 378            (count (- n (length tokeep)))
 379            (pruned (registry-prune db))
 380            (prune-count (length pruned)))
 381       (message "Expecting to prune %d entries and pruned %d"
 382                count prune-count)
 383       (should (and (= count 5)
 384                    (= count prune-count))))
 385     (message "Done with usage testing.")))
 386
 387 (ert-deftest registry-persistence-test ()
 388   (let* ((n 100)
 389          (tempfile (make-temp-file "registry-persistence-"))
 390          (name "persistence tester")
 391          (db (registry-make-testable-db n name tempfile))
 392          size back)
 393     (message "Saving to %s" tempfile)
 394     (eieio-persistent-save db)
 395     (setq size (nth 7 (file-attributes tempfile)))
 396     (message "Saved to %s: size %d" tempfile size)
 397     (should (< 0 size))
 398     (with-temp-buffer
 399       (insert-file-contents-literally tempfile)
 400       (should (looking-at (concat ";; Object "
 401                                   name
 402                                   "\n;; EIEIO PERSISTENT OBJECT"))))
 403     (message "Reading object back")
 404     (setq back (eieio-persistent-read tempfile))
 405     (should back)
 406     (message "Read object back: %d keys, expected %d==%d"
 407              (registry-size back) n (registry-size db))
 408     (should (= (registry-size back) n))
 409     (should (= (registry-size back) (registry-size db)))
 410     (delete-file tempfile))
 411   (message "Done with persistence testing."))
 412
 413 (provide 'registry)
 414 ;;; registry.el ends here