diff options
Diffstat (limited to 'lisp/gnus/gnus-registry.el')
| -rw-r--r-- | lisp/gnus/gnus-registry.el | 75 |
1 files changed, 59 insertions, 16 deletions
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 009786dec80..e6c96ab2b19 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -31,7 +31,17 @@ ;; gnus-registry.el intercepts article respooling, moving, deleting, ;; and copying for all backends. If it doesn't work correctly for ;; you, submit a bug report and I'll be glad to fix it. It needs -;; documentation in the manual (also on my to-do list). +;; better documentation in the manual (also on my to-do list). + +;; If you want to track recipients (and you should to make the +;; gnus-registry splitting work better), you need the To and Cc +;; headers collected by Gnus. Note that in more recent Gnus versions +;; this is already the case: look at `gnus-extra-headers' to be sure. + +;; ;;; you may also want Gcc Newsgroups Keywords X-Face +;; (add-to-list 'gnus-extra-headers 'To) +;; (add-to-list 'gnus-extra-headers 'Cc) +;; (setq nnmail-extra-headers gnus-extra-headers) ;; Put this in your startup file (~/.gnus.el for instance) or use Customize: @@ -303,9 +313,10 @@ This is not required after changing `gnus-registry-cache-file'." (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) (subject (mail-header-subject data-header)) + (extra (mail-header-extra data-header)) (recipients (gnus-registry-sort-addresses - (or (cdr (assq "Cc" data-header)) "") - (or (cdr (assq "To" data-header)) ""))) + (or (cdr-safe (assq 'Cc extra)) "") + (or (cdr-safe (assq 'To extra)) ""))) (sender (nth 0 (gnus-registry-extract-addresses (mail-header-from data-header)))) (from (gnus-group-guess-full-name-from-command-method from)) @@ -323,9 +334,9 @@ This is not required after changing `gnus-registry-cache-file'." (defun gnus-registry-spool-action (id group &optional subject sender recipients) (let ((to (gnus-group-guess-full-name-from-command-method group)) (recipients (or recipients - (gnus-registry-sort-addresses - (or (message-fetch-field "cc") "") - (or (message-fetch-field "to") "")))) + (gnus-registry-sort-addresses + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") "")))) (subject (or subject (message-fetch-field "subject"))) (sender (or sender (message-fetch-field "from")))) (when (and (stringp id) (string-match "\r$" id)) @@ -341,6 +352,8 @@ This is not required after changing `gnus-registry-cache-file'." 10 "gnus-registry-handle-action %S" (list id from to subject sender recipients)) (let ((db gnus-registry-db) + ;; if the group is ignored, set the destination to nil (same as delete) + (to (if (gnus-registry-ignore-group-p to) nil to)) ;; safe if not found (entry (gnus-registry-get-or-make-entry id)) (subject (gnus-string-remove-all-properties @@ -402,8 +415,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (sender (gnus-string-remove-all-properties (message-fetch-field "from"))) (recipients (gnus-registry-sort-addresses - (or (message-fetch-field "cc") "") - (or (message-fetch-field "to") ""))) + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") ""))) (subject (gnus-string-remove-all-properties (gnus-registry-simplify-subject (message-fetch-field "subject")))) @@ -442,8 +455,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (gnus-message 9 "%s is looking up %s" log-agent reference) (loop for group in (gnus-registry-get-id-key reference 'group) when (gnus-registry-follow-group-p group) - do (gnus-message 7 "%s traced %s to %s" log-agent reference group) - do (push group found))) + do + (progn + (gnus-message 7 "%s traced %s to %s" log-agent reference group) + (push group found)))) ;; filter the found groups and return them ;; the found groups are the full groups (setq found (gnus-registry-post-process-groups @@ -468,7 +483,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (if gnus-registry-track-extra 7 9) "%s (extra tracking) traced subject '%s' to %s" log-agent subject group) - collect group)) + and collect group)) ;; filter the found groups and return them ;; the found groups are NOT the full groups (setq found (gnus-registry-post-process-groups @@ -495,7 +510,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (if gnus-registry-track-extra 7 9) "%s (extra tracking) traced sender '%s' to %s" log-agent sender group) - collect group))) + and collect group))) ;; filter the found groups and return them ;; the found groups are NOT the full groups @@ -525,7 +540,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (if gnus-registry-track-extra 7 9) "%s (extra tracking) traced recipient '%s' to %s" log-agent recp group) - collect group))))) + and collect group))))) ;; filter the found groups and return them ;; the found groups are NOT the full groups @@ -641,6 +656,34 @@ Consults `gnus-registry-unfollowed-groups' and group nnmail-split-fancy-with-parent-ignore-groups))))) +;; note that gnus-registry-ignored-groups is defined in gnus.el as a +;; group/topic parameter and an associated variable! + +;; we do special logic for ignoring to accept regular expressions and +;; nnmail-split-fancy-with-parent-ignore-groups as well +(defun gnus-registry-ignore-group-p (group) + "Determines if a group name should be ignored. +Consults `gnus-registry-ignored-groups' and +`nnmail-split-fancy-with-parent-ignore-groups'." + (and group + (or (gnus-grep-in-list + group + (delq nil (mapcar (lambda (g) + (cond + ((stringp g) g) + ((and (listp g) (nth 1 g)) + (nth 0 g)) + (t nil))) gnus-registry-ignored-groups))) + ;; only use `gnus-parameter-registry-ignore' if + ;; `gnus-registry-ignored-groups' is a list of lists + ;; (it can be a list of regexes) + (and (listp (nth 0 gnus-registry-ignored-groups)) + (get-buffer "*Group*") ; in automatic tests this is false + (gnus-parameter-registry-ignore group)) + (gnus-grep-in-list + group + nnmail-split-fancy-with-parent-ignore-groups)))) + (defun gnus-registry-wash-for-keywords (&optional force) "Get the keywords of the current article. Overrides existing keywords with FORCE set non-nil." @@ -712,7 +755,7 @@ Addresses without a name will say \"noname\"." (defun gnus-registry-sort-addresses (&rest addresses) "Return a normalized and sorted list of ADDRESSES." (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses)) - 'string-lessp)) + 'string-lessp)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) @@ -743,7 +786,7 @@ Addresses without a name will say \"noname\"." (assoc article (gnus-data-list nil))) (gnus-string-remove-all-properties (cdr (assq header (gnus-data-header - (assoc article (gnus-data-list nil)))))) + (assoc article (gnus-data-list nil)))))) nil)) ;; registry marks glue @@ -972,7 +1015,7 @@ only the last one's marks are returned." extra-cell key val) ;; remove all the strings from the entry (dolist (elem rest) - (if (stringp elem) (setq rest (delq elem rest)))) + (if (stringp elem) (setq rest (delq elem rest)))) (gnus-registry-set-id-key id 'group groups) ;; just use the first extra element (setq rest (car-safe rest)) |