cgit.sxemacs.org Git - gnus/blob - lisp/gnus-registry.el

   1 ;;; gnus-registry.el --- article registry for Gnus
   2
   3 ;; Copyright (C) 2002-2012  Free Software Foundation, Inc.
   4
   5 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: news registry
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This is the gnus-registry.el package, which works with all
  26 ;; Gnus backends, not just nnmail.  The major issue is that it
  27 ;; doesn't go across backends, so for instance if an article is in
  28 ;; nnml:sys and you see a reference to it in nnimap splitting, the
  29 ;; article will end up in nnimap:sys
  30
  31 ;; gnus-registry.el intercepts article respooling, moving, deleting,
  32 ;; and copying for all backends.  If it doesn't work correctly for
  33 ;; you, submit a bug report and I'll be glad to fix it.  It needs
  34 ;; better documentation in the manual (also on my to-do list).
  35
  36 ;; If you want to track recipients (and you should to make the
  37 ;; gnus-registry splitting work better), you need the To and Cc
  38 ;; headers collected by Gnus.  Note that in more recent Gnus versions
  39 ;; this is already the case: look at `gnus-extra-headers' to be sure.
  40
  41 ;; ;;; you may also want Gcc Newsgroups Keywords X-Face
  42 ;; (add-to-list 'gnus-extra-headers 'To)
  43 ;; (add-to-list 'gnus-extra-headers 'Cc)
  44 ;; (setq nnmail-extra-headers gnus-extra-headers)
  45
  46 ;; Put this in your startup file (~/.gnus.el for instance) or use Customize:
  47
  48 ;; (setq gnus-registry-max-entries 2500
  49 ;;       gnus-registry-track-extra '(sender subject recipient))
  50
  51 ;; (gnus-registry-initialize)
  52
  53 ;; Then use this in your fancy-split:
  54
  55 ;; (: gnus-registry-split-fancy-with-parent)
  56
  57 ;; You should also consider using the nnregistry backend to look up
  58 ;; articles.  See the Gnus manual for more information.
  59
  60 ;; Finally, you can put %uM in your summary line format to show the
  61 ;; registry marks if you do this:
  62
  63 ;; show the marks as single characters (see the :char property in
  64 ;; `gnus-registry-marks'):
  65 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
  66
  67 ;; show the marks by name (see `gnus-registry-marks'):
  68 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
  69
  70 ;; TODO:
  71
  72 ;; - get the correct group on spool actions
  73
  74 ;; - articles that are spooled to a different backend should be moved
  75 ;;   after splitting
  76
  77 ;;; Code:
  78
  79 (eval-when-compile (require 'cl))
  80
  81 (require 'gnus)
  82 (require 'gnus-int)
  83 (require 'gnus-sum)
  84 (require 'gnus-art)
  85 (require 'gnus-util)
  86 (require 'nnmail)
  87 (require 'easymenu)
  88 (require 'registry)
  89
  90 (defvar gnus-adaptive-word-syntax-table)
  91
  92 (defvar gnus-registry-dirty t
  93  "Boolean set to t when the registry is modified")
  94
  95 (defgroup gnus-registry nil
  96   "The Gnus registry."
  97   :version "22.1"
  98   :group 'gnus)
  99
 100 (defvar gnus-registry-marks
 101   '((Important
 102      :char ?i
 103      :image "summary_important")
 104     (Work
 105      :char ?w
 106      :image "summary_work")
 107     (Personal
 108      :char ?p
 109      :image "summary_personal")
 110     (To-Do
 111      :char ?t
 112      :image "summary_todo")
 113     (Later
 114      :char ?l
 115      :image "summary_later"))
 116
 117   "List of registry marks and their options.
 118
 119 `gnus-registry-mark-article' will offer symbols from this list
 120 for completion.
 121
 122 Each entry must have a character to be useful for summary mode
 123 line display and for keyboard shortcuts.
 124
 125 Each entry must have an image string to be useful for visual
 126 display.")
 127
 128 (defcustom gnus-registry-default-mark 'To-Do
 129   "The default mark.  Should be a valid key for `gnus-registry-marks'."
 130   :group 'gnus-registry
 131   :type 'symbol)
 132
 133 (defcustom gnus-registry-unfollowed-addresses
 134   (list (regexp-quote user-mail-address))
 135   "List of addresses that gnus-registry-split-fancy-with-parent won't trace.
 136 The addresses are matched, they don't have to be fully qualified.
 137 In the messages, these addresses can be the sender or the
 138 recipients."
 139   :version "24.1"
 140   :group 'gnus-registry
 141   :type '(repeat regexp))
 142
 143 (defcustom gnus-registry-unfollowed-groups
 144   '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive")
 145   "List of groups that gnus-registry-split-fancy-with-parent won't return.
 146 The group names are matched, they don't have to be fully
 147 qualified.  This parameter tells the Gnus registry 'never split a
 148 message into a group that matches one of these, regardless of
 149 references.'
 150
 151 nnmairix groups are specifically excluded because they are ephemeral."
 152   :group 'gnus-registry
 153   :type '(repeat regexp))
 154
 155 (defcustom gnus-registry-install 'ask
 156   "Whether the registry should be installed."
 157   :group 'gnus-registry
 158   :type '(choice (const :tag "Never Install" nil)
 159                  (const :tag "Always Install" t)
 160                  (const :tag "Ask Me" ask)))
 161
 162 (defvar gnus-registry-enabled nil)
 163
 164 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
 165
 166 (defvar gnus-registry-misc-menus nil)   ; ugly way to keep the menus
 167
 168 (make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
 169 (make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
 170 (make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
 171 (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
 172 (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
 173
 174 (defcustom gnus-registry-track-extra '(subject sender recipient)
 175   "Whether the registry should track extra data about a message.
 176 The subject, recipients (To: and Cc:), and Sender (From:) headers
 177 are tracked this way by default."
 178   :group 'gnus-registry
 179   :type
 180   '(set :tag "Tracking choices"
 181     (const :tag "Track by subject (Subject: header)" subject)
 182     (const :tag "Track by recipient (To: and Cc: headers)" recipient)
 183     (const :tag "Track by sender (From: header)"  sender)))
 184
 185 (defcustom gnus-registry-split-strategy nil
 186   "The splitting strategy applied to the keys in `gnus-registry-track-extra'.
 187
 188 Given a set of unique found groups G and counts for each element
 189 of G, and a key K (typically 'sender or 'subject):
 190
 191 When nil, if G has only one element, use it.  Otherwise give up.
 192 This is the fastest but also least useful strategy.
 193
 194 When 'majority, use the majority by count.  So if there is a
 195 group with the most articles counted by K, use that.  Ties are
 196 resolved in no particular order, simply the first one found wins.
 197 This is the slowest strategy but also the most accurate one.
 198
 199 When 'first, the first element of G wins.  This is fast and
 200 should be OK if your senders and subjects don't \"bleed\" across
 201 groups."
 202   :group 'gnus-registry
 203   :type
 204   '(choice :tag "Splitting strategy"
 205            (const :tag "Only use single choices, discard multiple matches" nil)
 206            (const :tag "Majority of matches wins" majority)
 207            (const :tag "First found wins"  first)))
 208
 209 (defcustom gnus-registry-minimum-subject-length 5
 210   "The minimum length of a subject before it's considered trackable."
 211   :group 'gnus-registry
 212   :type 'integer)
 213
 214 (defcustom gnus-registry-extra-entries-precious '(mark)
 215   "What extra keys are precious, meaning entries with them won't get pruned.
 216 By default, 'mark is included, so articles with marks are
 217 considered precious.
 218
 219 Before you save the Gnus registry, it's pruned.  Any entries with
 220 keys in this list will not be pruned.  All other entries go to
 221 the Bit Bucket."
 222   :group 'gnus-registry
 223   :type '(repeat symbol))
 224
 225 (defcustom gnus-registry-cache-file
 226   (nnheader-concat
 227    (or gnus-dribble-directory gnus-home-directory "~/")
 228    ".gnus.registry.eioio")
 229   "File where the Gnus registry will be stored."
 230   :group 'gnus-registry
 231   :type 'file)
 232
 233 (defcustom gnus-registry-max-entries nil
 234   "Maximum number of entries in the registry, nil for unlimited."
 235   :group 'gnus-registry
 236   :type '(radio (const :format "Unlimited " nil)
 237                 (integer :format "Maximum number: %v")))
 238
 239 (defcustom gnus-registry-max-pruned-entries nil
 240   "Maximum number of pruned entries in the registry, nil for unlimited."
 241   :version "24.1"
 242   :group 'gnus-registry
 243   :type '(radio (const :format "Unlimited " nil)
 244                 (integer :format "Maximum number: %v")))
 245
 246 (defun gnus-registry-fixup-registry (db)
 247   (when db
 248     (let ((old (oref db :tracked)))
 249       (oset db :precious
 250             (append gnus-registry-extra-entries-precious
 251                     '()))
 252       (oset db :max-hard
 253             (or gnus-registry-max-entries
 254                 most-positive-fixnum))
 255       (oset db :prune-factor
 256             0.1)
 257       (oset db :max-soft
 258             (or gnus-registry-max-pruned-entries
 259                 most-positive-fixnum))
 260       (oset db :tracked
 261             (append gnus-registry-track-extra
 262                     '(mark group keyword)))
 263       (when (not (equal old (oref db :tracked)))
 264         (gnus-message 9 "Reindexing the Gnus registry (tracked change)")
 265         (registry-reindex db))))
 266   db)
 267
 268 (defun gnus-registry-make-db (&optional file)
 269   (interactive "fGnus registry persistence file: \n")
 270   (gnus-registry-fixup-registry
 271    (registry-db
 272     "Gnus Registry"
 273     :file (or file gnus-registry-cache-file)
 274     ;; these parameters are set in `gnus-registry-fixup-registry'
 275     :max-hard most-positive-fixnum
 276     :max-soft most-positive-fixnum
 277     :precious nil
 278     :tracked nil)))
 279
 280 (defvar gnus-registry-db (gnus-registry-make-db)
 281   "*The article registry by Message ID.  See `registry-db'")
 282
 283 ;; top-level registry data management
 284 (defun gnus-registry-remake-db (&optional forsure)
 285   "Remake the registry database after customization.
 286 This is not required after changing `gnus-registry-cache-file'."
 287   (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
 288   (when forsure
 289     (gnus-message 4 "Remaking the Gnus registry")
 290     (setq gnus-registry-db (gnus-registry-make-db))))
 291
 292 (defun gnus-registry-read ()
 293   "Read the registry cache file."
 294   (interactive)
 295   (let ((file gnus-registry-cache-file))
 296     (condition-case nil
 297         (progn
 298           (gnus-message 5 "Reading Gnus registry from %s..." file)
 299           (setq gnus-registry-db (gnus-registry-fixup-registry
 300                                   (eieio-persistent-read file)))
 301           (gnus-message 5 "Reading Gnus registry from %s...done" file))
 302       (error
 303        (gnus-message
 304         1
 305         "The Gnus registry could not be loaded from %s, creating a new one"
 306         file)
 307        (gnus-registry-remake-db t)))))
 308
 309 (defun gnus-registry-save (&optional file db)
 310   "Save the registry cache file."
 311   (interactive)
 312   (let ((file (or file gnus-registry-cache-file))
 313         (db (or db gnus-registry-db)))
 314     (gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
 315                   (registry-size db) file)
 316     (registry-prune db)
 317     ;; TODO: call (gnus-string-remove-all-properties v) on all elements?
 318     (eieio-persistent-save db file)
 319     (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
 320                   (registry-size db) file)))
 321
 322 (defun gnus-registry-remove-ignored ()
 323   (interactive)
 324   (let* ((db gnus-registry-db)
 325          (grouphashtb (registry-lookup-secondary db 'group))
 326          (old-size (registry-size db)))
 327     (registry-reindex db)
 328     (loop for k being the hash-keys of grouphashtb
 329           using (hash-values v)
 330           when (gnus-registry-ignore-group-p k)
 331           do (registry-delete db v nil))
 332     (registry-reindex db)
 333     (gnus-message 4 "Removed %d ignored entries from the Gnus registry"
 334                   (- old-size (registry-size db)))))
 335
 336 ;; article move/copy/spool/delete actions
 337 (defun gnus-registry-action (action data-header from &optional to method)
 338   (let* ((id (mail-header-id data-header))
 339          (subject (mail-header-subject data-header))
 340          (extra (mail-header-extra data-header))
 341          (recipients (gnus-registry-sort-addresses
 342                       (or (cdr-safe (assq 'Cc extra)) "")
 343                       (or (cdr-safe (assq 'To extra)) "")))
 344          (sender (nth 0 (gnus-registry-extract-addresses
 345                          (mail-header-from data-header))))
 346          (from (gnus-group-guess-full-name-from-command-method from))
 347          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
 348          (to-name (if to to "the Bit Bucket")))
 349     (gnus-message 7 "Gnus registry: article %s %s from %s to %s"
 350                   id (if method "respooling" "going") from to)
 351
 352     (gnus-registry-handle-action
 353      id
 354      ;; unless copying, remove the old "from" group
 355      (if (not (equal 'copy action)) from nil)
 356      to subject sender recipients)))
 357
 358 (defun gnus-registry-spool-action (id group &optional subject sender recipients)
 359   (let ((to (gnus-group-guess-full-name-from-command-method group))
 360         (recipients (or recipients
 361                         (gnus-registry-sort-addresses
 362                          (or (message-fetch-field "cc") "")
 363                          (or (message-fetch-field "to") ""))))
 364         (subject (or subject (message-fetch-field "subject")))
 365         (sender (or sender (message-fetch-field "from"))))
 366     (when (and (stringp id) (string-match "\r$" id))
 367       (setq id (substring id 0 -1)))
 368     (gnus-message 7 "Gnus registry: article %s spooled to %s"
 369                   id
 370                   to)
 371     (gnus-registry-handle-action id nil to subject sender recipients)))
 372
 373 (defun gnus-registry-handle-action (id from to subject sender
 374                                        &optional recipients)
 375   (gnus-message
 376    10
 377    "gnus-registry-handle-action %S" (list id from to subject sender recipients))
 378   (let ((db gnus-registry-db)
 379         ;; if the group is ignored, set the destination to nil (same as delete)
 380         (to (if (gnus-registry-ignore-group-p to) nil to))
 381         ;; safe if not found
 382         (entry (gnus-registry-get-or-make-entry id))
 383         (subject (gnus-string-remove-all-properties
 384                   (gnus-registry-simplify-subject subject)))
 385         (sender (gnus-string-remove-all-properties sender)))
 386
 387     ;; this could be done by calling `gnus-registry-set-id-key'
 388     ;; several times but it's better to bunch the transactions
 389     ;; together
 390
 391     (registry-delete db (list id) nil)
 392     (when from
 393       (setq entry (cons (delete from (assoc 'group entry))
 394                         (assq-delete-all 'group entry))))
 395
 396     (dolist (kv `((group ,to)
 397                   (sender ,sender)
 398                   (recipient ,@recipients)
 399                   (subject ,subject)))
 400       (when (second kv)
 401         (let ((new (or (assq (first kv) entry)
 402                        (list (first kv)))))
 403           (dolist (toadd (cdr kv))
 404             (add-to-list 'new toadd t))
 405           (setq entry (cons new
 406                             (assq-delete-all (first kv) entry))))))
 407     (gnus-message 10 "Gnus registry: new entry for %s is %S"
 408                   id
 409                   entry)
 410     (gnus-registry-insert db id entry)))
 411
 412 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 413 ;; the cache and if a match is found, return that group.
 414 (defun gnus-registry-split-fancy-with-parent ()
 415   "Split this message into the same group as its parent.  The parent
 416 is obtained from the registry.  This function can be used as an entry
 417 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 418 this: (: gnus-registry-split-fancy-with-parent)
 419
 420 This function tracks ALL backends, unlike
 421 `nnmail-split-fancy-with-parent' which tracks only nnmail
 422 messages.
 423
 424 For a message to be split, it looks for the parent message in the
 425 References or In-Reply-To header and then looks in the registry
 426 to see which group that message was put in.  This group is
 427 returned, unless `gnus-registry-follow-group-p' return nil for
 428 that group.
 429
 430 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 431   (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
 432          (reply-to (message-fetch-field "in-reply-to"))      ; may be nil
 433          ;; now, if reply-to is valid, append it to the References
 434          (refstr (if reply-to
 435                      (concat refstr " " reply-to)
 436                    refstr))
 437          (references (and refstr (gnus-extract-references refstr)))
 438          ;; these may not be used, but the code is cleaner having them up here
 439          (sender (gnus-string-remove-all-properties
 440                   (message-fetch-field "from")))