-;;; registry.el --- Track and remember data items by various fields
-
-;; Copyright (C) 2011-2012 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, 0.1 currently (don't change it)
-
-;; max-hard: an integer, default 5000000
-
-;; max-soft: an integer, default 50000
-
-;; 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. 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.
-
-;; 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
-;; 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))
-
-(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)
- (require 'eieio-base)))
- ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
- (ignore-errors
- (let ((load-path (cons (expand-file-name
- "gnus-fallback-lib/eieio"
- (file-name-directory (locate-library "gnus")))
- load-path)))
- (require 'eieio)
- (require 'eieio-base)))
- (error
- "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
-
-(defclass registry-db (eieio-persistent)
- ((version :initarg :version
- :initform 0.1
- :type float
- :custom float
- :documentation "The registry version.")
- (max-hard :initarg :max-hard
- :initform 5000000
- :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.")
- (prune-factor
- :initarg :prune-factor
- :initform 0.1
- :type float
- :custom float
- :documentation "At the max-hard limit, prune size * this entries.")
- (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.")))
-
-(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.
-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))))))
-
-(eval-and-compile
- (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 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.
-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."))
-
-(provide 'registry)
-;;; registry.el ends here
+;;; registry.el --- Track and remember data items by various fields
+
+;; Copyright (C) 2011-2014 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, 0.1 currently (don't change it)
+
+;; max-hard: an integer, default 5000000
+
+;; max-soft: an integer, default 50000
+
+;; 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. 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.
+
+;; 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
+;; 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)
+
+(defclass registry-db (eieio-persistent)
+ ((version :initarg :version
+ :initform 0.1
+ :type float
+ :custom float
+ :documentation "The registry version.")
+ (max-hard :initarg :max-hard
+ :initform 5000000
+ :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.")
+ (prune-factor
+ :initarg :prune-factor
+ :initform 0.1
+ :type float
+ :custom float
+ :documentation "At the max-hard limit, prune size * this entries.")
+ (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 :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-hard)))
+
+(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-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)))
+
+(provide 'registry)
+;;; registry.el ends here
HCoop / bpt / emacs.git / blobdiff