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 (eval-when-compile
  82   (when (null (ignore-errors (require 'ert)))
  83     (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
  84
  85 (ignore-errors
  86   (require 'ert))
  87 (require 'gnus)
  88 (require 'gnus-int)
  89 (require 'gnus-sum)
  90 (require 'gnus-art)
  91 (require 'gnus-util)
  92 (require 'nnmail)
  93 (require 'easymenu)
  94 (require 'registry)
  95
  96 (defvar gnus-adaptive-word-syntax-table)
  97
  98 (defvar gnus-registry-dirty t
  99  "Boolean set to t when the registry is modified")
 100
 101 (defgroup gnus-registry nil
 102   "The Gnus registry."
 103   :version "22.1"
 104   :group 'gnus)
 105
 106 (defvar gnus-registry-marks
 107   '((Important
 108      :char ?i
 109      :image "summary_important")
 110     (Work
 111      :char ?w
 112      :image "summary_work")
 113     (Personal
 114      :char ?p
 115      :image "summary_personal")
 116     (To-Do
 117      :char ?t
 118      :image "summary_todo")
 119     (Later
 120      :char ?l
 121      :image "summary_later"))
 122
 123   "List of registry marks and their options.
 124
 125 `gnus-registry-mark-article' will offer symbols from this list
 126 for completion.
 127
 128 Each entry must have a character to be useful for summary mode
 129 line display and for keyboard shortcuts.
 130
 131 Each entry must have an image string to be useful for visual
 132 display.")
 133
 134 (defcustom gnus-registry-default-mark 'To-Do
 135   "The default mark.  Should be a valid key for `gnus-registry-marks'."
 136   :group 'gnus-registry
 137   :type 'symbol)
 138
 139 (defcustom gnus-registry-unfollowed-addresses
 140   (list (regexp-quote user-mail-address))
 141   "List of addresses that gnus-registry-split-fancy-with-parent won't trace.
 142 The addresses are matched, they don't have to be fully qualified.
 143 In the messages, these addresses can be the sender or the
 144 recipients."
 145   :version "24.1"
 146   :group 'gnus-registry
 147   :type '(repeat regexp))
 148
 149 (defcustom gnus-registry-unfollowed-groups
 150   '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive")
 151   "List of groups that gnus-registry-split-fancy-with-parent won't return.
 152 The group names are matched, they don't have to be fully
 153 qualified.  This parameter tells the Gnus registry 'never split a
 154 message into a group that matches one of these, regardless of
 155 references.'
 156
 157 nnmairix groups are specifically excluded because they are ephemeral."
 158   :group 'gnus-registry
 159   :type '(repeat regexp))
 160
 161 (defcustom gnus-registry-install 'ask
 162   "Whether the registry should be installed."
 163   :group 'gnus-registry
 164   :type '(choice (const :tag "Never Install" nil)
 165                  (const :tag "Always Install" t)
 166                  (const :tag "Ask Me" ask)))
 167
 168 (defvar gnus-registry-enabled nil)
 169
 170 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
 171
 172 (defvar gnus-registry-misc-menus nil)   ; ugly way to keep the menus
 173
 174 (make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
 175 (make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
 176 (make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
 177 (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
 178 (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
 179
 180 (defcustom gnus-registry-track-extra '(subject sender recipient)
 181   "Whether the registry should track extra data about a message.
 182 The subject, recipients (To: and Cc:), and Sender (From:) headers
 183 are tracked this way by default."
 184   :group 'gnus-registry
 185   :type
 186   '(set :tag "Tracking choices"
 187     (const :tag "Track by subject (Subject: header)" subject)
 188     (const :tag "Track by recipient (To: and Cc: headers)" recipient)
 189     (const :tag "Track by sender (From: header)"  sender)))
 190
 191 (defcustom gnus-registry-split-strategy nil
 192   "The splitting strategy applied to the keys in `gnus-registry-track-extra'.
 193
 194 Given a set of unique found groups G and counts for each element
 195 of G, and a key K (typically 'sender or 'subject):
 196
 197 When nil, if G has only one element, use it.  Otherwise give up.
 198 This is the fastest but also least useful strategy.
 199
 200 When 'majority, use the majority by count.  So if there is a
 201 group with the most articles counted by K, use that.  Ties are
 202 resolved in no particular order, simply the first one found wins.
 203 This is the slowest strategy but also the most accurate one.
 204
 205 When 'first, the first element of G wins.  This is fast and
 206 should be OK if your senders and subjects don't \"bleed\" across
 207 groups."
 208   :group 'gnus-registry
 209   :type
 210   '(choice :tag "Splitting strategy"
 211            (const :tag "Only use single choices, discard multiple matches" nil)
 212            (const :tag "Majority of matches wins" majority)
 213            (const :tag "First found wins"  first)))
 214
 215 (defcustom gnus-registry-minimum-subject-length 5
 216   "The minimum length of a subject before it's considered trackable."
 217   :group 'gnus-registry
 218   :type 'integer)
 219
 220 (defcustom gnus-registry-extra-entries-precious '(mark)
 221   "What extra keys are precious, meaning entries with them won't get pruned.
 222 By default, 'mark is included, so articles with marks are
 223 considered precious.
 224
 225 Before you save the Gnus registry, it's pruned.  Any entries with
 226 keys in this list will not be pruned.  All other entries go to
 227 the Bit Bucket."
 228   :group 'gnus-registry
 229   :type '(repeat symbol))
 230
 231 (defcustom gnus-registry-cache-file
 232   (nnheader-concat
 233    (or gnus-dribble-directory gnus-home-directory "~/")
 234    ".gnus.registry.eioio")
 235   "File where the Gnus registry will be stored."
 236   :group 'gnus-registry
 237   :type 'file)
 238
 239 (defcustom gnus-registry-max-entries nil
 240   "Maximum number of entries in the registry, nil for unlimited."
 241   :group 'gnus-registry
 242   :type '(radio (const :format "Unlimited " nil)
 243                 (integer :format "Maximum number: %v")))
 244
 245 (defcustom gnus-registry-max-pruned-entries nil
 246   "Maximum number of pruned entries in the registry, nil for unlimited."
 247   :version "24.1"
 248   :group 'gnus-registry
 249   :type '(radio (const :format "Unlimited " nil)
 250                 (integer :format "Maximum number: %v")))
 251
 252 (defun gnus-registry-fixup-registry (db)
 253   (when db
 254     (let ((old (oref db :tracked)))
 255       (oset db :precious
 256             (append gnus-registry-extra-entries-precious
 257                     '()))
 258       (oset db :max-hard
 259             (or gnus-registry-max-entries
 260                 most-positive-fixnum))
 261       (oset db :prune-factor
 262             0.1)
 263       (oset db :max-soft
 264             (or gnus-registry-max-pruned-entries
 265                 most-positive-fixnum))
 266       (oset db :tracked
 267             (append gnus-registry-track-extra
 268                     '(mark group keyword)))
 269       (when (not (equal old (oref db :tracked)))
 270         (gnus-message 9 "Reindexing the Gnus registry (tracked change)")
 271         (registry-reindex db))))
 272   db)
 273
 274 (defun gnus-registry-make-db (&optional file)
 275   (interactive "fGnus registry persistence file: \n")
 276   (gnus-registry-fixup-registry
 277    (registry-db
 278     "Gnus Registry"
 279     :file (or file gnus-registry-cache-file)
 280     ;; these parameters are set in `gnus-registry-fixup-registry'
 281     :max-hard most-positive-fixnum
 282     :max-soft most-positive-fixnum
 283     :precious nil
 284     :tracked nil)))
 285
 286 (defvar gnus-registry-db (gnus-registry-make-db)
 287   "*The article registry by Message ID.  See `registry-db'")
 288
 289 ;; top-level registry data management
 290 (defun gnus-registry-remake-db (&optional forsure)
 291   "Remake the registry database after customization.
 292 This is not required after changing `gnus-registry-cache-file'."
 293   (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
 294   (when forsure
 295     (gnus-message 4 "Remaking the Gnus registry")
 296     (setq gnus-registry-db (gnus-registry-make-db))))
 297
 298 (defun gnus-registry-read ()
 299   "Read the registry cache file."
 300   (interactive)
 301   (let ((file gnus-registry-cache-file))
 302     (condition-case nil
 303         (progn
 304           (gnus-message 5 "Reading Gnus registry from %s..." file)
 305           (setq gnus-registry-db (gnus-registry-fixup-registry