From 8d6d9c8f8de3841257c0b74448a824583bbf2c01 Mon Sep 17 00:00:00 2001 From: Katsumi Yamaoka Date: Mon, 18 Apr 2011 22:59:02 +0000 Subject: [PATCH] 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. --- lisp/gnus/ChangeLog | 15 ++ lisp/gnus/gnus-registry.el | 48 +++--- lisp/gnus/registry.el | 320 +++++++++++++++++++------------------ 3 files changed, 197 insertions(+), 186 deletions(-) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index eac53d413cc..8417d37cadf 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,18 @@ +2011-04-18 Katsumi Yamaoka + + * 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 * registry.el (registry-reindex): New method to recreate the secondary diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index eab4403c34b..697dc373b1f 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -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)) diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el index 3e638427897..1a18dbd50d2 100644 --- a/lisp/gnus/registry.el +++ b/lisp/gnus/registry.el @@ -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))))) - -(defmethod registry-lookup ((db registry-db) keys) - "Search for KEYS in the registry-db THIS. +(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 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)))) - -(defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys) - "Search for KEYS in the registry-db THIS. + (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 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)))))) - -(defmethod registry-lookup-secondary ((db registry-db) tracksym - &optional create) - "Search for TRACKSYM in the registry-db THIS. + (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. + (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)))) + ;; 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)))) - -(defmethod registry-delete ((db registry-db) keys assert &rest spec) - "Delete KEYS from the registry-db THIS. + (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-insert ((db registry-db) key entry) - "Insert ENTRY under KEY into the registry-db THIS. + (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-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 (< (registry-size db) - (oref db :max-hard)) - nil - "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)))) + (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") + + ;; store the entry + (puthash key entry (oref db :data)) + + ;; 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)))))) - -(defmethod registry-size ((db registry-db)) - "Returns the size of the registry-db object THIS. + ;; 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 (/ (* 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))) - - ;; 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))) + (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"))) -- 2.39.2