From 1c69b0596a96f3f9808bf33b1f8274fb1ff6e663 Mon Sep 17 00:00:00 2001 From: Teodor Zlatanov Date: Thu, 6 Nov 2003 22:32:39 +0000 Subject: [PATCH] * gnus.el (gnus-group-guess-full-name-from-command-method): new function * gnus-registry.el (gnus-registry-fetch-group): use long names if requested (gnus-registry-split-fancy-with-parent): when long names are in use, strip the name if we're in the native server, or else return nothing (gnus-registry-spool-action, gnus-registry-action): use gnus-group-guess-full-name-from-command-method instead of gnus-group-guess-full-name --- lisp/ChangeLog | 18 ++++++++++++--- lisp/gnus-registry.el | 52 ++++++++++++++++++++++++++++++------------- lisp/gnus.el | 6 +++++ 3 files changed, 57 insertions(+), 19 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index de0b984e8..776f89e35 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,13 +1,25 @@ -2003-11-06 Teodor Zlatanov suggested by Jean-Marc Lasgouttes +2003-11-06 Teodor Zlatanov + + * gnus.el (gnus-group-guess-full-name-from-command-method): new function + + * gnus-registry.el (gnus-registry-fetch-group): use long names if + requested + (gnus-registry-split-fancy-with-parent): when long names are in + use, strip the name if we're in the native server, or else return nothing + (gnus-registry-spool-action, gnus-registry-action): use + gnus-group-guess-full-name-from-command-method instead of + gnus-group-guess-full-name * spam.el (spam-mark-spam-as-expired-and-move-routine) (spam-ham-copy-or-move-routine): prevent article deletions or moves unless the backend allows it * gnus.el (gnus-install-group-spam-parameters): fixed parameters - to list spamoracle as well + to list spamoracle as well, suggested by Jean-Marc Lasgouttes + - * spam.el (spam-spamoracle): doc change + * spam.el (spam-spamoracle): doc change, suggested by Jean-Marc + Lasgouttes 2003-11-04 Katsumi Yamaoka diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 64040aeba..18f61217c 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -301,8 +301,8 @@ tracked this way." (let* ((id (mail-header-id data-header)) (subject (gnus-registry-simplify-subject (mail-header-subject data-header))) - (from (gnus-group-guess-full-name from)) - (to (if to (gnus-group-guess-full-name to) nil)) + (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")) (old-entry (gethash id gnus-registry-hashtb))) (gnus-message 5 "Registry: article %s %s from %s to %s" @@ -320,16 +320,13 @@ tracked this way." (gnus-registry-add-group id to subject))) (defun gnus-registry-spool-action (id group &optional subject) - ;; do not process the draft IDs -; (unless (string-match "totally-fudged-out-message-id" id) -; (let ((group (gnus-group-guess-full-name group))) - (when (and (stringp id) (string-match "\r$" id)) - (setq id (substring id 0 -1))) - (gnus-message 5 "Registry: article %s spooled to %s" - id - group) - (gnus-registry-add-group id group subject)) -;) + (let ((group (gnus-group-guess-full-name-from-command-method group))) + (when (and (stringp id) (string-match "\r$" id)) + (setq id (substring id 0 -1))) + (gnus-message 5 "Registry: article %s spooled to %s" + id + group) + (gnus-registry-add-group id group subject))) ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. @@ -379,7 +376,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (setq res (gnus-registry-fetch-group key)) (gnus-message ;; raise level of messaging if gnus-registry-track-extra - (if gnus-registry-track-extra 5 9) + (if gnus-registry-track-extra 5 9) "%s (extra tracking) traced subject %s to group %s" "gnus-registry-split-fancy-with-parent" subject @@ -389,6 +386,26 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 5 "gnus-registry-split-fancy-with-parent traced %s to group %s" refstr (if res res "nil")) + + (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 + (gnus-message + 9 + "gnus-registry-split-fancy-with-parent stripped group %s to %s" + res + short-res) + (setq res short-res)) + ;; else... + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent ignored foreign group %s" + res) + (setq res nil)))) res)) (defun gnus-registry-register-message-ids () @@ -506,7 +523,9 @@ 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 (gnus-group-short-name crumb))))))) + (return (if gnus-registry-use-long-group-names + crumb + (gnus-group-short-name crumb)))))))) (defun gnus-registry-group-count (id) "Get the number of groups of a message, based on the message ID." @@ -543,7 +562,6 @@ Returns the first place where the trail finds a group name." (defun gnus-registry-add-group (id group &optional subject) "Add a group for a message, based on the message ID." - ;; make sure there are no duplicate entries (when group (when (and id (not (string-match "totally-fudged-out-message-id" id))) @@ -552,8 +570,10 @@ Returns the first place where the trail finds a group name." group (gnus-group-short-name group)))) (gnus-registry-delete-group id group) - (unless gnus-registry-use-long-group-names + + (unless gnus-registry-use-long-group-names ;; unnecessary in this case (gnus-registry-delete-group id full-group)) + (let ((trail (gethash id gnus-registry-hashtb))) (puthash id (if trail (cons group trail) diff --git a/lisp/gnus.el b/lisp/gnus.el index 2a8a920ef..03c0653dc 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -3266,6 +3266,12 @@ server is native)." group (gnus-group-full-name group (gnus-find-method-for-group group)))) +(defun gnus-group-guess-full-name-from-command-method (group) + "Guess the full name from GROUP, even if the method is native." + (if (gnus-group-prefixed-p group) + group + (gnus-group-full-name group gnus-command-method))) + (defun gnus-group-real-prefix (group) "Return the prefix of the current group name." (if (string-match "^[^:]+:" group) -- 2.34.1