X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=b2a66c286f941ec01806e16e50cea3fb8b779b11;hb=6433e9b0db6389b491674a9b7344f7565c2dd886;hp=4da392c18549292ba449e632d0da7b1a22862e62;hpb=35c5ae138dd2543e969cb672abf1152bb326b6f1;p=gnus

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index 4da392c18..b2a66c286 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)
@@ -40,19 +43,36 @@
 (defvar gnus-registry-hashtb nil
   "*The article registry by Message ID.")
 
-(defvar gnus-registry-headers-hashtb nil
-  "*The article header registry by Message ID.  Unused for now.")
-
 (defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
   "List of groups that gnus-registry-split-fancy-with-parent won't follow.
 The group names are matched, they don't have to be fully qualified."
   :group 'gnus-registry
   :type '(repeat string))
 
-(defcustom gnus-registry-unregistered-group-regex "^nntp"
-  "Group name regex that gnus-registry-register-message-ids won't process."
+(defcustom gnus-registry-install nil
+  "Whether the registry should be installed."
+  :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 'regexp)
+  :type 'integer)
 
 ;; Function(s) missing in Emacs 20
 (when (memq nil (mapcar 'fboundp '(puthash)))
@@ -61,11 +81,124 @@ The group names are matched, they don't have to be fully qualified."
     ;; alias puthash is missing from Emacs 20 cl-extra.el
     (defalias 'puthash 'cl-puthash)))
 
-(defun gnus-registry-translate-to-alist ()
-  (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb)))
-
-(defun gnus-registry-translate-from-alist ()
-  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
+(defun gnus-registry-cache-read ()
+  "Read the registry cache file."
+  (interactive)
+  (let ((file gnus-registry-cache-file))
+    (when (file-exists-p file)
+      (gnus-message 5 "Reading %s..." file)
+      (gnus-load file)
+      (gnus-message 5 "Reading %s...done" file))))
+
+(defun gnus-registry-cache-save ()
+  "Save the registry cache file."
+  (interactive)
+  (let ((file gnus-registry-cache-file))
+    (save-excursion
+      (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
+      (make-local-variable 'version-control)
+    (setq version-control gnus-backup-startup-file)
+    (setq buffer-file-name file)
+    (setq default-directory (file-name-directory buffer-file-name))
+    (buffer-disable-undo)
+    (erase-buffer)
+    (gnus-message 5 "Saving %s..." file)
+    (if gnus-save-startup-file-via-temp-buffer
+	(let ((coding-system-for-write gnus-ding-file-coding-system)
+	      (standard-output (current-buffer)))
+	  (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)
+	  (gnus-registry-cache-whitespace file)
+	  (save-buffer))
+      (let ((coding-system-for-write gnus-ding-file-coding-system)
+	    (version-control gnus-backup-startup-file)
+	    (startup-file file)
+	    (working-dir (file-name-directory file))
+	    working-file
+	    (i -1))
+	;; Generate the name of a non-existent file.
+	(while (progn (setq working-file
+			    (format
+			     (if (and (eq system-type 'ms-dos)
+				      (not (gnus-long-file-names)))
+				 "%s#%d.tm#" ; MSDOS limits files to 8+3
+			       (if (memq system-type '(vax-vms axp-vms))
+				   "%s$tmp$%d"
+				 "%s#tmp#%d"))
+			     working-dir (setq i (1+ i))))
+		      (file-exists-p working-file)))
+	
+	(unwind-protect
+	    (progn
+	      (gnus-with-output-to-file working-file
+		(gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
+	      
+	      ;; These bindings will mislead the current buffer
+	      ;; into thinking that it is visiting the startup
+	      ;; file.
+	      (let ((buffer-backed-up nil)
+		    (buffer-file-name startup-file)
+		    (file-precious-flag t)
+		    (setmodes (file-modes startup-file)))
+		;; Backup the current version of the startup file.
+		(backup-buffer)
+		
+		;; Replace the existing startup file with the temp file.
+		(rename-file working-file startup-file t)
+		(set-file-modes startup-file setmodes)))
+	  (condition-case nil
+	      (delete-file working-file)
+	    (file-error nil)))))
+    
+    (gnus-kill-buffer (current-buffer))
+    (gnus-message 5 "Saving %s...done" file))))
+
+;; 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)
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward "^(\\|(\\\"" nil t)
+      (replace-match "\n\\&" t))
+    (goto-char (point-min))
+    (while (re-search-forward " $" nil t)
+      (replace-match "" t t))))
+
+(defun gnus-registry-save (&optional force)
+;; TODO: delete entries with 0 groups
+  (when (or gnus-registry-dirty force)
+    (setq gnus-registry-alist (gnus-registry-trim 
+			       (hashtable-to-alist gnus-registry-hashtb)))
+    (gnus-registry-cache-save)
+    (setq gnus-registry-dirty nil)))
+
+(defun gnus-registry-read ()
+  (gnus-registry-cache-read)
+  (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."
@@ -159,8 +292,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 
 (defun gnus-registry-register-message-ids ()
   "Register the Message-ID of every article in the group"
-  (unless (and gnus-registry-unregistered-group-regex
-	       (string-match gnus-registry-unregistered-group-regex gnus-newsgroup-name))
+  (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
     (dolist (article gnus-newsgroup-articles)
       (let ((id (gnus-registry-fetch-message-id-fast article)))
 	(unless (gnus-registry-fetch-group id)
@@ -185,13 +317,19 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 		     (string-match x word))
 		   list)))))
 
-(defun gnus-registry-fetch-extra (id)
+(defun gnus-registry-fetch-extra (id &optional entry)
   "Get the extra data of a message, based on the message ID.
 Returns the first place where the trail finds a nonstring."
   (let ((trail (gethash id gnus-registry-hashtb)))
     (dolist (crumb trail)
       (unless (stringp crumb)
-	(return crumb)))))
+	(return (gnus-registry-fetch-extra-entry crumb entry))))))
+
+(defun gnus-registry-fetch-extra-entry (alist &optional entry)
+  "Get the extra data of a message, or a specific entry in it."
+  (if entry
+      (assq entry alist)
+    alist))
 
 (defun gnus-registry-store-extra (id extra)
   "Store the extra data of a message, based on the message ID.
@@ -201,7 +339,15 @@ 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."
+  (let* ((extra (gnus-registry-fetch-extra id))
+	 (alist (cons (cons key value)
+		 (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
+    (gnus-registry-store-extra id alist)))
 
 (defun gnus-registry-fetch-group (id)
   "Get the group of a message, based on the message ID.
@@ -211,7 +357,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."
@@ -231,8 +377,10 @@ 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)
   "Add a group for a message, based on the message ID."
@@ -240,32 +388,56 @@ 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)
 			(list group))
 		   gnus-registry-hashtb)
-	  (when extra (gnus-registry-store-extra id extra)))))))
+	  (when extra (gnus-registry-store-extra id extra))
+	  (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 
 (defun gnus-registry-clear ()
   "Clear the Gnus registry."
   (interactive)
-  (setq gnus-registry-alist nil 
-	gnus-registry-headers-alist nil)
-  (gnus-registry-translate-from-alist))
+  (setq gnus-registry-alist nil)
+  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+  (setq gnus-registry-dirty t))
 
-; also does copy, respool, and crosspost
-(add-hook 'gnus-summary-article-move-hook 'gnus-register-action) 
-(add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
-(add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
-(add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
-
-(add-hook 'gnus-save-newsrc-hook 'gnus-registry-translate-to-alist)
-(add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-translate-from-alist)
-
-(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
+(defun gnus-registry-install-hooks ()
+  "Install the registry hooks."
+  (interactive)
+  (add-hook 'gnus-summary-article-move-hook 'gnus-register-action) 
+  (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
+  (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
+  (add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
+  
+  (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
+  (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
+
+  (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))
 
 ;; TODO: a lot of things