registry.el (registry-prune-hard-candidates, registry-prune-soft-candidates): Helper methods for registry pruning.

 (registry-prune): Use them.  Make the sort function optional.

2 files changed, 47 insertions, 13 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 657700a6343..ad69b292a7f 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,9 @@
+2011-05-10  Teodor Zlatanov  <tzz@lifelogs.com>
+
+        * registry.el (registry-prune-hard-candidates)
+        (registry-prune-soft-candidates): Helper methods for registry pruning.
+        (registry-prune): Use them.  Make the sort function optional.
+
 2011-05-10  Julien Danjou  <julien@danjou.info>
 
         * shr.el (shr-put-color-1): Do not bug out when old-props is a face
diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el
index 4beafd4b845..ffba2e10e6a 100644
--- a/lisp/gnus/registry.el
+++ b/lisp/gnus/registry.el
@@ -314,29 +314,57 @@ Errors out if the key exists already."
 This is the key count of the :data slot."
     (hash-table-count (oref db :data)))
 
-  (defmethod registry-prune ((db registry-db))
+  (defmethod registry-prune ((db registry-db) &optional sortfun)
     "Prunes the registry-db object THIS.
-Removes only entries without the :precious keys."
+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))
-           (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)))
+                             collect k)))
+      (list limit 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))))
+  (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 10."
+    (let* ((data (oref db :data))
+           ;; prune to 10 below the max-hard limit so we're not
+           ;; pruning all the time
+           (limit (- (oref db :max-hard) 10))
+           (candidates (loop for k being the hash-keys of data
+                             collect k)))
+      (list limit candidates))))
 
 (ert-deftest registry-instantiation-test ()
   (should (registry-db "Testing")))