Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; gnus-registry.el --- article registry for Gnus |
e84b4b86 TTN |
2 | |
3 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, | |
d7a0267c | 4 | ;; 2005, 2006, 2007 Free Software Foundation, Inc. |
23f87bed MB |
5 | |
6 | ;; Author: Ted Zlatanov <tzz@lifelogs.com> | |
7 | ;; Keywords: news | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
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 | |
5a9dffec | 13 | ;; the Free Software Foundation; either version 3, or (at your option) |
23f87bed MB |
14 | ;; any later version. |
15 | ||
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. | |
20 | ||
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 | |
3a35cf56 LK |
23 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
24 | ;; Boston, MA 02110-1301, USA. | |
23f87bed MB |
25 | |
26 | ;;; Commentary: | |
27 | ||
01c52d31 MB |
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 | |
23f87bed MB |
33 | |
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). | |
38 | ||
39 | ;; Put this in your startup file (~/.gnus.el for instance) | |
40 | ||
41 | ;; (setq gnus-registry-max-entries 2500 | |
42 | ;; gnus-registry-use-long-group-names t) | |
43 | ||
44 | ;; (gnus-registry-initialize) | |
45 | ||
46 | ;; Then use this in your fancy-split: | |
47 | ||
48 | ;; (: gnus-registry-split-fancy-with-parent) | |
49 | ||
50 | ;; TODO: | |
51 | ||
52 | ;; - get the correct group on spool actions | |
53 | ||
54 | ;; - articles that are spooled to a different backend should be handled | |
55 | ||
56 | ;;; Code: | |
57 | ||
58 | (eval-when-compile (require 'cl)) | |
59 | ||
60 | (require 'gnus) | |
61 | (require 'gnus-int) | |
62 | (require 'gnus-sum) | |
996aa8c1 | 63 | (require 'gnus-util) |
23f87bed MB |
64 | (require 'nnmail) |
65 | ||
66 | (defvar gnus-registry-dirty t | |
67 | "Boolean set to t when the registry is modified") | |
68 | ||
69 | (defgroup gnus-registry nil | |
70 | "The Gnus registry." | |
bf247b6e | 71 | :version "22.1" |
23f87bed MB |
72 | :group 'gnus) |
73 | ||
01c52d31 MB |
74 | (defvar gnus-registry-hashtb (make-hash-table |
75 | :size 256 | |
76 | :test 'equal) | |
23f87bed MB |
77 | "*The article registry by Message ID.") |
78 | ||
01c52d31 MB |
79 | (defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$") |
80 | "List of groups that gnus-registry-split-fancy-with-parent won't return. | |
81 | The group names are matched, they don't have to be fully | |
82 | qualified. This parameter tells the Registry 'never split a | |
83 | message into a group that matches one of these, regardless of | |
84 | references.'" | |
23f87bed | 85 | :group 'gnus-registry |
01c52d31 | 86 | :type '(repeat regexp)) |
23f87bed MB |
87 | |
88 | (defcustom gnus-registry-install nil | |
89 | "Whether the registry should be installed." | |
90 | :group 'gnus-registry | |
91 | :type 'boolean) | |
92 | ||
93 | (defcustom gnus-registry-clean-empty t | |
94 | "Whether the empty registry entries should be deleted. | |
01c52d31 MB |
95 | Registry entries are considered empty when they have no groups |
96 | and no extra data." | |
23f87bed MB |
97 | :group 'gnus-registry |
98 | :type 'boolean) | |
99 | ||
100 | (defcustom gnus-registry-use-long-group-names nil | |
101 | "Whether the registry should use long group names (BUGGY)." | |
102 | :group 'gnus-registry | |
103 | :type 'boolean) | |
104 | ||
105 | (defcustom gnus-registry-track-extra nil | |
106 | "Whether the registry should track extra data about a message. | |
107 | The Subject and Sender (From:) headers are currently tracked this | |
108 | way." | |
109 | :group 'gnus-registry | |
bf247b6e | 110 | :type |
23f87bed MB |
111 | '(set :tag "Tracking choices" |
112 | (const :tag "Track by subject (Subject: header)" subject) | |
113 | (const :tag "Track by sender (From: header)" sender))) | |
114 | ||
115 | (defcustom gnus-registry-entry-caching t | |
116 | "Whether the registry should cache extra information." | |
117 | :group 'gnus-registry | |
118 | :type 'boolean) | |
119 | ||
120 | (defcustom gnus-registry-minimum-subject-length 5 | |
121 | "The minimum length of a subject before it's considered trackable." | |
122 | :group 'gnus-registry | |
123 | :type 'integer) | |
124 | ||
125 | (defcustom gnus-registry-trim-articles-without-groups t | |
126 | "Whether the registry should clean out message IDs without groups." | |
127 | :group 'gnus-registry | |
128 | :type 'boolean) | |
129 | ||
01c52d31 MB |
130 | (defcustom gnus-registry-cache-file |
131 | (nnheader-concat | |
132 | (or gnus-dribble-directory gnus-home-directory "~/") | |
133 | ".gnus.registry.eld") | |
23f87bed MB |
134 | "File where the Gnus registry will be stored." |
135 | :group 'gnus-registry | |
136 | :type 'file) | |
137 | ||
138 | (defcustom gnus-registry-max-entries nil | |
139 | "Maximum number of entries in the registry, nil for unlimited." | |
140 | :group 'gnus-registry | |
141 | :type '(radio (const :format "Unlimited " nil) | |
ad136a7c | 142 | (integer :format "Maximum number: %v"))) |
23f87bed | 143 | |
23f87bed MB |
144 | (defun gnus-registry-track-subject-p () |
145 | (memq 'subject gnus-registry-track-extra)) | |
146 | ||
147 | (defun gnus-registry-track-sender-p () | |
148 | (memq 'sender gnus-registry-track-extra)) | |
149 | ||
150 | (defun gnus-registry-cache-read () | |
151 | "Read the registry cache file." | |
152 | (interactive) | |
153 | (let ((file gnus-registry-cache-file)) | |
154 | (when (file-exists-p file) | |
155 | (gnus-message 5 "Reading %s..." file) | |
156 | (gnus-load file) | |
157 | (gnus-message 5 "Reading %s...done" file)))) | |
158 | ||
8aed9ac5 RS |
159 | ;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in |
160 | ;; `gnus-start.el'. --rsteib | |
23f87bed MB |
161 | (defun gnus-registry-cache-save () |
162 | "Save the registry cache file." | |
163 | (interactive) | |
164 | (let ((file gnus-registry-cache-file)) | |
165 | (save-excursion | |
166 | (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")) | |
167 | (make-local-variable 'version-control) | |
168 | (setq version-control gnus-backup-startup-file) | |
169 | (setq buffer-file-name file) | |
170 | (setq default-directory (file-name-directory buffer-file-name)) | |
171 | (buffer-disable-undo) | |
172 | (erase-buffer) | |
173 | (gnus-message 5 "Saving %s..." file) | |
174 | (if gnus-save-startup-file-via-temp-buffer | |
175 | (let ((coding-system-for-write gnus-ding-file-coding-system) | |
176 | (standard-output (current-buffer))) | |
177 | (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist) | |
178 | (gnus-registry-cache-whitespace file) | |
179 | (save-buffer)) | |
180 | (let ((coding-system-for-write gnus-ding-file-coding-system) | |
181 | (version-control gnus-backup-startup-file) | |
182 | (startup-file file) | |
183 | (working-dir (file-name-directory file)) | |
184 | working-file | |
185 | (i -1)) | |
186 | ;; Generate the name of a non-existent file. | |
187 | (while (progn (setq working-file | |
188 | (format | |
189 | (if (and (eq system-type 'ms-dos) | |
190 | (not (gnus-long-file-names))) | |
191 | "%s#%d.tm#" ; MSDOS limits files to 8+3 | |
192 | (if (memq system-type '(vax-vms axp-vms)) | |
193 | "%s$tmp$%d" | |
194 | "%s#tmp#%d")) | |
195 | working-dir (setq i (1+ i)))) | |
196 | (file-exists-p working-file))) | |
bf247b6e | 197 | |
23f87bed MB |
198 | (unwind-protect |
199 | (progn | |
200 | (gnus-with-output-to-file working-file | |
201 | (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) | |
bf247b6e | 202 | |
23f87bed MB |
203 | ;; These bindings will mislead the current buffer |
204 | ;; into thinking that it is visiting the startup | |
205 | ;; file. | |
206 | (let ((buffer-backed-up nil) | |
207 | (buffer-file-name startup-file) | |
208 | (file-precious-flag t) | |
209 | (setmodes (file-modes startup-file))) | |
210 | ;; Backup the current version of the startup file. | |
211 | (backup-buffer) | |
bf247b6e | 212 | |
23f87bed MB |
213 | ;; Replace the existing startup file with the temp file. |
214 | (rename-file working-file startup-file t) | |
01c52d31 | 215 | (gnus-set-file-modes startup-file setmodes))) |
23f87bed MB |
216 | (condition-case nil |
217 | (delete-file working-file) | |
218 | (file-error nil))))) | |
bf247b6e | 219 | |
23f87bed MB |
220 | (gnus-kill-buffer (current-buffer)) |
221 | (gnus-message 5 "Saving %s...done" file)))) | |
222 | ||
223 | ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> | |
224 | ;; Save the gnus-registry file with extra line breaks. | |
225 | (defun gnus-registry-cache-whitespace (filename) | |
01c52d31 | 226 | (gnus-message 7 "Adding whitespace to %s" filename) |
23f87bed MB |
227 | (save-excursion |
228 | (goto-char (point-min)) | |
229 | (while (re-search-forward "^(\\|(\\\"" nil t) | |
230 | (replace-match "\n\\&" t)) | |
231 | (goto-char (point-min)) | |
232 | (while (re-search-forward " $" nil t) | |
233 | (replace-match "" t t)))) | |
234 | ||
235 | (defun gnus-registry-save (&optional force) | |
236 | (when (or gnus-registry-dirty force) | |
237 | (let ((caching gnus-registry-entry-caching)) | |
238 | ;; turn off entry caching, so mtime doesn't get recorded | |
239 | (setq gnus-registry-entry-caching nil) | |
240 | ;; remove entry caches | |
241 | (maphash | |
242 | (lambda (key value) | |
243 | (if (hash-table-p value) | |
244 | (remhash key gnus-registry-hashtb))) | |
245 | gnus-registry-hashtb) | |
246 | ;; remove empty entries | |
bf247b6e | 247 | (when gnus-registry-clean-empty |
23f87bed | 248 | (gnus-registry-clean-empty-function)) |
01c52d31 MB |
249 | ;; now trim and clean text properties from the registry appropriately |
250 | (setq gnus-registry-alist | |
251 | (gnus-registry-remove-alist-text-properties | |
252 | (gnus-registry-trim | |
253 | (gnus-hashtable-to-alist | |
254 | gnus-registry-hashtb)))) | |
23f87bed MB |
255 | ;; really save |
256 | (gnus-registry-cache-save) | |
257 | (setq gnus-registry-entry-caching caching) | |
258 | (setq gnus-registry-dirty nil)))) | |
259 | ||
260 | (defun gnus-registry-clean-empty-function () | |
261 | "Remove all empty entries from the registry. Returns count thereof." | |
262 | (let ((count 0)) | |
01c52d31 | 263 | |
23f87bed MB |
264 | (maphash |
265 | (lambda (key value) | |
01c52d31 MB |
266 | (when (stringp key) |
267 | (dolist (group (gnus-registry-fetch-groups key)) | |
268 | (when (gnus-parameter-registry-ignore group) | |
269 | (gnus-message | |
270 | 10 | |
271 | "gnus-registry: deleted ignored group %s from key %s" | |
272 | group key) | |
273 | (gnus-registry-delete-group key group))) | |
274 | ||
275 | (unless (gnus-registry-group-count key) | |
276 | (gnus-registry-delete-id key)) | |
277 | ||
278 | (unless (or | |
279 | (gnus-registry-fetch-group key) | |
280 | ;; TODO: look for specific extra data here! | |
281 | ;; in this example, we look for 'label | |
282 | (gnus-registry-fetch-extra key 'label)) | |
283 | (incf count) | |
284 | (gnus-registry-delete-id key)) | |
285 | ||
286 | (unless (stringp key) | |
287 | (gnus-message | |
288 | 10 | |
289 | "gnus-registry key %s was not a string, removing" | |
290 | key) | |
291 | (gnus-registry-delete-id key)))) | |
292 | ||
23f87bed MB |
293 | gnus-registry-hashtb) |
294 | count)) | |
295 | ||
296 | (defun gnus-registry-read () | |
297 | (gnus-registry-cache-read) | |
996aa8c1 | 298 | (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) |
23f87bed MB |
299 | (setq gnus-registry-dirty nil)) |
300 | ||
01c52d31 MB |
301 | (defun gnus-registry-remove-alist-text-properties (v) |
302 | "Remove text properties from all strings in alist." | |
303 | (if (stringp v) | |
304 | (gnus-string-remove-all-properties v) | |
305 | (if (and (listp v) (listp (cdr v))) | |
306 | (mapcar 'gnus-registry-remove-alist-text-properties v) | |
307 | (if (and (listp v) (stringp (cdr v))) | |
308 | (cons (gnus-registry-remove-alist-text-properties (car v)) | |
309 | (gnus-registry-remove-alist-text-properties (cdr v))) | |
310 | v)))) | |
311 | ||
23f87bed | 312 | (defun gnus-registry-trim (alist) |
01c52d31 MB |
313 | "Trim alist to size, using gnus-registry-max-entries. |
314 | Also, drop all gnus-registry-ignored-groups matches." | |
23f87bed | 315 | (if (null gnus-registry-max-entries) |
7cb0aa56 | 316 | alist ; just return the alist |
23f87bed | 317 | ;; else, when given max-entries, trim the alist |
7cb0aa56 MB |
318 | (let* ((timehash (make-hash-table |
319 | :size 4096 | |
320 | :test 'equal)) | |
321 | (trim-length (- (length alist) gnus-registry-max-entries)) | |
322 | (trim-length (if (natnump trim-length) trim-length 0))) | |
23f87bed MB |
323 | (maphash |
324 | (lambda (key value) | |
7cb0aa56 | 325 | (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)) |
23f87bed | 326 | gnus-registry-hashtb) |
01c52d31 | 327 | |
23f87bed MB |
328 | ;; we use the return value of this setq, which is the trimmed alist |
329 | (setq alist | |
01c52d31 MB |
330 | (nthcdr |
331 | trim-length | |
332 | (sort alist | |
333 | (lambda (a b) | |
334 | (time-less-p | |
335 | (or (cdr (gethash (car a) timehash)) '(0 0 0)) | |
336 | (or (cdr (gethash (car b) timehash)) '(0 0 0)))))))))) | |
23f87bed | 337 | |
23f87bed MB |
338 | (defun gnus-registry-action (action data-header from &optional to method) |
339 | (let* ((id (mail-header-id data-header)) | |
01c52d31 MB |
340 | (subject (gnus-string-remove-all-properties |
341 | (gnus-registry-simplify-subject | |
342 | (mail-header-subject data-header)))) | |
343 | (sender (gnus-string-remove-all-properties (mail-header-from data-header))) | |
23f87bed MB |
344 | (from (gnus-group-guess-full-name-from-command-method from)) |
345 | (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) | |
346 | (to-name (if to to "the Bit Bucket")) | |
347 | (old-entry (gethash id gnus-registry-hashtb))) | |
01c52d31 | 348 | (gnus-message 7 "Registry: article %s %s from %s to %s" |
23f87bed MB |
349 | id |
350 | (if method "respooling" "going") | |
351 | from | |
352 | to) | |
353 | ||
354 | ;; All except copy will need a delete | |
355 | (gnus-registry-delete-group id from) | |
356 | ||
bf247b6e | 357 | (when (equal 'copy action) |
23f87bed MB |
358 | (gnus-registry-add-group id from subject sender)) ; undo the delete |
359 | ||
360 | (gnus-registry-add-group id to subject sender))) | |
361 | ||
362 | (defun gnus-registry-spool-action (id group &optional subject sender) | |
363 | (let ((group (gnus-group-guess-full-name-from-command-method group))) | |
364 | (when (and (stringp id) (string-match "\r$" id)) | |
365 | (setq id (substring id 0 -1))) | |
01c52d31 | 366 | (gnus-message 7 "Registry: article %s spooled to %s" |
23f87bed MB |
367 | id |
368 | group) | |
369 | (gnus-registry-add-group id group subject sender))) | |
370 | ||
371 | ;; Function for nn{mail|imap}-split-fancy: look up all references in | |
372 | ;; the cache and if a match is found, return that group. | |
373 | (defun gnus-registry-split-fancy-with-parent () | |
374 | "Split this message into the same group as its parent. The parent | |
375 | is obtained from the registry. This function can be used as an entry | |
376 | in `nnmail-split-fancy' or `nnimap-split-fancy', for example like | |
bf247b6e | 377 | this: (: gnus-registry-split-fancy-with-parent) |
23f87bed | 378 | |
01c52d31 MB |
379 | This function tracks ALL backends, unlike |
380 | `nnmail-split-fancy-with-parent' which tracks only nnmail | |
381 | messages. | |
382 | ||
23f87bed | 383 | For a message to be split, it looks for the parent message in the |
01c52d31 MB |
384 | References or In-Reply-To header and then looks in the registry |
385 | to see which group that message was put in. This group is | |
386 | returned, unless it matches one of the entries in | |
387 | gnus-registry-unfollowed-groups or | |
388 | nnmail-split-fancy-with-parent-ignore-groups. | |
23f87bed MB |
389 | |
390 | See the Info node `(gnus)Fancy Mail Splitting' for more details." | |
01c52d31 MB |
391 | (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string |
392 | (reply-to (message-fetch-field "in-reply-to")) ; grab reply-to | |
393 | ;; now, if reply-to is valid, append it to the References | |
394 | (refstr (if reply-to | |
395 | (concat refstr " " reply-to) | |
396 | refstr)) | |
23f87bed MB |
397 | (nnmail-split-fancy-with-parent-ignore-groups |
398 | (if (listp nnmail-split-fancy-with-parent-ignore-groups) | |
399 | nnmail-split-fancy-with-parent-ignore-groups | |
400 | (list nnmail-split-fancy-with-parent-ignore-groups))) | |
01c52d31 MB |
401 | res) |
402 | ;; the references string must be valid and parse to valid references | |
403 | (if (and refstr (gnus-extract-references refstr)) | |
404 | (dolist (reference (nreverse (gnus-extract-references refstr))) | |
405 | (setq res (or (gnus-registry-fetch-group reference) res)) | |
406 | (when (or (gnus-registry-grep-in-list | |
407 | res | |
408 | gnus-registry-unfollowed-groups) | |
409 | (gnus-registry-grep-in-list | |
410 | res | |
411 | nnmail-split-fancy-with-parent-ignore-groups)) | |
412 | (setq res nil))) | |
23f87bed MB |
413 | |
414 | ;; else: there were no references, now try the extra tracking | |
01c52d31 MB |
415 | (let ((sender (gnus-string-remove-all-properties(message-fetch-field "from"))) |
416 | (subject (gnus-string-remove-all-properties | |
417 | (gnus-registry-simplify-subject | |
418 | (message-fetch-field "subject")))) | |
23f87bed MB |
419 | (single-match t)) |
420 | (when (and single-match | |
421 | (gnus-registry-track-sender-p) | |
422 | sender) | |
423 | (maphash | |
424 | (lambda (key value) | |
bf247b6e | 425 | (let ((this-sender (cdr |
23f87bed MB |
426 | (gnus-registry-fetch-extra key 'sender)))) |
427 | (when (and single-match | |
428 | this-sender | |
429 | (equal sender this-sender)) | |
430 | ;; too many matches, bail | |
431 | (unless (equal res (gnus-registry-fetch-group key)) | |
432 | (setq single-match nil)) | |
433 | (setq res (gnus-registry-fetch-group key)) | |
01c52d31 MB |
434 | (when (and sender res) |
435 | (gnus-message | |
436 | ;; raise level of messaging if gnus-registry-track-extra | |
437 | (if gnus-registry-track-extra 7 9) | |
438 | "%s (extra tracking) traced sender %s to group %s" | |
439 | "gnus-registry-split-fancy-with-parent" | |
440 | sender | |
441 | res))))) | |
23f87bed MB |
442 | gnus-registry-hashtb)) |
443 | (when (and single-match | |
444 | (gnus-registry-track-subject-p) | |
445 | subject | |
446 | (< gnus-registry-minimum-subject-length (length subject))) | |
447 | (maphash | |
448 | (lambda (key value) | |
bf247b6e | 449 | (let ((this-subject (cdr |
23f87bed MB |
450 | (gnus-registry-fetch-extra key 'subject)))) |
451 | (when (and single-match | |
452 | this-subject | |
453 | (equal subject this-subject)) | |
454 | ;; too many matches, bail | |
455 | (unless (equal res (gnus-registry-fetch-group key)) | |
456 | (setq single-match nil)) | |
457 | (setq res (gnus-registry-fetch-group key)) | |
01c52d31 MB |
458 | (when (and subject res) |
459 | (gnus-message | |
460 | ;; raise level of messaging if gnus-registry-track-extra | |
461 | (if gnus-registry-track-extra 7 9) | |
462 | "%s (extra tracking) traced subject %s to group %s" | |
463 | "gnus-registry-split-fancy-with-parent" | |
464 | subject | |
465 | res))))) | |
23f87bed MB |
466 | gnus-registry-hashtb)) |
467 | (unless single-match | |
468 | (gnus-message | |
01c52d31 | 469 | 3 |
23f87bed MB |
470 | "gnus-registry-split-fancy-with-parent: too many extra matches for %s" |
471 | refstr) | |
472 | (setq res nil)))) | |
01c52d31 MB |
473 | (when (and refstr res) |
474 | (gnus-message | |
475 | 5 | |
476 | "gnus-registry-split-fancy-with-parent traced %s to group %s" | |
477 | refstr res)) | |
23f87bed MB |
478 | |
479 | (when (and res gnus-registry-use-long-group-names) | |
480 | (let ((m1 (gnus-find-method-for-group res)) | |
bf247b6e | 481 | (m2 (or gnus-command-method |
23f87bed MB |
482 | (gnus-find-method-for-group gnus-newsgroup-name))) |
483 | (short-res (gnus-group-short-name res))) | |
484 | (if (gnus-methods-equal-p m1 m2) | |
485 | (progn | |
486 | (gnus-message | |
bf247b6e | 487 | 9 |
23f87bed MB |
488 | "gnus-registry-split-fancy-with-parent stripped group %s to %s" |
489 | res | |
490 | short-res) | |
491 | (setq res short-res)) | |
492 | ;; else... | |
493 | (gnus-message | |
01c52d31 | 494 | 7 |
23f87bed MB |
495 | "gnus-registry-split-fancy-with-parent ignored foreign group %s" |
496 | res) | |
497 | (setq res nil)))) | |
498 | res)) | |
499 | ||
01c52d31 MB |
500 | (defun gnus-registry-wash-for-keywords (&optional force) |
501 | (interactive) | |
502 | (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article)) | |
503 | word words) | |
504 | (if (or (not (gnus-registry-fetch-extra id 'keywords)) | |
505 | force) | |
506 | (save-excursion | |
507 | (set-buffer gnus-article-buffer) | |
508 | (article-goto-body) | |
509 | (save-window-excursion | |
510 | (save-restriction | |
511 | (narrow-to-region (point) (point-max)) | |
512 | (with-syntax-table gnus-adaptive-word-syntax-table | |
513 | (while (re-search-forward "\\b\\w+\\b" nil t) | |
514 | (setq word (gnus-registry-remove-alist-text-properties | |
515 | (downcase (buffer-substring | |
516 | (match-beginning 0) (match-end 0))))) | |
517 | (if (> (length word) 3) | |
518 | (push word words)))))) | |
519 | (gnus-registry-store-extra-entry id 'keywords words))))) | |
520 | ||
521 | (defun gnus-registry-find-keywords (keyword) | |
522 | (interactive "skeyword: ") | |
523 | (let (articles) | |
524 | (maphash | |
525 | (lambda (key value) | |
526 | (when (gnus-registry-grep-in-list | |
527 | keyword | |
528 | (cdr (gnus-registry-fetch-extra key 'keywords))) | |
529 | (push key articles))) | |
530 | gnus-registry-hashtb) | |
531 | articles)) | |
532 | ||
23f87bed MB |
533 | (defun gnus-registry-register-message-ids () |
534 | "Register the Message-ID of every article in the group" | |
535 | (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) | |
536 | (dolist (article gnus-newsgroup-articles) | |
537 | (let ((id (gnus-registry-fetch-message-id-fast article))) | |
538 | (unless (gnus-registry-fetch-group id) | |
bf247b6e | 539 | (gnus-message 9 "Registry: Registering article %d with group %s" |
23f87bed | 540 | article gnus-newsgroup-name) |
bf247b6e | 541 | (gnus-registry-add-group |
23f87bed MB |
542 | (gnus-registry-fetch-message-id-fast article) |
543 | gnus-newsgroup-name | |
544 | (gnus-registry-fetch-simplified-message-subject-fast article) | |
545 | (gnus-registry-fetch-sender-fast article))))))) | |
546 | ||
547 | (defun gnus-registry-fetch-message-id-fast (article) | |
548 | "Fetch the Message-ID quickly, using the internal gnus-data-list function" | |
549 | (if (and (numberp article) | |
550 | (assoc article (gnus-data-list nil))) | |
551 | (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) | |
552 | nil)) | |
553 | ||
554 | (defun gnus-registry-simplify-subject (subject) | |
555 | (if (stringp subject) | |
556 | (gnus-simplify-subject subject) | |
557 | nil)) | |
558 | ||
559 | (defun gnus-registry-fetch-simplified-message-subject-fast (article) | |
560 | "Fetch the Subject quickly, using the internal gnus-data-list function" | |
561 | (if (and (numberp article) | |
562 | (assoc article (gnus-data-list nil))) | |
01c52d31 MB |
563 | (gnus-string-remove-all-properties |
564 | (gnus-registry-simplify-subject | |
565 | (mail-header-subject (gnus-data-header | |
566 | (assoc article (gnus-data-list nil)))))) | |
23f87bed MB |
567 | nil)) |
568 | ||
569 | (defun gnus-registry-fetch-sender-fast (article) | |
570 | "Fetch the Sender quickly, using the internal gnus-data-list function" | |
571 | (if (and (numberp article) | |
572 | (assoc article (gnus-data-list nil))) | |
01c52d31 MB |
573 | (gnus-string-remove-all-properties |
574 | (mail-header-from (gnus-data-header | |
575 | (assoc article (gnus-data-list nil))))) | |
23f87bed MB |
576 | nil)) |
577 | ||
578 | (defun gnus-registry-grep-in-list (word list) | |
579 | (when word | |
580 | (memq nil | |
581 | (mapcar 'not | |
bf247b6e | 582 | (mapcar |
23f87bed | 583 | (lambda (x) |
01c52d31 | 584 | (string-match word x)) |
23f87bed MB |
585 | list))))) |
586 | ||
01c52d31 MB |
587 | ;;; if this extends to more than 'flags, it should be improved to be more generic. |
588 | (defun gnus-registry-fetch-extra-flags (id) | |
589 | "Get the flags of a message, based on the message ID. | |
590 | Returns a list of symbol flags or nil." | |
591 | (car-safe (cdr (gnus-registry-fetch-extra id 'flags)))) | |
592 | ||
593 | (defun gnus-registry-has-extra-flag (id flag) | |
594 | "Checks if a message has `flag', based on the message ID." | |
595 | (memq flag (gnus-registry-fetch-extra-flags id))) | |
596 | ||
597 | (defun gnus-registry-store-extra-flags (id &rest flag-list) | |
598 | "Set the flags of a message, based on the message ID. | |
599 | The `flag-list' can be nil, in which case no flags are left." | |
600 | (gnus-registry-store-extra-entry id 'flags (list flag-list))) | |
601 | ||
602 | (defun gnus-registry-delete-extra-flags (id &rest flag-delete-list) | |
603 | "Delete the message flags in `flag-delete-list', based on the message ID." | |
604 | (let ((flags (gnus-registry-fetch-extra-flags id))) | |
605 | (when flags | |
606 | (dolist (flag flag-delete-list) | |
607 | (setq flags (delq flag flags)))) | |
608 | (gnus-registry-store-extra-flags id (car flags)))) | |
609 | ||
610 | (defun gnus-registry-delete-all-extra-flags (id) | |
611 | "Delete all the flags for a message ID." | |
612 | (gnus-registry-store-extra-flags id nil)) | |
613 | ||
23f87bed MB |
614 | (defun gnus-registry-fetch-extra (id &optional entry) |
615 | "Get the extra data of a message, based on the message ID. | |
616 | Returns the first place where the trail finds a nonstring." | |
617 | (let ((entry-cache (gethash entry gnus-registry-hashtb))) | |
618 | (if (and entry | |
619 | (hash-table-p entry-cache) | |
620 | (gethash id entry-cache)) | |
621 | (gethash id entry-cache) | |
622 | ;; else, if there is no caching possible... | |
623 | (let ((trail (gethash id gnus-registry-hashtb))) | |
624 | (when (listp trail) | |
625 | (dolist (crumb trail) | |
626 | (unless (stringp crumb) | |
627 | (return (gnus-registry-fetch-extra-entry crumb entry id))))))))) | |
628 | ||
629 | (defun gnus-registry-fetch-extra-entry (alist &optional entry id) | |
630 | "Get the extra data of a message, or a specific entry in it. | |
631 | Update the entry cache if needed." | |
632 | (if (and entry id) | |
633 | (let ((entry-cache (gethash entry gnus-registry-hashtb)) | |
634 | entree) | |
635 | (when gnus-registry-entry-caching | |
636 | ;; create the hash table | |
637 | (unless (hash-table-p entry-cache) | |
638 | (setq entry-cache (make-hash-table | |
639 | :size 4096 | |
640 | :test 'equal)) | |
641 | (puthash entry entry-cache gnus-registry-hashtb)) | |
642 | ||
643 | ;; get the entree from the hash table or from the alist | |
644 | (setq entree (gethash id entry-cache))) | |
bf247b6e | 645 | |
23f87bed MB |
646 | (unless entree |
647 | (setq entree (assq entry alist)) | |
648 | (when gnus-registry-entry-caching | |
649 | (puthash id entree entry-cache))) | |
650 | entree) | |
651 | alist)) | |
652 | ||
653 | (defun gnus-registry-store-extra (id extra) | |
654 | "Store the extra data of a message, based on the message ID. | |
655 | The message must have at least one group name." | |
656 | (when (gnus-registry-group-count id) | |
657 | ;; we now know the trail has at least 1 group name, so it's not empty | |
658 | (let ((trail (gethash id gnus-registry-hashtb)) | |
659 | (old-extra (gnus-registry-fetch-extra id)) | |
660 | entry-cache) | |
661 | (dolist (crumb trail) | |
662 | (unless (stringp crumb) | |
663 | (dolist (entry crumb) | |
664 | (setq entry-cache (gethash (car entry) gnus-registry-hashtb)) | |
665 | (when entry-cache | |
666 | (remhash id entry-cache)))) | |
667 | (puthash id (cons extra (delete old-extra trail)) | |
668 | gnus-registry-hashtb) | |
669 | (setq gnus-registry-dirty t))))) | |
670 | ||
01c52d31 MB |
671 | (defun gnus-registry-delete-extra-entry (id key) |
672 | "Delete a specific entry in the extras field of the registry entry for id." | |
673 | (gnus-registry-store-extra-entry id key nil)) | |
674 | ||
23f87bed MB |
675 | (defun gnus-registry-store-extra-entry (id key value) |
676 | "Put a specific entry in the extras field of the registry entry for id." | |
677 | (let* ((extra (gnus-registry-fetch-extra id)) | |
01c52d31 MB |
678 | ;; all the entries except the one for `key' |
679 | (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) | |
680 | (alist (if value | |
681 | (gnus-registry-remove-alist-text-properties | |
682 | (cons (cons key value) | |
683 | the-rest)) | |
684 | the-rest))) | |
23f87bed MB |
685 | (gnus-registry-store-extra id alist))) |
686 | ||
687 | (defun gnus-registry-fetch-group (id) | |
688 | "Get the group of a message, based on the message ID. | |
689 | Returns the first place where the trail finds a group name." | |
690 | (when (gnus-registry-group-count id) | |
691 | ;; we now know the trail has at least 1 group name | |
692 | (let ((trail (gethash id gnus-registry-hashtb))) | |
693 | (dolist (crumb trail) | |
694 | (when (stringp crumb) | |
bf247b6e KS |
695 | (return (if gnus-registry-use-long-group-names |
696 | crumb | |
23f87bed MB |
697 | (gnus-group-short-name crumb)))))))) |
698 | ||
01c52d31 MB |
699 | (defun gnus-registry-fetch-groups (id) |
700 | "Get the groups of a message, based on the message ID." | |
701 | (let ((trail (gethash id gnus-registry-hashtb)) | |
702 | groups) | |
703 | (dolist (crumb trail) | |
704 | (when (stringp crumb) | |
705 | ;; push the group name into the list | |
706 | (setq | |
707 | groups | |
708 | (cons | |
709 | (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) | |
710 | crumb | |
711 | (gnus-group-short-name crumb)) | |
712 | groups)))) | |
713 | ;; return the list of groups | |
714 | groups)) | |
715 | ||
23f87bed MB |
716 | (defun gnus-registry-group-count (id) |
717 | "Get the number of groups of a message, based on the message ID." | |
718 | (let ((trail (gethash id gnus-registry-hashtb))) | |
719 | (if (and trail (listp trail)) | |
720 | (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail)) | |
721 | 0))) | |
722 | ||
723 | (defun gnus-registry-delete-group (id group) | |
724 | "Delete a group for a message, based on the message ID." | |
01c52d31 | 725 | (when (and group id) |
23f87bed | 726 | (let ((trail (gethash id gnus-registry-hashtb)) |
01c52d31 | 727 | (short-group (gnus-group-short-name group))) |
23f87bed | 728 | (puthash id (if trail |
01c52d31 | 729 | (delete short-group (delete group trail)) |
23f87bed MB |
730 | nil) |
731 | gnus-registry-hashtb)) | |
732 | ;; now, clear the entry if there are no more groups | |
733 | (when gnus-registry-trim-articles-without-groups | |
734 | (unless (gnus-registry-group-count id) | |
735 | (gnus-registry-delete-id id))) | |
270a576a MB |
736 | ;; is this ID still in the registry? |
737 | (when (gethash id gnus-registry-hashtb) | |
01c52d31 | 738 | (gnus-registry-store-extra-entry id 'mtime (current-time))))) |
23f87bed MB |
739 | |
740 | (defun gnus-registry-delete-id (id) | |
741 | "Delete a message ID from the registry." | |
742 | (when (stringp id) | |
743 | (remhash id gnus-registry-hashtb) | |
744 | (maphash | |
745 | (lambda (key value) | |
746 | (when (hash-table-p value) | |
747 | (remhash id value))) | |
748 | gnus-registry-hashtb))) | |
749 | ||
750 | (defun gnus-registry-add-group (id group &optional subject sender) | |
751 | "Add a group for a message, based on the message ID." | |
752 | (when group | |
753 | (when (and id | |
754 | (not (string-match "totally-fudged-out-message-id" id))) | |
755 | (let ((full-group group) | |
bf247b6e KS |
756 | (group (if gnus-registry-use-long-group-names |
757 | group | |
23f87bed MB |
758 | (gnus-group-short-name group)))) |
759 | (gnus-registry-delete-group id group) | |
760 | ||
761 | (unless gnus-registry-use-long-group-names ;; unnecessary in this case | |
762 | (gnus-registry-delete-group id full-group)) | |
763 | ||
764 | (let ((trail (gethash id gnus-registry-hashtb))) | |
765 | (puthash id (if trail | |
766 | (cons group trail) | |
767 | (list group)) | |
768 | gnus-registry-hashtb) | |
769 | ||
770 | (when (and (gnus-registry-track-subject-p) | |
771 | subject) | |
772 | (gnus-registry-store-extra-entry | |
bf247b6e KS |
773 | id |
774 | 'subject | |
23f87bed MB |
775 | (gnus-registry-simplify-subject subject))) |
776 | (when (and (gnus-registry-track-sender-p) | |
777 | sender) | |
778 | (gnus-registry-store-extra-entry | |
bf247b6e | 779 | id |
23f87bed MB |
780 | 'sender |
781 | sender)) | |
bf247b6e | 782 | |
23f87bed MB |
783 | (gnus-registry-store-extra-entry id 'mtime (current-time))))))) |
784 | ||
785 | (defun gnus-registry-clear () | |
786 | "Clear the Gnus registry." | |
787 | (interactive) | |
788 | (setq gnus-registry-alist nil) | |
996aa8c1 | 789 | (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) |
23f87bed MB |
790 | (setq gnus-registry-dirty t)) |
791 | ||
792 | ;;;###autoload | |
793 | (defun gnus-registry-initialize () | |
794 | (interactive) | |
795 | (setq gnus-registry-install t) | |
796 | (gnus-registry-install-hooks) | |
797 | (gnus-registry-read)) | |
798 | ||
799 | ;;;###autoload | |
800 | (defun gnus-registry-install-hooks () | |
801 | "Install the registry hooks." | |
802 | (interactive) | |
bf247b6e | 803 | (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) |
23f87bed MB |
804 | (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) |
805 | (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
806 | (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
bf247b6e | 807 | |
23f87bed MB |
808 | (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) |
809 | (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
810 | ||
811 | (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
812 | ||
813 | (defun gnus-registry-unload-hook () | |
814 | "Uninstall the registry hooks." | |
815 | (interactive) | |
bf247b6e | 816 | (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) |
23f87bed MB |
817 | (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) |
818 | (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
819 | (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
bf247b6e | 820 | |
23f87bed MB |
821 | (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) |
822 | (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
823 | ||
824 | (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
825 | ||
6d52545d RS |
826 | (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) |
827 | ||
23f87bed MB |
828 | (when gnus-registry-install |
829 | (gnus-registry-install-hooks) | |
830 | (gnus-registry-read)) | |
831 | ||
832 | ;; TODO: a lot of things | |
833 | ||
834 | (provide 'gnus-registry) | |
835 | ||
836 | ;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 | |
837 | ;;; gnus-registry.el ends here |