X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/0b6799c345f8b7ffd5295fce000c615928ab7cde..cbee283dd7dd655124e81a6bd555506476180b5d:/lisp/gnus/gnus-registry.el

diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index 4c2e77e4d4..b5ec4e1ae5 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -79,17 +79,51 @@
   "*The article registry by Message ID.")
 
 (defcustom gnus-registry-marks
-  '(Important Work Personal To-Do Later)
-  "List of marks that `gnus-registry-mark-article' will offer for completion."
+  '((Important
+     :char ?i
+     :image "summary_important")
+    (Work
+     :char ?w
+     :image "summary_work")
+    (Personal
+     :char ?p
+     :image "summary_personal")
+    (To-Do
+     :char ?t
+     :image "summary_todo")
+    (Later
+     :char ?l
+     :image "summary_later"))
+
+  "List of registry marks and their options.
+
+`gnus-registry-mark-article' will offer symbols from this list
+for completion.  
+
+Each entry must have a character to be useful for summary mode
+line display and for keyboard shortcuts.
+
+Each entry must have an image string to be useful for visual
+display."
   :group 'gnus-registry
-  :type '(repeat symbol))
+  :type '(repeat :tag "Registry Marks"
+		 (cons :tag "Mark"
+		       (symbol :tag "Name")
+		       (checklist :tag "Options" :greedy t
+				  (group :inline t
+					 (const :format "" :value :char)
+					 (character :tag "Character code"))
+				  (group :inline t
+					 (const :format "" :value :image)
+					 (string :tag "Image"))))))
 
 (defcustom gnus-registry-default-mark 'To-Do
-  "The default mark."
+  "The default mark.  Should be a valid key for `gnus-registry-marks'."
   :group 'gnus-registry
   :type 'symbol)
 
