gnus-art.el (gnus-article-stop-animations): Fix glitches caused by addition of psec...
[gnus] / lisp / gnus-registry.el
index 02b98f0..71e0096 100644 (file)
@@ -1,6 +1,6 @@
 ;;; gnus-registry.el --- article registry for Gnus
 
-;; Copyright (C) 2002-2011  Free Software Foundation, Inc.
+;; Copyright (C) 2002-2012  Free Software Foundation, Inc.
 
 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
 ;; Keywords: news registry
 ;; 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)
 
 ;; 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
 
 (eval-when-compile (require 'cl))
 
-(eval-when-compile
-  (when (null (require 'ert nil t))
-    (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
-
-(require 'ert nil t)
 (require 'gnus)
 (require 'gnus-int)
 (require 'gnus-sum)
@@ -74,7 +90,7 @@
 (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."
@@ -117,7 +133,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))
 
@@ -140,6 +159,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
@@ -150,14 +171,15 @@ nnmairix groups are specifically excluded because they are ephemeral."
 (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
 (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
 
-(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
@@ -216,24 +238,31 @@ the Bit Bucket."
 
 (defcustom gnus-registry-max-pruned-entries nil
   "Maximum number of pruned entries in the registry, nil for unlimited."
+  :version "24.1"
   :group 'gnus-registry
   :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))))
+    (let ((old (oref db :tracked)))
+      (oset db :precious
+            (append gnus-registry-extra-entries-precious
+                    '()))
+      (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))
+      (oset 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)
@@ -249,7 +278,7 @@ the Bit Bucket."
     :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)
@@ -257,7 +286,7 @@ 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 ()
@@ -290,14 +319,30 @@ 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 (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")))
@@ -308,21 +353,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
@@ -333,24 +393,28 @@ 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))
+            (add-to-list 'new toadd t))
           (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
@@ -374,6 +438,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"))))
@@ -386,12 +453,13 @@ 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
@@ -411,65 +479,98 @@ 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
                    "references" refstr found)))
 
-     ;; else: there were no matches, try the extra tracking by sender
+     ;; else: there were no matches, now try the extra tracking by subject
      (when (and (null found)
-                (memq 'sender gnus-registry-track-extra)
-                sender
-                (gnus-grep-in-list
-                 sender
-                 gnus-registry-unfollowed-addresses))
+                (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 'sender sender)))))
+                       (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 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)))
+                         "%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, now try the extra tracking by subject
+     ;; else: there were no matches, try the extra tracking by sender
      (when (and (null found)
-                (memq 'subject gnus-registry-track-extra)
-                subject
-                (< gnus-registry-minimum-subject-length (length subject)))
+                (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 'subject subject)))))
+                       (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 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))))
+                         "%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)
+