Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; gnus-registry.el --- article registry for Gnus |
e84b4b86 | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 2002-2011 Free Software Foundation, Inc. |
23f87bed MB |
4 | |
5 | ;; Author: Ted Zlatanov <tzz@lifelogs.com> | |
0ab5c2be | 6 | ;; Keywords: news registry |
23f87bed MB |
7 | |
8 | ;; This file is part of GNU Emacs. | |
9 | ||
5e809f55 | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
23f87bed | 11 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
23f87bed MB |
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 | |
5e809f55 | 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
23f87bed MB |
18 | ;; GNU General Public License for more details. |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
23f87bed MB |
22 | |
23 | ;;; Commentary: | |
24 | ||
01c52d31 MB |
25 | ;; This is the gnus-registry.el package, which works with all |
26 | ;; backends, not just nnmail (e.g. NNTP). The major issue is that it | |
27 | ;; doesn't go across backends, so for instance if an article is in | |
28 | ;; nnml:sys and you see a reference to it in nnimap splitting, the | |
29 | ;; article will end up in nnimap:sys | |
23f87bed MB |
30 | |
31 | ;; gnus-registry.el intercepts article respooling, moving, deleting, | |
32 | ;; and copying for all backends. If it doesn't work correctly for | |
33 | ;; you, submit a bug report and I'll be glad to fix it. It needs | |
34 | ;; documentation in the manual (also on my to-do list). | |
35 | ||
36 | ;; Put this in your startup file (~/.gnus.el for instance) | |
37 | ||
38 | ;; (setq gnus-registry-max-entries 2500 | |
39 | ;; gnus-registry-use-long-group-names t) | |
40 | ||
41 | ;; (gnus-registry-initialize) | |
42 | ||
43 | ;; Then use this in your fancy-split: | |
44 | ||
45 | ;; (: gnus-registry-split-fancy-with-parent) | |
46 | ||
36d3245f G |
47 | ;; You should also consider using the nnregistry backend to look up |
48 | ;; articles. See the Gnus manual for more information. | |
49 | ||
23f87bed MB |
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 | 64 | (require 'nnmail) |
ec7995fa | 65 | (require 'easymenu) |
23f87bed | 66 | |
9efa445f DN |
67 | (defvar gnus-adaptive-word-syntax-table) |
68 | ||
23f87bed MB |
69 | (defvar gnus-registry-dirty t |
70 | "Boolean set to t when the registry is modified") | |
71 | ||
72 | (defgroup gnus-registry nil | |
73 | "The Gnus registry." | |
bf247b6e | 74 | :version "22.1" |
23f87bed MB |
75 | :group 'gnus) |
76 | ||
c9fc72fa | 77 | (defvar gnus-registry-hashtb (make-hash-table |
01c52d31 MB |
78 | :size 256 |
79 | :test 'equal) | |
23f87bed MB |
80 | "*The article registry by Message ID.") |
81 | ||
0b6799c3 | 82 | (defcustom gnus-registry-marks |
14e8de0c | 83 | '((Important |
8f7abae3 MB |
84 | :char ?i |
85 | :image "summary_important") | |
14e8de0c | 86 | (Work |
8f7abae3 MB |
87 | :char ?w |
88 | :image "summary_work") | |
14e8de0c | 89 | (Personal |
8f7abae3 MB |
90 | :char ?p |
91 | :image "summary_personal") | |
14e8de0c | 92 | (To-Do |
8f7abae3 MB |
93 | :char ?t |
94 | :image "summary_todo") | |
14e8de0c | 95 | (Later |
8f7abae3 MB |
96 | :char ?l |
97 | :image "summary_later")) | |
14e8de0c MB |
98 | |
99 | "List of registry marks and their options. | |
100 | ||
101 | `gnus-registry-mark-article' will offer symbols from this list | |
c9fc72fa | 102 | for completion. |
14e8de0c MB |
103 | |
104 | Each entry must have a character to be useful for summary mode | |
105 | line display and for keyboard shortcuts. | |
106 | ||
107 | Each entry must have an image string to be useful for visual | |
108 | display." | |
0b6799c3 | 109 | :group 'gnus-registry |
8f7abae3 MB |
110 | :type '(repeat :tag "Registry Marks" |
111 | (cons :tag "Mark" | |
112 | (symbol :tag "Name") | |
113 | (checklist :tag "Options" :greedy t | |
114 | (group :inline t | |
115 | (const :format "" :value :char) | |
116 | (character :tag "Character code")) | |
117 | (group :inline t | |
118 | (const :format "" :value :image) | |
119 | (string :tag "Image")))))) | |
0b6799c3 MB |
120 | |
121 | (defcustom gnus-registry-default-mark 'To-Do | |
14e8de0c | 122 | "The default mark. Should be a valid key for `gnus-registry-marks'." |
0b6799c3 MB |
123 | :group 'gnus-registry |
124 | :type 'symbol) | |
125 | ||
c9fc72fa | 126 | (defcustom gnus-registry-unfollowed-groups |
a5954fa5 | 127 | '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive") |
01c52d31 MB |
128 | "List of groups that gnus-registry-split-fancy-with-parent won't return. |
129 | The group names are matched, they don't have to be fully | |
130 | qualified. This parameter tells the Registry 'never split a | |
131 | message into a group that matches one of these, regardless of | |
6b958814 G |
132 | references.' |
133 | ||
134 | nnmairix groups are specifically excluded because they are ephemeral." | |
23f87bed | 135 | :group 'gnus-registry |
01c52d31 | 136 | :type '(repeat regexp)) |
23f87bed | 137 | |
8f7abae3 | 138 | (defcustom gnus-registry-install 'ask |
23f87bed MB |
139 | "Whether the registry should be installed." |
140 | :group 'gnus-registry | |
8f7abae3 MB |
141 | :type '(choice (const :tag "Never Install" nil) |
142 | (const :tag "Always Install" t) | |
143 | (const :tag "Ask Me" ask))) | |
23f87bed | 144 | |
ec7995fa KY |
145 | (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. |
146 | ||
147 | (defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus | |
148 | ||
23f87bed MB |
149 | (defcustom gnus-registry-clean-empty t |
150 | "Whether the empty registry entries should be deleted. | |
01c52d31 MB |
151 | Registry entries are considered empty when they have no groups |
152 | and no extra data." | |
23f87bed MB |
153 | :group 'gnus-registry |
154 | :type 'boolean) | |
155 | ||
64763fe3 MB |
156 | (defcustom gnus-registry-use-long-group-names t |
157 | "Whether the registry should use long group names." | |
23f87bed MB |
158 | :group 'gnus-registry |
159 | :type 'boolean) | |
160 | ||
b86402ab MB |
161 | (defcustom gnus-registry-max-track-groups 20 |
162 | "The maximum number of non-unique group matches to check for a message ID." | |
163 | :group 'gnus-registry | |
164 | :type '(radio (const :format "Unlimited " nil) | |
165 | (integer :format "Maximum non-unique matches: %v"))) | |
166 | ||
23f87bed MB |
167 | (defcustom gnus-registry-track-extra nil |
168 | "Whether the registry should track extra data about a message. | |
169 | The Subject and Sender (From:) headers are currently tracked this | |
170 | way." | |
171 | :group 'gnus-registry | |
bf247b6e | 172 | :type |
23f87bed MB |
173 | '(set :tag "Tracking choices" |
174 | (const :tag "Track by subject (Subject: header)" subject) | |
175 | (const :tag "Track by sender (From: header)" sender))) | |
176 | ||
58a67d68 MB |
177 | (defcustom gnus-registry-split-strategy nil |
178 | "Whether the registry should track extra data about a message. | |
179 | The Subject and Sender (From:) headers are currently tracked this | |
180 | way." | |
181 | :group 'gnus-registry | |
182 | :type | |
183 | '(choice :tag "Tracking choices" | |
184 | (const :tag "Only use single choices, discard multiple matches" nil) | |
185 | (const :tag "Majority of matches wins" majority) | |
186 | (const :tag "First found wins" first))) | |
187 | ||
23f87bed MB |
188 | (defcustom gnus-registry-entry-caching t |
189 | "Whether the registry should cache extra information." | |
190 | :group 'gnus-registry | |
191 | :type 'boolean) | |
192 | ||
193 | (defcustom gnus-registry-minimum-subject-length 5 | |
194 | "The minimum length of a subject before it's considered trackable." | |
195 | :group 'gnus-registry | |
196 | :type 'integer) | |
197 | ||
198 | (defcustom gnus-registry-trim-articles-without-groups t | |
199 | "Whether the registry should clean out message IDs without groups." | |
200 | :group 'gnus-registry | |
201 | :type 'boolean) | |
202 | ||
0b6799c3 MB |
203 | (defcustom gnus-registry-extra-entries-precious '(marks) |
204 | "What extra entries are precious, meaning they won't get trimmed. | |
205 | When you save the Gnus registry, it's trimmed to be no longer | |
206 | than `gnus-registry-max-entries' (which is nil by default, so no | |
207 | trimming happens). Any entries with extra data in this list (by | |
208 | default, marks are included, so articles with marks are | |
209 | considered precious) will not be trimmed." | |
210 | :group 'gnus-registry | |
211 | :type '(repeat symbol)) | |
212 | ||
c9fc72fa LMI |
213 | (defcustom gnus-registry-cache-file |
214 | (nnheader-concat | |
215 | (or gnus-dribble-directory gnus-home-directory "~/") | |
01c52d31 | 216 | ".gnus.registry.eld") |
23f87bed MB |
217 | "File where the Gnus registry will be stored." |
218 | :group 'gnus-registry | |
219 | :type 'file) | |
220 | ||
221 | (defcustom gnus-registry-max-entries nil | |
222 | "Maximum number of entries in the registry, nil for unlimited." | |
223 | :group 'gnus-registry | |
224 | :type '(radio (const :format "Unlimited " nil) | |
ad136a7c | 225 | (integer :format "Maximum number: %v"))) |
23f87bed | 226 | |
23f87bed MB |
227 | (defun gnus-registry-track-subject-p () |
228 | (memq 'subject gnus-registry-track-extra)) | |
229 | ||
230 | (defun gnus-registry-track-sender-p () | |
231 | (memq 'sender gnus-registry-track-extra)) | |
232 | ||
233 | (defun gnus-registry-cache-read () | |
234 | "Read the registry cache file." | |
235 | (interactive) | |
236 | (let ((file gnus-registry-cache-file)) | |
237 | (when (file-exists-p file) | |
238 | (gnus-message 5 "Reading %s..." file) | |
239 | (gnus-load file) | |
240 | (gnus-message 5 "Reading %s...done" file)))) | |
241 | ||
8aed9ac5 RS |
242 | ;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in |
243 | ;; `gnus-start.el'. --rsteib | |
23f87bed MB |
244 | (defun gnus-registry-cache-save () |
245 | "Save the registry cache file." | |
246 | (interactive) | |
247 | (let ((file gnus-registry-cache-file)) | |
20a673b2 | 248 | (with-current-buffer (gnus-get-buffer-create " *Gnus-registry-cache*") |
23f87bed MB |
249 | (make-local-variable 'version-control) |
250 | (setq version-control gnus-backup-startup-file) | |
251 | (setq buffer-file-name file) | |
252 | (setq default-directory (file-name-directory buffer-file-name)) | |
253 | (buffer-disable-undo) | |
254 | (erase-buffer) | |
255 | (gnus-message 5 "Saving %s..." file) | |
256 | (if gnus-save-startup-file-via-temp-buffer | |
257 | (let ((coding-system-for-write gnus-ding-file-coding-system) | |
258 | (standard-output (current-buffer))) | |
c9fc72fa | 259 | (gnus-gnus-to-quick-newsrc-format |
14e8de0c | 260 | t "gnus registry startup file" 'gnus-registry-alist) |
23f87bed MB |
261 | (gnus-registry-cache-whitespace file) |
262 | (save-buffer)) | |
263 | (let ((coding-system-for-write gnus-ding-file-coding-system) | |
264 | (version-control gnus-backup-startup-file) | |
265 | (startup-file file) | |
266 | (working-dir (file-name-directory file)) | |
267 | working-file | |
268 | (i -1)) | |
269 | ;; Generate the name of a non-existent file. | |
270 | (while (progn (setq working-file | |
271 | (format | |
272 | (if (and (eq system-type 'ms-dos) | |
273 | (not (gnus-long-file-names))) | |
274 | "%s#%d.tm#" ; MSDOS limits files to 8+3 | |
7c2fb837 | 275 | "%s#tmp#%d") |
23f87bed MB |
276 | working-dir (setq i (1+ i)))) |
277 | (file-exists-p working-file))) | |
bf247b6e | 278 | |
23f87bed MB |
279 | (unwind-protect |
280 | (progn | |
281 | (gnus-with-output-to-file working-file | |
c9fc72fa | 282 | (gnus-gnus-to-quick-newsrc-format |
14e8de0c | 283 | t "gnus registry startup file" 'gnus-registry-alist)) |
bf247b6e | 284 | |
23f87bed MB |
285 | ;; These bindings will mislead the current buffer |
286 | ;; into thinking that it is visiting the startup | |
287 | ;; file. | |
288 | (let ((buffer-backed-up nil) | |
289 | (buffer-file-name startup-file) | |
290 | (file-precious-flag t) | |
291 | (setmodes (file-modes startup-file))) | |
292 | ;; Backup the current version of the startup file. | |
293 | (backup-buffer) | |
bf247b6e | 294 | |
23f87bed MB |
295 | ;; Replace the existing startup file with the temp file. |
296 | (rename-file working-file startup-file t) | |
01c52d31 | 297 | (gnus-set-file-modes startup-file setmodes))) |
23f87bed MB |
298 | (condition-case nil |
299 | (delete-file working-file) | |
300 | (file-error nil))))) | |
bf247b6e | 301 | |
23f87bed MB |
302 | (gnus-kill-buffer (current-buffer)) |
303 | (gnus-message 5 "Saving %s...done" file)))) | |
304 | ||
305 | ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> | |
306 | ;; Save the gnus-registry file with extra line breaks. | |
307 | (defun gnus-registry-cache-whitespace (filename) | |
01c52d31 | 308 | (gnus-message 7 "Adding whitespace to %s" filename) |
23f87bed MB |
309 | (save-excursion |
310 | (goto-char (point-min)) | |
311 | (while (re-search-forward "^(\\|(\\\"" nil t) | |
312 | (replace-match "\n\\&" t)) | |
313 | (goto-char (point-min)) | |
314 | (while (re-search-forward " $" nil t) | |
315 | (replace-match "" t t)))) | |
316 | ||
317 | (defun gnus-registry-save (&optional force) | |
318 | (when (or gnus-registry-dirty force) | |
319 | (let ((caching gnus-registry-entry-caching)) | |
320 | ;; turn off entry caching, so mtime doesn't get recorded | |
321 | (setq gnus-registry-entry-caching nil) | |
322 | ;; remove entry caches | |
323 | (maphash | |
324 | (lambda (key value) | |
325 | (if (hash-table-p value) | |
326 | (remhash key gnus-registry-hashtb))) | |
327 | gnus-registry-hashtb) | |
328 | ;; remove empty entries | |
bf247b6e | 329 | (when gnus-registry-clean-empty |
23f87bed | 330 | (gnus-registry-clean-empty-function)) |
01c52d31 | 331 | ;; now trim and clean text properties from the registry appropriately |
c9fc72fa | 332 | (setq gnus-registry-alist |
01c52d31 MB |
333 | (gnus-registry-remove-alist-text-properties |
334 | (gnus-registry-trim | |
335 | (gnus-hashtable-to-alist | |
336 | gnus-registry-hashtb)))) | |
23f87bed MB |
337 | ;; really save |
338 | (gnus-registry-cache-save) | |
339 | (setq gnus-registry-entry-caching caching) | |
340 | (setq gnus-registry-dirty nil)))) | |
341 | ||
342 | (defun gnus-registry-clean-empty-function () | |
343 | "Remove all empty entries from the registry. Returns count thereof." | |
344 | (let ((count 0)) | |
01c52d31 | 345 | |
23f87bed MB |
346 | (maphash |
347 | (lambda (key value) | |
01c52d31 MB |
348 | (when (stringp key) |
349 | (dolist (group (gnus-registry-fetch-groups key)) | |
350 | (when (gnus-parameter-registry-ignore group) | |
351 | (gnus-message | |
c9fc72fa | 352 | 10 |
01c52d31 MB |
353 | "gnus-registry: deleted ignored group %s from key %s" |
354 | group key) | |
355 | (gnus-registry-delete-group key group))) | |
356 | ||
357 | (unless (gnus-registry-group-count key) | |
358 | (gnus-registry-delete-id key)) | |
359 | ||
360 | (unless (or | |
361 | (gnus-registry-fetch-group key) | |
362 | ;; TODO: look for specific extra data here! | |
363 | ;; in this example, we look for 'label | |
364 | (gnus-registry-fetch-extra key 'label)) | |
365 | (incf count) | |
366 | (gnus-registry-delete-id key)) | |
c9fc72fa | 367 | |
01c52d31 | 368 | (unless (stringp key) |
c9fc72fa LMI |
369 | (gnus-message |
370 | 10 | |
371 | "gnus-registry key %s was not a string, removing" | |
01c52d31 MB |
372 | key) |
373 | (gnus-registry-delete-id key)))) | |
c9fc72fa | 374 | |
23f87bed MB |
375 | gnus-registry-hashtb) |
376 | count)) | |
377 | ||
378 | (defun gnus-registry-read () | |
379 | (gnus-registry-cache-read) | |
996aa8c1 | 380 | (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) |
23f87bed MB |
381 | (setq gnus-registry-dirty nil)) |
382 | ||
01c52d31 MB |
383 | (defun gnus-registry-remove-alist-text-properties (v) |
384 | "Remove text properties from all strings in alist." | |
385 | (if (stringp v) | |
386 | (gnus-string-remove-all-properties v) | |
387 | (if (and (listp v) (listp (cdr v))) | |
388 | (mapcar 'gnus-registry-remove-alist-text-properties v) | |
389 | (if (and (listp v) (stringp (cdr v))) | |
390 | (cons (gnus-registry-remove-alist-text-properties (car v)) | |
391 | (gnus-registry-remove-alist-text-properties (cdr v))) | |
392 | v)))) | |
393 | ||
23f87bed | 394 | (defun gnus-registry-trim (alist) |
01c52d31 | 395 | "Trim alist to size, using gnus-registry-max-entries. |
0b6799c3 | 396 | Any entries with extra data (marks, currently) are left alone." |
c9fc72fa | 397 | (if (null gnus-registry-max-entries) |
7cb0aa56 | 398 | alist ; just return the alist |
23f87bed | 399 | ;; else, when given max-entries, trim the alist |
7cb0aa56 | 400 | (let* ((timehash (make-hash-table |
0b6799c3 MB |
401 | :size 20000 |
402 | :test 'equal)) | |
403 | (precious (make-hash-table | |
404 | :size 20000 | |
7cb0aa56 MB |
405 | :test 'equal)) |
406 | (trim-length (- (length alist) gnus-registry-max-entries)) | |
0b6799c3 MB |
407 | (trim-length (if (natnump trim-length) trim-length 0)) |
408 | precious-list junk-list) | |
23f87bed MB |
409 | (maphash |
410 | (lambda (key value) | |
0b6799c3 MB |
411 | (let ((extra (gnus-registry-fetch-extra key))) |
412 | (dolist (item gnus-registry-extra-entries-precious) | |
413 | (dolist (e extra) | |
414 | (when (equal (nth 0 e) item) | |
415 | (puthash key t precious) | |
416 | (return)))) | |
417 | (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))) | |
23f87bed | 418 | gnus-registry-hashtb) |
23f87bed | 419 | |
0b6799c3 | 420 | (dolist (item alist) |
3d0f8a67 | 421 | (let ((key (nth 0 item))) |
0b6799c3 MB |
422 | (if (gethash key precious) |
423 | (push item precious-list) | |
424 | (push item junk-list)))) | |
425 | ||
c9fc72fa | 426 | (sort |
0b6799c3 MB |
427 | junk-list |
428 | (lambda (a b) | |
c9fc72fa | 429 | (let ((t1 (or (cdr (gethash (car a) timehash)) |
0b6799c3 | 430 | '(0 0 0))) |
c9fc72fa | 431 | (t2 (or (cdr (gethash (car b) timehash)) |
0b6799c3 MB |
432 | '(0 0 0)))) |
433 | (time-less-p t1 t2)))) | |
434 | ||
435 | ;; we use the return value of this setq, which is the trimmed alist | |
436 | (setq alist (append precious-list | |
437 | (nthcdr trim-length junk-list)))))) | |
c9fc72fa | 438 | |
23f87bed MB |
439 | (defun gnus-registry-action (action data-header from &optional to method) |
440 | (let* ((id (mail-header-id data-header)) | |
01c52d31 MB |
441 | (subject (gnus-string-remove-all-properties |
442 | (gnus-registry-simplify-subject | |
443 | (mail-header-subject data-header)))) | |
c9fc72fa | 444 | (sender (gnus-string-remove-all-properties |
14e8de0c | 445 | (mail-header-from data-header))) |
23f87bed MB |
446 | (from (gnus-group-guess-full-name-from-command-method from)) |
447 | (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) | |
448 | (to-name (if to to "the Bit Bucket")) | |
449 | (old-entry (gethash id gnus-registry-hashtb))) | |
01c52d31 | 450 | (gnus-message 7 "Registry: article %s %s from %s to %s" |
23f87bed MB |
451 | id |
452 | (if method "respooling" "going") | |
453 | from | |
454 | to) | |
455 | ||
456 | ;; All except copy will need a delete | |
457 | (gnus-registry-delete-group id from) | |
458 | ||
bf247b6e | 459 | (when (equal 'copy action) |
23f87bed MB |
460 | (gnus-registry-add-group id from subject sender)) ; undo the delete |
461 | ||
462 | (gnus-registry-add-group id to subject sender))) | |
463 | ||
464 | (defun gnus-registry-spool-action (id group &optional subject sender) | |
465 | (let ((group (gnus-group-guess-full-name-from-command-method group))) | |
466 | (when (and (stringp id) (string-match "\r$" id)) | |
467 | (setq id (substring id 0 -1))) | |
01c52d31 | 468 | (gnus-message 7 "Registry: article %s spooled to %s" |
23f87bed MB |
469 | id |
470 | group) | |
471 | (gnus-registry-add-group id group subject sender))) | |
472 | ||
473 | ;; Function for nn{mail|imap}-split-fancy: look up all references in | |
474 | ;; the cache and if a match is found, return that group. | |
475 | (defun gnus-registry-split-fancy-with-parent () | |
476 | "Split this message into the same group as its parent. The parent | |
477 | is obtained from the registry. This function can be used as an entry | |
478 | in `nnmail-split-fancy' or `nnimap-split-fancy', for example like | |
bf247b6e | 479 | this: (: gnus-registry-split-fancy-with-parent) |
23f87bed | 480 | |
01c52d31 MB |
481 | This function tracks ALL backends, unlike |
482 | `nnmail-split-fancy-with-parent' which tracks only nnmail | |
483 | messages. | |
484 | ||
23f87bed | 485 | For a message to be split, it looks for the parent message in the |
01c52d31 MB |
486 | References or In-Reply-To header and then looks in the registry |
487 | to see which group that message was put in. This group is | |
14e8de0c MB |
488 | returned, unless `gnus-registry-follow-group-p' return nil for |
489 | that group. | |
23f87bed MB |
490 | |
491 | See the Info node `(gnus)Fancy Mail Splitting' for more details." | |
14e8de0c MB |
492 | (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed |
493 | (reply-to (message-fetch-field "in-reply-to")) ; may be nil | |
01c52d31 | 494 | ;; now, if reply-to is valid, append it to the References |
c9fc72fa | 495 | (refstr (if reply-to |
01c52d31 MB |
496 | (concat refstr " " reply-to) |
497 | refstr)) | |
14e8de0c MB |
498 | ;; these may not be used, but the code is cleaner having them up here |
499 | (sender (gnus-string-remove-all-properties | |
500 | (message-fetch-field "from"))) | |
501 | (subject (gnus-string-remove-all-properties | |
502 | (gnus-registry-simplify-subject | |
503 | (message-fetch-field "subject")))) | |
504 | ||
505 | (nnmail-split-fancy-with-parent-ignore-groups | |
506 | (if (listp nnmail-split-fancy-with-parent-ignore-groups) | |
507 | nnmail-split-fancy-with-parent-ignore-groups | |
508 | (list nnmail-split-fancy-with-parent-ignore-groups))) | |
509 | (log-agent "gnus-registry-split-fancy-with-parent") | |
58a67d68 | 510 | found found-full) |
14e8de0c MB |
511 | |
512 | ;; this is a big if-else statement. it uses | |
513 | ;; gnus-registry-post-process-groups to filter the results after | |
514 | ;; every step. | |
515 | (cond | |
516 | ;; the references string must be valid and parse to valid references | |
517 | ((and refstr (gnus-extract-references refstr)) | |
518 | (dolist (reference (nreverse (gnus-extract-references refstr))) | |
519 | (gnus-message | |
520 | 9 | |
521 | "%s is looking for matches for reference %s from [%s]" | |
522 | log-agent reference refstr) | |
c9fc72fa LMI |
523 | (dolist (group (gnus-registry-fetch-groups |
524 | reference | |
b86402ab | 525 | gnus-registry-max-track-groups)) |
14e8de0c | 526 | (when (and group (gnus-registry-follow-group-p group)) |
23f87bed | 527 | (gnus-message |
14e8de0c MB |
528 | 7 |
529 | "%s traced the reference %s from [%s] to group %s" | |
530 | log-agent reference refstr group) | |
531 | (push group found)))) | |
532 | ;; filter the found groups and return them | |
58a67d68 | 533 | ;; the found groups are the full groups |
c9fc72fa | 534 | (setq found (gnus-registry-post-process-groups |
58a67d68 | 535 | "references" refstr found found))) |
c9fc72fa | 536 | |
14e8de0c | 537 | ;; else: there were no matches, now try the extra tracking by sender |
8336c962 MB |
538 | ((and (gnus-registry-track-sender-p) |
539 | sender | |
0ab5c2be MB |
540 | (not (equal (gnus-extract-address-component-email sender) |
541 | user-mail-address))) | |
14e8de0c MB |
542 | (maphash |
543 | (lambda (key value) | |
a5954fa5 G |
544 | ;; don't use more than gnus-registry-max-track-groups |
545 | (when (< (length found-full) gnus-registry-max-track-groups) | |
546 | (let ((this-sender | |
547 | (cdr (gnus-registry-fetch-extra key 'sender))) | |
548 | matches) | |
549 | (when (and this-sender | |
550 | (equal sender this-sender)) | |
551 | (let ((groups (gnus-registry-fetch-groups | |
552 | key | |
553 | gnus-registry-max-track-groups))) | |
554 | (dolist (group groups) | |
555 | (when (and group (gnus-registry-follow-group-p group)) | |
556 | (push group found-full) | |
557 | (setq found (append (list group) (delete group found)))))) | |
558 | (push key matches) | |
559 | (gnus-message | |
560 | ;; raise level of messaging if gnus-registry-track-extra | |
561 | (if gnus-registry-track-extra 7 9) | |
562 | "%s (extra tracking) traced sender %s to groups %s (keys %s)" | |
563 | log-agent sender found matches))))) | |
14e8de0c MB |
564 | gnus-registry-hashtb) |
565 | ;; filter the found groups and return them | |
58a67d68 | 566 | ;; the found groups are NOT the full groups |
c9fc72fa | 567 | (setq found (gnus-registry-post-process-groups |
58a67d68 | 568 | "sender" sender found found-full))) |
c9fc72fa | 569 | |
14e8de0c MB |
570 | ;; else: there were no matches, now try the extra tracking by subject |
571 | ((and (gnus-registry-track-subject-p) | |
572 | subject | |
573 | (< gnus-registry-minimum-subject-length (length subject))) | |
574 | (maphash | |
575 | (lambda (key value) | |
576 | (let ((this-subject (cdr | |
577 | (gnus-registry-fetch-extra key 'subject))) | |
578 | matches) | |
579 | (when (and this-subject | |
580 | (equal subject this-subject)) | |
c9fc72fa | 581 | (let ((groups (gnus-registry-fetch-groups |
b86402ab MB |
582 | key |
583 | gnus-registry-max-track-groups))) | |
9b3ebcb6 | 584 | (dolist (group groups) |
7cad71ad G |
585 | (when (and group (gnus-registry-follow-group-p group)) |
586 | (push group found-full) | |
587 | (setq found (append (list group) (delete group found)))))) | |
14e8de0c MB |
588 | (push key matches) |
589 | (gnus-message | |
590 | ;; raise level of messaging if gnus-registry-track-extra | |
591 | (if gnus-registry-track-extra 7 9) | |
592 | "%s (extra tracking) traced subject %s to groups %s (keys %s)" | |
593 | log-agent subject found matches)))) | |
594 | gnus-registry-hashtb) | |
595 | ;; filter the found groups and return them | |
58a67d68 | 596 | ;; the found groups are NOT the full groups |
c9fc72fa | 597 | (setq found (gnus-registry-post-process-groups |
58a67d68 MB |
598 | "subject" subject found found-full)))) |
599 | ;; after the (cond) we extract the actual value safely | |
600 | (car-safe found))) | |
14e8de0c | 601 | |
58a67d68 | 602 | (defun gnus-registry-post-process-groups (mode key groups groups-full) |
14e8de0c MB |
603 | "Modifies GROUPS found by MODE for KEY to determine which ones to follow. |
604 | ||
605 | MODE can be 'subject' or 'sender' for example. The KEY is the | |
606 | value by which MODE was searched. | |
607 | ||
608 | Transforms each group name to the equivalent short name. | |
609 | ||
610 | Checks if the current Gnus method (from `gnus-command-method' or | |
611 | from `gnus-newsgroup-name') is the same as the group's method. | |
612 | This is not possible if gnus-registry-use-long-group-names is | |
613 | false. Foreign methods are not supported so they are rejected. | |
614 | ||
615 | Reduces the list to a single group, or complains if that's not | |
58a67d68 MB |
616 | possible. Uses `gnus-registry-split-strategy' and GROUPS-FULL if |
617 | necessary." | |
14e8de0c MB |
618 | (let ((log-agent "gnus-registry-post-process-group") |
619 | out) | |
58a67d68 MB |
620 | |
621 | ;; the strategy can be 'first, 'majority, or nil | |
622 | (when (eq gnus-registry-split-strategy 'first) | |
623 | (when groups | |
624 | (setq groups (list (car-safe groups))))) | |
625 | ||
626 | (when (eq gnus-registry-split-strategy 'majority) | |
627 | (let ((freq (make-hash-table | |
628 | :size 256 | |
629 | :test 'equal))) | |
630 | (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full) | |
631 | (setq groups (list (car-safe | |
632 | (sort | |
633 | groups | |
634 | (lambda (a b) | |
635 | (> (gethash a freq 0) | |
636 | (gethash b freq 0))))))))) | |
c9fc72fa | 637 | |
14e8de0c MB |
638 | (if gnus-registry-use-long-group-names |
639 | (dolist (group groups) | |
640 | (let ((m1 (gnus-find-method-for-group group)) | |
641 | (m2 (or gnus-command-method | |
642 | (gnus-find-method-for-group gnus-newsgroup-name))) | |
643 | (short-name (gnus-group-short-name group))) | |
644 | (if (gnus-methods-equal-p m1 m2) | |
645 | (progn | |
646 | ;; this is REALLY just for debugging | |
647 | (gnus-message | |
648 | 10 | |
649 | "%s stripped group %s to %s" | |
650 | log-agent group short-name) | |
651 | (unless (member short-name out) | |
652 | (push short-name out))) | |
653 | ;; else... | |
654 | (gnus-message | |
655 | 7 | |
656 | "%s ignored foreign group %s" | |
657 | log-agent group)))) | |
658 | (setq out groups)) | |
659 | (when (cdr-safe out) | |
23f87bed | 660 | (gnus-message |
14e8de0c MB |
661 | 5 |
662 | "%s: too many extra matches (%s) for %s %s. Returning none." | |
663 | log-agent out mode key) | |
664 | (setq out nil)) | |
665 | out)) | |
666 | ||
667 | (defun gnus-registry-follow-group-p (group) | |
668 | "Determines if a group name should be followed. | |
669 | Consults `gnus-registry-unfollowed-groups' and | |
670 | `nnmail-split-fancy-with-parent-ignore-groups'." | |
77154961 | 671 | (not (or (gnus-grep-in-list |
14e8de0c MB |
672 | group |
673 | gnus-registry-unfollowed-groups) | |
77154961 | 674 | (gnus-grep-in-list |
14e8de0c MB |
675 | group |
676 | nnmail-split-fancy-with-parent-ignore-groups)))) | |
23f87bed | 677 | |
01c52d31 MB |
678 | (defun gnus-registry-wash-for-keywords (&optional force) |
679 | (interactive) | |
680 | (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article)) | |
681 | word words) | |
682 | (if (or (not (gnus-registry-fetch-extra id 'keywords)) | |
683 | force) | |
20a673b2 | 684 | (with-current-buffer gnus-article-buffer |
01c52d31 MB |
685 | (article-goto-body) |
686 | (save-window-excursion | |
687 | (save-restriction | |
688 | (narrow-to-region (point) (point-max)) | |
689 | (with-syntax-table gnus-adaptive-word-syntax-table | |
690 | (while (re-search-forward "\\b\\w+\\b" nil t) | |
691 | (setq word (gnus-registry-remove-alist-text-properties | |
692 | (downcase (buffer-substring | |
693 | (match-beginning 0) (match-end 0))))) | |
694 | (if (> (length word) 3) | |
695 | (push word words)))))) | |
696 | (gnus-registry-store-extra-entry id 'keywords words))))) | |
697 | ||
698 | (defun gnus-registry-find-keywords (keyword) | |
699 | (interactive "skeyword: ") | |
700 | (let (articles) | |
701 | (maphash | |
702 | (lambda (key value) | |
0ab5c2be MB |
703 | (when (member keyword |
704 | (cdr-safe (gnus-registry-fetch-extra key 'keywords))) | |
01c52d31 MB |
705 | (push key articles))) |
706 | gnus-registry-hashtb) | |
707 | articles)) | |
708 | ||
23f87bed MB |
709 | (defun gnus-registry-register-message-ids () |
710 | "Register the Message-ID of every article in the group" | |
711 | (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) | |
712 | (dolist (article gnus-newsgroup-articles) | |
713 | (let ((id (gnus-registry-fetch-message-id-fast article))) | |
3d0f8a67 | 714 | (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id)) |
bf247b6e | 715 | (gnus-message 9 "Registry: Registering article %d with group %s" |
23f87bed | 716 | article gnus-newsgroup-name) |
c9fc72fa LMI |
717 | (gnus-registry-add-group |
718 | id | |
23f87bed MB |
719 | gnus-newsgroup-name |
720 | (gnus-registry-fetch-simplified-message-subject-fast article) | |
721 | (gnus-registry-fetch-sender-fast article))))))) | |
722 | ||
723 | (defun gnus-registry-fetch-message-id-fast (article) | |
724 | "Fetch the Message-ID quickly, using the internal gnus-data-list function" | |
725 | (if (and (numberp article) | |
726 | (assoc article (gnus-data-list nil))) | |
727 | (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) | |
728 | nil)) | |
729 | ||
730 | (defun gnus-registry-simplify-subject (subject) | |
731 | (if (stringp subject) | |
732 | (gnus-simplify-subject subject) | |
733 | nil)) | |
734 | ||
735 | (defun gnus-registry-fetch-simplified-message-subject-fast (article) | |
736 | "Fetch the Subject quickly, using the internal gnus-data-list function" | |
737 | (if (and (numberp article) | |
738 | (assoc article (gnus-data-list nil))) | |
01c52d31 MB |
739 | (gnus-string-remove-all-properties |
740 | (gnus-registry-simplify-subject | |
741 | (mail-header-subject (gnus-data-header | |
742 | (assoc article (gnus-data-list nil)))))) | |
23f87bed MB |
743 | nil)) |
744 | ||
745 | (defun gnus-registry-fetch-sender-fast (article) | |
746 | "Fetch the Sender quickly, using the internal gnus-data-list function" | |
747 | (if (and (numberp article) | |
748 | (assoc article (gnus-data-list nil))) | |
01c52d31 MB |
749 | (gnus-string-remove-all-properties |
750 | (mail-header-from (gnus-data-header | |
751 | (assoc article (gnus-data-list nil))))) | |
23f87bed MB |
752 | nil)) |
753 | ||
14e8de0c MB |
754 | (defun gnus-registry-do-marks (type function) |
755 | "For each known mark, call FUNCTION for each cell of type TYPE. | |
756 | ||
757 | FUNCTION should take two parameters, a mark symbol and the cell value." | |
758 | (dolist (mark-info gnus-registry-marks) | |
8f7abae3 MB |
759 | (let* ((mark (car-safe mark-info)) |
760 | (data (cdr-safe mark-info)) | |
761 | (cell-data (plist-get data type))) | |
762 | (when cell-data | |
763 | (funcall function mark cell-data))))) | |
14e8de0c MB |
764 | |
765 | ;;; this is ugly code, but I don't know how to do it better | |
8f7abae3 | 766 | (defun gnus-registry-install-shortcuts () |
14e8de0c MB |
767 | "Install the keyboard shortcuts and menus for the registry. |
768 | Uses `gnus-registry-marks' to find what shortcuts to install." | |
8f7abae3 | 769 | (let (keys-plist) |
ec7995fa KY |
770 | (setq gnus-registry-misc-menus nil) |
771 | (gnus-registry-do-marks | |
8f7abae3 MB |
772 | :char |
773 | (lambda (mark data) | |
774 | (let ((function-format | |
775 | (format "gnus-registry-%%s-article-%s-mark" mark))) | |
14e8de0c MB |
776 | |
777 | ;;; The following generates these functions: | |
778 | ;;; (defun gnus-registry-set-article-Important-mark (&rest articles) | |
779 | ;;; "Apply the Important mark to process-marked ARTICLES." | |
780 | ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) | |
781 | ;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) | |
782 | ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) | |
783 | ;;; "Apply the Important mark to process-marked ARTICLES." | |
784 | ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) | |
785 | ;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) | |
786 | ||
8f7abae3 MB |
787 | (dolist (remove '(t nil)) |
788 | (let* ((variant-name (if remove "remove" "set")) | |
789 | (function-name (format function-format variant-name)) | |
790 | (shortcut (format "%c" data)) | |
791 | (shortcut (if remove (upcase shortcut) shortcut))) | |
5e2a84e3 | 792 | (unintern function-name obarray) |
8f7abae3 | 793 | (eval |
c9fc72fa | 794 | `(defun |
8f7abae3 | 795 | ;; function name |
c9fc72fa | 796 | ,(intern function-name) |
8f7abae3 MB |
797 | ;; parameter definition |
798 | (&rest articles) | |
799 | ;; documentation | |
c9fc72fa | 800 | ,(format |
8f7abae3 MB |
801 | "%s the %s mark over process-marked ARTICLES." |
802 | (upcase-initials variant-name) | |
803 | mark) | |
804 | ;; interactive definition | |
c9fc72fa | 805 | (interactive |
8f7abae3 MB |
806 | (gnus-summary-work-articles current-prefix-arg)) |
807 | ;; actual code | |
808 | ||
809 | ;; if this is called and the user doesn't want the | |
810 | ;; registry enabled, we'll ask anyhow | |
811 | (when (eq gnus-registry-install nil) | |
812 | (setq gnus-registry-install 'ask)) | |
813 | ||
814 | ;; now the user is asked if gnus-registry-install is 'ask | |
815 | (when (gnus-registry-install-p) | |
c9fc72fa | 816 | (gnus-registry-set-article-mark-internal |
8f7abae3 MB |
817 | ;; all this just to get the mark, I must be doing it wrong |
818 | (intern ,(symbol-name mark)) | |
819 | articles ,remove t) | |
ec7995fa | 820 | (gnus-message |
c9fc72fa | 821 | 9 |
ec7995fa KY |
822 | "Applying mark %s to %d articles" |
823 | ,(symbol-name mark) (length articles)) | |
8f7abae3 | 824 | (dolist (article articles) |
c9fc72fa | 825 | (gnus-summary-update-article |
ec7995fa | 826 | article |
8f7abae3 MB |
827 | (assoc article (gnus-data-list nil))))))) |
828 | (push (intern function-name) keys-plist) | |
c9fc72fa | 829 | (push shortcut keys-plist) |
ec7995fa KY |
830 | (push (vector (format "%s %s" |
831 | (upcase-initials variant-name) | |
832 | (symbol-name mark)) | |
833 | (intern function-name) t) | |
834 | gnus-registry-misc-menus) | |
835 | (gnus-message | |
c9fc72fa LMI |
836 | 9 |
837 | "Defined mark handling function %s" | |
8f7abae3 MB |
838 | function-name)))))) |
839 | (gnus-define-keys-1 | |
ec7995fa KY |
840 | '(gnus-registry-mark-map "M" gnus-summary-mark-map) |
841 | keys-plist) | |
842 | (add-hook 'gnus-summary-menu-hook | |
843 | (lambda () | |
c9fc72fa | 844 | (easy-menu-add-item |
ec7995fa | 845 | gnus-summary-misc-menu |
c9fc72fa | 846 | nil |
ec7995fa | 847 | (cons "Registry Marks" gnus-registry-misc-menus)))))) |
8f7abae3 MB |
848 | |
849 | ;;; use like this: | |
c9fc72fa | 850 | ;;; (defalias 'gnus-user-format-function-M |
8f7abae3 MB |
851 | ;;; 'gnus-registry-user-format-function-M) |
852 | (defun gnus-registry-user-format-function-M (headers) | |
853 | (let* ((id (mail-header-message-id headers)) | |
854 | (marks (when id (gnus-registry-fetch-extra-marks id)))) | |
855 | (apply 'concat (mapcar (lambda(mark) | |
c9fc72fa | 856 | (let ((c |
8f7abae3 | 857 | (plist-get |
c9fc72fa | 858 | (cdr-safe |
8f7abae3 MB |
859 | (assoc mark gnus-registry-marks)) |
860 | :char))) | |
861 | (if c | |
862 | (list c) | |
863 | nil))) | |
864 | marks)))) | |
0b6799c3 MB |
865 | |
866 | (defun gnus-registry-read-mark () | |
867 | "Read a mark name from the user with completion." | |
229b59da G |
868 | (let ((mark (gnus-completing-read |
869 | "Label" | |
870 | (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) | |
871 | nil nil nil | |
872 | (symbol-name gnus-registry-default-mark)))) | |
0b6799c3 MB |
873 | (when (stringp mark) |
874 | (intern mark)))) | |
875 | ||
876 | (defun gnus-registry-set-article-mark (&rest articles) | |
877 | "Apply a mark to process-marked ARTICLES." | |
878 | (interactive (gnus-summary-work-articles current-prefix-arg)) | |
879 | (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t)) | |
880 | ||
881 | (defun gnus-registry-remove-article-mark (&rest articles) | |
882 | "Remove a mark from process-marked ARTICLES." | |
883 | (interactive (gnus-summary-work-articles current-prefix-arg)) | |
884 | (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t)) | |
885 | ||
886 | (defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message) | |
887 | "Apply a mark to a list of ARTICLES." | |
888 | (let ((article-id-list | |
889 | (mapcar 'gnus-registry-fetch-message-id-fast articles))) | |
890 | (dolist (id article-id-list) | |
891 | (let* ( | |
892 | ;; all the marks for this article without the mark of | |
893 | ;; interest | |
894 | (marks | |
895 | (delq mark (gnus-registry-fetch-extra-marks id))) | |
896 | ;; the new marks we want to use | |
897 | (new-marks (if remove | |
898 | marks | |
899 | (cons mark marks)))) | |
900 | (when show-message | |
901 | (gnus-message 1 "%s mark %s with message ID %s, resulting in %S" | |
902 | (if remove "Removing" "Adding") | |
903 | mark id new-marks)) | |
c9fc72fa | 904 | |
0b6799c3 MB |
905 | (apply 'gnus-registry-store-extra-marks ; set the extra marks |
906 | id ; for the message ID | |
907 | new-marks))))) | |
908 | ||
909 | (defun gnus-registry-get-article-marks (&rest articles) | |
910 | "Get the Gnus registry marks for ARTICLES and show them if interactive. | |
911 | Uses process/prefix conventions. For multiple articles, | |
912 | only the last one's marks are returned." | |
913 | (interactive (gnus-summary-work-articles 1)) | |
914 | (let (marks) | |
915 | (dolist (article articles) | |
916 | (let ((article-id | |
917 | (gnus-registry-fetch-message-id-fast article))) | |
918 | (setq marks (gnus-registry-fetch-extra-marks article-id)))) | |
919 | (when (interactive-p) | |
920 | (gnus-message 1 "Marks are %S" marks)) | |
921 | marks)) | |
922 | ||
923 | ;;; if this extends to more than 'marks, it should be improved to be more generic. | |
924 | (defun gnus-registry-fetch-extra-marks (id) | |
925 | "Get the marks of a message, based on the message ID. | |
926 | Returns a list of symbol marks or nil." | |
927 | (car-safe (cdr (gnus-registry-fetch-extra id 'marks)))) | |
928 | ||
929 | (defun gnus-registry-has-extra-mark (id mark) | |
930 | "Checks if a message has `mark', based on the message ID `id'." | |
931 | (memq mark (gnus-registry-fetch-extra-marks id))) | |
932 | ||
933 | (defun gnus-registry-store-extra-marks (id &rest mark-list) | |
934 | "Set the marks of a message, based on the message ID. | |
935 | The `mark-list' can be nil, in which case no marks are left." | |
936 | (gnus-registry-store-extra-entry id 'marks (list mark-list))) | |
937 | ||
938 | (defun gnus-registry-delete-extra-marks (id &rest mark-delete-list) | |
939 | "Delete the message marks in `mark-delete-list', based on the message ID." | |
940 | (let ((marks (gnus-registry-fetch-extra-marks id))) | |
941 | (when marks | |
942 | (dolist (mark mark-delete-list) | |
943 | (setq marks (delq mark marks)))) | |
944 | (gnus-registry-store-extra-marks id (car marks)))) | |
945 | ||
946 | (defun gnus-registry-delete-all-extra-marks (id) | |
947 | "Delete all the marks for a message ID." | |
948 | (gnus-registry-store-extra-marks id nil)) | |
01c52d31 | 949 | |
23f87bed MB |
950 | (defun gnus-registry-fetch-extra (id &optional entry) |
951 | "Get the extra data of a message, based on the message ID. | |
952 | Returns the first place where the trail finds a nonstring." | |
953 | (let ((entry-cache (gethash entry gnus-registry-hashtb))) | |
954 | (if (and entry | |
955 | (hash-table-p entry-cache) | |
956 | (gethash id entry-cache)) | |
957 | (gethash id entry-cache) | |
958 | ;; else, if there is no caching possible... | |
959 | (let ((trail (gethash id gnus-registry-hashtb))) | |
960 | (when (listp trail) | |
961 | (dolist (crumb trail) | |
962 | (unless (stringp crumb) | |
963 | (return (gnus-registry-fetch-extra-entry crumb entry id))))))))) | |
964 | ||
965 | (defun gnus-registry-fetch-extra-entry (alist &optional entry id) | |
966 | "Get the extra data of a message, or a specific entry in it. | |
967 | Update the entry cache if needed." | |
968 | (if (and entry id) | |
969 | (let ((entry-cache (gethash entry gnus-registry-hashtb)) | |
970 | entree) | |
971 | (when gnus-registry-entry-caching | |
972 | ;; create the hash table | |
973 | (unless (hash-table-p entry-cache) | |
974 | (setq entry-cache (make-hash-table | |
975 | :size 4096 | |
976 | :test 'equal)) | |
977 | (puthash entry entry-cache gnus-registry-hashtb)) | |
978 | ||
979 | ;; get the entree from the hash table or from the alist | |
980 | (setq entree (gethash id entry-cache))) | |
bf247b6e | 981 | |
23f87bed MB |
982 | (unless entree |
983 | (setq entree (assq entry alist)) | |
984 | (when gnus-registry-entry-caching | |
985 | (puthash id entree entry-cache))) | |
986 | entree) | |
987 | alist)) | |
988 | ||
989 | (defun gnus-registry-store-extra (id extra) | |
990 | "Store the extra data of a message, based on the message ID. | |
991 | The message must have at least one group name." | |
992 | (when (gnus-registry-group-count id) | |
993 | ;; we now know the trail has at least 1 group name, so it's not empty | |
994 | (let ((trail (gethash id gnus-registry-hashtb)) | |
995 | (old-extra (gnus-registry-fetch-extra id)) | |
996 | entry-cache) | |
997 | (dolist (crumb trail) | |
998 | (unless (stringp crumb) | |
999 | (dolist (entry crumb) | |
1000 | (setq entry-cache (gethash (car entry) gnus-registry-hashtb)) | |
1001 | (when entry-cache | |
1002 | (remhash id entry-cache)))) | |
1003 | (puthash id (cons extra (delete old-extra trail)) | |
1004 | gnus-registry-hashtb) | |
1005 | (setq gnus-registry-dirty t))))) | |
1006 | ||
01c52d31 MB |
1007 | (defun gnus-registry-delete-extra-entry (id key) |
1008 | "Delete a specific entry in the extras field of the registry entry for id." | |
1009 | (gnus-registry-store-extra-entry id key nil)) | |
1010 | ||
23f87bed MB |
1011 | (defun gnus-registry-store-extra-entry (id key value) |
1012 | "Put a specific entry in the extras field of the registry entry for id." | |
1013 | (let* ((extra (gnus-registry-fetch-extra id)) | |
01c52d31 | 1014 | ;; all the entries except the one for `key' |
c9fc72fa | 1015 | (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) |
01c52d31 MB |
1016 | (alist (if value |
1017 | (gnus-registry-remove-alist-text-properties | |
1018 | (cons (cons key value) | |
1019 | the-rest)) | |
1020 | the-rest))) | |
23f87bed MB |
1021 | (gnus-registry-store-extra id alist))) |
1022 | ||
1023 | (defun gnus-registry-fetch-group (id) | |
1024 | "Get the group of a message, based on the message ID. | |
1025 | Returns the first place where the trail finds a group name." | |
1026 | (when (gnus-registry-group-count id) | |
1027 | ;; we now know the trail has at least 1 group name | |
1028 | (let ((trail (gethash id gnus-registry-hashtb))) | |
1029 | (dolist (crumb trail) | |
1030 | (when (stringp crumb) | |
bf247b6e KS |
1031 | (return (if gnus-registry-use-long-group-names |
1032 | crumb | |
23f87bed MB |
1033 | (gnus-group-short-name crumb)))))))) |
1034 | ||
b86402ab MB |
1035 | (defun gnus-registry-fetch-groups (id &optional max) |
1036 | "Get the groups (up to MAX, if given) of a message, based on the message ID." | |
01c52d31 MB |
1037 | (let ((trail (gethash id gnus-registry-hashtb)) |
1038 | groups) | |
1039 | (dolist (crumb trail) | |
1040 | (when (stringp crumb) | |
1041 | ;; push the group name into the list | |
c9fc72fa | 1042 | (setq |
01c52d31 MB |
1043 | groups |
1044 | (cons | |
1045 | (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) | |
1046 | crumb | |
1047 | (gnus-group-short-name crumb)) | |
b86402ab MB |
1048 | groups)) |
1049 | (when (and max (> (length groups) max)) | |
1050 | (return)))) | |
01c52d31 MB |
1051 | ;; return the list of groups |
1052 | groups)) | |
1053 | ||
23f87bed MB |
1054 | (defun gnus-registry-group-count (id) |
1055 | "Get the number of groups of a message, based on the message ID." | |
1056 | (let ((trail (gethash id gnus-registry-hashtb))) | |
1057 | (if (and trail (listp trail)) | |
1058 | (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail)) | |
1059 | 0))) | |
1060 | ||
1061 | (defun gnus-registry-delete-group (id group) | |
1062 | "Delete a group for a message, based on the message ID." | |
01c52d31 | 1063 | (when (and group id) |
23f87bed | 1064 | (let ((trail (gethash id gnus-registry-hashtb)) |
01c52d31 | 1065 | (short-group (gnus-group-short-name group))) |
23f87bed | 1066 | (puthash id (if trail |
01c52d31 | 1067 | (delete short-group (delete group trail)) |
23f87bed MB |
1068 | nil) |
1069 | gnus-registry-hashtb)) | |
1070 | ;; now, clear the entry if there are no more groups | |
1071 | (when gnus-registry-trim-articles-without-groups | |
1072 | (unless (gnus-registry-group-count id) | |
1073 | (gnus-registry-delete-id id))) | |
270a576a MB |
1074 | ;; is this ID still in the registry? |
1075 | (when (gethash id gnus-registry-hashtb) | |
01c52d31 | 1076 | (gnus-registry-store-extra-entry id 'mtime (current-time))))) |
23f87bed MB |
1077 | |
1078 | (defun gnus-registry-delete-id (id) | |
1079 | "Delete a message ID from the registry." | |
1080 | (when (stringp id) | |
1081 | (remhash id gnus-registry-hashtb) | |
1082 | (maphash | |
1083 | (lambda (key value) | |
1084 | (when (hash-table-p value) | |
1085 | (remhash id value))) | |
1086 | gnus-registry-hashtb))) | |
1087 | ||
1088 | (defun gnus-registry-add-group (id group &optional subject sender) | |
1089 | "Add a group for a message, based on the message ID." | |
1090 | (when group | |
1091 | (when (and id | |
1092 | (not (string-match "totally-fudged-out-message-id" id))) | |
1093 | (let ((full-group group) | |
bf247b6e KS |
1094 | (group (if gnus-registry-use-long-group-names |
1095 | group | |
23f87bed MB |
1096 | (gnus-group-short-name group)))) |
1097 | (gnus-registry-delete-group id group) | |
1098 | ||
1099 | (unless gnus-registry-use-long-group-names ;; unnecessary in this case | |
1100 | (gnus-registry-delete-group id full-group)) | |
1101 | ||
1102 | (let ((trail (gethash id gnus-registry-hashtb))) | |
1103 | (puthash id (if trail | |
1104 | (cons group trail) | |
1105 | (list group)) | |
1106 | gnus-registry-hashtb) | |
1107 | ||
1108 | (when (and (gnus-registry-track-subject-p) | |
1109 | subject) | |
1110 | (gnus-registry-store-extra-entry | |
bf247b6e KS |
1111 | id |
1112 | 'subject | |
23f87bed MB |
1113 | (gnus-registry-simplify-subject subject))) |
1114 | (when (and (gnus-registry-track-sender-p) | |
1115 | sender) | |
1116 | (gnus-registry-store-extra-entry | |
bf247b6e | 1117 | id |
23f87bed MB |
1118 | 'sender |
1119 | sender)) | |
bf247b6e | 1120 | |
23f87bed MB |
1121 | (gnus-registry-store-extra-entry id 'mtime (current-time))))))) |
1122 | ||
1123 | (defun gnus-registry-clear () | |
1124 | "Clear the Gnus registry." | |
1125 | (interactive) | |
1126 | (setq gnus-registry-alist nil) | |
996aa8c1 | 1127 | (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) |
23f87bed MB |
1128 | (setq gnus-registry-dirty t)) |
1129 | ||
1130 | ;;;###autoload | |
1131 | (defun gnus-registry-initialize () | |
8f7abae3 | 1132 | "Initialize the Gnus registry." |
23f87bed | 1133 | (interactive) |
8f7abae3 MB |
1134 | (gnus-message 5 "Initializing the registry") |
1135 | (setq gnus-registry-install t) ; in case it was 'ask or nil | |
23f87bed | 1136 | (gnus-registry-install-hooks) |
8f7abae3 | 1137 | (gnus-registry-install-shortcuts) |
23f87bed MB |
1138 | (gnus-registry-read)) |
1139 | ||
1140 | ;;;###autoload | |
1141 | (defun gnus-registry-install-hooks () | |
1142 | "Install the registry hooks." | |
1143 | (interactive) | |
bf247b6e | 1144 | (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) |
23f87bed MB |
1145 | (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) |
1146 | (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
1147 | (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
bf247b6e | 1148 | |
23f87bed MB |
1149 | (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) |
1150 | (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
1151 | ||
1152 | (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
1153 | ||
1154 | (defun gnus-registry-unload-hook () | |
1155 | "Uninstall the registry hooks." | |
1156 | (interactive) | |
bf247b6e | 1157 | (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) |
23f87bed MB |
1158 | (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) |
1159 | (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
1160 | (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
bf247b6e | 1161 | |
23f87bed MB |
1162 | (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) |
1163 | (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
1164 | ||
1165 | (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
1166 | ||
6d52545d RS |
1167 | (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) |
1168 | ||
8f7abae3 MB |
1169 | (defun gnus-registry-install-p () |
1170 | (interactive) | |
1171 | (when (eq gnus-registry-install 'ask) | |
1172 | (setq gnus-registry-install | |
1173 | (gnus-y-or-n-p | |
1174 | (concat "Enable the Gnus registry? " | |
1175 | "See the variable `gnus-registry-install' " | |
1176 | "to get rid of this query permanently. "))) | |
1177 | (when gnus-registry-install | |
1178 | ;; we just set gnus-registry-install to t, so initialize the registry! | |
1179 | (gnus-registry-initialize))) | |
1180 | ;;; we could call it here: (customize-variable 'gnus-registry-install) | |
1181 | gnus-registry-install) | |
1182 | ||
8f7abae3 | 1183 | ;; TODO: a few things |
23f87bed MB |
1184 | |
1185 | (provide 'gnus-registry) | |
1186 | ||
23f87bed | 1187 | ;;; gnus-registry.el ends here |