diff options
Diffstat (limited to 'lisp/gnus/registry.el')
| -rw-r--r-- | lisp/gnus/registry.el | 378 |
1 files changed, 0 insertions, 378 deletions
diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el deleted file mode 100644 index 16f5d20dccf..00000000000 --- a/lisp/gnus/registry.el +++ /dev/null @@ -1,378 +0,0 @@ -;;; registry.el --- Track and remember data items by various fields - -;; Copyright (C) 2011-2017 Free Software Foundation, Inc. - -;; Author: Teodor Zlatanov <tzz@lifelogs.com> -;; Keywords: data - -;; 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. - -;; 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This library provides a general-purpose EIEIO-based registry -;; database with persistence, initialized with these fields: - -;; version: a float - -;; max-size: an integer, default most-positive-fixnum - -;; prune-factor: a float between 0 and 1, default 0.1 - -;; precious: a list of symbols - -;; tracked: a list of symbols - -;; tracker: a hashtable tuned for 100 symbols to track (you should -;; only access this with the :lookup2-function and the -;; :lookup2+-function) - -;; data: a hashtable with default size 10K and resize threshold 2.0 -;; (this reflects the expected usage so override it if you know better) - -;; ...plus methods to do all the work: `registry-search', -;; `registry-lookup', `registry-lookup-secondary', -;; `registry-lookup-secondary-value', `registry-insert', -;; `registry-delete', `registry-prune', `registry-size' which see - -;; and with the following properties: - -;; Every piece of data has a unique ID and some general-purpose fields -;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g. - -;; ((F1 D1) (F2 D2) (F3 a b c)) - -;; 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. 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-size limit, even if they have the F2 -;; field. - -;; The user decides which fields are "tracked", F1 for example. Any -;; new entry is then indexed by all the tracked fields so it can be -;; quickly looked up that way. The data is always a list (see example -;; above) and each list element is indexed. - -;; Precious and tracked field names must be symbols. All other -;; fields can be any other Emacs Lisp types. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'eieio) -(require 'eieio-base) - -;; 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.") - -(defclass registry-db (eieio-persistent) - ((version :initarg :version - :initform nil - :type (or null float) - :documentation "The registry version.") - (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 "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 - :documentation "The tracked (indexed) fields, a list of symbols.") - (precious :initarg :precious - :initform nil - :type t - :documentation "The precious fields, a list of symbols.") - (tracker :initarg :tracker - :type hash-table - :documentation "The field tracking hashtable.") - (data :initarg :data - :type hash-table - :documentation "The data hashtable."))) - -(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. -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. -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. -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)))) - -(defun registry--match (mode entry check-list) - ;; for all members - (when check-list - (let ((key (nth 0 (nth 0 check-list))) - (vals (cdr-safe (nth 0 check-list))) - found) - (while (and key vals (not found)) - (setq found (case mode - (:member - (member (car-safe vals) (cdr-safe (assoc key entry)))) - (:regex - (string-match (car vals) - (mapconcat - 'prin1-to-string - (cdr-safe (assoc key entry)) - "\0")))) - vals (cdr-safe vals))) - (or found - (registry--match mode entry (cdr-safe check-list)))))) - -(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. -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 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-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.0 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 - (floor (- (oref db max-size) - (* (oref db max-size) - (oref db prune-factor))))) - candidates) - (if (registry-full db) - (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))) - (cl-subseq (mapcar #'car candidates) 0 (min limit (length candidates))))) - -(provide 'registry) -;;; registry.el ends here |