Mercurial > emacs
comparison lisp/gnus/gnus-registry.el @ 56927:55fd4f77387a after-merge-gnus-5_10
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Merge from emacs--gnus--5.10, gnus--rel--5.10
Patches applied:
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--base-0
tag of miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-464
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-1
Import from CVS branch gnus-5_10-branch
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-2
Merge from lorentey@elte.hu--2004/emacs--multi-tty--0, emacs--cvs-trunk--0
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-3
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-4
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-18
Update from CVS
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-19
Remove autoconf-generated files from archive
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-20
Update from CVS
author | Miles Bader <miles@gnu.org> |
---|---|
date | Sat, 04 Sep 2004 13:13:48 +0000 |
parents | |
children | 06f2ccbf6e0f |
comparison
equal
deleted
inserted
replaced
56926:f8e248e9a717 | 56927:55fd4f77387a |
---|---|
1 ;;; gnus-registry.el --- article registry for Gnus | |
2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 | |
3 ;; Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Ted Zlatanov <tzz@lifelogs.com> | |
6 ;; Keywords: news | |
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 2, or (at your option) | |
13 ;; 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; see the file COPYING. If not, write to the | |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 ;; Boston, MA 02111-1307, USA. | |
24 | |
25 ;;; Commentary: | |
26 | |
27 ;; This is the gnus-registry.el package, works with other backends | |
28 ;; besides nnmail. The major issue is that it doesn't go across | |
29 ;; backends, so for instance if an article is in nnml:sys and you see | |
30 ;; a reference to it in nnimap splitting, the article will end up in | |
31 ;; nnimap:sys | |
32 | |
33 ;; gnus-registry.el intercepts article respooling, moving, deleting, | |
34 ;; and copying for all backends. If it doesn't work correctly for | |
35 ;; you, submit a bug report and I'll be glad to fix it. It needs | |
36 ;; documentation in the manual (also on my to-do list). | |
37 | |
38 ;; Put this in your startup file (~/.gnus.el for instance) | |
39 | |
40 ;; (setq gnus-registry-max-entries 2500 | |
41 ;; gnus-registry-use-long-group-names t) | |
42 | |
43 ;; (gnus-registry-initialize) | |
44 | |
45 ;; Then use this in your fancy-split: | |
46 | |
47 ;; (: gnus-registry-split-fancy-with-parent) | |
48 | |
49 ;; TODO: | |
50 | |
51 ;; - get the correct group on spool actions | |
52 | |
53 ;; - articles that are spooled to a different backend should be handled | |
54 | |
55 ;;; Code: | |
56 | |
57 (eval-when-compile (require 'cl)) | |
58 | |
59 (require 'gnus) | |
60 (require 'gnus-int) | |
61 (require 'gnus-sum) | |
62 (require 'nnmail) | |
63 | |
64 (defvar gnus-registry-dirty t | |
65 "Boolean set to t when the registry is modified") | |
66 | |
67 (defgroup gnus-registry nil | |
68 "The Gnus registry." | |
69 :group 'gnus) | |
70 | |
71 (defvar gnus-registry-hashtb nil | |
72 "*The article registry by Message ID.") | |
73 | |
74 (defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue") | |
75 "List of groups that gnus-registry-split-fancy-with-parent won't follow. | |
76 The group names are matched, they don't have to be fully qualified." | |
77 :group 'gnus-registry | |
78 :type '(repeat string)) | |
79 | |
80 (defcustom gnus-registry-install nil | |
81 "Whether the registry should be installed." | |
82 :group 'gnus-registry | |
83 :type 'boolean) | |
84 | |
85 (defcustom gnus-registry-clean-empty t | |
86 "Whether the empty registry entries should be deleted. | |
87 Registry entries are considered empty when they have no groups." | |
88 :group 'gnus-registry | |
89 :type 'boolean) | |
90 | |
91 (defcustom gnus-registry-use-long-group-names nil | |
92 "Whether the registry should use long group names (BUGGY)." | |
93 :group 'gnus-registry | |
94 :type 'boolean) | |
95 | |
96 (defcustom gnus-registry-track-extra nil | |
97 "Whether the registry should track extra data about a message. | |
98 The Subject and Sender (From:) headers are currently tracked this | |
99 way." | |
100 :group 'gnus-registry | |
101 :type | |
102 '(set :tag "Tracking choices" | |
103 (const :tag "Track by subject (Subject: header)" subject) | |
104 (const :tag "Track by sender (From: header)" sender))) | |
105 | |
106 (defcustom gnus-registry-entry-caching t | |
107 "Whether the registry should cache extra information." | |
108 :group 'gnus-registry | |
109 :type 'boolean) | |
110 | |
111 (defcustom gnus-registry-minimum-subject-length 5 | |
112 "The minimum length of a subject before it's considered trackable." | |
113 :group 'gnus-registry | |
114 :type 'integer) | |
115 | |
116 (defcustom gnus-registry-trim-articles-without-groups t | |
117 "Whether the registry should clean out message IDs without groups." | |
118 :group 'gnus-registry | |
119 :type 'boolean) | |
120 | |
121 (defcustom gnus-registry-cache-file "~/.gnus.registry.eld" | |
122 "File where the Gnus registry will be stored." | |
123 :group 'gnus-registry | |
124 :type 'file) | |
125 | |
126 (defcustom gnus-registry-max-entries nil | |
127 "Maximum number of entries in the registry, nil for unlimited." | |
128 :group 'gnus-registry | |
129 :type '(radio (const :format "Unlimited " nil) | |
130 (integer :format "Maximum number: %v\n" :size 0))) | |
131 | |
132 ;; Function(s) missing in Emacs 20 | |
133 (when (memq nil (mapcar 'fboundp '(puthash))) | |
134 (require 'cl) | |
135 (unless (fboundp 'puthash) | |
136 ;; alias puthash is missing from Emacs 20 cl-extra.el | |
137 (defalias 'puthash 'cl-puthash))) | |
138 | |
139 (defun gnus-registry-track-subject-p () | |
140 (memq 'subject gnus-registry-track-extra)) | |
141 | |
142 (defun gnus-registry-track-sender-p () | |
143 (memq 'sender gnus-registry-track-extra)) | |
144 | |
145 (defun gnus-registry-cache-read () | |
146 "Read the registry cache file." | |
147 (interactive) | |
148 (let ((file gnus-registry-cache-file)) | |
149 (when (file-exists-p file) | |
150 (gnus-message 5 "Reading %s..." file) | |
151 (gnus-load file) | |
152 (gnus-message 5 "Reading %s...done" file)))) | |
153 | |
154 (defun gnus-registry-cache-save () | |
155 "Save the registry cache file." | |
156 (interactive) | |
157 (let ((file gnus-registry-cache-file)) | |
158 (save-excursion | |
159 (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")) | |
160 (make-local-variable 'version-control) | |
161 (setq version-control gnus-backup-startup-file) | |
162 (setq buffer-file-name file) | |
163 (setq default-directory (file-name-directory buffer-file-name)) | |
164 (buffer-disable-undo) | |
165 (erase-buffer) | |
166 (gnus-message 5 "Saving %s..." file) | |
167 (if gnus-save-startup-file-via-temp-buffer | |
168 (let ((coding-system-for-write gnus-ding-file-coding-system) | |
169 (standard-output (current-buffer))) | |
170 (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist) | |
171 (gnus-registry-cache-whitespace file) | |
172 (save-buffer)) | |
173 (let ((coding-system-for-write gnus-ding-file-coding-system) | |
174 (version-control gnus-backup-startup-file) | |
175 (startup-file file) | |
176 (working-dir (file-name-directory file)) | |
177 working-file | |
178 (i -1)) | |
179 ;; Generate the name of a non-existent file. | |
180 (while (progn (setq working-file | |
181 (format | |
182 (if (and (eq system-type 'ms-dos) | |
183 (not (gnus-long-file-names))) | |
184 "%s#%d.tm#" ; MSDOS limits files to 8+3 | |
185 (if (memq system-type '(vax-vms axp-vms)) | |
186 "%s$tmp$%d" | |
187 "%s#tmp#%d")) | |
188 working-dir (setq i (1+ i)))) | |
189 (file-exists-p working-file))) | |
190 | |
191 (unwind-protect | |
192 (progn | |
193 (gnus-with-output-to-file working-file | |
194 (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) | |
195 | |
196 ;; These bindings will mislead the current buffer | |
197 ;; into thinking that it is visiting the startup | |
198 ;; file. | |
199 (let ((buffer-backed-up nil) | |
200 (buffer-file-name startup-file) | |
201 (file-precious-flag t) | |
202 (setmodes (file-modes startup-file))) | |
203 ;; Backup the current version of the startup file. | |
204 (backup-buffer) | |
205 | |
206 ;; Replace the existing startup file with the temp file. | |
207 (rename-file working-file startup-file t) | |
208 (set-file-modes startup-file setmodes))) | |
209 (condition-case nil | |
210 (delete-file working-file) | |
211 (file-error nil))))) | |
212 | |
213 (gnus-kill-buffer (current-buffer)) | |
214 (gnus-message 5 "Saving %s...done" file)))) | |
215 | |
216 ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> | |
217 ;; Save the gnus-registry file with extra line breaks. | |
218 (defun gnus-registry-cache-whitespace (filename) | |
219 (gnus-message 5 "Adding whitespace to %s" filename) | |
220 (save-excursion | |
221 (goto-char (point-min)) | |
222 (while (re-search-forward "^(\\|(\\\"" nil t) | |
223 (replace-match "\n\\&" t)) | |
224 (goto-char (point-min)) | |
225 (while (re-search-forward " $" nil t) | |
226 (replace-match "" t t)))) | |
227 | |
228 (defun gnus-registry-save (&optional force) | |
229 (when (or gnus-registry-dirty force) | |
230 (let ((caching gnus-registry-entry-caching)) | |
231 ;; turn off entry caching, so mtime doesn't get recorded | |
232 (setq gnus-registry-entry-caching nil) | |
233 ;; remove entry caches | |
234 (maphash | |
235 (lambda (key value) | |
236 (if (hash-table-p value) | |
237 (remhash key gnus-registry-hashtb))) | |
238 gnus-registry-hashtb) | |
239 ;; remove empty entries | |
240 (when gnus-registry-clean-empty | |
241 (gnus-registry-clean-empty-function)) | |
242 ;; now trim the registry appropriately | |
243 (setq gnus-registry-alist (gnus-registry-trim | |
244 (hashtable-to-alist gnus-registry-hashtb))) | |
245 ;; really save | |
246 (gnus-registry-cache-save) | |
247 (setq gnus-registry-entry-caching caching) | |
248 (setq gnus-registry-dirty nil)))) | |
249 | |
250 (defun gnus-registry-clean-empty-function () | |
251 "Remove all empty entries from the registry. Returns count thereof." | |
252 (let ((count 0)) | |
253 (maphash | |
254 (lambda (key value) | |
255 (unless (gnus-registry-fetch-group key) | |
256 (incf count) | |
257 (remhash key gnus-registry-hashtb))) | |
258 gnus-registry-hashtb) | |
259 count)) | |
260 | |
261 (defun gnus-registry-read () | |
262 (gnus-registry-cache-read) | |
263 (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) | |
264 (setq gnus-registry-dirty nil)) | |
265 | |
266 (defun gnus-registry-trim (alist) | |
267 "Trim alist to size, using gnus-registry-max-entries." | |
268 (if (null gnus-registry-max-entries) | |
269 alist ; just return the alist | |
270 ;; else, when given max-entries, trim the alist | |
271 (let ((timehash (make-hash-table | |
272 :size 4096 | |
273 :test 'equal))) | |
274 (maphash | |
275 (lambda (key value) | |
276 (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)) | |
277 gnus-registry-hashtb) | |
278 | |
279 ;; we use the return value of this setq, which is the trimmed alist | |
280 (setq alist | |
281 (nthcdr | |
282 (- (length alist) gnus-registry-max-entries) | |
283 (sort alist | |
284 (lambda (a b) | |
285 (time-less-p | |
286 (cdr (gethash (car a) timehash)) | |
287 (cdr (gethash (car b) timehash)))))))))) | |
288 | |
289 (defun alist-to-hashtable (alist) | |
290 "Build a hashtable from the values in ALIST." | |
291 (let ((ht (make-hash-table | |
292 :size 4096 | |
293 :test 'equal))) | |
294 (mapc | |
295 (lambda (kv-pair) | |
296 (puthash (car kv-pair) (cdr kv-pair) ht)) | |
297 alist) | |
298 ht)) | |
299 | |
300 (defun hashtable-to-alist (hash) | |
301 "Build an alist from the values in HASH." | |
302 (let ((list nil)) | |
303 (maphash | |
304 (lambda (key value) | |
305 (setq list (cons (cons key value) list))) | |
306 hash) | |
307 list)) | |
308 | |
309 (defun gnus-registry-action (action data-header from &optional to method) | |
310 (let* ((id (mail-header-id data-header)) | |
311 (subject (gnus-registry-simplify-subject | |
312 (mail-header-subject data-header))) | |
313 (sender (mail-header-from data-header)) | |
314 (from (gnus-group-guess-full-name-from-command-method from)) | |
315 (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) | |
316 (to-name (if to to "the Bit Bucket")) | |
317 (old-entry (gethash id gnus-registry-hashtb))) | |
318 (gnus-message 5 "Registry: article %s %s from %s to %s" | |
319 id | |
320 (if method "respooling" "going") | |
321 from | |
322 to) | |
323 | |
324 ;; All except copy will need a delete | |
325 (gnus-registry-delete-group id from) | |
326 | |
327 (when (equal 'copy action) | |
328 (gnus-registry-add-group id from subject sender)) ; undo the delete | |
329 | |
330 (gnus-registry-add-group id to subject sender))) | |
331 | |
332 (defun gnus-registry-spool-action (id group &optional subject sender) | |
333 (let ((group (gnus-group-guess-full-name-from-command-method group))) | |
334 (when (and (stringp id) (string-match "\r$" id)) | |
335 (setq id (substring id 0 -1))) | |
336 (gnus-message 5 "Registry: article %s spooled to %s" | |
337 id | |
338 group) | |
339 (gnus-registry-add-group id group subject sender))) | |
340 | |
341 ;; Function for nn{mail|imap}-split-fancy: look up all references in | |
342 ;; the cache and if a match is found, return that group. | |
343 (defun gnus-registry-split-fancy-with-parent () | |
344 "Split this message into the same group as its parent. The parent | |
345 is obtained from the registry. This function can be used as an entry | |
346 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like | |
347 this: (: gnus-registry-split-fancy-with-parent) | |
348 | |
349 For a message to be split, it looks for the parent message in the | |
350 References or In-Reply-To header and then looks in the registry to | |
351 see which group that message was put in. This group is returned. | |
352 | |
353 See the Info node `(gnus)Fancy Mail Splitting' for more details." | |
354 (let ((refstr (or (message-fetch-field "references") | |
355 (message-fetch-field "in-reply-to"))) | |
356 (nnmail-split-fancy-with-parent-ignore-groups | |
357 (if (listp nnmail-split-fancy-with-parent-ignore-groups) | |
358 nnmail-split-fancy-with-parent-ignore-groups | |
359 (list nnmail-split-fancy-with-parent-ignore-groups))) | |
360 references res) | |
361 (if refstr | |
362 (progn | |
363 (setq references (nreverse (gnus-split-references refstr))) | |
364 (mapcar (lambda (x) | |
365 (setq res (or (gnus-registry-fetch-group x) res)) | |
366 (when (or (gnus-registry-grep-in-list | |
367 res | |
368 gnus-registry-unfollowed-groups) | |
369 (gnus-registry-grep-in-list | |
370 res | |
371 nnmail-split-fancy-with-parent-ignore-groups)) | |
372 (setq res nil))) | |
373 references)) | |
374 | |
375 ;; else: there were no references, now try the extra tracking | |
376 (let ((sender (message-fetch-field "from")) | |
377 (subject (gnus-registry-simplify-subject | |
378 (message-fetch-field "subject"))) | |
379 (single-match t)) | |
380 (when (and single-match | |
381 (gnus-registry-track-sender-p) | |
382 sender) | |
383 (maphash | |
384 (lambda (key value) | |
385 (let ((this-sender (cdr | |
386 (gnus-registry-fetch-extra key 'sender)))) | |
387 (when (and single-match | |
388 this-sender | |
389 (equal sender this-sender)) | |
390 ;; too many matches, bail | |
391 (unless (equal res (gnus-registry-fetch-group key)) | |
392 (setq single-match nil)) | |
393 (setq res (gnus-registry-fetch-group key)) | |
394 (gnus-message | |
395 ;; raise level of messaging if gnus-registry-track-extra | |
396 (if gnus-registry-track-extra 5 9) | |
397 "%s (extra tracking) traced sender %s to group %s" | |
398 "gnus-registry-split-fancy-with-parent" | |
399 sender | |
400 (if res res "nil"))))) | |
401 gnus-registry-hashtb)) | |
402 (when (and single-match | |
403 (gnus-registry-track-subject-p) | |
404 subject | |
405 (< gnus-registry-minimum-subject-length (length subject))) | |
406 (maphash | |
407 (lambda (key value) | |
408 (let ((this-subject (cdr | |
409 (gnus-registry-fetch-extra key 'subject)))) | |
410 (when (and single-match | |
411 this-subject | |
412 (equal subject this-subject)) | |
413 ;; too many matches, bail | |
414 (unless (equal res (gnus-registry-fetch-group key)) | |
415 (setq single-match nil)) | |
416 (setq res (gnus-registry-fetch-group key)) | |
417 (gnus-message | |
418 ;; raise level of messaging if gnus-registry-track-extra | |
419 (if gnus-registry-track-extra 5 9) | |
420 "%s (extra tracking) traced subject %s to group %s" | |
421 "gnus-registry-split-fancy-with-parent" | |
422 subject | |
423 (if res res "nil"))))) | |
424 gnus-registry-hashtb)) | |
425 (unless single-match | |
426 (gnus-message | |
427 5 | |
428 "gnus-registry-split-fancy-with-parent: too many extra matches for %s" | |
429 refstr) | |
430 (setq res nil)))) | |
431 (gnus-message | |
432 5 | |
433 "gnus-registry-split-fancy-with-parent traced %s to group %s" | |
434 refstr (if res res "nil")) | |
435 | |
436 (when (and res gnus-registry-use-long-group-names) | |
437 (let ((m1 (gnus-find-method-for-group res)) | |
438 (m2 (or gnus-command-method | |
439 (gnus-find-method-for-group gnus-newsgroup-name))) | |
440 (short-res (gnus-group-short-name res))) | |
441 (if (gnus-methods-equal-p m1 m2) | |
442 (progn | |
443 (gnus-message | |
444 9 | |
445 "gnus-registry-split-fancy-with-parent stripped group %s to %s" | |
446 res | |
447 short-res) | |
448 (setq res short-res)) | |
449 ;; else... | |
450 (gnus-message | |
451 5 | |
452 "gnus-registry-split-fancy-with-parent ignored foreign group %s" | |
453 res) | |
454 (setq res nil)))) | |
455 res)) | |
456 | |
457 (defun gnus-registry-register-message-ids () | |
458 "Register the Message-ID of every article in the group" | |
459 (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) | |
460 (dolist (article gnus-newsgroup-articles) | |
461 (let ((id (gnus-registry-fetch-message-id-fast article))) | |
462 (unless (gnus-registry-fetch-group id) | |
463 (gnus-message 9 "Registry: Registering article %d with group %s" | |
464 article gnus-newsgroup-name) | |
465 (gnus-registry-add-group | |
466 (gnus-registry-fetch-message-id-fast article) | |
467 gnus-newsgroup-name | |
468 (gnus-registry-fetch-simplified-message-subject-fast article) | |
469 (gnus-registry-fetch-sender-fast article))))))) | |
470 | |
471 (defun gnus-registry-fetch-message-id-fast (article) | |
472 "Fetch the Message-ID quickly, using the internal gnus-data-list function" | |
473 (if (and (numberp article) | |
474 (assoc article (gnus-data-list nil))) | |
475 (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) | |
476 nil)) | |
477 | |
478 (defun gnus-registry-simplify-subject (subject) | |
479 (if (stringp subject) | |
480 (gnus-simplify-subject subject) | |
481 nil)) | |
482 | |
483 (defun gnus-registry-fetch-simplified-message-subject-fast (article) | |
484 "Fetch the Subject quickly, using the internal gnus-data-list function" | |
485 (if (and (numberp article) | |
486 (assoc article (gnus-data-list nil))) | |
487 (gnus-registry-simplify-subject | |
488 (mail-header-subject (gnus-data-header | |
489 (assoc article (gnus-data-list nil))))) | |
490 nil)) | |
491 | |
492 (defun gnus-registry-fetch-sender-fast (article) | |
493 "Fetch the Sender quickly, using the internal gnus-data-list function" | |
494 (if (and (numberp article) | |
495 (assoc article (gnus-data-list nil))) | |
496 (mail-header-from (gnus-data-header | |
497 (assoc article (gnus-data-list nil)))) | |
498 nil)) | |
499 | |
500 (defun gnus-registry-grep-in-list (word list) | |
501 (when word | |
502 (memq nil | |
503 (mapcar 'not | |
504 (mapcar | |
505 (lambda (x) | |
506 (string-match x word)) | |
507 list))))) | |
508 | |
509 (defun gnus-registry-fetch-extra (id &optional entry) | |
510 "Get the extra data of a message, based on the message ID. | |
511 Returns the first place where the trail finds a nonstring." | |
512 (let ((entry-cache (gethash entry gnus-registry-hashtb))) | |
513 (if (and entry | |
514 (hash-table-p entry-cache) | |
515 (gethash id entry-cache)) | |
516 (gethash id entry-cache) | |
517 ;; else, if there is no caching possible... | |
518 (let ((trail (gethash id gnus-registry-hashtb))) | |
519 (when (listp trail) | |
520 (dolist (crumb trail) | |
521 (unless (stringp crumb) | |
522 (return (gnus-registry-fetch-extra-entry crumb entry id))))))))) | |
523 | |
524 (defun gnus-registry-fetch-extra-entry (alist &optional entry id) | |
525 "Get the extra data of a message, or a specific entry in it. | |
526 Update the entry cache if needed." | |
527 (if (and entry id) | |
528 (let ((entry-cache (gethash entry gnus-registry-hashtb)) | |
529 entree) | |
530 (when gnus-registry-entry-caching | |
531 ;; create the hash table | |
532 (unless (hash-table-p entry-cache) | |
533 (setq entry-cache (make-hash-table | |
534 :size 4096 | |
535 :test 'equal)) | |
536 (puthash entry entry-cache gnus-registry-hashtb)) | |
537 | |
538 ;; get the entree from the hash table or from the alist | |
539 (setq entree (gethash id entry-cache))) | |
540 | |
541 (unless entree | |
542 (setq entree (assq entry alist)) | |
543 (when gnus-registry-entry-caching | |
544 (puthash id entree entry-cache))) | |
545 entree) | |
546 alist)) | |
547 | |
548 (defun gnus-registry-store-extra (id extra) | |
549 "Store the extra data of a message, based on the message ID. | |
550 The message must have at least one group name." | |
551 (when (gnus-registry-group-count id) | |
552 ;; we now know the trail has at least 1 group name, so it's not empty | |
553 (let ((trail (gethash id gnus-registry-hashtb)) | |
554 (old-extra (gnus-registry-fetch-extra id)) | |
555 entry-cache) | |
556 (dolist (crumb trail) | |
557 (unless (stringp crumb) | |
558 (dolist (entry crumb) | |
559 (setq entry-cache (gethash (car entry) gnus-registry-hashtb)) | |
560 (when entry-cache | |
561 (remhash id entry-cache)))) | |
562 (puthash id (cons extra (delete old-extra trail)) | |
563 gnus-registry-hashtb) | |
564 (setq gnus-registry-dirty t))))) | |
565 | |
566 (defun gnus-registry-store-extra-entry (id key value) | |
567 "Put a specific entry in the extras field of the registry entry for id." | |
568 (let* ((extra (gnus-registry-fetch-extra id)) | |
569 (alist (cons (cons key value) | |
570 (gnus-assq-delete-all key (gnus-registry-fetch-extra id))))) | |
571 (gnus-registry-store-extra id alist))) | |
572 | |
573 (defun gnus-registry-fetch-group (id) | |
574 "Get the group of a message, based on the message ID. | |
575 Returns the first place where the trail finds a group name." | |
576 (when (gnus-registry-group-count id) | |
577 ;; we now know the trail has at least 1 group name | |
578 (let ((trail (gethash id gnus-registry-hashtb))) | |
579 (dolist (crumb trail) | |
580 (when (stringp crumb) | |
581 (return (if gnus-registry-use-long-group-names | |
582 crumb | |
583 (gnus-group-short-name crumb)))))))) | |
584 | |
585 (defun gnus-registry-group-count (id) | |
586 "Get the number of groups of a message, based on the message ID." | |
587 (let ((trail (gethash id gnus-registry-hashtb))) | |
588 (if (and trail (listp trail)) | |
589 (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail)) | |
590 0))) | |
591 | |
592 (defun gnus-registry-delete-group (id group) | |
593 "Delete a group for a message, based on the message ID." | |
594 (when group | |
595 (when id | |
596 (let ((trail (gethash id gnus-registry-hashtb)) | |
597 (group (gnus-group-short-name group))) | |
598 (puthash id (if trail | |
599 (delete group trail) | |
600 nil) | |
601 gnus-registry-hashtb)) | |
602 ;; now, clear the entry if there are no more groups | |
603 (when gnus-registry-trim-articles-without-groups | |
604 (unless (gnus-registry-group-count id) | |
605 (gnus-registry-delete-id id))) | |
606 (gnus-registry-store-extra-entry id 'mtime (current-time))))) | |
607 | |
608 (defun gnus-registry-delete-id (id) | |
609 "Delete a message ID from the registry." | |
610 (when (stringp id) | |
611 (remhash id gnus-registry-hashtb) | |
612 (maphash | |
613 (lambda (key value) | |
614 (when (hash-table-p value) | |
615 (remhash id value))) | |
616 gnus-registry-hashtb))) | |
617 | |
618 (defun gnus-registry-add-group (id group &optional subject sender) | |
619 "Add a group for a message, based on the message ID." | |
620 (when group | |
621 (when (and id | |
622 (not (string-match "totally-fudged-out-message-id" id))) | |
623 (let ((full-group group) | |
624 (group (if gnus-registry-use-long-group-names | |
625 group | |
626 (gnus-group-short-name group)))) | |
627 (gnus-registry-delete-group id group) | |
628 | |
629 (unless gnus-registry-use-long-group-names ;; unnecessary in this case | |
630 (gnus-registry-delete-group id full-group)) | |
631 | |
632 (let ((trail (gethash id gnus-registry-hashtb))) | |
633 (puthash id (if trail | |
634 (cons group trail) | |
635 (list group)) | |
636 gnus-registry-hashtb) | |
637 | |
638 (when (and (gnus-registry-track-subject-p) | |
639 subject) | |
640 (gnus-registry-store-extra-entry | |
641 id | |
642 'subject | |
643 (gnus-registry-simplify-subject subject))) | |
644 (when (and (gnus-registry-track-sender-p) | |
645 sender) | |
646 (gnus-registry-store-extra-entry | |
647 id | |
648 'sender | |
649 sender)) | |
650 | |
651 (gnus-registry-store-extra-entry id 'mtime (current-time))))))) | |
652 | |
653 (defun gnus-registry-clear () | |
654 "Clear the Gnus registry." | |
655 (interactive) | |
656 (setq gnus-registry-alist nil) | |
657 (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) | |
658 (setq gnus-registry-dirty t)) | |
659 | |
660 ;;;###autoload | |
661 (defun gnus-registry-initialize () | |
662 (interactive) | |
663 (setq gnus-registry-install t) | |
664 (gnus-registry-install-hooks) | |
665 (gnus-registry-read)) | |
666 | |
667 ;;;###autoload | |
668 (defun gnus-registry-install-hooks () | |
669 "Install the registry hooks." | |
670 (interactive) | |
671 (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) | |
672 (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) | |
673 (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
674 (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
675 | |
676 (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) | |
677 (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
678 | |
679 (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
680 | |
681 (defun gnus-registry-unload-hook () | |
682 "Uninstall the registry hooks." | |
683 (interactive) | |
684 (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) | |
685 (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) | |
686 (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
687 (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
688 | |
689 (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) | |
690 (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
691 | |
692 (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
693 | |
694 (when gnus-registry-install | |
695 (gnus-registry-install-hooks) | |
696 (gnus-registry-read)) | |
697 | |
698 ;; TODO: a lot of things | |
699 | |
700 (provide 'gnus-registry) | |
701 | |
702 ;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 | |
703 ;;; gnus-registry.el ends here |