-(defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$")
+(defcustom gnus-registry-unfollowed-groups 
+  '("delayed$" "drafts$" "queue$" "INBOX$")
   "List of groups that gnus-registry-split-fancy-with-parent won't return.
 The group names are matched, they don't have to be fully
 qualified.  This parameter tells the Registry 'never split a
@@ -98,10 +132,12 @@ references.'"
   :group 'gnus-registry
   :type '(repeat regexp))
 
-(defcustom gnus-registry-install nil
+(defcustom gnus-registry-install 'ask
   "Whether the registry should be installed."
   :group 'gnus-registry
-  :type 'boolean)
+  :type '(choice (const :tag "Never Install" nil)
+		 (const :tag "Always Install" t)
+		 (const :tag "Ask Me" ask)))
 
 (defcustom gnus-registry-clean-empty t
   "Whether the empty registry entries should be deleted.
@@ -197,7 +233,8 @@ considered precious) will not be trimmed."
     (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-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)
@@ -221,7 +258,8 @@ considered precious) will not be trimmed."
 	(unwind-protect
 	    (progn
 	      (gnus-with-output-to-file working-file
-		(gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
+		(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
@@ -334,7 +372,6 @@ considered precious) will not be trimmed."
 
 (defun gnus-registry-trim (alist)
   "Trim alist to size, using gnus-registry-max-entries.
-Also, drop all gnus-registry-ignored-groups matches.
 Any entries with extra data (marks, currently) are left alone."
   (if (null gnus-registry-max-entries)      
       alist                             ; just return the alist
@@ -360,7 +397,7 @@ Any entries with extra data (marks, currently) are left alone."
        gnus-registry-hashtb)
 
       (dolist (item alist)
-	(let ((key (nth 0 item)))	      
+	(let ((key (nth 0 item)))
 	  (if (gethash key precious)
 	      (push item precious-list)
 	    (push item junk-list))))
@@ -383,7 +420,8 @@ Any entries with extra data (marks, currently) are left alone."
 	 (subject (gnus-string-remove-all-properties
 		   (gnus-registry-simplify-subject
 		    (mail-header-subject data-header))))
-	 (sender (gnus-string-remove-all-properties (mail-header-from data-header)))
+	 (sender (gnus-string-remove-all-properties 
+		  (mail-header-from data-header)))
 	 (from (gnus-group-guess-full-name-from-command-method from))
 	 (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
 	 (to-name (if to to "the Bit Bucket"))
@@ -426,119 +464,156 @@ messages.
 For a message to be split, it looks for the parent message in the
 References or In-Reply-To header and then looks in the registry
 to see which group that message was put in.  This group is
-returned, unless it matches one of the entries in
-gnus-registry-unfollowed-groups or
-nnmail-split-fancy-with-parent-ignore-groups.
+returned, unless `gnus-registry-follow-group-p' return nil for
+that group.
 
 See the Info node `(gnus)Fancy Mail Splitting' for more details."
-  (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string
-	 (reply-to (message-fetch-field "in-reply-to"))	     ; grab reply-to
+  (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
+	 (reply-to (message-fetch-field "in-reply-to"))	     ; may be nil
 	 ;; now, if reply-to is valid, append it to the References
 	 (refstr (if reply-to 
 		     (concat refstr " " reply-to)
 		   refstr))
-	(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)))
-	res)
-    ;; the references string must be valid and parse to valid references
-    (if (and refstr (gnus-extract-references refstr))
-	(dolist (reference (nreverse (gnus-extract-references refstr)))
-	  (setq res (or (gnus-registry-fetch-group reference) res))
-	  (when (or (gnus-registry-grep-in-list
-		     res
-		     gnus-registry-unfollowed-groups)
-		    (gnus-registry-grep-in-list
-		     res
-		     nnmail-split-fancy-with-parent-ignore-groups))
-	    (setq res nil)))
-
-      ;; else: there were no references, now try the extra tracking
-      (let ((sender (gnus-string-remove-all-properties(message-fetch-field "from")))
-	    (subject (gnus-string-remove-all-properties
-		      (gnus-registry-simplify-subject
-		       (message-fetch-field "subject"))))
-	    (single-match t))
-	(when (and single-match
-		   (gnus-registry-track-sender-p)
-		   sender)
-	  (maphash
-	   (lambda (key value)
-	     (let ((this-sender (cdr
-				 (gnus-registry-fetch-extra key 'sender))))
-	       (when (and single-match
-			  this-sender
-			  (equal sender this-sender))
-		 ;; too many matches, bail
-		 (unless (equal res (gnus-registry-fetch-group key))
-		   (setq single-match nil))
-		 (setq res (gnus-registry-fetch-group key))
-		 (when (and sender res)
-		   (gnus-message
-		    ;; raise level of messaging if gnus-registry-track-extra
-		    (if gnus-registry-track-extra 7 9)
-		    "%s (extra tracking) traced sender %s to group %s"
-		    "gnus-registry-split-fancy-with-parent"
-		    sender
-		    res)))))
-	   gnus-registry-hashtb))
-	(when (and single-match
-		   (gnus-registry-track-subject-p)
-		   subject
-		   (< gnus-registry-minimum-subject-length (length subject)))
-	  (maphash
-	   (lambda (key value)
-	     (let ((this-subject (cdr
-				  (gnus-registry-fetch-extra key 'subject))))
-	       (when (and single-match
-			  this-subject
-			  (equal subject this-subject))
-		 ;; too many matches, bail
-		 (unless (equal res (gnus-registry-fetch-group key))
-		   (setq single-match nil))
-		 (setq res (gnus-registry-fetch-group key))
-		 (when (and subject res)
-		   (gnus-message
-		    ;; raise level of messaging if gnus-registry-track-extra
-		    (if gnus-registry-track-extra 7 9)
-		    "%s (extra tracking) traced subject %s to group %s"
-		    "gnus-registry-split-fancy-with-parent"
-		    subject
-		    res)))))
-	   gnus-registry-hashtb))
-	(unless single-match
-	  (gnus-message
-	   3
-	   "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
-	   refstr)
-	  (setq res nil))))
-    (when (and refstr res)
-      (gnus-message
-       5
-       "gnus-registry-split-fancy-with-parent traced %s to group %s"
-       refstr res))
-
-    (when (and res gnus-registry-use-long-group-names)
-      (let ((m1 (gnus-find-method-for-group res))
-	    (m2 (or gnus-command-method
-		    (gnus-find-method-for-group gnus-newsgroup-name)))
-	    (short-res (gnus-group-short-name res)))
-      (if (gnus-methods-equal-p m1 m2)
-	  (progn
+	 ;; these may not be used, but the code is cleaner having them up here
+	 (sender (gnus-string-remove-all-properties
+		  (message-fetch-field "from")))
+	 (subject (gnus-string-remove-all-properties
+		   (gnus-registry-simplify-subject
+		    (message-fetch-field "subject"))))
+
+	 (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)))
+	 (log-agent "gnus-registry-split-fancy-with-parent")
+	 found)
+
+    ;; this is a big if-else statement.  it uses
+    ;; gnus-registry-post-process-groups to filter the results after
+    ;; every step.
+    (cond
+     ;; the references string must be valid and parse to valid references
+     ((and refstr (gnus-extract-references refstr))
+      (dolist (reference (nreverse (gnus-extract-references refstr)))
+	(gnus-message
+	 9
+	 "%s is looking for matches for reference %s from [%s]"
+	 log-agent reference refstr)
+	(dolist (group (gnus-registry-fetch-groups reference))
+	  (when (and group (gnus-registry-follow-group-p group))
 	    (gnus-message
-	     9
-	     "gnus-registry-split-fancy-with-parent stripped group %s to %s"
-	     res
-	     short-res)
-	    (setq res short-res))
-	;; else...
+	     7
+	     "%s traced the reference %s from [%s] to group %s"
+	     log-agent reference refstr group)
+	    (push group found))))
+      ;; filter the found groups and return them
+      (setq found (gnus-registry-post-process-groups 
+		   "references" refstr found)))
+
+     ;; else: there were no matches, now try the extra tracking by sender
+     ((and (gnus-registry-track-sender-p) 
+	   sender)
+      (maphash
+       (lambda (key value)
+	 (let ((this-sender (cdr
+			     (gnus-registry-fetch-extra key 'sender)))
+	       matches)
+	   (when (and this-sender
+		      (equal sender this-sender))
+	     (let ((groups (gnus-registry-fetch-groups key)))
+	       (dolist (group groups)
+		 (setq found (append (list group) (delete group found)))))
+	     (push key matches)
+	     (gnus-message
+	      ;; raise level of messaging if gnus-registry-track-extra
+	      (if gnus-registry-track-extra 7 9)
+	      "%s (extra tracking) traced sender %s to groups %s (keys %s)"
+	      log-agent sender found matches))))
+       gnus-registry-hashtb)
+      ;; filter the found groups and return them
+      (setq found (gnus-registry-post-process-groups "sender" sender found)))
+      
+     ;; else: there were no matches, now try the extra tracking by subject
+     ((and (gnus-registry-track-subject-p)
+	   subject
+	   (< gnus-registry-minimum-subject-length (length subject)))
+      (maphash
+       (lambda (key value)
+	 (let ((this-subject (cdr
+			      (gnus-registry-fetch-extra key 'subject)))
+	       matches)
+	   (when (and this-subject
+		      (equal subject this-subject))
+	     (let ((groups (gnus-registry-fetch-groups key)))
+	       (dolist (group groups)
+		 (setq found (append (list group) (delete group found)))))
+	     (push key matches)
+	     (gnus-message
+	      ;; raise level of messaging if gnus-registry-track-extra
+	      (if gnus-registry-track-extra 7 9)
+	      "%s (extra tracking) traced subject %s to groups %s (keys %s)"
+	      log-agent subject found matches))))
+       gnus-registry-hashtb)
+      ;; filter the found groups and return them
+      (setq found (gnus-registry-post-process-groups 
+		   "subject" subject found))))))
+
+(defun gnus-registry-post-process-groups (mode key groups)
+  "Modifies GROUPS found by MODE for KEY to determine which ones to follow.
+
+MODE can be 'subject' or 'sender' for example.  The KEY is the
+value by which MODE was searched.
+
+Transforms each group name to the equivalent short name.
+
+Checks if the current Gnus method (from `gnus-command-method' or
+from `gnus-newsgroup-name') is the same as the group's method.
+This is not possible if gnus-registry-use-long-group-names is
+false.  Foreign methods are not supported so they are rejected.
+
+Reduces the list to a single group, or complains if that's not
+possible."
+  (let ((log-agent "gnus-registry-post-process-group")
+	out)
+    (if gnus-registry-use-long-group-names
+	(dolist (group groups)
+	  (let ((m1 (gnus-find-method-for-group group))
+		(m2 (or gnus-command-method
+			(gnus-find-method-for-group gnus-newsgroup-name)))
+		(short-name (gnus-group-short-name group)))
+	    (if (gnus-methods-equal-p m1 m2)
+		(progn
+		  ;; this is REALLY just for debugging
+		  (gnus-message
+		   10
+		   "%s stripped group %s to %s"
+		   log-agent group short-name)
+		  (unless (member short-name out)
+		    (push short-name out)))
+	      ;; else...
+	      (gnus-message
+	       7
+	       "%s ignored foreign group %s"
+	       log-agent group))))
+      (setq out groups))
+    (when (cdr-safe out)
 	(gnus-message
-	 7
-	 "gnus-registry-split-fancy-with-parent ignored foreign group %s"
-	 res)
-	(setq res nil))))
-    res))
+	 5
+	 "%s: too many extra matches (%s) for %s %s.  Returning none."
+	 log-agent out mode key)
+	(setq out nil))
+    out))
+
+(defun gnus-registry-follow-group-p (group)
+  "Determines if a group name should be followed.
+Consults `gnus-registry-unfollowed-groups' and
+`nnmail-split-fancy-with-parent-ignore-groups'."
+  (not (or (gnus-registry-grep-in-list
+	    group
+	    gnus-registry-unfollowed-groups)
+	   (gnus-registry-grep-in-list
+	    group
+	    nnmail-split-fancy-with-parent-ignore-groups))))
 
 (defun gnus-registry-wash-for-keywords (&optional force)
   (interactive)
@@ -578,11 +653,11 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
   (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)
+	(unless (member gnus-newsgroup-name (gnus-registry-fetch-groups 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-registry-add-group 
+	   id 
 	   gnus-newsgroup-name
 	   (gnus-registry-fetch-simplified-message-subject-fast article)
 	   (gnus-registry-fetch-sender-fast article)))))))
@@ -628,6 +703,101 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 		     (string-match word x))
 		   list)))))
 
+(defun gnus-registry-do-marks (type function)
+  "For each known mark, call FUNCTION for each cell of type TYPE.
+
+FUNCTION should take two parameters, a mark symbol and the cell value."
+  (dolist (mark-info gnus-registry-marks)
+    (let* ((mark (car-safe mark-info))
+	   (data (cdr-safe mark-info))
+	   (cell-data (plist-get data type)))
+      (when cell-data
+	(funcall function mark cell-data)))))
+
+;;; this is ugly code, but I don't know how to do it better
+(defun gnus-registry-install-shortcuts ()
+  "Install the keyboard shortcuts and menus for the registry.
+Uses `gnus-registry-marks' to find what shortcuts to install."
+  (let (keys-plist)
+    (gnus-registry-do-marks 
+     :char
+     (lambda (mark data)
+       (let ((function-format
+	      (format "gnus-registry-%%s-article-%s-mark" mark)))
+
+;;; The following generates these functions:
+;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
+;;;   "Apply the Important mark to process-marked ARTICLES."
+;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
+;;;   (gnus-registry-set-article-mark-internal 'Important articles nil t))
+;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
+;;;   "Apply the Important mark to process-marked ARTICLES."
+;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
+;;;   (gnus-registry-set-article-mark-internal 'Important articles t t))
+
+	 (dolist (remove '(t nil))
+	   (let* ((variant-name (if remove "remove" "set"))
+		  (function-name (format function-format variant-name))
+		  (shortcut (format "%c" data))
+		  (shortcut (if remove (upcase shortcut) shortcut)))
+	     (unintern function-name)
+	     (eval
+	      `(defun 
+		 ;; function name
+		 ,(intern function-name) 
+		 ;; parameter definition
+		 (&rest articles)
+		 ;; documentation
+		 ,(format 
+		   "%s the %s mark over process-marked ARTICLES."
+		   (upcase-initials variant-name)
+		   mark)
+		 ;; interactive definition
+		 (interactive 
+		  (gnus-summary-work-articles current-prefix-arg))
+		 ;; actual code
+
+		 ;; if this is called and the user doesn't want the
+		 ;; registry enabled, we'll ask anyhow
+		 (when (eq gnus-registry-install nil)
+		   (setq gnus-registry-install 'ask))
+
+		 ;; now the user is asked if gnus-registry-install is 'ask
+		 (when (gnus-registry-install-p)
+		   (gnus-registry-set-article-mark-internal 
+		    ;; all this just to get the mark, I must be doing it wrong
+		    (intern ,(symbol-name mark))
+		    articles ,remove t)
+		   (dolist (article articles)
+		     (gnus-summary-update-article 
+		      article 
+		      (assoc article (gnus-data-list nil)))))))
+	     (push (intern function-name) keys-plist)
+	     (push shortcut keys-plist)
+	     (gnus-message 
+	      9 
+	      "Defined mark handling function %s" 
+	      function-name))))))
+    (gnus-define-keys-1
+     '(gnus-registry-mark-map "M" gnus-summary-mark-map) 
+     keys-plist)))
+
+;;; use like this:
+;;; (defalias 'gnus-user-format-function-M 
+;;;           'gnus-registry-user-format-function-M)
+(defun gnus-registry-user-format-function-M (headers)
+  (let* ((id (mail-header-message-id headers))
+	 (marks (when id (gnus-registry-fetch-extra-marks id))))
+    (apply 'concat (mapcar (lambda(mark)
+			     (let ((c 
+				    (plist-get
+				     (cdr-safe 
+				      (assoc mark gnus-registry-marks))
+				     :char)))
+			       (if c
+				   (list c)
+				 nil)))
+			   marks))))
 
 (defun gnus-registry-read-mark ()
   "Read a mark name from the user with completion."
@@ -635,7 +805,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 	       (symbol-name gnus-registry-default-mark)
 	       "Label" 
 	       (mapcar (lambda (x)	; completion list
-			 (cons (symbol-name x) x))
+			 (cons (symbol-name (car-safe x)) (car-safe x)))
 		       gnus-registry-marks))))
     (when (stringp mark)
       (intern mark))))
