X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fregistry.el;h=ef076a52580f412f34f872f105ee4dfdb75963bc;hp=3c4457d857765c905ec55834ea0e59d5dcd23685;hb=0c38751cb18d51ed294dabcfb16ed21a610e2daa;hpb=96b11ae6da3fed2ee5b4ae882e88a2efc6c63d21 diff --git a/lisp/registry.el b/lisp/registry.el index 3c4457d85..ef076a525 100644 --- a/lisp/registry.el +++ b/lisp/registry.el @@ -1,33 +1,35 @@ ;;; registry.el --- Track and remember data items by various fields -;; Copyright (C) 2011 Teodor Zlatanov +;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ;; Author: Teodor Zlatanov ;; Keywords: data -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . +;; along with GNU Emacs. If not, see . ;;; Commentary: ;; 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 @@ -55,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 @@ -75,8 +78,8 @@ ;;; Code: -(eval-when-compile (require 'ert)) (eval-when-compile (require 'cl)) + (eval-and-compile (or (ignore-errors (progn (require 'eieio) @@ -92,22 +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 "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 @@ -122,50 +147,69 @@ (data :initarg :data :type hash-table :documentation "The data hashtable."))) - -(defmethod initialize-instance :after ((this registry-db) slots) +)) + +(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))) + (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 a alist of the key followed by the entry in a list, not a cons cell." - (let ((data (oref db :data))) +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)))) + (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 a alist of the key followed by the entry in a list, not a cons cell." - (let ((data (oref db :data))) +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)))))) + (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) + &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 + h (when create - (puthash tracksym - (make-hash-table :size 800 :rehash-size 2.0 :test 'equal) - (oref db :tracker)) - (gethash tracksym (oref db :tracker)))))) + (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) + &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 @@ -173,7 +217,7 @@ When SET is not nil, set it for VAL (use t for an empty list)." ;; set the entry if requested, (when set (puthash val (if (eq t set) '() set) - (registry-lookup-secondary db tracksym t))) + (registry-lookup-secondary db tracksym t))) (gethash val (registry-lookup-secondary db tracksym)))) (defun registry--match (mode entry check-list) @@ -204,206 +248,150 @@ 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)))) + (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))) + (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))) + (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 (gethash key (oref db data))) nil + "Key already exists in database") - (assert (< (registry-size db) - (oref db :max-hard)) - nil - "max-hard size limit reached") + (assert (not (registry-full db)) + nil + "registry max-size limit reached") ;; store the entry - (puthash key entry (oref db :data)) + (puthash key entry (oref db data)) ;; store the secondary indices - (dolist (tr (oref db :tracked)) + (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)))) + (pushnew key value-keys :test 'equal) + (registry-lookup-secondary-value db tr val value-keys)))) entry) -(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)) - "Prunes the registry-db object THIS. -Removes only entries without the :precious keys." +(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)) - (limit (oref db :max-soft)) - (size (registry-size db)) - (candidates (loop for k being the hash-keys of data - using (hash-values v) - when (notany precious-p v) - collect k)) - (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))) - -(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))))) - (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.")) + (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