1 ;;; gnus-registry.el --- article registry for Gnus
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
28 ;; This is the gnus-registry.el package, which works with all
29 ;; backends, not just nnmail (e.g. NNTP). The major issue is that it
30 ;; doesn't go across backends, so for instance if an article is in
31 ;; nnml:sys and you see a reference to it in nnimap splitting, the
32 ;; article will end up in nnimap:sys
34 ;; gnus-registry.el intercepts article respooling, moving, deleting,
35 ;; and copying for all backends. If it doesn't work correctly for
36 ;; you, submit a bug report and I'll be glad to fix it. It needs
37 ;; documentation in the manual (also on my to-do list).
39 ;; Put this in your startup file (~/.gnus.el for instance)
41 ;; (setq gnus-registry-max-entries 2500
42 ;; gnus-registry-use-long-group-names t)
44 ;; (gnus-registry-initialize)
46 ;; Then use this in your fancy-split:
48 ;; (: gnus-registry-split-fancy-with-parent)
52 ;; - get the correct group on spool actions
54 ;; - articles that are spooled to a different backend should be handled
58 (eval-when-compile (require 'cl))
66 (defvar gnus-registry-dirty t
67 "Boolean set to t when the registry is modified")
69 (defgroup gnus-registry nil
74 (defvar gnus-registry-hashtb (make-hash-table
77 "*The article registry by Message ID.")
79 (defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
80 "List of groups that gnus-registry-split-fancy-with-parent won't follow.
81 The group names are matched, they don't have to be fully qualified."
83 :type '(repeat string))
85 (defcustom gnus-registry-install nil
86 "Whether the registry should be installed."
90 (defcustom gnus-registry-clean-empty t
91 "Whether the empty registry entries should be deleted.
92 Registry entries are considered empty when they have no groups
97 (defcustom gnus-registry-use-long-group-names nil
98 "Whether the registry should use long group names (BUGGY)."
102 (defcustom gnus-registry-track-extra nil
103 "Whether the registry should track extra data about a message.
104 The Subject and Sender (From:) headers are currently tracked this
106 :group 'gnus-registry
108 '(set :tag "Tracking choices"
109 (const :tag "Track by subject (Subject: header)" subject)
110 (const :tag "Track by sender (From: header)" sender)))
112 (defcustom gnus-registry-entry-caching t
113 "Whether the registry should cache extra information."
114 :group 'gnus-registry
117 (defcustom gnus-registry-minimum-subject-length 5
118 "The minimum length of a subject before it's considered trackable."
119 :group 'gnus-registry
122 (defcustom gnus-registry-trim-articles-without-groups t
123 "Whether the registry should clean out message IDs without groups."
124 :group 'gnus-registry
127 (defcustom gnus-registry-cache-file
129 (or gnus-dribble-directory gnus-home-directory "~/")
130 ".gnus.registry.eld")
131 "File where the Gnus registry will be stored."
132 :group 'gnus-registry
135 (defcustom gnus-registry-max-entries nil
136 "Maximum number of entries in the registry, nil for unlimited."
137 :group 'gnus-registry
138 :type '(radio (const :format "Unlimited " nil)
139 (integer :format "Maximum number: %v")))
141 (defun gnus-registry-track-subject-p ()
142 (memq 'subject gnus-registry-track-extra))
144 (defun gnus-registry-track-sender-p ()
145 (memq 'sender gnus-registry-track-extra))
147 (defun gnus-registry-cache-read ()
148 "Read the registry cache file."
150 (let ((file gnus-registry-cache-file))
151 (when (file-exists-p file)
152 (gnus-message 5 "Reading %s..." file)
154 (gnus-message 5 "Reading %s...done" file))))
156 (defun gnus-registry-cache-save ()
157 "Save the registry cache file."
159 (let ((file gnus-registry-cache-file))
161 (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
162 (make-local-variable 'version-control)
163 (setq version-control gnus-backup-startup-file)
164 (setq buffer-file-name file)
165 (setq default-directory (file-name-directory buffer-file-name))
166 (buffer-disable-undo)
168 (gnus-message 5 "Saving %s..." file)
169 (if gnus-save-startup-file-via-temp-buffer
170 (let ((coding-system-for-write gnus-ding-file-coding-system)
171 (standard-output (current-buffer)))
172 (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)
173 (gnus-registry-cache-whitespace file)
174 (set-text-properties (point-min) (point-max) nil)
176 (let ((coding-system-for-write gnus-ding-file-coding-system)
177 (version-control gnus-backup-startup-file)
179 (working-dir (file-name-directory file))
182 ;; Generate the name of a non-existent file.
183 (while (progn (setq working-file
185 (if (and (eq system-type 'ms-dos)
186 (not (gnus-long-file-names)))
187 "%s#%d.tm#" ; MSDOS limits files to 8+3
188 (if (memq system-type '(vax-vms axp-vms))
191 working-dir (setq i (1+ i))))
192 (file-exists-p working-file)))
196 (gnus-with-output-to-file working-file
197 (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
199 ;; These bindings will mislead the current buffer
200 ;; into thinking that it is visiting the startup
202 (let ((buffer-backed-up nil)
203 (buffer-file-name startup-file)
204 (file-precious-flag t)
205 (setmodes (file-modes startup-file)))
206 ;; Backup the current version of the startup file.
209 ;; Replace the existing startup file with the temp file.
210 (rename-file working-file startup-file t)
211 (gnus-set-file-modes startup-file setmodes)))
213 (delete-file working-file)
216 (gnus-kill-buffer (current-buffer))
217 (gnus-message 5 "Saving %s...done" file))))
219 ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
220 ;; Save the gnus-registry file with extra line breaks.
221 (defun gnus-registry-cache-whitespace (filename)
222 (gnus-message 7 "Adding whitespace to %s" filename)
224 (goto-char (point-min))
225 (while (re-search-forward "^(\\|(\\\"" nil t)
226 (replace-match "\n\\&" t))
227 (goto-char (point-min))
228 (while (re-search-forward " $" nil t)
229 (replace-match "" t t))))
231 (defun gnus-registry-save (&optional force)
232 (when (or gnus-registry-dirty force)
233 (let ((caching gnus-registry-entry-caching))
234 ;; turn off entry caching, so mtime doesn't get recorded
235 (setq gnus-registry-entry-caching nil)
236 ;; remove entry caches
239 (if (hash-table-p value)
240 (remhash key gnus-registry-hashtb)))
241 gnus-registry-hashtb)
242 ;; remove empty entries
243 (when gnus-registry-clean-empty
244 (gnus-registry-clean-empty-function))
245 ;; now trim the registry appropriately
246 (setq gnus-registry-alist (gnus-registry-trim
247 (gnus-hashtable-to-alist
248 gnus-registry-hashtb)))
250 (gnus-registry-cache-save)
251 (setq gnus-registry-entry-caching caching)
252 (setq gnus-registry-dirty nil))))
254 (defun gnus-registry-clean-empty-function ()
255 "Remove all empty entries from the registry. Returns count thereof."
261 (dolist (group (gnus-registry-fetch-groups key))
262 (when (gnus-parameter-registry-ignore group)
265 "gnus-registry: deleted ignored group %s from key %s"
267 (gnus-registry-delete-group key group)))
269 (unless (gnus-registry-group-count key)
270 (gnus-registry-delete-id key))
273 (gnus-registry-fetch-group key)
274 ;; TODO: look for specific extra data here!
275 ;; in this example, we look for 'label
276 (gnus-registry-fetch-extra key 'label)
279 (gnus-registry-delete-id key))
281 (unless (stringp key)
284 "gnus-registry key %s was not a string, removing"
286 (gnus-registry-delete-id key))))
288 gnus-registry-hashtb)
291 (defun gnus-registry-read ()
292 (gnus-registry-cache-read)
293 (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
294 (setq gnus-registry-dirty nil))
296 (defun gnus-registry-trim (alist)
297 "Trim alist to size, using gnus-registry-max-entries.
298 Also, drop all gnus-registry-ignored-groups matches."
299 (if (null gnus-registry-max-entries)
300 alist ; just return the alist
301 ;; else, when given max-entries, trim the alist
302 (let* ((timehash (make-hash-table
305 (trim-length (- (length alist) gnus-registry-max-entries))
306 (trim-length (if (natnump trim-length) trim-length 0)))
309 (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
310 gnus-registry-hashtb)
312 ;; we use the return value of this setq, which is the trimmed alist
319 (or (cdr (gethash (car a) timehash)) '(0 0 0))
320 (or (cdr (gethash (car b) timehash)) '(0 0 0))))))))))
322 (defun gnus-registry-action (action data-header from &optional to method)
323 (let* ((id (mail-header-id data-header))
324 (subject (gnus-registry-simplify-subject
325 (mail-header-subject data-header)))
326 (sender (mail-header-from data-header))
327 (from (gnus-group-guess-full-name-from-command-method from))
328 (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
329 (to-name (if to to "the Bit Bucket"))
330 (old-entry (gethash id gnus-registry-hashtb)))
331 (gnus-message 7 "Registry: article %s %s from %s to %s"
333 (if method "respooling" "going")
337 ;; All except copy will need a delete
338 (gnus-registry-delete-group id from)
340 (when (equal 'copy action)
341 (gnus-registry-add-group id from subject sender)) ; undo the delete
343 (gnus-registry-add-group id to subject sender)))
345 (defun gnus-registry-spool-action (id group &optional subject sender)
346 (let ((group (gnus-group-guess-full-name-from-com