gnus-registry.el, registry.el: Silence the byte compiler.
gnus-registry.el: Eliminate cl functions. (gnus-registry-sort-addresses): New function that replaces mapcan. (gnus-registry-action, gnus-registry-spool-action) (gnus-registry-split-fancy-with-parent) (gnus-registry-fetch-recipients-fast): Use it. (gnus-registry-import-eld): Replace delete* with dolist + delq. 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): Use eval-and-compile.
This commit is contained in:
Katsumi Yamaoka
parent
7eed1860d8
commit
8d6d9c8f8d
3 changed files with 184 additions and 173 deletions
|
|
@ -1,3 +1,18 @@
|
|||
2011-04-18 Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
|
||||
* gnus-registry.el: Eliminate cl functions.
|
||||
(gnus-registry-sort-addresses): New function that replaces mapcan.
|
||||
(gnus-registry-action, gnus-registry-spool-action)
|
||||
(gnus-registry-split-fancy-with-parent)
|
||||
(gnus-registry-fetch-recipients-fast): Use it.
|
||||
(gnus-registry-import-eld): Replace delete* with dolist + delq.
|
||||
|
||||
* 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):
|
||||
Use eval-and-compile.
|
||||
|
||||
2011-04-16 Teodor Zlatanov <tzz@lifelogs.com>
|
||||
|
||||
* registry.el (registry-reindex): New method to recreate the secondary
|
||||
|
|
|
|||
|
|
@ -303,15 +303,9 @@ This is not required after changing `gnus-registry-cache-file'."
|
|||
(defun gnus-registry-action (action data-header from &optional to method)
|
||||
(let* ((id (mail-header-id data-header))
|
||||
(subject (mail-header-subject data-header))
|
||||
(recipients (sort (mapcan 'gnus-registry-extract-addresses
|
||||
(list
|
||||
(or (ignore-errors
|
||||
(mail-header "Cc" data-header))
|
||||
"")
|
||||
(or (ignore-errors
|
||||
(mail-header "To" data-header))
|
||||
"")))
|
||||
'string-lessp))
|
||||
(recipients (gnus-registry-sort-addresses
|
||||
(or (ignore-errors (mail-header "Cc" data-header)) "")
|
||||
(or (ignore-errors (mail-header "To" data-header)) "")))
|
||||
(sender (nth 0 (gnus-registry-extract-addresses
|
||||
(mail-header-from data-header))))
|
||||
(from (gnus-group-guess-full-name-from-command-method from))
|
||||
|
|
@ -329,11 +323,9 @@ This is not required after changing `gnus-registry-cache-file'."
|
|||
(defun gnus-registry-spool-action (id group &optional subject sender recipients)
|
||||
(let ((to (gnus-group-guess-full-name-from-command-method group))
|
||||
(recipients (or recipients
|
||||
(sort (mapcan 'gnus-registry-extract-addresses
|
||||
(list
|
||||
(or (message-fetch-field "cc") "")
|
||||
(or (message-fetch-field "to") "")))
|
||||
'string-lessp)))
|
||||
(gnus-registry-sort-addresses
|
||||
(or (message-fetch-field "cc") "")
|
||||
(or (message-fetch-field "to") ""))))
|
||||
(subject (or subject (message-fetch-field "subject")))
|
||||
(sender (or sender (message-fetch-field "from"))))
|
||||
(when (and (stringp id) (string-match "\r$" id))
|
||||
|
|
@ -409,11 +401,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
|
|||
;; these may not be used, but the code is cleaner having them up here
|
||||
(sender (gnus-string-remove-all-properties
|
||||
(message-fetch-field "from")))
|
||||
(recipients (sort (mapcan 'gnus-registry-extract-addresses
|
||||
(list
|
||||
(or (message-fetch-field "cc") "")
|
||||
(or (message-fetch-field "to") "")))
|
||||
'string-lessp))
|
||||
(recipients (gnus-registry-sort-addresses
|
||||
(or (message-fetch-field "cc") "")
|
||||
(or (message-fetch-field "to") "")))
|
||||
(subject (gnus-string-remove-all-properties
|
||||
(gnus-registry-simplify-subject
|
||||
(message-fetch-field "subject"))))
|
||||
|
|
@ -719,6 +709,11 @@ Addresses without a name will say \"noname\"."
|
|||
(format "%s <%s>" name addr))))
|
||||
(mail-extract-address-components text t)))
|
||||
|
||||
(defun gnus-registry-sort-addresses (&rest addresses)
|
||||
"Return a normalized and sorted list of ADDRESSES."
|
||||
(sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
|
||||
'string-lessp))
|
||||
|
||||
(defun gnus-registry-simplify-subject (subject)
|
||||
(if (stringp subject)
|
||||
(gnus-simplify-subject subject)
|
||||
|
|
@ -738,15 +733,9 @@ Addresses without a name will say \"noname\"."
|
|||
(gnus-registry-fetch-header-fast "from" article))
|
||||
|
||||
(defun gnus-registry-fetch-recipients-fast (article)
|
||||
(sort (mapcan 'gnus-registry-extract-addresses
|
||||
(list
|
||||
(or (ignore-errors
|
||||
(gnus-registry-fetch-header-fast "Cc" article))
|
||||
"")
|
||||
(or (ignore-errors
|
||||
(gnus-registry-fetch-header-fast "To" article))
|
||||
"")))
|
||||
'string-lessp))
|
||||
(gnus-registry-sort-addresses
|
||||
(or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
|
||||
(or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
|
||||
|
||||
(defun gnus-registry-fetch-header-fast (article header)
|
||||
"Fetch the HEADER quickly, using the internal gnus-data-list function"
|
||||
|
|
@ -982,7 +971,8 @@ only the last one's marks are returned."
|
|||
collect p))
|
||||
extra-cell key val)
|
||||
;; remove all the strings from the entry
|
||||
(delete* nil rest :test (lambda (a b) (stringp b)))
|
||||
(dolist (elem rest)
|
||||
(if (stringp elem) (setq rest (delq elem rest))))
|
||||
(gnus-registry-set-id-key id 'group groups)
|
||||
;; just use the first extra element
|
||||
(setq rest (car-safe rest))
|
||||
|
|
|
|||
|
|
@ -131,58 +131,60 @@
|
|||
: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)))))
|
||||
(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 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)))
|
||||
(delq nil
|
||||
(mapcar
|
||||
(lambda (k)
|
||||
(when (gethash k data)
|
||||
(list k (gethash k data))))
|
||||
keys))))
|
||||
(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.
|
||||
(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)))
|
||||
(delq nil
|
||||
(loop for key in keys
|
||||
when (gethash key data)
|
||||
collect (list key (gethash key data))))))
|
||||
(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.
|
||||
(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))))))
|
||||
(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.
|
||||
(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
|
||||
|
|
@ -204,129 +206,133 @@ 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))))))
|
||||
|
||||
(defmethod registry-search ((db registry-db) &rest spec)
|
||||
"Search for SPEC across the registry-db THIS.
|
||||
(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))))
|
||||
(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.
|
||||
(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)))
|
||||
keys))
|
||||
(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-insert ((db registry-db) key entry)
|
||||
"Insert ENTRY under KEY into the registry-db THIS.
|
||||
(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 (< (registry-size db)
|
||||
(oref db :max-hard))
|
||||
nil
|
||||
"max-hard size limit reached")
|
||||
|
||||
;; store the entry
|
||||
(puthash key entry (oref db :data))
|
||||
;; 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))))
|
||||
;; store the secondary indices
|
||||
(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 (/ (* 1000 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))))))
|
||||
;; 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-size ((db registry-db))
|
||||
"Returns the size of the registry-db object THIS.
|
||||
(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 (/ (* 1000 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)))
|
||||
(hash-table-count (oref db :data)))
|
||||
|
||||
(defmethod registry-prune ((db registry-db))
|
||||
"Prunes the registry-db object THIS.
|
||||
(defmethod registry-prune ((db registry-db))
|
||||
"Prunes the registry-db object THIS.
|
||||
Removes 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))
|
||||
(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)))
|
||||
(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)))
|
||||
;; 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)))
|
||||
(registry-delete db candidates nil))))
|
||||
|
||||
(ert-deftest registry-instantiation-test ()
|
||||
(should (registry-db "Testing")))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue