Synch to Gnus 200308070200.

[elisp/gnus.git-] / lisp / gnus-registry.el

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index 40b8a33..8b7ecaf 100644 (file)
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -54,6 +54,22 @@ The group names are matched, they don't have to be fully qualified."
   :group 'gnus-registry
   :type 'boolean)
 
+(defcustom gnus-registry-clean-empty t
+  "Whether the empty registry entries should be deleted.
+Registry entries are considered empty when they have no groups."
+  :group 'gnus-registry
+  :type 'boolean)
+
+(defcustom gnus-registry-use-long-group-names nil
+  "Whether the registry should use long group names (BUGGY)."
+  :group 'gnus-registry
+  :type 'boolean)
+
+(defcustom gnus-registry-trim-articles-without-groups t
+  "Whether the registry should clean out message IDs without groups."
+  :group 'gnus-registry
+  :type 'boolean)
+
 (defcustom gnus-registry-cache-file "~/.gnus.registry.eld"
   "File where the Gnus registry will be stored."
   :group 'gnus-registry
@@ -62,7 +78,8 @@ The group names are matched, they don't have to be fully qualified."
 (defcustom gnus-registry-max-entries nil
   "Maximum number of entries in the registry, nil for unlimited."
   :group 'gnus-registry
-  :type 'integer)
+  :type '(radio (const :format "Unlimited " nil)
+               (integer :format "Maximum number: %v\n" :size 0)))
 
 ;; Function(s) missing in Emacs 20
 (when (memq nil (mapcar 'fboundp '(puthash)))
@@ -145,7 +162,7 @@ The group names are matched, they don't have to be fully qualified."
 ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
 ;; Save the gnus-registry file with extra line breaks.
 (defun gnus-registry-cache-whitespace (filename)
-  (gnus-message 4 "Adding whitespace to %s" filename)
+  (gnus-message 5 "Adding whitespace to %s" filename)
   (save-excursion
     (goto-char (point-min))
     (while (re-search-forward "^(\\|(\\\"" nil t)
@@ -155,13 +172,28 @@ The group names are matched, they don't have to be fully qualified."
       (replace-match "" t t))))
 
 (defun gnus-registry-save (&optional force)
-;; TODO: delete entries with 0 groups
   (when (or gnus-registry-dirty force)
+    ;; remove empty entries
+    (when gnus-registry-clean-empty 
+      (gnus-registry-clean-empty-function))
+    ;; now trim the registry appropriately
     (setq gnus-registry-alist (gnus-registry-trim 
                               (hashtable-to-alist gnus-registry-hashtb)))
+    ;; really save
     (gnus-registry-cache-save)
     (setq gnus-registry-dirty nil)))
 
+(defun gnus-registry-clean-empty-function ()
+  "Remove all empty entries from the registry.  Returns count thereof."
+  (let ((count 0))
+    (maphash
+     (lambda (key value)
+       (unless (gnus-registry-fetch-group key)
+        (incf count)
+        (remhash key gnus-registry-hashtb)))
+     gnus-registry-hashtb)
+    count))
+
 (defun gnus-registry-read ()
   (gnus-registry-cache-read)
   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
@@ -169,7 +201,9 @@ The group names are matched, they don't have to be fully qualified."
 
 (defun gnus-registry-trim (alist)
   "Trim alist to size, using gnus-registry-max-entries."
-  (unless (null gnus-registry-max-entries)
+  (if (null gnus-registry-max-entries)
+      alist                            ; just return the alist
+    ;; else, when given max-entries, trim the alist
     (let ((timehash (make-hash-table                       
                     :size 4096
                     :test 'equal)))
@@ -178,6 +212,7 @@ The group names are matched, they don't have to be fully qualified."
         (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
        gnus-registry-hashtb)
 
+      ;; we use the return value of this setq, which is the trimmed alist
       (setq alist
            (nthcdr
             (- (length alist) gnus-registry-max-entries)
@@ -344,7 +379,7 @@ Returns the first place where the trail finds a group name."
     (let ((trail (gethash id gnus-registry-hashtb)))
       (dolist (crumb trail)
        (when (stringp crumb)
-         (return crumb))))))
+         (return (gnus-group-short-name crumb)))))))
 
 (defun gnus-registry-group-count (id)
   "Get the number of groups of a message, based on the message ID."
@@ -364,8 +399,9 @@ Returns the first place where the trail finds a group name."
                      nil)
                 gnus-registry-hashtb))
       ;; now, clear the entry if there are no more groups
-      (unless (gnus-registry-group-count id)
-       (remhash id gnus-registry-hashtb))
+      (when gnus-registry-trim-articles-without-groups
+       (unless (gnus-registry-group-count id)
+         (remhash id gnus-registry-hashtb)))
       (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 
 (defun gnus-registry-add-group (id group &rest extra)
@@ -374,8 +410,13 @@ Returns the first place where the trail finds a group name."
   (when group
     (when (and id
               (not (string-match "totally-fudged-out-message-id" id)))
-      (let ((group (gnus-group-short-name group)))
-       (gnus-registry-delete-group id group)   
+      (let ((full-group group)
+           (group (if gnus-registry-use-long-group-names 
+                      group 
+                    (gnus-group-short-name group))))
+       (gnus-registry-delete-group id group)
+       (unless gnus-registry-use-long-group-names 
+         (gnus-registry-delete-group id full-group))
        (let ((trail (gethash id gnus-registry-hashtb)))
          (puthash id (if trail
                          (cons group trail)
@@ -404,8 +445,22 @@ Returns the first place where the trail finds a group name."
 
   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 
+(defun gnus-registry-unload-hook ()
+  "Uninstall the registry hooks."
+  (interactive)
+  (remove-hook 'gnus-summary-article-move-hook 'gnus-register-action) 
+  (remove-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
+  (remove-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
+  (remove-hook 'nnmail-spool-hook 'gnus-register-spool-action)
+  
+  (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
+  (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
+
+  (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+
 (when gnus-registry-install
-  (gnus-registry-install-hooks))
+  (gnus-registry-install-hooks)
+  (gnus-registry-read))
 
 ;; TODO: a lot of things