X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=8b7ecafe19e87437b2a9d48775a7ee4ef8b9fd00;hb=3cf1618f34957ba08d8f91bdd552f9408d1d7a0f;hp=e97b1e4abb33b1630678be02c9e3d85f1397944e;hpb=8415a1b40b3e9f3245d7adaee84514c22f1a4385;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index e97b1e4..8b7ecaf 100644
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -33,6 +33,9 @@
 (require 'gnus-sum)
 (require 'nnmail)
 
+(defvar gnus-registry-dirty t
+ "Boolean set to t when the registry is modified")
+
 (defgroup gnus-registry nil
   "The Gnus registry."
   :group 'gnus)
@@ -51,11 +54,33 @@ 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
   :type 'file)
 
+(defcustom gnus-registry-max-entries nil
+  "Maximum number of entries in the registry, nil for unlimited."
+  :group 'gnus-registry
+  :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)))
   (require 'cl)
@@ -77,7 +102,6 @@ The group names are matched, they don't have to be fully qualified."
   (interactive)
   (let ((file gnus-registry-cache-file))
     (save-excursion
-      ;; Save .newsrc.eld.
       (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
       (make-local-variable 'version-control)
     (setq version-control gnus-backup-startup-file)
@@ -138,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)
@@ -147,13 +171,56 @@ The group names are matched, they don't have to be fully qualified."
     (while (re-search-forward " $" nil t)
       (replace-match "" t t))))
 
-(defun gnus-registry-save ()
-  (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb))
-  (gnus-registry-cache-save))
+(defun gnus-registry-save (&optional force)
+  (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)))
+  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+  (setq gnus-registry-dirty nil))
+
+(defun gnus-registry-trim (alist)
+  "Trim alist to size, using 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)))
+      (maphash
+       (lambda (key value)
+	 (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)
+	     (sort alist 
+		   (lambda (a b)
+		     (time-less-p 
+		      (cdr (gethash (car a) timehash))
+		      (cdr (gethash (car b) timehash))))))))))
 
 (defun alist-to-hashtable (alist)
   "Build a hashtable from the values in ALIST."
@@ -294,7 +361,8 @@ The message must have at least one group name."
     (let ((trail (gethash id gnus-registry-hashtb))
 	  (old-extra (gnus-registry-fetch-extra id)))
       (puthash id (cons extra (delete old-extra trail))
-	       gnus-registry-hashtb))))
+	       gnus-registry-hashtb)
+      (setq gnus-registry-dirty t))))
 
 (defun gnus-registry-store-extra-entry (id key value)
   "Put a specific entry in the extras field of the registry entry for id."
@@ -311,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."
@@ -331,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)
@@ -341,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)
@@ -355,7 +429,8 @@ Returns the first place where the trail finds a group name."
   "Clear the Gnus registry."
   (interactive)
   (setq gnus-registry-alist nil)
-  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
+  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+  (setq gnus-registry-dirty t))
 
 (defun gnus-registry-install-hooks ()
   "Install the registry hooks."
@@ -370,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