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