(eval-when-compile (require 'cl))
-(require 'ert)
+(eval-when-compile
+ (when (null (ignore-errors (require 'ert)))
+ (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
+
+(ignore-errors
+ (require 'ert))
(require 'gnus)
(require 'gnus-int)
(require 'gnus-sum)
:type '(radio (const :format "Unlimited " nil)
(integer :format "Maximum number: %v")))
+(defun gnus-registry-fixup-registry (db)
+ (when db
+ (oset db :precious
+ (append gnus-registry-extra-entries-precious
+ '()))
+ (oset db :max-hard
+ (or gnus-registry-max-entries
+ most-positive-fixnum))
+ (oset db :max-soft
+ (or gnus-registry-max-pruned-entries
+ most-positive-fixnum))
+ (oset db :tracked
+ (append gnus-registry-track-extra
+ '(mark group keyword))))
+ db)
+
(defun gnus-registry-make-db (&optional file)
(interactive "fGnus registry persistence file: \n")
(gnus-registry-fixup-registry
This is not required after changing `gnus-registry-cache-file'."
(interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
(when forsure
- (gnus-message 1 "Remaking the Gnus registry")
+ (gnus-message 4 "Remaking the Gnus registry")
(setq gnus-registry-db (gnus-registry-make-db))))
(defun gnus-registry-read ()
file)
(gnus-registry-remake-db t)))))
-(defun gnus-registry-fixup-registry (db)
- (when db
- (oset db :precious
- (append gnus-registry-extra-entries-precious
- '()))
- (oset db :max-hard
- (or gnus-registry-max-entries
- most-positive-fixnum))
- (oset db :max-soft
- (or gnus-registry-max-pruned-entries
- most-positive-fixnum))
- (oset db :tracked
- (append gnus-registry-track-extra
- '(mark group keyword))))
- db)
-
(defun gnus-registry-save (&optional file db)
"Save the registry cache file."
(interactive)
;; article move/copy/spool/delete actions
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
- (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)))
+ (subject (mail-header-subject data-header))
+ (sender (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")))
to subject sender)))
(defun gnus-registry-spool-action (id group &optional subject sender)
- (let ((to (gnus-group-guess-full-name-from-command-method group)))
+ (let ((to (gnus-group-guess-full-name-from-command-method group))
+ (subject (or subject (message-fetch-field "subject")))
+ (sender (or sender (message-fetch-field "from"))))
(when (and (stringp id) (string-match "\r$" id))
(setq id (substring id 0 -1)))
(gnus-message 7 "Gnus registry: article %s spooled to %s"
(gnus-registry-handle-action id nil to subject sender)))
(defun gnus-registry-handle-action (id from to subject sender)
+ (gnus-message
+ 10
+ "gnus-registry-handle-action %S" (list id from to subject sender))
(let ((db gnus-registry-db)
;; safe if not found
- (entry (gnus-registry-get-or-make-entry id)))
+ (entry (gnus-registry-get-or-make-entry id))
+ (subject (gnus-string-remove-all-properties
+ (gnus-registry-simplify-subject subject)))
+ (sender (gnus-string-remove-all-properties sender)))
;; this could be done by calling `gnus-registry-set-id-key'
;; several times but it's better to bunch the transactions
&allow-other-keys)
(gnus-message
10
- "gnus-registry--split-fancy-with-parent-internal: %S" spec)
+ "gnus-registry--split-fancy-with-parent-internal %S" spec)
(let ((db gnus-registry-db)
found)
- ;; this is a big if-else statement. it uses
+ ;; this is a big chain of statements. 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
- (references
+ ;; the references string must be valid and parse to valid references
+ (when references
+ (gnus-message
+ 9
+ "%s is tracing references %s"
+ log-agent refstr)
(dolist (reference (nreverse references))
- (gnus-message
- 9
- "%s is looking for matches for reference %s from [%s]"
- log-agent reference refstr)
- (setq found
- (loop for group in (gnus-registry-get-id-key reference 'group)
- when (gnus-registry-follow-group-p group)
- do (gnus-message
- 7
- "%s traced the reference %s from [%s] to group %s"
- log-agent reference refstr group)
- collect group)))
+ (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)))
;; filter the found groups and return them
;; the found groups are the full groups
(setq found (gnus-registry-post-process-groups
"references" refstr found)))
;; else: there were no matches, try the extra tracking by sender
- ((and (memq 'sender gnus-registry-track-extra)
- sender
- (gnus-grep-in-list
- sender
- gnus-registry-unfollowed-addresses))
- (setq found
- (loop for group
- in (registry-lookup-secondary-value db 'sender sender)
-
- when (gnus-registry-follow-group-p group)
-
- do (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"
- log-agent sender found)
- collect group))
-
- ;; 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)))
+ (when (and (null found)
+ (memq 'sender gnus-registry-track-extra)
+ sender
+ (gnus-grep-in-list
+ sender
+ gnus-registry-unfollowed-addresses))
+ (let ((groups (apply
+ 'append
+ (mapcar
+ (lambda (reference)
+ (gnus-registry-get-id-key reference 'group))
+ (registry-lookup-secondary-value db 'sender sender)))))
+ (setq found
+ (loop for group in groups
+ when (gnus-registry-follow-group-p group)
+ do (gnus-message
+ ;; warn more if gnus-registry-track-extra
+ (if gnus-registry-track-extra 7 9)
+ "%s (extra tracking) traced sender '%s' to %s"
+ log-agent sender group)
+ collect group)))
+
+ ;; 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)))
;; else: there were no matches, now try the extra tracking by subject
- ((and (memq 'subject gnus-registry-track-extra)
- subject
- (< gnus-registry-minimum-subject-length (length subject)))
- (setq found
- (loop for group
- in (registry-lookup-secondary-value db 'subject subject)
-
- when (gnus-registry-follow-group-p group)
-
- do (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"
- log-agent subject found)
- collect group))
- ;; 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))))
- ;; after the (cond) we extract the actual value safely
- (car-safe found)))
+ (when (and (null found)
+ (memq 'subject gnus-registry-track-extra)
+ subject
+ (< gnus-registry-minimum-subject-length (length subject)))
+ (let ((groups (apply
+ 'append
+ (mapcar
+ (lambda (reference)
+ (gnus-registry-get-id-key reference 'group))
+ (registry-lookup-secondary-value db 'subject subject)))))
+ (setq found
+ (loop for group in groups
+ when (gnus-registry-follow-group-p group)
+ do (gnus-message
+ ;; warn more if gnus-registry-track-extra
+ (if gnus-registry-track-extra 7 9)
+ "%s (extra tracking) traced subject '%s' to %s"
+ log-agent subject group)
+ collect group))
+ ;; 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))))
+ ;; after the (cond) we extract the actual value safely
+ (car-safe found)))
(defun gnus-registry-post-process-groups (mode key groups)
"Inspects GROUPS found by MODE for KEY to determine which ones to follow.
Reduces the list to a single group, or complains if that's not
possible. Uses `gnus-registry-split-strategy'."
(let ((log-agent "gnus-registry-post-process-group")
- out)
-
- ;; the strategy can be nil, in which case groups is nil
- (setq groups
+ (desc (format "%d groups" (length groups)))
+ out chosen)
+ ;; the strategy can be nil, in which case chosen is nil
+ (setq chosen
(case gnus-registry-split-strategy
- ;; first strategy
+ ;; default, take only one-element lists into chosen
+ ((nil)
+ (and (= (length groups) 1)
+ (car-safe groups)))
+
((first)
- (and groups (list (car-safe groups))))
+ (car-safe groups))
((majority)
(let ((freq (make-hash-table
:size 256
:test 'equal)))
- (mapc (lambda (x) (puthash x (1+ (gethash x freq 0)) freq))
+ (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
+ (puthash x (1+ (gethash x freq 0)) freq)))
groups)
- (list (car-safe
- (sort groups (lambda (a b)
- (> (gethash a freq 0)
- (gethash b freq 0))))))))))
+ (setq desc (format "%d groups, %d unique"
+ (length groups)
+ (hash-table-count freq)))
+ (car-safe
+ (sort groups
+ (lambda (a b)
+ (> (gethash (gnus-group-short-name a) freq 0)
+ (gethash (gnus-group-short-name b) freq 0)))))))))
+
+ (if chosen
+ (gnus-message
+ 9
+ "%s: strategy %s on %s produced %s"
+ log-agent gnus-registry-split-strategy desc chosen)
+ (gnus-message
+ 9
+ "%s: strategy %s on %s did not produce an answer"
+ log-agent
+ (or gnus-registry-split-strategy "default")
+ desc))
+
+ (setq groups (and chosen (list chosen)))
(dolist (group groups)
(let ((m1 (gnus-find-method-for-group 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)
+ (when (not (equal group short-name))
+ (gnus-message
+ 10
+ "%s: stripped group %s to %s"
+ log-agent group short-name))
(add-to-list 'out short-name))
;; else...
(gnus-message
7
- "%s ignored foreign group %s"
+ "%s: ignored foreign group %s"
log-agent group))))
- ;; is there just one group?
+ (setq out (delq nil out))
+
(cond
((= (length out) 1) out)
((null out)
(nth 1 (assoc id entries))))
+(defun gnus-registry-delete-entries (idlist)
+ (registry-delete gnus-registry-db idlist nil))
+
(defun gnus-registry-get-id-key (id key)
(cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
(registry-insert db id entry)
entry))
+(defun gnus-registry-import-eld (file)
+ (interactive "fOld registry file to import? ")
+ ;; example content:
+ ;; (setq gnus-registry-alist '(
+ ;; ("<messageID>" ((marks nil)
+ ;; (mtime 19365 1776 440496)
+ ;; (sender . "root (Cron Daemon)")
+ ;; (subject . "Cron"))
+ ;; "cron" "nnml+private:cron")
+ (load file t)
+ (when (boundp 'gnus-registry-alist)
+ (let* ((old (symbol-value 'gnus-registry-alist))
+ (count 0)
+ (expected (length old))
+ entry)
+ (while (car-safe old)
+ (incf count)
+ ;; don't use progress reporters for backwards compatibility
+ (when (and (< 0 expected)
+ (= 0 (mod count 100)))
+ (message "importing: %d of %d (%.2f%%)"
+ count expected (/ (* 100 count) expected)))
+ (setq entry (car-safe old)
+ old (cdr-safe old))
+ (let* ((id (car-safe entry))
+ (new-entry (gnus-registry-get-or-make-entry id))
+ (rest (cdr-safe entry))
+ (groups (loop for p in rest
+ when (stringp p)
+ collect p))
+ extra-cell key val)
+ ;; remove all the strings from the entry
+ (delete* nil rest :test (lambda (a b) (stringp b)))
+ (gnus-registry-set-id-key id 'group groups)
+ ;; just use the first extra element
+ (setq rest (car-safe rest))
+ (while (car-safe rest)
+ (setq extra-cell (car-safe rest)
+ key (car-safe extra-cell)
+ val (cdr-safe extra-cell)
+ rest (cdr-safe rest))
+ (when (and val (atom val))
+ (setq val (list val)))
+ (gnus-registry-set-id-key id key val))))
+ (message "Import done, collected %d entries" count))))
(ert-deftest gnus-registry-usage-test ()
(let* ((n 100)
projects / gnus / blobdiff