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

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index e5aed7c24..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,15 +43,37 @@
 (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-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 'integer)
+
 ;; Function(s) missing in Emacs 20
 (when (memq nil (mapcar 'fboundp '(puthash)))
   (require 'cl)
@@ -56,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."
@@ -94,9 +232,13 @@ The group names are matched, they don't have to be fully qualified."
 		  from
 		  to)
 
-    (cond
-     ((equal 'delete action) (gnus-registry-delete-group id from))
-     (t (gnus-registry-add-group id to)))))
+    ;; All except copy will need a delete
+    (gnus-registry-delete-group id from)
+
+    (when (equal 'copy action) 
+      (gnus-registry-add-group id from)) ; undo the delete
+
+    (gnus-registry-add-group id to)))
 
 (defun gnus-register-spool-action (id group)
   ;; do not process the draft IDs
@@ -125,8 +267,11 @@ see which group that message was put in.  This group is returned.
 See the Info node `(gnus)Fancy Mail Splitting' for more details."
   (let ((refstr (or (message-fetch-field "references")
 		    (message-fetch-field "in-reply-to")))
-	(references nil)
-	(res nil))
+	(nnmail-split-fancy-with-parent-ignore-groups
+	 (if (listp nnmail-split-fancy-with-parent-ignore-groups)
+	     nnmail-split-fancy-with-parent-ignore-groups
+	   (list nnmail-split-fancy-with-parent-ignore-groups)))
+	references res)
     (when refstr
       (setq references (nreverse (gnus-split-references refstr)))
       (mapcar (lambda (x)
@@ -139,64 +284,160 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 			   nnmail-split-fancy-with-parent-ignore-groups))
 		  (setq res nil)))
 	      references)
+      (gnus-message 
+       5 
+       "gnus-registry-split-fancy-with-parent traced %s to group %s"
+       refstr (if res res "nil"))
       res)))
 
+(defun gnus-registry-register-message-ids ()
+  "Register the Message-ID of every article in the group"
+  (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)
+	  (gnus-message 9 "Registry: Registering article %d with group %s" 
+			article gnus-newsgroup-name)
+	  (gnus-registry-add-group (gnus-registry-fetch-message-id-fast article)
+				   gnus-newsgroup-name))))))
+
+(defun gnus-registry-fetch-message-id-fast (article)
+  "Fetch the Message-ID quickly, using the internal gnus-data-list function"
+  (if (and (numberp article)
+	   (assoc article (gnus-data-list nil)))
+      (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
+    nil))
+
 (defun gnus-registry-grep-in-list (word list)
-  (memq nil
-	(mapcar 'not
-	 (mapcar 
-	  (lambda (x)
-	    (string-match x word))
-	  list))))
+  (when word
+    (memq nil
+	  (mapcar 'not
+		  (mapcar 
+		   (lambda (x)
+		     (string-match x word))
+		   list)))))
+
+(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 (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.
+The message must have at least one group name."
+  (when (gnus-registry-group-count id)
+    ;; we now know the trail has at least 1 group name, so it's not empty
+    (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)
+      (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.
-Returns the first place where the trail finds a spool action."
+Returns the first place where the trail finds a group name."
+  (when (gnus-registry-group-count id)
+    ;; we now know the trail has at least 1 group name
+    (let ((trail (gethash id gnus-registry-hashtb)))
+      (dolist (crumb trail)
+	(when (stringp 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."
   (let ((trail (gethash id gnus-registry-hashtb)))
-    (if trail
-	(car trail)
-      nil)))
+    (if (and trail (listp trail))
+	(apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
+      0)))
 
 (defun gnus-registry-delete-group (id group)
-  "Get the group of a message, based on the message ID.
-Returns the first place where the trail finds a spool action."
-  (let ((trail (gethash id gnus-registry-hashtb))
-	(group (gnus-group-short-name group)))
-    (puthash id (if trail
-		    (delete group trail)
-		  nil)
-    gnus-registry-hashtb))
-  ;; now, clear the entry if it's empty
-  (unless (gethash id gnus-registry-hashtb)
-    (remhash id gnus-registry-hashtb)))
-
-(defun gnus-registry-add-group (id group)
-  "Get the group of a message, based on the message ID.
-Returns the first place where the trail finds a spool action."
+  "Delete a group for a message, based on the message ID."
+  (when group
+    (when id
+      (let ((trail (gethash id gnus-registry-hashtb))
+	    (group (gnus-group-short-name group)))
+	(puthash id (if trail
+			(delete group trail)
+		      nil)
+		 gnus-registry-hashtb))
+      ;; now, clear the entry if there are no more groups
+      (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."
   ;; make sure there are no duplicate entries
-  (let ((group (gnus-group-short-name group)))
-    (gnus-registry-delete-group id group)	
-    (let ((trail (gethash id gnus-registry-hashtb)))
-      (puthash id (if trail
-		      (cons group trail)
-		    (list group))
-	       gnus-registry-hashtb))))
+  (when group
+    (when (and id
+	       (not (string-match "totally-fudged-out-message-id" id)))
+      (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))
+	  (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))
-
-; 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)
+  (setq gnus-registry-alist nil)
+  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+  (setq gnus-registry-dirty t))
+
+(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