X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=d25b8b1d24b7b7f3cdc6299e3e912c6ada2968e6;hb=1fa3b0313c103cb7a9fb24c414fc8ac305dbe790;hp=697dc373b1ff2bbbcd394aed813c04f5d5f02016;hpb=76291d81a179dad7f89478eb52e94c36531db83f;p=gnus diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 697dc373b..d25b8b1d2 100644 --- a/lisp/gnus-registry.el +++ b/lisp/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: @@ -47,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 @@ -144,6 +164,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 @@ -234,6 +256,8 @@ the Bit Bucket." (oset db :max-hard (or gnus-registry-max-entries most-positive-fixnum)) + (oset db :prune-factor + 0.1) (oset db :max-soft (or gnus-registry-max-pruned-entries most-positive-fixnum)) @@ -299,13 +323,28 @@ This is not required after changing `gnus-registry-cache-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 (mail-header-subject data-header)) + (extra (mail-header-extra data-header)) (recipients (gnus-registry-sort-addresses - (or (ignore-errors (mail-header "Cc" data-header)) "") - (or (ignore-errors (mail-header "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 +362,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 +380,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 @@ -370,7 +411,7 @@ This is not required after changing `gnus-registry-cache-file'." (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. @@ -402,8 +443,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 +483,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 +511,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 +538,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 +568,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 +684,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 +783,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) @@ -742,8 +813,8 @@ Addresses without a name will say \"noname\"." (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 @@ -804,8 +875,9 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; 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)) + (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) @@ -842,22 +914,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." @@ -919,8 +1001,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)))) @@ -936,9 +1018,17 @@ 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)) + (registry-insert db id entry) + entry) + (defun gnus-registry-import-eld (file) (interactive "fOld registry file to import? ") ;; example content: @@ -972,7 +1062,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)) @@ -1032,7 +1122,7 @@ only the last one's marks are returned." (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) @@ -1064,7 +1154,6 @@ only the last one's marks are returned." "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)) @@ -1073,6 +1162,7 @@ only the last one's marks are returned." (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) @@ -1094,23 +1184,25 @@ only the last one's marks are returned." (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) - (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 () + "If the registry is not already enabled, and `gnus-registry-install' is t, +the registry is enabled. If `gnus-registry-install' is `ask', +the user is asked first. Returns non-nil iff the registry is enabled." (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) ;; TODO: a few things