- (let ((refstr (or (message-fetch-field "references")
- (message-fetch-field "in-reply-to")))
- (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)
- (if refstr
- (progn
- (setq references (nreverse (gnus-split-references refstr)))
- (mapcar (lambda (x)
- (setq res (or (gnus-registry-fetch-group x) 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)))
- references))
- ;; there were no references, now try the extra tracking
- (when gnus-registry-track-extra
- (let ((subject (gnus-registry-simplify-subject
- (message-fetch-field "subject"))))
- (when (and subject
- (< gnus-registry-minimum-subject-length (length subject)))
- (maphash
- (lambda (key value)
- (let ((this-subject (cdr
- (gnus-registry-fetch-extra key 'subject))))
- (when (and this-subject
- (equal subject this-subject))
- (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)
- "%s (extra tracking) traced subject %s to group %s"
- "gnus-registry-split-fancy-with-parent"
- subject
- (if res res "nil")))))
- gnus-registry-hashtb)))))
- (gnus-message
- 5
- "gnus-registry-split-fancy-with-parent traced %s to group %s"
- refstr (if res res "nil"))
- res))
+ (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))
+ ;; 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 found-full)
+
+ ;; 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
+ gnus-registry-max-track-groups))
+ (when (and group (gnus-registry-follow-group-p group))
+ (gnus-message
+ 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
+ ;; the found groups are the full groups
+ (setq found (gnus-registry-post-process-groups
+ "references" refstr found found)))
+
+ ;; else: there were no matches, now try the extra tracking by sender
+ ((and (gnus-registry-track-sender-p)
+ sender
+ (not (equal (gnus-extract-address-component-email sender)
+ user-mail-address)))
+ (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
+ gnus-registry-max-track-groups)))
+ (dolist (group groups)
+ (push group found-full)
+ (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
+ ;; the found groups are NOT the full groups
+ (setq found (gnus-registry-post-process-groups
+ "sender" sender found found-full)))
+
+ ;; 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
+ gnus-registry-max-track-groups)))
+ (dolist (group groups)
+ (push group found-full)
+ (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
+ ;; the found groups are NOT the full groups
+ (setq found (gnus-registry-post-process-groups
+ "subject" subject found found-full))))
+ ;; after the (cond) we extract the actual value safely
+ (car-safe found)))
+
+(defun gnus-registry-post-process-groups (mode key groups groups-full)
+ "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. Uses `gnus-registry-split-strategy' and GROUPS-FULL if
+necessary."
+ (let ((log-agent "gnus-registry-post-process-group")
+ out)
+
+ ;; the strategy can be 'first, 'majority, or nil
+ (when (eq gnus-registry-split-strategy 'first)
+ (when groups
+ (setq groups (list (car-safe groups)))))
+
+ (when (eq gnus-registry-split-strategy 'majority)
+ (let ((freq (make-hash-table
+ :size 256
+ :test 'equal)))
+ (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full)
+ (setq groups (list (car-safe
+ (sort
+ groups
+ (lambda (a b)
+ (> (gethash a freq 0)
+ (gethash b freq 0)))))))))
+
+ (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
+ 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)
+ (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
+ word words)
+ (if (or (not (gnus-registry-fetch-extra id 'keywords))
+ force)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (article-goto-body)
+ (save-window-excursion
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (with-syntax-table gnus-adaptive-word-syntax-table
+ (while (re-search-forward "\\b\\w+\\b" nil t)
+ (setq word (gnus-registry-remove-alist-text-properties
+ (downcase (buffer-substring
+ (match-beginning 0) (match-end 0)))))
+ (if (> (length word) 3)
+ (push word words))))))
+ (gnus-registry-store-extra-entry id 'keywords words)))))
+
+(defun gnus-registry-find-keywords (keyword)
+ (interactive "skeyword: ")
+ (let (articles)
+ (maphash
+ (lambda (key value)
+ (when (member keyword
+ (cdr-safe (gnus-registry-fetch-extra key 'keywords)))
+ (push key articles)))
+ gnus-registry-hashtb)
+ articles))