;; 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:
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
(subject (mail-header-subject data-header))
- (recipients (sort (mapcan 'gnus-registry-extract-addresses
- (list
- (or (ignore-errors
- (mail-header "Cc" data-header))
- "")
- (or (ignore-errors
- (mail-header "To" data-header))
- "")))
- 'string-lessp))
+ (extra (mail-header-extra data-header))
+ (recipients (gnus-registry-sort-addresses
+ (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))
(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
- (sort (mapcan 'gnus-registry-extract-addresses
- (list
- (or (message-fetch-field "cc") "")
- (or (message-fetch-field "to") "")))
- 'string-lessp)))
+ (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))
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
(gnus-message 10 "Gnus registry: new entry for %s is %S"
id
entry)
- (registry-insert db id entry)))
+ (gnus-registry-insert db id entry)))
;; Function for nn{mail|imap}-split-fancy: look up all references in
;; the cache and if a match is found, return that group.
;; these may not be used, but the code is cleaner having them up here
(sender (gnus-string-remove-all-properties
(message-fetch-field "from")))
- (recipients (sort (mapcan 'gnus-registry-extract-addresses
- (list
- (or (message-fetch-field "cc") "")
- (or (message-fetch-field "to") "")))
- 'string-lessp))
+ (recipients (gnus-registry-sort-addresses
+ (or (message-fetch-field "cc") "")
+ (or (message-fetch-field "to") "")))
(subject (gnus-string-remove-all-properties
(gnus-registry-simplify-subject
(message-fetch-field "subject"))))
(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
(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
(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
(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
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."
(format "%s <%s>" name addr))))
(mail-extract-address-components text t)))
+(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))
+
(defun gnus-registry-simplify-subject (subject)
(if (stringp subject)
(gnus-simplify-subject subject)
(gnus-registry-fetch-header-fast "from" article))
(defun gnus-registry-fetch-recipients-fast (article)
- (sort (mapcan 'gnus-registry-extract-addresses
- (list
- (or (ignore-errors
- (gnus-registry-fetch-header-fast "Cc" article))
- "")
- (or (ignore-errors
- (gnus-registry-fetch-header-fast "To" article))
- "")))
- 'string-lessp))
+ (gnus-registry-sort-addresses
+ (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
+ (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
(defun gnus-registry-fetch-header-fast (article header)
"Fetch the HEADER quickly, using the internal gnus-data-list function"
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(gnus-string-remove-all-properties
- (mail-header header (gnus-data-header
- (assoc article (gnus-data-list nil)))))
+ (cdr (assq header (gnus-data-header
+ (assoc article (gnus-data-list nil))))))
nil))
;; registry marks glue
(entries (registry-lookup db (list id))))
(when (null entries)
- (registry-insert db id (list (list 'creation-time (current-time))
- '(group) '(sender) '(subject)))
+ (gnus-registry-insert db id (list (list 'creation-time (current-time))
+ '(group) '(sender) '(subject)))
(setq entries (registry-lookup db (list id))))
(nth 1 (assoc id entries))))
(entry (gnus-registry-get-or-make-entry id)))
(registry-delete db (list id) nil)
(setq entry (cons (cons key vals) (assq-delete-all key entry)))
- (registry-insert db id entry)
+ (gnus-registry-insert db id entry)
entry))
+(defun gnus-registry-insert (db id entry)
+ "Just like `registry-insert' but tries to prune on error."
+ (when (registry-full db)
+ (message "Trying to prune the registry because it's full")
+ (registry-prune db))
+ (registry-insert db id entry)
+ entry)
+
(defun gnus-registry-import-eld (file)
(interactive "fOld registry file to import? ")
;; example content:
collect p))
extra-cell key val)
;; remove all the strings from the entry
- (delete* nil rest :test (lambda (a b) (stringp b)))
+ (dolist (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))
(should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
(should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4")))
(message "Trying to insert a duplicate key")
- (should-error (registry-insert db "55" '()))
+ (should-error (gnus-registry-insert db "55" '()))
(message "Looking up individual keys (gnus-registry-get-or-make-entry)")
(should (gnus-registry-get-or-make-entry "22"))
(message "Saving the Gnus registry to %s" tempfile)
projects / gnus / blobdiff