X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=f73f21694bffe4daacbed636e22b6acef1189f64;hb=783de080977c6368cc1efc00bf1cddf677da6254;hp=511012df577410c7b8fb7732fd29453c6a6f0d32;hpb=4b3eae16e6dfbed9198a27657860934a02b5b8b5;p=gnus diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 511012df5..f73f21694 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -1,6 +1,6 @@ ;;; gnus-registry.el --- article registry for Gnus -;; Copyright (C) 2002-2011 Free Software Foundation, Inc. +;; Copyright (C) 2002-2015 Free Software Foundation, Inc. ;; Author: Ted Zlatanov ;; Keywords: news registry @@ -31,11 +31,22 @@ ;; 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). -;; Put this in your startup file (~/.gnus.el for instance) +;; 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. -;; (setq gnus-registry-max-entries 2500) +;; ;;; 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: + +;; (setq gnus-registry-max-entries 2500 +;; gnus-registry-track-extra '(sender subject recipient)) ;; (gnus-registry-initialize) @@ -46,6 +57,16 @@ ;; You should also consider using the nnregistry backend to look up ;; articles. See the Gnus manual for more information. +;; Finally, you can put %uM in your summary line format to show the +;; registry marks if you do this: + +;; show the marks as single characters (see the :char property in +;; `gnus-registry-marks'): +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) + +;; show the marks by name (see `gnus-registry-marks'): +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) + ;; TODO: ;; - get the correct group on spool actions @@ -57,10 +78,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (when (null (require 'ert nil t)) - (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) - (require 'gnus) (require 'gnus-int) (require 'gnus-sum) @@ -70,10 +87,16 @@ (require 'easymenu) (require 'registry) +;; Silence XEmacs byte compiler, which will otherwise complain about +;; call to `eieio-persistent-read'. +(when (featurep 'xemacs) + (byte-compiler-options + (warnings (- callargs)))) + (defvar gnus-adaptive-word-syntax-table) (defvar gnus-registry-dirty t - "Boolean set to t when the registry is modified") + "Boolean set to t when the registry is modified.") (defgroup gnus-registry nil "The Gnus registry." @@ -116,7 +139,10 @@ display.") (defcustom gnus-registry-unfollowed-addresses (list (regexp-quote user-mail-address)) "List of addresses that gnus-registry-split-fancy-with-parent won't trace. -The addresses are matched, they don't have to be fully qualified." +The addresses are matched, they don't have to be fully qualified. +In the messages, these addresses can be the sender or the +recipients." + :version "24.1" :group 'gnus-registry :type '(repeat regexp)) @@ -139,6 +165,8 @@ nnmairix groups are specifically excluded because they are ephemeral." (const :tag "Always Install" t) (const :tag "Ask Me" ask))) +(defvar gnus-registry-enabled nil) + (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. (defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus @@ -148,15 +176,18 @@ nnmairix groups are specifically excluded because they are ephemeral." (make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4") (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4") (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4") +;; FIXME it was simply deleted. +(make-obsolete-variable 'gnus-registry-max-pruned-entries nil "25.1") -(defcustom gnus-registry-track-extra '(subject sender) +(defcustom gnus-registry-track-extra '(subject sender recipient) "Whether the registry should track extra data about a message. -The Subject and Sender (From:) headers are tracked this way by -default." +The subject, recipients (To: and Cc:), and Sender (From:) headers +are tracked this way by default." :group 'gnus-registry :type '(set :tag "Tracking choices" (const :tag "Track by subject (Subject: header)" subject) + (const :tag "Track by recipient (To: and Cc: headers)" recipient) (const :tag "Track by sender (From: header)" sender))) (defcustom gnus-registry-split-strategy nil @@ -202,7 +233,7 @@ the Bit Bucket." (defcustom gnus-registry-cache-file (nnheader-concat (or gnus-dribble-directory gnus-home-directory "~/") - ".gnus.registry.eioio") + ".gnus.registry.eieio") "File where the Gnus registry will be stored." :group 'gnus-registry :type 'file) @@ -213,42 +244,69 @@ the Bit Bucket." :type '(radio (const :format "Unlimited " nil) (integer :format "Maximum number: %v"))) -(defcustom gnus-registry-max-pruned-entries nil - "Maximum number of pruned entries in the registry, nil for unlimited." +(defcustom gnus-registry-prune-factor 0.1 + "When pruning, try to prune back to this factor less than the maximum size. + +In order to prevent constant pruning, we prune back to a number +somewhat less than the maximum size. This option controls +exactly how much less. For example, given a maximum size of +50000 and a prune factor of 0.1, the pruning process will try to +cut the registry back to \(- 50000 \(* 50000 0.1\)\) -> 45000 +entries. The pruning process is constrained by the presence of +\"precious\" entries." + :version "25.1" :group 'gnus-registry - :type '(radio (const :format "Unlimited " nil) - (integer :format "Maximum number: %v"))) + :type 'float) + +(defcustom gnus-registry-default-sort-function + #'gnus-registry-sort-by-creation-time + "Sort function to use when pruning the registry. +Entries that sort to the front of the list are pruned first. +This can slow pruning down. Set to nil to perform no sorting." + :version "25.1" + :group 'gnus-registry + :type '(choice (const :tag "No sorting" nil) function)) + +(defun gnus-registry-sort-by-creation-time (l r) + "Sort older entries to front of list." + ;; Pruning starts from the front of the list. + (time-less-p + (cadr (assq 'creation-time r)) + (cadr (assq 'creation-time l)))) (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)))) + (let ((old (oref db tracked))) + (setf (oref db precious) + (append gnus-registry-extra-entries-precious + '())) + (setf (oref db max-size) + (or gnus-registry-max-entries + most-positive-fixnum)) + (setf (oref db prune-factor) + (or gnus-registry-prune-factor + 0.1)) + (setf (oref db tracked) + (append gnus-registry-track-extra + '(mark group keyword))) + (when (not (equal old (oref db tracked))) + (gnus-message 9 "Reindexing the Gnus registry (tracked change)") + (registry-reindex db)))) db) (defun gnus-registry-make-db (&optional file) (interactive "fGnus registry persistence file: \n") (gnus-registry-fixup-registry - (registry-db - "Gnus Registry" - :file (or file gnus-registry-cache-file) - ;; these parameters are set in `gnus-registry-fixup-registry' - :max-hard most-positive-fixnum - :max-soft most-positive-fixnum - :precious nil - :tracked nil))) + (make-instance 'registry-db + :file (or file gnus-registry-cache-file) + ;; these parameters are set in `gnus-registry-fixup-registry' + :max-size most-positive-fixnum + :version registry-db-version + :precious nil + :tracked nil))) (defvar gnus-registry-db (gnus-registry-make-db) - "*The article registry by Message ID. See `registry-db'") + "The article registry by Message ID. See `registry-db'.") ;; top-level registry data management (defun gnus-registry-remake-db (&optional forsure) @@ -256,19 +314,30 @@ the Bit Bucket." 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 () - "Read the registry cache file." +(defun gnus-registry-load () + "Load the registry from the cache file." (interactive) (let ((file gnus-registry-cache-file)) (condition-case nil - (progn - (gnus-message 5 "Reading Gnus registry from %s..." file) - (setq gnus-registry-db (gnus-registry-fixup-registry - (eieio-persistent-read file))) - (gnus-message 5 "Reading Gnus registry from %s...done" file)) + (gnus-registry-read file) + (file-error + ;; Fix previous mis-naming of the registry file. + (let ((old-file-name + (concat (file-name-sans-extension + gnus-registry-cache-file) + ".eioio"))) + (if (and (file-exists-p old-file-name) + (yes-or-no-p + (format "Rename registry file from %s to %s? " + old-file-name file))) + (progn + (gnus-registry-read old-file-name) + (setf (oref gnus-registry-db file) file) + (gnus-message 1 "Registry filename changed to %s" file)) + (gnus-registry-remake-db t)))) (error (gnus-message 1 @@ -276,6 +345,19 @@ This is not required after changing `gnus-registry-cache-file'." file) (gnus-registry-remake-db t))))) +(defun gnus-registry-read (file) + "Do the actual reading of the registry persistence file." + (gnus-message 5 "Reading Gnus registry from %s..." file) + (setq gnus-registry-db + (gnus-registry-fixup-registry + (condition-case nil + (with-no-warnings + (eieio-persistent-read file 'registry-db)) + ;; Older EIEIO versions do not check the class name. + ('wrong-number-of-arguments + (eieio-persistent-read file))))) + (gnus-message 5 "Reading Gnus registry from %s...done" file)) + (defun gnus-registry-save (&optional file db) "Save the registry cache file." (interactive) @@ -283,23 +365,39 @@ This is not required after changing `gnus-registry-cache-file'." (db (or db gnus-registry-db))) (gnus-message 5 "Saving Gnus registry (%d entries) to %s..." (registry-size db) file) - (registry-prune db) + (registry-prune + db gnus-registry-default-sort-function) ;; TODO: call (gnus-string-remove-all-properties v) on all elements? (eieio-persistent-save db file) (gnus-message 5 "Saving Gnus registry (size %d) to %s...done" (registry-size db) file))) +(defun gnus-registry-remove-ignored () + (interactive) + (let* ((db gnus-registry-db) + (grouphashtb (registry-lookup-secondary db 'group)) + (old-size (registry-size db))) + (registry-reindex db) + (loop for k being the hash-keys of grouphashtb + using (hash-values v) + when (gnus-registry-ignore-group-p k) + do (registry-delete db v nil)) + (registry-reindex db) + (gnus-message 4 "Removed %d ignored entries from the Gnus registry" + (- old-size (registry-size db))))) + ;; 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)) + (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)) - (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) - (to-name (if to to "the Bit Bucket"))) + (to (if to (gnus-group-guess-full-name-from-command-method to) nil))) (gnus-message 7 "Gnus registry: article %s %s from %s to %s" id (if method "respooling" "going") from to) @@ -307,21 +405,36 @@ This is not required after changing `gnus-registry-cache-file'." id ;; unless copying, remove the old "from" group (if (not (equal 'copy action)) from nil) - to subject sender))) - -(defun gnus-registry-spool-action (id group &optional subject sender) - (let ((to (gnus-group-guess-full-name-from-command-method group))) + to subject sender recipients))) + +(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") "")))) + (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" id to) - (gnus-registry-handle-action id nil to subject sender))) + (gnus-registry-handle-action id nil to subject sender recipients))) -(defun gnus-registry-handle-action (id from to subject sender) +(defun gnus-registry-handle-action (id from to subject sender + &optional recipients) + (gnus-message + 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))) + (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 @@ -332,24 +445,29 @@ This is not required after changing `gnus-registry-cache-file'." (setq entry (cons (delete from (assoc 'group entry)) (assq-delete-all 'group entry)))) - (dolist (kv `((group ,to) (sender ,sender) (subject ,subject))) + (dolist (kv `((group ,to) + (sender ,sender) + (recipient ,@recipients) + (subject ,subject))) (when (second kv) (let ((new (or (assq (first kv) entry) (list (first kv))))) - (add-to-list 'new (second kv) t) + (dolist (toadd (cdr kv)) + (unless (member toadd new) + (setq new (append new (list toadd))))) (setq entry (cons new (assq-delete-all (first kv) entry)))))) (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. (defun gnus-registry-split-fancy-with-parent () - "Split this message into the same group as its parent. The parent -is obtained from the registry. This function can be used as an entry -in `nnmail-split-fancy' or `nnimap-split-fancy', for example like + "Split this message into the same group as its parent. +The parent is obtained from the registry. This function can be used as an +entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like this: (: gnus-registry-split-fancy-with-parent) This function tracks ALL backends, unlike @@ -373,6 +491,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; 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 (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")))) @@ -385,94 +506,126 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." :references references :refstr refstr :sender sender + :recipients recipients :subject subject :log-agent "Gnus registry fancy splitting with parent"))) (defun* gnus-registry--split-fancy-with-parent-internal (&rest spec - &key references refstr sender subject log-agent + &key references refstr sender subject recipients log-agent &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 + (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 "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)) - (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 - ;; 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))) - ;; 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))) - (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 - ;; 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) + 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 + "subject" subject found)))) + + ;; else: there were no matches, try the extra tracking by sender + (when (and (null found) + (memq 'sender gnus-registry-track-extra) + sender + (not (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) + 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 + "sender" sender found))) + + ;; else: there were no matches, try the extra tracking by recipient + (when (and (null found) + (memq 'recipient gnus-registry-track-extra) + recipients) + (dolist (recp recipients) + (when (and (null found) + (not (gnus-grep-in-list + recp + gnus-registry-unfollowed-addresses))) + (let ((groups (apply 'append + (mapcar + (lambda (reference) + (gnus-registry-get-id-key reference 'group)) + (registry-lookup-secondary-value + db 'recipient recp))))) + (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 recipient '%s' to %s" + log-agent recp 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 + "recipients" (mapconcat 'identity recipients ", ") 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. @@ -489,25 +642,48 @@ 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'." (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)) @@ -517,29 +693,31 @@ possible. Uses `gnus-registry-split-strategy'." (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) - (add-to-list 'out short-name)) + (when (not (equal group short-name)) + (gnus-message + 10 + "%s: stripped group %s to %s" + log-agent group short-name)) + (pushnew short-name out :test #'equal)) ;; 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) (gnus-message 5 - "%s: no matches for %s %s." - log-agent out mode key) + "%s: no matches for %s '%s'." + log-agent mode key) nil) (t (gnus-message 5 - "%s: too many extra matches (%s) for %s %s. Returning none." + "%s: too many extra matches (%s) for %s '%s'. Returning none." log-agent out mode key) nil)))) @@ -555,6 +733,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." @@ -578,8 +784,9 @@ Overrides existing keywords with FORCE set non-nil." (gnus-registry-set-id-key id 'keyword words))))) (defun gnus-registry-keywords () - (let ((table (registry-lookup-secondary gnus-registry-db 'keyword))) - (when table (maphash (lambda (k v) k) table)))) + (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)) + (ks ())) + (when table (maphash (lambda (k _v) (push k ks)) table) ks))) (defun gnus-registry-find-keywords (keyword) (interactive (list @@ -587,7 +794,7 @@ Overrides existing keywords with FORCE set non-nil." (registry-lookup-secondary-value gnus-registry-db 'keyword keyword)) (defun gnus-registry-register-message-ids () - "Register the Message-ID of every article in the group" + "Register the Message-ID of every article in the group." (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) (dolist (article gnus-newsgroup-articles) (let* ((id (gnus-registry-fetch-message-id-fast article)) @@ -597,23 +804,44 @@ Overrides existing keywords with FORCE set non-nil." article gnus-newsgroup-name) (gnus-registry-handle-action id nil gnus-newsgroup-name (gnus-registry-fetch-simplified-message-subject-fast article) - (gnus-registry-fetch-sender-fast article))))))) + (gnus-registry-fetch-sender-fast article) + (gnus-registry-fetch-recipients-fast article))))))) ;; message field fetchers (defun gnus-registry-fetch-message-id-fast (article) - "Fetch the Message-ID quickly, using the internal gnus-data-list function" + "Fetch the Message-ID quickly, using the internal gnus-data-list function." (if (and (numberp article) (assoc article (gnus-data-list nil))) (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) nil)) +(defun gnus-registry-extract-addresses (text) + "Extract all the addresses in a normalized way from TEXT. +Returns an unsorted list of strings in the name
format. +Addresses without a name will say \"noname\"." + (mapcar (lambda (add) + (gnus-string-remove-all-properties + (let* ((name (or (nth 0 add) "noname")) + (addr (nth 1 add)) + (addr (if (bufferp addr) + (with-current-buffer addr + (buffer-string)) + addr))) + (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) nil)) (defun gnus-registry-fetch-simplified-message-subject-fast (article) - "Fetch the Subject quickly, using the internal gnus-data-list function" + "Fetch the Subject quickly, using the internal gnus-data-list function." (if (and (numberp article) (assoc article (gnus-data-list nil))) (gnus-string-remove-all-properties @@ -623,12 +851,20 @@ Overrides existing keywords with FORCE set non-nil." nil)) (defun gnus-registry-fetch-sender-fast (article) - "Fetch the Sender quickly, using the internal gnus-data-list function" + (gnus-registry-fetch-header-fast "from" article)) + +(defun gnus-registry-fetch-recipients-fast (article) + (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-from (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 @@ -643,7 +879,34 @@ FUNCTION should take two parameters, a mark symbol and the cell value." (when cell-data (funcall function mark cell-data))))) -;;; this is ugly code, but I don't know how to do it better +;; FIXME: Why not merge gnus-registry--set/remove-mark and +;; gnus-registry-set-article-mark-internal? +(defun gnus-registry--set/remove-mark (remove mark articles) + "Set/remove the MARK over process-marked ARTICLES." + ;; If this is called and the user doesn't want the + ;; registry enabled, we'll ask anyhow. + (unless gnus-registry-install + (let ((gnus-registry-install 'ask)) + (gnus-registry-install-p))) + + ;; Now the user is asked if gnus-registry-install is `ask'. + (when (gnus-registry-install-p) + (gnus-registry-set-article-mark-internal + ;; All this just to get the mark, I must be doing it wrong. + mark articles remove t) + ;; FIXME: Why do we do the above only here and not directly inside + ;; gnus-registry-set-article-mark-internal? I.e. we wouldn't we want to do + ;; the things below when gnus-registry-set-article-mark-internal is called + ;; from gnus-registry-set-article-mark or + ;; gnus-registry-remove-article-mark? + (gnus-message 9 "Applying mark %s to %d articles" + mark (length articles)) + (dolist (article articles) + (gnus-summary-update-article + article + (assoc article (gnus-data-list nil)))))) + +;; This is ugly code, but I don't know how to do it better. (defun gnus-registry-install-shortcuts () "Install the keyboard shortcuts and menus for the registry. Uses `gnus-registry-marks' to find what shortcuts to install." @@ -655,68 +918,41 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (let ((function-format (format "gnus-registry-%%s-article-%s-mark" mark))) -;;; The following generates these functions: -;;; (defun gnus-registry-set-article-Important-mark (&rest articles) -;;; "Apply the Important mark to process-marked ARTICLES." -;;; (interactive (gnus-summary-work-articles current-prefix-arg)) -;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) -;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) -;;; "Apply the Important mark to process-marked ARTICLES." -;;; (interactive (gnus-summary-work-articles current-prefix-arg)) -;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) +;;; The following generates these functions: +;;; (defun gnus-registry-set-article-Important-mark (&rest articles) +;;; "Apply the Important mark to process-marked ARTICLES." +;;; (interactive (gnus-summary-work-articles current-prefix-arg)) +;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) +;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) +;;; "Apply the Important mark to process-marked ARTICLES." +;;; (interactive (gnus-summary-work-articles current-prefix-arg)) +;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) (dolist (remove '(t nil)) (let* ((variant-name (if remove "remove" "set")) - (function-name (format function-format variant-name)) - (shortcut (format "%c" data)) - (shortcut (if remove (upcase shortcut) shortcut))) - (unintern function-name obarray) - (eval - `(defun - ;; function name - ,(intern function-name) - ;; parameter definition - (&rest articles) - ;; documentation - ,(format - "%s the %s mark over process-marked ARTICLES." - (upcase-initials variant-name) - mark) - ;; interactive definition - (interactive - (gnus-summary-work-articles current-prefix-arg)) - ;; actual code - - ;; if this is called and the user doesn't want the - ;; registry enabled, we'll ask anyhow - (when (eq gnus-registry-install nil) - (setq gnus-registry-install 'ask)) - - ;; now the user is asked if gnus-registry-install is 'ask - (when (gnus-registry-install-p) - (gnus-registry-set-article-mark-internal - ;; all this just to get the mark, I must be doing it wrong - (intern ,(symbol-name mark)) - articles ,remove t) - (gnus-message - 9 - "Applying mark %s to %d articles" - ,(symbol-name mark) (length articles)) - (dolist (article articles) - (gnus-summary-update-article - article - (assoc article (gnus-data-list nil))))))) - (push (intern function-name) keys-plist) + (function-name + (intern (format function-format variant-name))) + (shortcut (format "%c" (if remove (upcase data) data)))) + (defalias function-name + ;; If it weren't for the function's docstring, we could + ;; use a closure, with lexical-let :-( + `(lambda (&rest articles) + ,(format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark ',mark ',remove articles))) + (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" (upcase-initials variant-name) (symbol-name mark)) - (intern function-name) t) + function-name t) gnus-registry-misc-menus) - (gnus-message - 9 - "Defined mark handling function %s" - function-name)))))) + (gnus-message 9 "Defined mark handling function %s" + function-name)))))) (gnus-define-keys-1 '(gnus-registry-mark-map "M" gnus-summary-mark-map) keys-plist) @@ -727,22 +963,32 @@ Uses `gnus-registry-marks' to find what shortcuts to install." nil (cons "Registry Marks" gnus-registry-misc-menus)))))) -;;; use like this: -;;; (defalias 'gnus-user-format-function-M -;;; 'gnus-registry-user-format-function-M) -(defun gnus-registry-user-format-function-M (headers) +(make-obsolete 'gnus-registry-user-format-function-M + 'gnus-registry-article-marks-to-chars "24.1") ? + +(defalias 'gnus-registry-user-format-function-M + 'gnus-registry-article-marks-to-chars) + +;; use like this: +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +(defun gnus-registry-article-marks-to-chars (headers) + "Show the marks for an article by the :char property." + (let* ((id (mail-header-message-id headers)) + (marks (when id (gnus-registry-get-id-key id 'mark)))) + (mapconcat (lambda (mark) + (plist-get + (cdr-safe + (assoc mark gnus-registry-marks)) + :char)) + marks ""))) + +;; use like this: +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +(defun gnus-registry-article-marks-to-names (headers) + "Show the marks for an article by name." (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (apply 'concat (mapcar (lambda (mark) - (let ((c - (plist-get - (cdr-safe - (assoc mark gnus-registry-marks)) - :char))) - (if c - (list c) - nil))) - marks)))) + (mapconcat (lambda (mark) (symbol-name mark)) marks ","))) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." @@ -790,7 +1036,7 @@ only the last one's marks are returned." (let* ((article (last articles)) (id (gnus-registry-fetch-message-id-fast article)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (when (interactive-p) + (when (gmm-called-interactively-p 'any) (gnus-message 1 "Marks are %S" marks)) marks)) @@ -804,8 +1050,8 @@ only the last one's marks are returned." (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)))) @@ -821,9 +1067,18 @@ only the last one's marks are returned." (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 gnus-registry-default-sort-function)) + (registry-insert db id entry) + entry) + (defun gnus-registry-import-eld (file) (interactive "fOld registry file to import? ") ;; example content: @@ -849,14 +1104,14 @@ only the last one's marks are returned." (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))) + (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)) @@ -870,87 +1125,28 @@ only the last one's marks are returned." (gnus-registry-set-id-key id key val)))) (message "Import done, collected %d entries" count)))) -(ert-deftest gnus-registry-usage-test () - (let* ((n 100) - (tempfile (make-temp-file "gnus-registry-persist")) - (db (gnus-registry-make-db tempfile)) - (gnus-registry-db db) - back size) - (message "Adding %d keys to the test Gnus registry" n) - (dotimes (i n) - (let ((id (number-to-string i))) - (gnus-registry-handle-action id - (if (>= 50 i) "fromgroup" nil) - "togroup" - (when (>= 70 i) - (format "subject %d" (mod i 10))) - (when (>= 80 i) - (format "sender %d" (mod i 10)))))) - (message "Testing Gnus registry size is %d" n) - (should (= n (registry-size db))) - (message "Looking up individual keys (registry-lookup)") - (should (equal (loop for e - in (mapcar 'cadr - (registry-lookup db '("20" "83" "72"))) - collect (assq 'subject e) - collect (assq 'sender e) - collect (assq 'group e)) - '((subject "subject 0") (sender "sender 0") (group "togroup") - (subject) (sender) (group "togroup") - (subject) (sender "sender 2") (group "togroup")))) - - (message "Looking up individual keys (gnus-registry-id-key)") - (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" '())) - (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) - (should (gnus-registry-save tempfile db)) - (setq size (nth 7 (file-attributes tempfile))) - (message "Saving the Gnus registry to %s: size %d" tempfile size) - (should (< 0 size)) - (with-temp-buffer - (insert-file-contents-literally tempfile) - (should (looking-at (concat ";; Object " - "Gnus Registry" - "\n;; EIEIO PERSISTENT OBJECT")))) - (message "Reading Gnus registry back") - (setq back (eieio-persistent-read tempfile)) - (should back) - (message "Read Gnus registry back: %d keys, expected %d==%d" - (registry-size back) n (registry-size db)) - (should (= (registry-size back) n)) - (should (= (registry-size back) (registry-size db))) - (delete-file tempfile) - (message "Pruning Gnus registry to 0 by setting :max-soft") - (oset db :max-soft 0) - (registry-prune db) - (should (= (registry-size db) 0))) - (message "Done with Gnus registry usage testing.")) - ;;;###autoload (defun gnus-registry-initialize () -"Initialize the Gnus registry." + "Initialize the Gnus registry." (interactive) (gnus-message 5 "Initializing the registry") - (setq gnus-registry-install t) ; in case it was 'ask or nil (gnus-registry-install-hooks) (gnus-registry-install-shortcuts) - (gnus-registry-read)) + (gnus-registry-load)) +;; FIXME: Why autoload this function? ;;;###autoload (defun gnus-registry-install-hooks () "Install the registry hooks." (interactive) + (setq gnus-registry-enabled t) (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) - (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) + (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load) (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) @@ -963,25 +1159,97 @@ only the last one's marks are returned." (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) - (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) + (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load) - (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + (setq gnus-registry-enabled nil)) (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) (defun gnus-registry-install-p () + "Return non-nil if the registry is enabled (and maybe enable it first). +If the registry is not already enabled, then if `gnus-registry-install' +is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it." (interactive) - (when (eq gnus-registry-install 'ask) - (setq gnus-registry-install - (gnus-y-or-n-p - (concat "Enable the Gnus registry? " - "See the variable `gnus-registry-install' " - "to get rid of this query permanently. "))) - (when gnus-registry-install - ;; we just set gnus-registry-install to t, so initialize the registry! + (unless gnus-registry-enabled + (when (if (eq gnus-registry-install 'ask) + (gnus-y-or-n-p + (concat "Enable the Gnus registry? " + "See the variable `gnus-registry-install' " + "to get rid of this query permanently. ")) + gnus-registry-install) (gnus-registry-initialize))) -;;; we could call it here: (customize-variable 'gnus-registry-install) - gnus-registry-install) + gnus-registry-enabled) + +;; largely based on nnir-warp-to-article +(defun gnus-try-warping-via-registry () + "Try to warp via the registry. +This will be done via the current article's source group based on +data stored in the registry." + (interactive) + (when (gnus-summary-article-header) + (let* ((message-id (mail-header-id (gnus-summary-article-header))) + ;; Retrieve the message's group(s) from the registry + (groups (gnus-registry-get-id-key message-id 'group)) + ;; If starting from an ephemeral group, this describes + ;; how to restore the window configuration + (quit-config + (gnus-ephemeral-group-p gnus-newsgroup-name)) + (seen-groups (list (gnus-group-group-name)))) + + (catch 'found + (dolist (group (mapcar 'gnus-simplify-group-name groups)) + + ;; skip over any groups we really don't want to warp to. + (unless (or (member group seen-groups) + (gnus-ephemeral-group-p group) ;; any ephemeral group + (memq (car (gnus-find-method-for-group group)) + ;; Specific methods; this list may need to expand. + '(nnir))) + + ;; remember that we've seen this group already + (push group seen-groups) + + ;; first exit from any ephemeral summary buffer. + (when quit-config + (gnus-summary-exit) + ;; and if the ephemeral summary buffer in turn came from + ;; another summary buffer we have to clean that summary + ;; up too. + (when (eq (cdr quit-config) 'summary) + (gnus-summary-exit)) + ;; remember that we've already done this part + (setq quit-config nil)) + + ;; Try to activate the group. If that fails, just move + ;; along. We may have more groups to work with + (when + (ignore-errors + (gnus-select-group-with-message-id group message-id) t) + (throw 'found t)))))))) + +(defun gnus-registry-remove-extra-data (extra) + "Remove tracked EXTRA data from the gnus registry. +EXTRA is a list of symbols. Valid symbols are those contained in +the docs of `gnus-registry-track-extra'. This command is useful +when you stop tracking some extra data and now want to purge it +from your existing entries." + (interactive (list (mapcar 'intern + (completing-read-multiple + "Extra data: " + '("subject" "sender" "recipient"))))) + (when extra + (let ((db gnus-registry-db)) + (registry-reindex db) + (loop for k being the hash-keys of (oref db data) + using (hash-value v) + do (let ((newv (delq nil (mapcar #'(lambda (entry) + (unless (member (car entry) extra) + entry)) + v)))) + (registry-delete db (list k) nil) + (gnus-registry-insert db k newv))) + (registry-reindex db)))) ;; TODO: a few things