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 |