X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fregistry.el;h=ef076a52580f412f34f872f105ee4dfdb75963bc;hp=5fd309a5c7d2a47380e4fe586ea1bd32606bb1f0;hb=0c38751cb18d51ed294dabcfb16ed21a610e2daa;hpb=63812fc80f280d4e1133f8b934fc17320e88fff2 diff --git a/lisp/registry.el b/lisp/registry.el index 5fd309a5c..ef076a525 100644 --- a/lisp/registry.el +++ b/lisp/registry.el @@ -1,6 +1,6 @@ ;;; registry.el --- Track and remember data items by various fields -;; Copyright (C) 2011 Free Software Foundation, Inc. +;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ;; Author: Teodor Zlatanov ;; Keywords: data @@ -25,11 +25,11 @@ ;; This library provides a general-purpose EIEIO-based registry ;; database with persistence, initialized with these fields: -;; version: a float, 0.1 currently (don't change it) +;; version: a float -;; max-hard: an integer, default 5000000 +;; max-size: an integer, default most-positive-fixnum -;; max-soft: an integer, default 50000 +;; prune-factor: a float between 0 and 1, default 0.1 ;; precious: a list of symbols @@ -57,14 +57,15 @@ ;; Note that whether a field has one or many pieces of data, the data ;; is always a list of values. -;; The user decides which fields are "precious", F2 for example. At -;; PRUNE TIME (when the :prune-function is called), the registry will -;; trim any entries without the F2 field until the size is :max-soft -;; or less. No entries with the F2 field will be removed at PRUNE -;; TIME. +;; The user decides which fields are "precious", F2 for example. When +;; the registry is pruned, any entries without the F2 field will be +;; removed until the size is :max-size * :prune-factor _less_ than the +;; maximum database size. No entries with the F2 field will be removed +;; at PRUNE TIME, which means it may not be possible to prune back all +;; the way to the target size. -;; When an entry is inserted, the registry will reject new entries -;; if they bring it over the max-hard limit, even if they have the F2 +;; When an entry is inserted, the registry will reject new entries if +;; they bring it over the :max-size limit, even if they have the F2 ;; field. ;; The user decides which fields are "tracked", F1 for example. Any @@ -79,12 +80,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (when (null (ignore-errors (require 'ert))) - (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) - -(ignore-errors - (require 'ert)) (eval-and-compile (or (ignore-errors (progn (require 'eieio) @@ -100,28 +95,44 @@ (error "eieio not found in `load-path' or gnus-fallback-lib/ directory."))) +(eval-when-compile + (unless (fboundp 'cl-remf) + (defalias 'cl-remf 'remf) + (defalias 'cl-loop 'loop) + (defalias 'cl-subseq 'subseq))) + +;; The version number needs to be kept outside of the class definition +;; itself. The persistent-save process does *not* write to file any +;; slot values that are equal to the default :initform value. If a +;; database object is at the most recent version, therefore, its +;; version number will not be written to file. That makes it +;; difficult to know when a database needs to be upgraded. +(defvar registry-db-version 0.2 + "The current version of the registry format.") + +(eval (backquote (defclass registry-db (eieio-persistent) ((version :initarg :version - :initform 0.1 - :type float - :custom float + :initform nil + :type (or null float) :documentation "The registry version.") - (max-hard :initarg :max-hard - :initform 5000000 + (max-size :initarg :max-size + ;; EIEIO's :initform is not 100% compatible with CLOS in + ;; that if the form is an atom, it assumes it's constant + ;; value rather than an expression, so in order to get the value + ;; of `most-positive-fixnum', we need to use an + ;; expression that's not just a symbol. + :initform ,(symbol-value 'most-positive-fixnum) :type integer :custom integer - :documentation "Never accept more than this many elements.") - (max-soft :initarg :max-soft - :initform 50000 - :type integer - :custom integer - :documentation "Prune as much as possible to get to this size.") + :documentation "The maximum number of registry entries.") (prune-factor :initarg :prune-factor :initform 0.1 :type float :custom float - :documentation "At the max-hard limit, prune size * this entries.") + :documentation "Prune to \(:max-size * :prune-factor\) less + than the :max-size limit. Should be a float between 0 and 1.") (tracked :initarg :tracked :initform nil :type t @@ -136,61 +147,78 @@ (data :initarg :data :type hash-table :documentation "The data hashtable."))) - -(eval-and-compile - (defmethod initialize-instance :AFTER ((this registry-db) slots) - "Set value of data slot of THIS after initialization." - (with-slots (data tracker) this - (unless (member :data slots) - (setq data - (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal))) - (unless (member :tracker slots) - (setq tracker (make-hash-table :size 100 :rehash-size 2.0))))) - - (defmethod registry-lookup ((db registry-db) keys) - "Search for KEYS in the registry-db THIS. +)) + +(defmethod initialize-instance :BEFORE ((this registry-db) slots) + "Check whether a registry object needs to be upgraded." + ;; Hardcoded upgrade routines. Version 0.1 to 0.2 requires the + ;; :max-soft slot to disappear, and the :max-hard slot to be renamed + ;; :max-size. + (let ((current-version + (and (plist-member slots :version) + (plist-get slots :version)))) + (when (or (null current-version) + (eql current-version 0.1)) + (setq slots + (plist-put slots :max-size (plist-get slots :max-hard))) + (setq slots + (plist-put slots :version registry-db-version)) + (cl-remf slots :max-hard) + (cl-remf slots :max-soft)))) + +(defmethod initialize-instance :AFTER ((this registry-db) slots) + "Set value of data slot of THIS after initialization." + (with-slots (data tracker) this + (unless (member :data slots) + (setq data + (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal))) + (unless (member :tracker slots) + (setq tracker (make-hash-table :size 100 :rehash-size 2.0))))) + +(defmethod registry-lookup ((db registry-db) keys) + "Search for KEYS in the registry-db THIS. Returns an alist of the key followed by the entry in a list, not a cons cell." - (let ((data (oref db :data))) - (delq nil - (mapcar - (lambda (k) - (when (gethash k data) - (list k (gethash k data)))) - keys)))) - - (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys) - "Search for KEYS in the registry-db THIS. + (let ((data (oref db data))) + (delq nil + (mapcar + (lambda (k) + (when (gethash k data) + (list k (gethash k data)))) + keys)))) + +(defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys) + "Search for KEYS in the registry-db THIS. Returns an alist of the key followed by the entry in a list, not a cons cell." - (let ((data (oref db :data))) - (delq nil - (loop for key in keys - when (gethash key data) - collect (list key (gethash key data)))))) - - (defmethod registry-lookup-secondary ((db registry-db) tracksym - &optional create) - "Search for TRACKSYM in the registry-db THIS. + (let ((data (oref db data))) + (delq nil + (loop for key in keys + when (gethash key data) + collect (list key (gethash key data)))))) + +(defmethod registry-lookup-secondary ((db registry-db) tracksym + &optional create) + "Search for TRACKSYM in the registry-db THIS. When CREATE is not nil, create the secondary index hashtable if needed." - (let ((h (gethash tracksym (oref db :tracker)))) - (if h - h - (when create - (puthash tracksym - (make-hash-table :size 800 :rehash-size 2.0 :test 'equal) - (oref db :tracker)) - (gethash tracksym (oref db :tracker)))))) - - (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val - &optional set) - "Search for TRACKSYM with value VAL in the registry-db THIS. + (let ((h (gethash tracksym (oref db :tracker)))) + (if h + h + (when create + (puthash tracksym + (make-hash-table :size 800 :rehash-size 2.0 :test 'equal) + (oref db :tracker)) + (gethash tracksym (oref db :tracker)))))) + +(defmethod registry-lookup-secondary-value ((db registry-db) tracksym val + &optional set) + "Search for TRACKSYM with value VAL in the registry-db THIS. When SET is not nil, set it for VAL (use t for an empty list)." - ;; either we're asked for creation or there should be an existing index - (when (or set (registry-lookup-secondary db tracksym)) - ;; set the entry if requested, - (when set - (puthash val (if (eq t set) '() set) - (registry-lookup-secondary db tracksym t))) - (gethash val (registry-lookup-secondary db tracksym))))) + ;; either we're asked for creation or there should be an existing index + (when (or set (registry-lookup-secondary db tracksym)) + ;; set the entry if requested, + (when set + (puthash val (if (eq t set) '() set) + (registry-lookup-secondary db tracksym t))) + (gethash val (registry-lookup-secondary db tracksym)))) (defun registry--match (mode entry check-list) ;; for all members @@ -212,272 +240,158 @@ When SET is not nil, set it for VAL (use t for an empty list)." (or found (registry--match mode entry (cdr-safe check-list)))))) -(eval-and-compile - (defmethod registry-search ((db registry-db) &rest spec) - "Search for SPEC across the registry-db THIS. +(defmethod registry-search ((db registry-db) &rest spec) + "Search for SPEC across the registry-db THIS. For example calling with :member '(a 1 2) will match entry '((a 3 1)). Calling with :all t (any non-nil value) will match all. Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\"). The test order is to check :all first, then :member, then :regex." - (when db - (let ((all (plist-get spec :all)) - (member (plist-get spec :member)) - (regex (plist-get spec :regex))) - (loop for k being the hash-keys of (oref db :data) - using (hash-values v) - when (or - ;; :all non-nil returns all - all - ;; member matching - (and member (registry--match :member v member)) - ;; regex matching - (and regex (registry--match :regex v regex))) - collect k)))) - - (defmethod registry-delete ((db registry-db) keys assert &rest spec) - "Delete KEYS from the registry-db THIS. + (when db + (let ((all (plist-get spec :all)) + (member (plist-get spec :member)) + (regex (plist-get spec :regex))) + (loop for k being the hash-keys of (oref db data) + using (hash-values v) + when (or + ;; :all non-nil returns all + all + ;; member matching + (and member (registry--match :member v member)) + ;; regex matching + (and regex (registry--match :regex v regex))) + collect k)))) + +(defmethod registry-delete ((db registry-db) keys assert &rest spec) + "Delete KEYS from the registry-db THIS. If KEYS is nil, use SPEC to do a search. Updates the secondary ('tracked') indices as well. With assert non-nil, errors out if the key does not exist already." - (let* ((data (oref db :data)) - (keys (or keys - (apply 'registry-search db spec))) - (tracked (oref db :tracked))) - - (dolist (key keys) - (let ((entry (gethash key data))) - (when assert - (assert entry nil - "Key %s does not exists in database" key)) - ;; clean entry from the secondary indices - (dolist (tr tracked) - ;; is this tracked symbol indexed? - (when (registry-lookup-secondary db tr) - ;; for every value in the entry under that key... - (dolist (val (cdr-safe (assq tr entry))) - (let* ((value-keys (registry-lookup-secondary-value - db tr val))) - (when (member key value-keys) - ;; override the previous value - (registry-lookup-secondary-value - db tr val - ;; with the indexed keys MINUS the current key - ;; (we pass t when the list is empty) - (or (delete key value-keys) t))))))) - (remhash key data))) - keys)) - - (defmethod registry-full ((db registry-db)) - "Checks if registry-db THIS is full." - (>= (registry-size db) - (oref db :max-hard))) - - (defmethod registry-insert ((db registry-db) key entry) - "Insert ENTRY under KEY into the registry-db THIS. + (let* ((data (oref db data)) + (keys (or keys + (apply 'registry-search db spec))) + (tracked (oref db tracked))) + + (dolist (key keys) + (let ((entry (gethash key data))) + (when assert + (assert entry nil + "Key %s does not exist in database" key)) + ;; clean entry from the secondary indices + (dolist (tr tracked) + ;; is this tracked symbol indexed? + (when (registry-lookup-secondary db tr) + ;; for every value in the entry under that key... + (dolist (val (cdr-safe (assq tr entry))) + (let* ((value-keys (registry-lookup-secondary-value + db tr val))) + (when (member key value-keys) + ;; override the previous value + (registry-lookup-secondary-value + db tr val + ;; with the indexed keys MINUS the current key + ;; (we pass t when the list is empty) + (or (delete key value-keys) t))))))) + (remhash key data))) + keys)) + +(defmethod registry-size ((db registry-db)) + "Returns the size of the registry-db object THIS. +This is the key count of the `data' slot." + (hash-table-count (oref db data))) + +(defmethod registry-full ((db registry-db)) + "Checks if registry-db THIS is full." + (>= (registry-size db) + (oref db :max-size))) + +(defmethod registry-insert ((db registry-db) key entry) + "Insert ENTRY under KEY into the registry-db THIS. Updates the secondary ('tracked') indices as well. Errors out if the key exists already." - (assert (not (gethash key (oref db :data))) nil - "Key already exists in database") - - (assert (not (registry-full db)) - nil - "registry max-hard size limit reached") - - ;; store the entry - (puthash key entry (oref db :data)) - - ;; store the secondary indices - (dolist (tr (oref db :tracked)) - ;; for every value in the entry under that key... - (dolist (val (cdr-safe (assq tr entry))) - (let* ((value-keys (registry-lookup-secondary-value db tr val))) - (pushnew key value-keys :test 'equal) - (registry-lookup-secondary-value db tr val value-keys)))) - entry) - - (defmethod registry-reindex ((db registry-db)) - "Rebuild the secondary indices of registry-db THIS." - (let ((count 0) - (expected (* (length (oref db :tracked)) (registry-size db)))) - (dolist (tr (oref db :tracked)) - (let (values) - (maphash - (lambda (key v) - (incf count) - (when (and (< 0 expected) - (= 0 (mod count 1000))) - (message "reindexing: %d of %d (%.2f%%)" - count expected (/ (* 100 count) expected))) - (dolist (val (cdr-safe (assq tr v))) - (let* ((value-keys (registry-lookup-secondary-value db tr val))) - (push key value-keys) - (registry-lookup-secondary-value db tr val value-keys)))) - (oref db :data)))))) - - (defmethod registry-size ((db registry-db)) - "Returns the size of the registry-db object THIS. -This is the key count of the :data slot." - (hash-table-count (oref db :data))) - - (defmethod registry-prune ((db registry-db) &optional sortfun) - "Prunes the registry-db object THIS. -Removes only entries without the :precious keys if it can, -then removes oldest entries first. -Returns the number of deleted entries. -If SORTFUN is given, tries to keep entries that sort *higher*. -SORTFUN is passed only the two keys so it must look them up directly." - (dolist (collector '(registry-prune-soft-candidates - registry-prune-hard-candidates)) - (let* ((size (registry-size db)) - (collected (funcall collector db)) - (limit (nth 0 collected)) - (candidates (nth 1 collected)) - ;; sort the candidates if SORTFUN was given - (candidates (if sortfun (sort candidates sortfun) candidates)) - (candidates-count (length candidates)) - ;; are we over max-soft? - (prune-needed (> size limit))) - - ;; while we have more candidates than we need to remove... - (while (and (> candidates-count (- size limit)) candidates) - (decf candidates-count) - (setq candidates (cdr candidates))) - - (registry-delete db candidates nil) - (length candidates)))) - - (defmethod registry-prune-soft-candidates ((db registry-db)) - "Collects pruning candidates from the registry-db object THIS. -Proposes only entries without the :precious keys." - (let* ((precious (oref db :precious)) - (precious-p (lambda (entry-key) - (cdr (memq (car entry-key) precious)))) - (data (oref db :data)) - (limit (oref db :max-soft)) - (candidates (loop for k being the hash-keys of data - using (hash-values v) - when (notany precious-p v) - collect k))) - (list limit candidates))) - - (defmethod registry-prune-hard-candidates ((db registry-db)) - "Collects pruning candidates from the registry-db object THIS. -Proposes any entries over the max-hard limit minus size * prune-factor." - (let* ((data (oref db :data)) - ;; prune to (size * prune-factor) below the max-hard limit so - ;; we're not pruning all the time - (limit (max 0 (- (oref db :max-hard) - (* (registry-size db) (oref db :prune-factor))))) - (candidates (loop for k being the hash-keys of data - collect k))) - (list limit candidates)))) - -(ert-deftest registry-instantiation-test () - (should (registry-db "Testing"))) - -(ert-deftest registry-match-test () - (let ((entry '((hello "goodbye" "bye") (blank)))) - - (message "Testing :regex matching") - (should (registry--match :regex entry '((hello "nye" "bye")))) - (should (registry--match :regex entry '((hello "good")))) - (should-not (registry--match :regex entry '((hello "nye")))) - (should-not (registry--match :regex entry '((hello)))) - - (message "Testing :member matching") - (should (registry--match :member entry '((hello "bye")))) - (should (registry--match :member entry '((hello "goodbye")))) - (should-not (registry--match :member entry '((hello "good")))) - (should-not (registry--match :member entry '((hello "nye")))) - (should-not (registry--match :member entry '((hello))))) - (message "Done with matching testing.")) - -(defun registry-make-testable-db (n &optional name file) - (let* ((db (registry-db - (or name "Testing") - :file (or file "unused") - :max-hard n - :max-soft 0 ; keep nothing not precious - :precious '(extra more-extra) - :tracked '(sender subject groups)))) - (dotimes (i n) - (registry-insert db i `((sender "me") - (subject "about you") - (more-extra) ; empty data key should be pruned - ;; first 5 entries will NOT have this extra data - ,@(when (< 5 i) (list (list 'extra "more data"))) - (groups ,(number-to-string i))))) - db)) - -(ert-deftest registry-usage-test () - (let* ((n 100) - (db (registry-make-testable-db n))) - (message "size %d" n) - (should (= n (registry-size db))) - (message "max-hard test") - (should-error (registry-insert db "new" '())) - (message "Individual lookup") - (should (= 58 (caadr (registry-lookup db '(1 58 99))))) - (message "Grouped individual lookup") - (should (= 3 (length (registry-lookup db '(1 58 99))))) - (when (boundp 'lexical-binding) - (message "Individual lookup (breaks before lexbind)") - (should (= 58 - (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99))))) - (message "Grouped individual lookup (breaks before lexbind)") - (should (= 3 - (length (registry-lookup-breaks-before-lexbind db - '(1 58 99)))))) - (message "Search") - (should (= n (length (registry-search db :all t)))) - (should (= n (length (registry-search db :member '((sender "me")))))) - (message "Secondary index search") - (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) - (should (equal '(74) (registry-lookup-secondary-value db 'groups "74"))) - (message "Delete") - (should (registry-delete db '(1) t)) - (decf n) - (message "Search after delete") - (should (= n (length (registry-search db :all t)))) - (message "Secondary search after delete") - (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) - ;; (message "Pruning") - ;; (let* ((tokeep (registry-search db :member '((extra "more data")))) - ;; (count (- n (length tokeep))) - ;; (pruned (registry-prune db)) - ;; (prune-count (length pruned))) - ;; (message "Expecting to prune %d entries and pruned %d" - ;; count prune-count) - ;; (should (and (= count 5) - ;; (= count prune-count)))) - (message "Done with usage testing."))) - -(ert-deftest registry-persistence-test () - (let* ((n 100) - (tempfile (make-temp-file "registry-persistence-")) - (name "persistence tester") - (db (registry-make-testable-db n name tempfile)) - size back) - (message "Saving to %s" tempfile) - (eieio-persistent-save db) - (setq size (nth 7 (file-attributes tempfile))) - (message "Saved to %s: size %d" tempfile size) - (should (< 0 size)) - (with-temp-buffer - (insert-file-contents-literally tempfile) - (should (looking-at (concat ";; Object " - name - "\n;; EIEIO PERSISTENT OBJECT")))) - (message "Reading object back") - (setq back (eieio-persistent-read tempfile)) - (should back) - (message "Read object back: %d keys, expected %d==%d" - (registry-size back) n (registry-size db)) - (should (= (registry-size back) n)) - (should (= (registry-size back) (registry-size db))) - (delete-file tempfile)) - (message "Done with persistence testing.")) + (assert (not (gethash key (oref db data))) nil + "Key already exists in database") + + (assert (not (registry-full db)) + nil + "registry max-size limit reached") + + ;; store the entry + (puthash key entry (oref db data)) + + ;; store the secondary indices + (dolist (tr (oref db tracked)) + ;; for every value in the entry under that key... + (dolist (val (cdr-safe (assq tr entry))) + (let* ((value-keys (registry-lookup-secondary-value db tr val))) + (pushnew key value-keys :test 'equal) + (registry-lookup-secondary-value db tr val value-keys)))) + entry) + +(defmethod registry-reindex ((db registry-db)) + "Rebuild the secondary indices of registry-db THIS." + (let ((count 0) + (expected (* (length (oref db tracked)) (registry-size db)))) + (dolist (tr (oref db tracked)) + (let (values) + (maphash + (lambda (key v) + (incf count) + (when (and (< 0 expected) + (= 0 (mod count 1000))) + (message "reindexing: %d of %d (%.2f%%)" + count expected (/ (* 100 count) expected))) + (dolist (val (cdr-safe (assq tr v))) + (let* ((value-keys (registry-lookup-secondary-value db tr val))) + (push key value-keys) + (registry-lookup-secondary-value db tr val value-keys)))) + (oref db data)))))) + +(defmethod registry-prune ((db registry-db) &optional sortfunc) + "Prunes the registry-db object DB. + +Attempts to prune the number of entries down to \(* +:max-size :prune-factor\) less than the max-size limit, so +pruning doesn't need to happen on every save. Removes only +entries without the :precious keys, so it may not be possible to +reach the target limit. + +Entries to be pruned are first sorted using SORTFUNC. Entries +from the front of the list are deleted first. + +Returns the number of deleted entries." + (let ((size (registry-size db)) + (target-size (- (oref db :max-size) + (* (oref db :max-size) + (oref db :prune-factor)))) + candidates) + (if (> size target-size) + (progn + (setq candidates + (registry-collect-prune-candidates + db (- size target-size) sortfunc)) + (length (registry-delete db candidates nil))) + 0))) + +(defmethod registry-collect-prune-candidates ((db registry-db) limit sortfunc) + "Collects pruning candidates from the registry-db object DB. + +Proposes only entries without the :precious keys, and attempts to +return LIMIT such candidates. If SORTFUNC is provided, sort +entries first and return candidates from beginning of list." + (let* ((precious (oref db :precious)) + (precious-p (lambda (entry-key) + (cdr (memq (car entry-key) precious)))) + (data (oref db data)) + (candidates (cl-loop for k being the hash-keys of data + using (hash-values v) + when (notany precious-p v) + collect (cons k v)))) + ;; We want the full entries for sorting, but should only return a + ;; list of entry keys. + (when sortfunc + (setq candidates (sort candidates sortfunc))) + (delq nil (cl-subseq (mapcar #'car candidates) 0 limit)))) (provide 'registry) ;;; registry.el ends here