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

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

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 657700a6343a2765e0d75e970b35ea88885fb406..ad69b292a7f21e52f2fcb2439b4b5c113b6116a7 100644 (file)
--- 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 4beafd4b8453bfcfe33aaef425e76db3378be615..ffba2e10e6a2231f4a5c477f8e9e8366d6f0c072 100644 (file)
--- 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")))