@@ -894,9 +1064,12 @@ Returns the first place where the trail finds a group name."
 
 ;;;###autoload
 (defun gnus-registry-initialize ()
+"Initialize the Gnus registry."
   (interactive)
-  (setq gnus-registry-install t)
+  (gnus-message 5 "Initializing the registry")
+  (setq gnus-registry-install t)	; in case it was 'ask or nil
   (gnus-registry-install-hooks)
+  (gnus-registry-install-shortcuts)
   (gnus-registry-read))
 
 ;;;###autoload
@@ -928,13 +1101,26 @@ Returns the first place where the trail finds a group name."
 
 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
 
-(when gnus-registry-install
-  (gnus-registry-install-hooks)
-  (gnus-registry-read))
-
-;; TODO: a lot of things
+(defun gnus-registry-install-p ()
+  (interactive)
+  (when (eq gnus-registry-install 'ask)
+    (setq gnus-registry-install
+	  (gnus-y-or-n-p
+	   (concat "Enable the Gnus registry?  "
+		   "See the variable `gnus-registry-install' "
+		   "to get rid of this query permanently. ")))
+    (when gnus-registry-install
+      ;; we just set gnus-registry-install to t, so initialize the registry!
+      (gnus-registry-initialize)))
+;;; we could call it here: (customize-variable 'gnus-registry-install)
+  gnus-registry-install)
+
+(when (gnus-registry-install-p)
+  (gnus-registry-initialize))
+
+;; TODO: a few things
 
 (provide 'gnus-registry)
 
-;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
+;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
 ;;; gnus-registry.el ends here