Commit f38a45fa authored by David Engster's avatar David Engster

* registry.el (initialize-instance, registry-lookup)

  (registry-lookup-breaks-before-lexbind, registry-lookup-secondary)
  (registry-lookup-secondary-value, registry-search, registry-delete)
  (registry-insert, registry-reindex, registry-size, registry-prune): Do
  not wrap methods in `eval-and-compile'.  This breaks due to latest
  changes in EIEIO (introduction of eieio-core.el).
parent 890f7890
2013-06-02 David Engster <deng@randomsample.de>
* registry.el (initialize-instance, registry-lookup)
(registry-lookup-breaks-before-lexbind, registry-lookup-secondary)
(registry-lookup-secondary-value, registry-search, registry-delete)
(registry-insert, registry-reindex, registry-size, registry-prune): Do
not wrap methods in `eval-and-compile'. This breaks due to latest
changes in EIEIO (introduction of eieio-core.el).
2013-05-24 Julien Danjou <julien@danjou.info> 2013-05-24 Julien Danjou <julien@danjou.info>
* sieve.el (sieve-setup-buffer): Fix default port value in sieve buffer * sieve.el (sieve-setup-buffer): Fix default port value in sieve buffer
......
...@@ -119,60 +119,59 @@ ...@@ -119,60 +119,59 @@
:type hash-table :type hash-table
:documentation "The data hashtable."))) :documentation "The data hashtable.")))
(eval-and-compile (defmethod initialize-instance :AFTER ((this registry-db) slots)
(defmethod initialize-instance :AFTER ((this registry-db) slots) "Set value of data slot of THIS after initialization."
"Set value of data slot of THIS after initialization." (with-slots (data tracker) this
(with-slots (data tracker) this (unless (member :data slots)
(unless (member :data slots) (setq data
(setq data (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
(make-hash-table :size 10000 :rehash-size 2.0 :test 'equal))) (unless (member :tracker slots)
(unless (member :tracker slots) (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
(setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
(defmethod registry-lookup ((db registry-db) keys)
(defmethod registry-lookup ((db registry-db) keys) "Search for KEYS in the registry-db THIS.
"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." Returns an alist of the key followed by the entry in a list, not a cons cell."
(let ((data (oref db :data))) (let ((data (oref db :data)))
(delq nil (delq nil
(mapcar (mapcar
(lambda (k) (lambda (k)
(when (gethash k data) (when (gethash k data)
(list k (gethash k data)))) (list k (gethash k data))))
keys)))) keys))))
(defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys) (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
"Search for KEYS in the registry-db THIS. "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." Returns an alist of the key followed by the entry in a list, not a cons cell."
(let ((data (oref db :data))) (let ((data (oref db :data)))
(delq nil (delq nil
(loop for key in keys (loop for key in keys
when (gethash key data) when (gethash key data)
collect (list key (gethash key data)))))) collect (list key (gethash key data))))))
(defmethod registry-lookup-secondary ((db registry-db) tracksym (defmethod registry-lookup-secondary ((db registry-db) tracksym
&optional create) &optional create)
"Search for TRACKSYM in the registry-db THIS. "Search for TRACKSYM in the registry-db THIS.
When CREATE is not nil, create the secondary index hashtable if needed." When CREATE is not nil, create the secondary index hashtable if needed."
(let ((h (gethash tracksym (oref db :tracker)))) (let ((h (gethash tracksym (oref db :tracker))))
(if h (if h
h h
(when create (when create
(puthash tracksym (puthash tracksym
(make-hash-table :size 800 :rehash-size 2.0 :test 'equal) (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
(oref db :tracker)) (oref db :tracker))
(gethash tracksym (oref db :tracker)))))) (gethash tracksym (oref db :tracker))))))
(defmethod registry-lookup-secondary-value ((db registry-db) tracksym val (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. "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)." 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 ;; either we're asked for creation or there should be an existing index
(when (or set (registry-lookup-secondary db tracksym)) (when (or set (registry-lookup-secondary db tracksym))
;; set the entry if requested, ;; set the entry if requested,
(when set (when set
(puthash val (if (eq t set) '() 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))))) (gethash val (registry-lookup-secondary db tracksym))))
(defun registry--match (mode entry check-list) (defun registry--match (mode entry check-list)
;; for all members ;; for all members
...@@ -194,166 +193,165 @@ When SET is not nil, set it for VAL (use t for an empty list)." ...@@ -194,166 +193,165 @@ When SET is not nil, set it for VAL (use t for an empty list)."
(or found (or found
(registry--match mode entry (cdr-safe check-list)))))) (registry--match mode entry (cdr-safe check-list))))))
(eval-and-compile (defmethod registry-search ((db registry-db) &rest spec)
(defmethod registry-search ((db registry-db) &rest spec) "Search for SPEC across the registry-db THIS.
"Search for SPEC across the registry-db THIS.
For example calling with :member '(a 1 2) will match entry '((a 3 1)). 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 :all t (any non-nil value) will match all.
Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\"). Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\").
The test order is to check :all first, then :member, then :regex." The test order is to check :all first, then :member, then :regex."
(when db (when db
(let ((all (plist-get spec :all)) (let ((all (plist-get spec :all))
(member (plist-get spec :member)) (member (plist-get spec :member))
(regex (plist-get spec :regex))) (regex (plist-get spec :regex)))
(loop for k being the hash-keys of (oref db :data) (loop for k being the hash-keys of (oref db :data)
using (hash-values v) using (hash-values v)
when (or when (or
;; :all non-nil returns all ;; :all non-nil returns all
all all
;; member matching ;; member matching
(and member (registry--match :member v member)) (and member (registry--match :member v member))
;; regex matching ;; regex matching
(and regex (registry--match :regex v regex))) (and regex (registry--match :regex v regex)))
collect k)))) collect k))))
(defmethod registry-delete ((db registry-db) keys assert &rest spec) (defmethod registry-delete ((db registry-db) keys assert &rest spec)
"Delete KEYS from the registry-db THIS. "Delete KEYS from the registry-db THIS.
If KEYS is nil, use SPEC to do a search. If KEYS is nil, use SPEC to do a search.
Updates the secondary ('tracked') indices as well. Updates the secondary ('tracked') indices as well.
With assert non-nil, errors out if the key does not exist already." With assert non-nil, errors out if the key does not exist already."
(let* ((data (oref db :data)) (let* ((data (oref db :data))
(keys (or keys (keys (or keys
(apply 'registry-search db spec))) (apply 'registry-search db spec)))
(tracked (oref db :tracked))) (tracked (oref db :tracked)))
(dolist (key keys) (dolist (key keys)
(let ((entry (gethash key data))) (let ((entry (gethash key data)))
(when assert (when assert
(assert entry nil (assert entry nil
"Key %s does not exists in database" key)) "Key %s does not exists in database" key))
;; clean entry from the secondary indices ;; clean entry from the secondary indices
(dolist (tr tracked) (dolist (tr tracked)
;; is this tracked symbol indexed? ;; is this tracked symbol indexed?
(when (registry-lookup-secondary db tr) (when (registry-lookup-secondary db tr)
;; for every value in the entry under that key... ;; for every value in the entry under that key...
(dolist (val (cdr-safe (assq tr entry))) (dolist (val (cdr-safe (assq tr entry)))
(let* ((value-keys (registry-lookup-secondary-value (let* ((value-keys (registry-lookup-secondary-value
db tr val))) db tr val)))
(when (member key value-keys) (when (member key value-keys)
;; override the previous value ;; override the previous value
(registry-lookup-secondary-value (registry-lookup-secondary-value
db tr val db tr val
;; with the indexed keys MINUS the current key ;; with the indexed keys MINUS the current key
;; (we pass t when the list is empty) ;; (we pass t when the list is empty)
(or (delete key value-keys) t))))))) (or (delete key value-keys) t)))))))
(remhash key data))) (remhash key data)))
keys)) keys))
(defmethod registry-size ((db registry-db)) (defmethod registry-size ((db registry-db))
"Returns the size of the registry-db object THIS. "Returns the size of the registry-db object THIS.
This is the key count of the :data slot." This is the key count of the :data slot."
(hash-table-count (oref db :data))) (hash-table-count (oref db :data)))
(defmethod registry-full ((db registry-db)) (defmethod registry-full ((db registry-db))
"Checks if registry-db THIS is full." "Checks if registry-db THIS is full."
(>= (registry-size db) (>= (registry-size db)
(oref db :max-hard))) (oref db :max-hard)))
(defmethod registry-insert ((db registry-db) key entry) (defmethod registry-insert ((db registry-db) key entry)
"Insert ENTRY under KEY into the registry-db THIS. "Insert ENTRY under KEY into the registry-db THIS.
Updates the secondary ('tracked') indices as well. Updates the secondary ('tracked') indices as well.
Errors out if the key exists already." Errors out if the key exists already."
(assert (not (gethash key (oref db :data))) nil (assert (not (gethash key (oref db :data))) nil
"Key already exists in database") "Key already exists in database")
(assert (not (registry-full db)) (assert (not (registry-full db))
nil nil
"registry max-hard size limit reached") "registry max-hard size limit reached")
;; store the entry ;; store the entry
(puthash key entry (oref db :data)) (puthash key entry (oref db :data))
;; store the secondary indices ;; 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)) (dolist (tr (oref db :tracked))
;; for every value in the entry under that key... (let (values)
(dolist (val (cdr-safe (assq tr entry))) (maphash
(let* ((value-keys (registry-lookup-secondary-value db tr val))) (lambda (key v)
(pushnew key value-keys :test 'equal) (incf count)
(registry-lookup-secondary-value db tr val value-keys)))) (when (and (< 0 expected)
entry) (= 0 (mod count 1000)))
(message "reindexing: %d of %d (%.2f%%)"
(defmethod registry-reindex ((db registry-db)) count expected (/ (* 100 count) expected)))
"Rebuild the secondary indices of registry-db THIS." (dolist (val (cdr-safe (assq tr v)))
(let ((count 0) (let* ((value-keys (registry-lookup-secondary-value db tr val)))
(expected (* (length (oref db :tracked)) (registry-size db)))) (push key value-keys)
(dolist (tr (oref db :tracked)) (registry-lookup-secondary-value db tr val value-keys))))
(let (values) (oref db :data))))))
(maphash
(lambda (key v) (defmethod registry-prune ((db registry-db) &optional sortfun)
(incf count) "Prunes the registry-db object THIS.
(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, Removes only entries without the :precious keys if it can,
then removes oldest entries first. then removes oldest entries first.
Returns the number of deleted entries. Returns the number of deleted entries.
If SORTFUN is given, tries to keep entries that sort *higher*. 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." SORTFUN is passed only the two keys so it must look them up directly."
(dolist (collector '(registry-prune-soft-candidates (dolist (collector '(registry-prune-soft-candidates
registry-prune-hard-candidates)) registry-prune-hard-candidates))
(let* ((size (registry-size db)) (let* ((size (registry-size db))
(collected (funcall collector db)) (collected (funcall collector db))
(limit (nth 0 collected)) (limit (nth 0 collected))
(candidates (nth 1 collected)) (candidates (nth 1 collected))
;; sort the candidates if SORTFUN was given ;; sort the candidates if SORTFUN was given
(candidates (if sortfun (sort candidates sortfun) candidates)) (candidates (if sortfun (sort candidates sortfun) candidates))
(candidates-count (length candidates)) (candidates-count (length candidates))
;; are we over max-soft? ;; are we over max-soft?
(prune-needed (> size limit))) (prune-needed (> size limit)))
;; while we have more candidates than we need to remove... ;; while we have more candidates than we need to remove...
(while (and (> candidates-count (- size limit)) candidates) (while (and (> candidates-count (- size limit)) candidates)
(decf candidates-count) (decf candidates-count)
(setq candidates (cdr candidates))) (setq candidates (cdr candidates)))
(registry-delete db candidates nil) (registry-delete db candidates nil)
(length candidates)))) (length candidates))))
(defmethod registry-prune-soft-candidates ((db registry-db)) (defmethod registry-prune-soft-candidates ((db registry-db))
"Collects pruning candidates from the registry-db object THIS. "Collects pruning candidates from the registry-db object THIS.
Proposes only entries without the :precious keys." Proposes only entries without the :precious keys."
(let* ((precious (oref db :precious)) (let* ((precious (oref db :precious))
(precious-p (lambda (entry-key) (precious-p (lambda (entry-key)
(cdr (memq (car entry-key) precious)))) (cdr (memq (car entry-key) precious))))
(data (oref db :data)) (data (oref db :data))
(limit (oref db :max-soft)) (limit (oref db :max-soft))
(candidates (loop for k being the hash-keys of data (candidates (loop for k being the hash-keys of data
using (hash-values v) using (hash-values v)
when (notany precious-p v) when (notany precious-p v)
collect k))) collect k)))
(list limit candidates))) (list limit candidates)))
(defmethod registry-prune-hard-candidates ((db registry-db)) (defmethod registry-prune-hard-candidates ((db registry-db))
"Collects pruning candidates from the registry-db object THIS. "Collects pruning candidates from the registry-db object THIS.
Proposes any entries over the max-hard limit minus size * prune-factor." Proposes any entries over the max-hard limit minus size * prune-factor."
(let* ((data (oref db :data)) (let* ((data (oref db :data))
;; prune to (size * prune-factor) below the max-hard limit so ;; prune to (size * prune-factor) below the max-hard limit so
;; we're not pruning all the time ;; we're not pruning all the time
(limit (max 0 (- (oref db :max-hard) (limit (max 0 (- (oref db :max-hard)
(* (registry-size db) (oref db :prune-factor))))) (* (registry-size db) (oref db :prune-factor)))))
(candidates (loop for k being the hash-keys of data (candidates (loop for k being the hash-keys of data
collect k))) collect k)))
(list limit candidates)))) (list limit candidates)))
(provide 'registry) (provide 'registry)
;;; registry.el ends here ;;; registry.el ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment