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 | 25 | ;; This is the gnus-registry.el package, which works with all |
11a3174d | 26 | ;; Gnus backends, not just nnmail. The major issue is that it |
01c52d31 MB |
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 | ||
11a3174d | 38 | ;; (setq gnus-registry-max-entries 2500) |
23f87bed MB |
39 | |
40 | ;; (gnus-registry-initialize) | |
41 | ||
42 | ;; Then use this in your fancy-split: | |
43 | ||
44 | ;; (: gnus-registry-split-fancy-with-parent) | |
45 | ||
36d3245f G |
46 | ;; You should also consider using the nnregistry backend to look up |
47 | ;; articles. See the Gnus manual for more information. | |
48 | ||
23f87bed MB |
49 | ;; TODO: |
50 | ||
51 | ;; - get the correct group on spool actions | |
52 | ||
11a3174d TZ |
53 | ;; - articles that are spooled to a different backend should be moved |
54 | ;; after splitting | |
23f87bed MB |
55 | |
56 | ;;; Code: | |
57 | ||
58 | (eval-when-compile (require 'cl)) | |
59 | ||
42b23765 | 60 | (eval-when-compile |
2237da9c | 61 | (when (null (ignore-errors (require 'ert))) |
42b23765 TZ |
62 | (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) |
63 | ||
2237da9c G |
64 | (ignore-errors |
65 | (require 'ert)) | |
23f87bed MB |
66 | (require 'gnus) |
67 | (require 'gnus-int) | |
68 | (require 'gnus-sum) | |
11a3174d | 69 | (require 'gnus-art) |
996aa8c1 | 70 | (require 'gnus-util) |
23f87bed | 71 | (require 'nnmail) |
ec7995fa | 72 | (require 'easymenu) |
11a3174d | 73 | (require 'registry) |
23f87bed | 74 | |
9efa445f DN |
75 | (defvar gnus-adaptive-word-syntax-table) |
76 | ||
23f87bed MB |
77 | (defvar gnus-registry-dirty t |
78 | "Boolean set to t when the registry is modified") | |
79 | ||
80 | (defgroup gnus-registry nil | |
81 | "The Gnus registry." | |
bf247b6e | 82 | :version "22.1" |
23f87bed MB |
83 | :group 'gnus) |
84 | ||
11a3174d | 85 | (defvar gnus-registry-marks |
14e8de0c | 86 | '((Important |
8f7abae3 MB |
87 | :char ?i |
88 | :image "summary_important") | |
14e8de0c | 89 | (Work |
8f7abae3 MB |
90 | :char ?w |
91 | :image "summary_work") | |
14e8de0c | 92 | (Personal |
8f7abae3 MB |
93 | :char ?p |
94 | :image "summary_personal") | |
14e8de0c | 95 | (To-Do |
8f7abae3 MB |
96 | :char ?t |
97 | :image "summary_todo") | |
14e8de0c | 98 | (Later |
8f7abae3 MB |
99 | :char ?l |
100 | :image "summary_later")) | |
14e8de0c MB |
101 | |
102 | "List of registry marks and their options. | |
103 | ||
104 | `gnus-registry-mark-article' will offer symbols from this list | |
c9fc72fa | 105 | for completion. |
14e8de0c MB |
106 | |
107 | Each entry must have a character to be useful for summary mode | |
108 | line display and for keyboard shortcuts. | |
109 | ||
110 | Each entry must have an image string to be useful for visual | |
11a3174d | 111 | display.") |
0b6799c3 MB |
112 | |
113 | (defcustom gnus-registry-default-mark 'To-Do | |
14e8de0c | 114 | "The default mark. Should be a valid key for `gnus-registry-marks'." |
0b6799c3 MB |
115 | :group 'gnus-registry |
116 | :type 'symbol) | |
117 | ||
11a3174d TZ |
118 | (defcustom gnus-registry-unfollowed-addresses |
119 | (list (regexp-quote user-mail-address)) | |
120 | "List of addresses that gnus-registry-split-fancy-with-parent won't trace. | |
121 | The addresses are matched, they don't have to be fully qualified." | |
122 | :group 'gnus-registry | |
123 | :type '(repeat regexp)) | |
124 | ||
c9fc72fa | 125 | (defcustom gnus-registry-unfollowed-groups |
a5954fa5 | 126 | '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive") |
01c52d31 MB |
127 | "List of groups that gnus-registry-split-fancy-with-parent won't return. |
128 | The group names are matched, they don't have to be fully | |
11a3174d | 129 | qualified. This parameter tells the Gnus registry 'never split a |
01c52d31 | 130 | message into a group that matches one of these, regardless of |
6b958814 G |
131 | references.' |
132 | ||
133 | nnmairix groups are specifically excluded because they are ephemeral." | |
23f87bed | 134 | :group 'gnus-registry |
01c52d31 | 135 | :type '(repeat regexp)) |
23f87bed | 136 | |
8f7abae3 | 137 | (defcustom gnus-registry-install 'ask |
23f87bed MB |
138 | "Whether the registry should be installed." |
139 | :group 'gnus-registry | |
8f7abae3 | 140 | :type '(choice (const :tag "Never Install" nil) |
11a3174d TZ |
141 | (const :tag "Always Install" t) |
142 | (const :tag "Ask Me" ask))) | |
23f87bed | 143 | |
ec7995fa KY |
144 | (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. |
145 | ||
11a3174d | 146 | (defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus |
23f87bed | 147 | |
11a3174d TZ |
148 | (make-obsolete-variable 'gnus-registry-clean-empty nil "23.4") |
149 | (make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4") | |
150 | (make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4") | |
151 | (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4") | |
152 | (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4") | |
b86402ab | 153 | |
11a3174d | 154 | (defcustom gnus-registry-track-extra '(subject sender) |
23f87bed | 155 | "Whether the registry should track extra data about a message. |
11a3174d TZ |
156 | The Subject and Sender (From:) headers are tracked this way by |
157 | default." | |
23f87bed | 158 | :group 'gnus-registry |
bf247b6e | 159 | :type |
23f87bed MB |
160 | '(set :tag "Tracking choices" |
161 | (const :tag "Track by subject (Subject: header)" subject) | |
162 | (const :tag "Track by sender (From: header)" sender))) | |
163 | ||
58a67d68 | 164 | (defcustom gnus-registry-split-strategy nil |
11a3174d | 165 | "The splitting strategy applied to the keys in `gnus-registry-track-extra'. |
58a67d68 | 166 | |
11a3174d TZ |
167 | Given a set of unique found groups G and counts for each element |
168 | of G, and a key K (typically 'sender or 'subject): | |
169 | ||
170 | When nil, if G has only one element, use it. Otherwise give up. | |
171 | This is the fastest but also least useful strategy. | |
172 | ||
173 | When 'majority, use the majority by count. So if there is a | |
174 | group with the most articles counted by K, use that. Ties are | |
175 | resolved in no particular order, simply the first one found wins. | |
176 | This is the slowest strategy but also the most accurate one. | |
177 | ||
178 | When 'first, the first element of G wins. This is fast and | |
179 | should be OK if your senders and subjects don't \"bleed\" across | |
180 | groups." | |
23f87bed | 181 | :group 'gnus-registry |
11a3174d TZ |
182 | :type |
183 | '(choice :tag "Splitting strategy" | |
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))) | |
23f87bed MB |
187 | |
188 | (defcustom gnus-registry-minimum-subject-length 5 | |
189 | "The minimum length of a subject before it's considered trackable." | |
190 | :group 'gnus-registry | |
191 | :type 'integer) | |
192 | ||
11a3174d TZ |
193 | (defcustom gnus-registry-extra-entries-precious '(mark) |
194 | "What extra keys are precious, meaning entries with them won't get pruned. | |
195 | By default, 'mark is included, so articles with marks are | |
196 | considered precious. | |
197 | ||
198 | Before you save the Gnus registry, it's pruned. Any entries with | |
199 | keys in this list will not be pruned. All other entries go to | |
200 | the Bit Bucket." | |
0b6799c3 MB |
201 | :group 'gnus-registry |
202 | :type '(repeat symbol)) | |
203 | ||
c9fc72fa LMI |
204 | (defcustom gnus-registry-cache-file |
205 | (nnheader-concat | |
206 | (or gnus-dribble-directory gnus-home-directory "~/") | |
11a3174d | 207 | ".gnus.registry.eioio") |
23f87bed MB |
208 | "File where the Gnus registry will be stored." |
209 | :group 'gnus-registry | |
210 | :type 'file) | |
211 | ||
212 | (defcustom gnus-registry-max-entries nil | |
213 | "Maximum number of entries in the registry, nil for unlimited." | |
214 | :group 'gnus-registry | |
215 | :type '(radio (const :format "Unlimited " nil) | |
11a3174d | 216 | (integer :format "Maximum number: %v"))) |
23f87bed | 217 | |
11a3174d TZ |
218 | (defcustom gnus-registry-max-pruned-entries nil |
219 | "Maximum number of pruned entries in the registry, nil for unlimited." | |
220 | :group 'gnus-registry | |
221 | :type '(radio (const :format "Unlimited " nil) | |
222 | (integer :format "Maximum number: %v"))) | |
223 | ||
224 | (defun gnus-registry-fixup-registry (db) | |
225 | (when db | |
226 | (oset db :precious | |
227 | (append gnus-registry-extra-entries-precious | |
228 | '())) | |
229 | (oset db :max-hard | |
230 | (or gnus-registry-max-entries | |
231 | most-positive-fixnum)) | |
232 | (oset db :max-soft | |
233 | (or gnus-registry-max-pruned-entries | |
234 | most-positive-fixnum)) | |
235 | (oset db :tracked | |
236 | (append gnus-registry-track-extra | |
237 | '(mark group keyword)))) | |
238 | db) | |
239 | ||
240 | (defun gnus-registry-make-db (&optional file) | |
241 | (interactive "fGnus registry persistence file: \n") | |
242 | (gnus-registry-fixup-registry | |
243 | (registry-db | |
244 | "Gnus Registry" | |
245 | :file (or file gnus-registry-cache-file) | |
246 | ;; these parameters are set in `gnus-registry-fixup-registry' | |
247 | :max-hard most-positive-fixnum | |
248 | :max-soft most-positive-fixnum | |
249 | :precious nil | |
250 | :tracked nil))) | |
251 | ||
252 | (defvar gnus-registry-db (gnus-registry-make-db) | |
253 | "*The article registry by Message ID. See `registry-db'") | |
254 | ||
255 | ;; top-level registry data management | |
256 | (defun gnus-registry-remake-db (&optional forsure) | |
257 | "Remake the registry database after customization. | |
258 | This is not required after changing `gnus-registry-cache-file'." | |
259 | (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? "))) | |
260 | (when forsure | |
261 | (gnus-message 1 "Remaking the Gnus registry") | |
262 | (setq gnus-registry-db (gnus-registry-make-db)))) | |
23f87bed | 263 | |
11a3174d | 264 | (defun gnus-registry-read () |
23f87bed MB |
265 | "Read the registry cache file." |
266 | (interactive) | |
267 | (let ((file gnus-registry-cache-file)) | |
11a3174d TZ |
268 | (condition-case nil |
269 | (progn | |
270 | (gnus-message 5 "Reading Gnus registry from %s..." file) | |
271 | (setq gnus-registry-db (gnus-registry-fixup-registry | |
272 | (eieio-persistent-read file))) | |
273 | (gnus-message 5 "Reading Gnus registry from %s...done" file)) | |
274 | (error | |
275 | (gnus-message | |
276 | 1 | |
277 | "The Gnus registry could not be loaded from %s, creating a new one" | |
278 | file) | |
279 | (gnus-registry-remake-db t))))) | |
280 | ||
281 | (defun gnus-registry-save (&optional file db) | |
23f87bed MB |
282 | "Save the registry cache file." |
283 | (interactive) | |
11a3174d TZ |
284 | (let ((file (or file gnus-registry-cache-file)) |
285 | (db (or db gnus-registry-db))) | |
286 | (gnus-message 5 "Saving Gnus registry (%d entries) to %s..." | |
287 | (registry-size db) file) | |
288 | (registry-prune db) | |
289 | ;; TODO: call (gnus-string-remove-all-properties v) on all elements? | |
290 | (eieio-persistent-save db file) | |
291 | (gnus-message 5 "Saving Gnus registry (size %d) to %s...done" | |
292 | (registry-size db) file))) | |
293 | ||
294 | ;; article move/copy/spool/delete actions | |
23f87bed MB |
295 | (defun gnus-registry-action (action data-header from &optional to method) |
296 | (let* ((id (mail-header-id data-header)) | |
11a3174d TZ |
297 | (subject (gnus-string-remove-all-properties |
298 | (gnus-registry-simplify-subject | |
299 | (mail-header-subject data-header)))) | |
300 | (sender (gnus-string-remove-all-properties | |
301 | (mail-header-from data-header))) | |
302 | (from (gnus-group-guess-full-name-from-command-method from)) | |
303 | (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) | |
304 | (to-name (if to to "the Bit Bucket"))) | |
305 | (gnus-message 7 "Gnus registry: article %s %s from %s to %s" | |
306 | id (if method "respooling" "going") from to) | |
307 | ||
308 | (gnus-registry-handle-action | |
309 | id | |
310 | ;; unless copying, remove the old "from" group | |
311 | (if (not (equal 'copy action)) from nil) | |
312 | to subject sender))) | |
23f87bed MB |
313 | |
314 | (defun gnus-registry-spool-action (id group &optional subject sender) | |
11a3174d | 315 | (let ((to (gnus-group-guess-full-name-from-command-method group))) |
23f87bed MB |
316 | (when (and (stringp id) (string-match "\r$" id)) |
317 | (setq id (substring id 0 -1))) | |
11a3174d TZ |
318 | (gnus-message 7 "Gnus registry: article %s spooled to %s" |
319 | id | |
320 | to) | |
321 | (gnus-registry-handle-action id nil to subject sender))) | |
322 | ||
323 | (defun gnus-registry-handle-action (id from to subject sender) | |
4523dc7f G |
324 | (gnus-message |
325 | 10 | |
326 | "gnus-registry-handle-action %S" (list id from to subject sender)) | |
11a3174d TZ |
327 | (let ((db gnus-registry-db) |
328 | ;; safe if not found | |
329 | (entry (gnus-registry-get-or-make-entry id))) | |
330 | ||
331 | ;; this could be done by calling `gnus-registry-set-id-key' | |
332 | ;; several times but it's better to bunch the transactions | |
333 | ;; together | |
334 | ||
335 | (registry-delete db (list id) nil) | |
336 | (when from | |
337 | (setq entry (cons (delete from (assoc 'group entry)) | |
338 | (assq-delete-all 'group entry)))) | |
339 | ||
340 | (dolist (kv `((group ,to) (sender ,sender) (subject ,subject))) | |
341 | (when (second kv) | |
342 | (let ((new (or (assq (first kv) entry) | |
343 | (list (first kv))))) | |
344 | (add-to-list 'new (second kv) t) | |
345 | (setq entry (cons new | |
346 | (assq-delete-all (first kv) entry)))))) | |
347 | (gnus-message 10 "Gnus registry: new entry for %s is %S" | |
348 | id | |
349 | entry) | |
350 | (registry-insert db id entry))) | |
23f87bed MB |
351 | |
352 | ;; Function for nn{mail|imap}-split-fancy: look up all references in | |
353 | ;; the cache and if a match is found, return that group. | |
354 | (defun gnus-registry-split-fancy-with-parent () | |
355 | "Split this message into the same group as its parent. The parent | |
356 | is obtained from the registry. This function can be used as an entry | |
357 | in `nnmail-split-fancy' or `nnimap-split-fancy', for example like | |
bf247b6e | 358 | this: (: gnus-registry-split-fancy-with-parent) |
23f87bed | 359 | |
01c52d31 MB |
360 | This function tracks ALL backends, unlike |
361 | `nnmail-split-fancy-with-parent' which tracks only nnmail | |
362 | messages. | |
363 | ||
23f87bed | 364 | For a message to be split, it looks for the parent message in the |
01c52d31 MB |
365 | References or In-Reply-To header and then looks in the registry |
366 | to see which group that message was put in. This group is | |
14e8de0c MB |
367 | returned, unless `gnus-registry-follow-group-p' return nil for |
368 | that group. | |
23f87bed MB |
369 | |
370 | See the Info node `(gnus)Fancy Mail Splitting' for more details." | |
14e8de0c | 371 | (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed |
11a3174d TZ |
372 | (reply-to (message-fetch-field "in-reply-to")) ; may be nil |
373 | ;; now, if reply-to is valid, append it to the References | |
374 | (refstr (if reply-to | |
375 | (concat refstr " " reply-to) | |
376 | refstr)) | |
377 | (references (and refstr (gnus-extract-references refstr))) | |
378 | ;; these may not be used, but the code is cleaner having them up here | |
379 | (sender (gnus-string-remove-all-properties | |
380 | (message-fetch-field "from"))) | |
381 | (subject (gnus-string-remove-all-properties | |
382 | (gnus-registry-simplify-subject | |
383 | (message-fetch-field "subject")))) | |
384 | ||
385 | (nnmail-split-fancy-with-parent-ignore-groups | |
386 | (if (listp nnmail-split-fancy-with-parent-ignore-groups) | |
387 | nnmail-split-fancy-with-parent-ignore-groups | |
388 | (list nnmail-split-fancy-with-parent-ignore-groups)))) | |
389 | (gnus-registry--split-fancy-with-parent-internal | |
390 | :references references | |
391 | :refstr refstr | |
392 | :sender sender | |
393 | :subject subject | |
394 | :log-agent "Gnus registry fancy splitting with parent"))) | |
395 | ||
396 | (defun* gnus-registry--split-fancy-with-parent-internal | |
397 | (&rest spec | |
398 | &key references refstr sender subject log-agent | |
399 | &allow-other-keys) | |
400 | (gnus-message | |
401 | 10 | |
2237da9c | 402 | "gnus-registry--split-fancy-with-parent-internal %S" spec) |
11a3174d TZ |
403 | (let ((db gnus-registry-db) |
404 | found) | |
2237da9c | 405 | ;; this is a big chain of statements. it uses |
14e8de0c MB |
406 | ;; gnus-registry-post-process-groups to filter the results after |
407 | ;; every step. | |
2237da9c G |
408 | ;; the references string must be valid and parse to valid references |
409 | (when references | |
410 | (gnus-message | |
411 | 9 | |
412 | "%s is tracing references %s" | |
413 | log-agent refstr) | |
11a3174d | 414 | (dolist (reference (nreverse references)) |
2237da9c G |
415 | (gnus-message 9 "%s is looking up %s" log-agent reference) |
416 | (loop for group in (gnus-registry-get-id-key reference 'group) | |
417 | when (gnus-registry-follow-group-p group) | |
418 | do (gnus-message 7 "%s traced %s to %s" log-agent reference group) | |
419 | do (push group found))) | |
14e8de0c | 420 | ;; filter the found groups and return them |
58a67d68 | 421 | ;; the found groups are the full groups |
c9fc72fa | 422 | (setq found (gnus-registry-post-process-groups |
11a3174d TZ |
423 | "references" refstr found))) |
424 | ||
425 | ;; else: there were no matches, try the extra tracking by sender | |
2237da9c G |
426 | (when (and (null found) |
427 | (memq 'sender gnus-registry-track-extra) | |
428 | sender | |
429 | (gnus-grep-in-list | |
430 | sender | |
431 | gnus-registry-unfollowed-addresses)) | |
432 | (let ((groups (apply | |
433 | 'append | |
434 | (mapcar | |
435 | (lambda (reference) | |
436 | (gnus-registry-get-id-key reference 'group)) | |
437 | (registry-lookup-secondary-value db 'sender sender))))) | |
438 | (setq found | |
439 | (loop for group in groups | |
440 | when (gnus-registry-follow-group-p group) | |
441 | do (gnus-message | |
442 | ;; warn more if gnus-registry-track-extra | |
443 | (if gnus-registry-track-extra 7 9) | |
444 | "%s (extra tracking) traced sender '%s' to %s" | |
445 | log-agent sender group) | |
446 | collect group))) | |
447 | ||
448 | ;; filter the found groups and return them | |
449 | ;; the found groups are NOT the full groups | |
450 | (setq found (gnus-registry-post-process-groups | |
451 | "sender" sender found))) | |
c9fc72fa | 452 | |
14e8de0c | 453 | ;; else: there were no matches, now try the extra tracking by subject |
2237da9c G |
454 | (when (and (null found) |
455 | (memq 'subject gnus-registry-track-extra) | |
456 | subject | |
457 | (< gnus-registry-minimum-subject-length (length subject))) | |
458 | (let ((groups (apply | |
459 | 'append | |
460 | (mapcar | |
461 | (lambda (reference) | |
462 | (gnus-registry-get-id-key reference 'group)) | |
463 | (registry-lookup-secondary-value db 'subject subject))))) | |
464 | (setq found | |
465 | (loop for group in groups | |
466 | when (gnus-registry-follow-group-p group) | |
467 | do (gnus-message | |
468 | ;; warn more if gnus-registry-track-extra | |
469 | (if gnus-registry-track-extra 7 9) | |
470 | "%s (extra tracking) traced subject '%s' to %s" | |
471 | log-agent subject group) | |
472 | collect group)) | |
473 | ;; filter the found groups and return them | |
474 | ;; the found groups are NOT the full groups | |
475 | (setq found (gnus-registry-post-process-groups | |
476 | "subject" subject found)))) | |
477 | ;; after the (cond) we extract the actual value safely | |
478 | (car-safe found))) | |
14e8de0c | 479 | |
11a3174d TZ |
480 | (defun gnus-registry-post-process-groups (mode key groups) |
481 | "Inspects GROUPS found by MODE for KEY to determine which ones to follow. | |
14e8de0c MB |
482 | |
483 | MODE can be 'subject' or 'sender' for example. The KEY is the | |
484 | value by which MODE was searched. | |
485 | ||
486 | Transforms each group name to the equivalent short name. | |
487 | ||
488 | Checks if the current Gnus method (from `gnus-command-method' or | |
489 | from `gnus-newsgroup-name') is the same as the group's method. | |
11a3174d | 490 | Foreign methods are not supported so they are rejected. |
14e8de0c MB |
491 | |
492 | Reduces the list to a single group, or complains if that's not | |
11a3174d | 493 | possible. Uses `gnus-registry-split-strategy'." |
14e8de0c | 494 | (let ((log-agent "gnus-registry-post-process-group") |
2237da9c G |
495 | (desc (format "%d groups" (length groups))) |
496 | out chosen) | |
497 | ;; the strategy can be nil, in which case chosen is nil | |
498 | (setq chosen | |
11a3174d | 499 | (case gnus-registry-split-strategy |
2237da9c G |
500 | ;; default, take only one-element lists into chosen |
501 | ((nil) | |
502 | (and (= (length groups) 1) | |
503 | (car-safe groups))) | |
504 | ||
11a3174d | 505 | ((first) |
2237da9c | 506 | (car-safe groups)) |
11a3174d TZ |
507 | |
508 | ((majority) | |
509 | (let ((freq (make-hash-table | |
510 | :size 256 | |
511 | :test 'equal))) | |
2237da9c G |
512 | (mapc (lambda (x) (let ((x (gnus-group-short-name x))) |
513 | (puthash x (1+ (gethash x freq 0)) freq))) | |
11a3174d | 514 | groups) |
2237da9c G |
515 | (setq desc (format "%d groups, %d unique" |
516 | (length groups) | |
517 | (hash-table-count freq))) | |
518 | (car-safe | |
519 | (sort groups | |
520 | (lambda (a b) | |
521 | (> (gethash (gnus-group-short-name a) freq 0) | |
522 | (gethash (gnus-group-short-name b) freq 0))))))))) | |
523 | ||
524 | (if chosen | |
525 | (gnus-message | |
526 | 9 | |
527 | "%s: strategy %s on %s produced %s" | |
528 | log-agent gnus-registry-split-strategy desc chosen) | |
529 | (gnus-message | |
530 | 9 | |
531 | "%s: strategy %s on %s did not produce an answer" | |
532 | log-agent | |
533 | (or gnus-registry-split-strategy "default") | |
534 | desc)) | |
535 | ||
536 | (setq groups (and chosen (list chosen))) | |
11a3174d TZ |
537 | |
538 | (dolist (group groups) | |
539 | (let ((m1 (gnus-find-method-for-group group)) | |
540 | (m2 (or gnus-command-method | |
541 | (gnus-find-method-for-group gnus-newsgroup-name))) | |
542 | (short-name (gnus-group-short-name group))) | |
543 | (if (gnus-methods-equal-p m1 m2) | |
544 | (progn | |
545 | ;; this is REALLY just for debugging | |
2237da9c G |
546 | (when (not (equal group short-name)) |
547 | (gnus-message | |
548 | 10 | |
549 | "%s: stripped group %s to %s" | |
550 | log-agent group short-name)) | |
11a3174d TZ |
551 | (add-to-list 'out short-name)) |
552 | ;; else... | |
553 | (gnus-message | |
554 | 7 | |
2237da9c | 555 | "%s: ignored foreign group %s" |
11a3174d TZ |
556 | log-agent group)))) |
557 | ||
2237da9c G |
558 | (setq out (delq nil out)) |
559 | ||
11a3174d TZ |
560 | (cond |
561 | ((= (length out) 1) out) | |
562 | ((null out) | |
563 | (gnus-message | |
564 | 5 | |
565 | "%s: no matches for %s %s." | |
566 | log-agent out mode key) | |
567 | nil) | |
568 | (t (gnus-message | |
569 | 5 | |
570 | "%s: too many extra matches (%s) for %s %s. Returning none." | |
571 | log-agent out mode key) | |
572 | nil)))) | |
14e8de0c MB |
573 | |
574 | (defun gnus-registry-follow-group-p (group) | |
575 | "Determines if a group name should be followed. | |
576 | Consults `gnus-registry-unfollowed-groups' and | |
577 | `nnmail-split-fancy-with-parent-ignore-groups'." | |
11a3174d TZ |
578 | (and group |
579 | (not (or (gnus-grep-in-list | |
580 | group | |
581 | gnus-registry-unfollowed-groups) | |
582 | (gnus-grep-in-list | |
583 | group | |
584 | nnmail-split-fancy-with-parent-ignore-groups))))) | |
23f87bed | 585 | |
01c52d31 | 586 | (defun gnus-registry-wash-for-keywords (&optional force) |
11a3174d TZ |
587 | "Get the keywords of the current article. |
588 | Overrides existing keywords with FORCE set non-nil." | |
01c52d31 MB |
589 | (interactive) |
590 | (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article)) | |
11a3174d TZ |
591 | word words) |
592 | (if (or (not (gnus-registry-get-id-key id 'keyword)) | |
593 | force) | |
594 | (with-current-buffer gnus-article-buffer | |
595 | (article-goto-body) | |
596 | (save-window-excursion | |
597 | (save-restriction | |
598 | (narrow-to-region (point) (point-max)) | |
599 | (with-syntax-table gnus-adaptive-word-syntax-table | |
600 | (while (re-search-forward "\\b\\w+\\b" nil t) | |
601 | (setq word (gnus-string-remove-all-properties | |
602 | (downcase (buffer-substring | |
603 | (match-beginning 0) (match-end 0))))) | |
604 | (if (> (length word) 2) | |
605 | (push word words)))))) | |
606 | (gnus-registry-set-id-key id 'keyword words))))) | |
607 | ||
608 | (defun gnus-registry-keywords () | |
609 | (let ((table (registry-lookup-secondary gnus-registry-db 'keyword))) | |
610 | (when table (maphash (lambda (k v) k) table)))) | |
01c52d31 MB |
611 | |
612 | (defun gnus-registry-find-keywords (keyword) | |
11a3174d TZ |
613 | (interactive (list |
614 | (completing-read "Keyword: " (gnus-registry-keywords) nil t))) | |
615 | (registry-lookup-secondary-value gnus-registry-db 'keyword keyword)) | |
01c52d31 | 616 | |
23f87bed MB |
617 | (defun gnus-registry-register-message-ids () |
618 | "Register the Message-ID of every article in the group" | |
619 | (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) | |
620 | (dolist (article gnus-newsgroup-articles) | |
11a3174d TZ |
621 | (let* ((id (gnus-registry-fetch-message-id-fast article)) |
622 | (groups (gnus-registry-get-id-key id 'group))) | |
623 | (unless (member gnus-newsgroup-name groups) | |
624 | (gnus-message 9 "Registry: Registering article %d with group %s" | |
625 | article gnus-newsgroup-name) | |
626 | (gnus-registry-handle-action id nil gnus-newsgroup-name | |
627 | (gnus-registry-fetch-simplified-message-subject-fast article) | |
628 | (gnus-registry-fetch-sender-fast article))))))) | |
629 | ||
630 | ;; message field fetchers | |
23f87bed MB |
631 | (defun gnus-registry-fetch-message-id-fast (article) |
632 | "Fetch the Message-ID quickly, using the internal gnus-data-list function" | |
633 | (if (and (numberp article) | |
11a3174d | 634 | (assoc article (gnus-data-list nil))) |
23f87bed MB |
635 | (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) |
636 | nil)) | |
637 | ||
638 | (defun gnus-registry-simplify-subject (subject) | |
639 | (if (stringp subject) | |
640 | (gnus-simplify-subject subject) | |
641 | nil)) | |
642 | ||
643 | (defun gnus-registry-fetch-simplified-message-subject-fast (article) | |
644 | "Fetch the Subject quickly, using the internal gnus-data-list function" | |
645 | (if (and (numberp article) | |
11a3174d | 646 | (assoc article (gnus-data-list nil))) |
01c52d31 MB |
647 | (gnus-string-remove-all-properties |
648 | (gnus-registry-simplify-subject | |
11a3174d TZ |
649 | (mail-header-subject (gnus-data-header |
650 | (assoc article (gnus-data-list nil)))))) | |
23f87bed MB |
651 | nil)) |
652 | ||
653 | (defun gnus-registry-fetch-sender-fast (article) | |
654 | "Fetch the Sender quickly, using the internal gnus-data-list function" | |
655 | (if (and (numberp article) | |
11a3174d | 656 | (assoc article (gnus-data-list nil))) |
01c52d31 MB |
657 | (gnus-string-remove-all-properties |
658 | (mail-header-from (gnus-data-header | |
11a3174d | 659 | (assoc article (gnus-data-list nil))))) |
23f87bed MB |
660 | nil)) |
661 | ||
11a3174d | 662 | ;; registry marks glue |
14e8de0c MB |
663 | (defun gnus-registry-do-marks (type function) |
664 | "For each known mark, call FUNCTION for each cell of type TYPE. | |
665 | ||
666 | FUNCTION should take two parameters, a mark symbol and the cell value." | |
667 | (dolist (mark-info gnus-registry-marks) | |
8f7abae3 | 668 | (let* ((mark (car-safe mark-info)) |
11a3174d TZ |
669 | (data (cdr-safe mark-info)) |
670 | (cell-data (plist-get data type))) | |
8f7abae3 | 671 | (when cell-data |
11a3174d | 672 | (funcall function mark cell-data))))) |
14e8de0c MB |
673 | |
674 | ;;; this is ugly code, but I don't know how to do it better | |
8f7abae3 | 675 | (defun gnus-registry-install-shortcuts () |
14e8de0c MB |
676 | "Install the keyboard shortcuts and menus for the registry. |
677 | Uses `gnus-registry-marks' to find what shortcuts to install." | |
8f7abae3 | 678 | (let (keys-plist) |
ec7995fa KY |
679 | (setq gnus-registry-misc-menus nil) |
680 | (gnus-registry-do-marks | |
8f7abae3 MB |
681 | :char |
682 | (lambda (mark data) | |
683 | (let ((function-format | |
11a3174d | 684 | (format "gnus-registry-%%s-article-%s-mark" mark))) |
14e8de0c MB |
685 | |
686 | ;;; The following generates these functions: | |
687 | ;;; (defun gnus-registry-set-article-Important-mark (&rest articles) | |
688 | ;;; "Apply the Important mark to process-marked ARTICLES." | |
689 | ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) | |
690 | ;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) | |
691 | ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) | |
692 | ;;; "Apply the Important mark to process-marked ARTICLES." | |
693 | ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) | |
694 | ;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) | |
695 | ||
11a3174d TZ |
696 | (dolist (remove '(t nil)) |
697 | (let* ((variant-name (if remove "remove" "set")) | |
698 | (function-name (format function-format variant-name)) | |
699 | (shortcut (format "%c" data)) | |
700 | (shortcut (if remove (upcase shortcut) shortcut))) | |
701 | (unintern function-name obarray) | |
702 | (eval | |
703 | `(defun | |
704 | ;; function name | |
705 | ,(intern function-name) | |
706 | ;; parameter definition | |
707 | (&rest articles) | |
708 | ;; documentation | |
709 | ,(format | |
710 | "%s the %s mark over process-marked ARTICLES." | |
711 | (upcase-initials variant-name) | |
712 | mark) | |
713 | ;; interactive definition | |
714 | (interactive | |
715 | (gnus-summary-work-articles current-prefix-arg)) | |
716 | ;; actual code | |
717 | ||
718 | ;; if this is called and the user doesn't want the | |
719 | ;; registry enabled, we'll ask anyhow | |
720 | (when (eq gnus-registry-install nil) | |
721 | (setq gnus-registry-install 'ask)) | |
722 | ||
723 | ;; now the user is asked if gnus-registry-install is 'ask | |
724 | (when (gnus-registry-install-p) | |
725 | (gnus-registry-set-article-mark-internal | |
726 | ;; all this just to get the mark, I must be doing it wrong | |
727 | (intern ,(symbol-name mark)) | |
728 | articles ,remove t) | |
729 | (gnus-message | |
730 | 9 | |
731 | "Applying mark %s to %d articles" | |
732 | ,(symbol-name mark) (length articles)) | |
733 | (dolist (article articles) | |
734 | (gnus-summary-update-article | |
735 | article | |
736 | (assoc article (gnus-data-list nil))))))) | |
737 | (push (intern function-name) keys-plist) | |
738 | (push shortcut keys-plist) | |
739 | (push (vector (format "%s %s" | |
740 | (upcase-initials variant-name) | |
741 | (symbol-name mark)) | |
742 | (intern function-name) t) | |
743 | gnus-registry-misc-menus) | |
744 | (gnus-message | |
745 | 9 | |
746 | "Defined mark handling function %s" | |
747 | function-name)))))) | |
8f7abae3 | 748 | (gnus-define-keys-1 |
ec7995fa KY |
749 | '(gnus-registry-mark-map "M" gnus-summary-mark-map) |
750 | keys-plist) | |
751 | (add-hook 'gnus-summary-menu-hook | |
11a3174d TZ |
752 | (lambda () |
753 | (easy-menu-add-item | |
754 | gnus-summary-misc-menu | |
755 | nil | |
756 | (cons "Registry Marks" gnus-registry-misc-menus)))))) | |
8f7abae3 MB |
757 | |
758 | ;;; use like this: | |
c9fc72fa | 759 | ;;; (defalias 'gnus-user-format-function-M |
8f7abae3 MB |
760 | ;;; 'gnus-registry-user-format-function-M) |
761 | (defun gnus-registry-user-format-function-M (headers) | |
762 | (let* ((id (mail-header-message-id headers)) | |
11a3174d TZ |
763 | (marks (when id (gnus-registry-get-id-key id 'mark)))) |
764 | (apply 'concat (mapcar (lambda (mark) | |
765 | (let ((c | |
766 | (plist-get | |
767 | (cdr-safe | |
768 | (assoc mark gnus-registry-marks)) | |
769 | :char))) | |
770 | (if c | |
771 | (list c) | |
772 | nil))) | |
773 | marks)))) | |
0b6799c3 MB |
774 | |
775 | (defun gnus-registry-read-mark () | |
776 | "Read a mark name from the user with completion." | |
229b59da G |
777 | (let ((mark (gnus-completing-read |
778 | "Label" | |
779 | (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) | |
780 | nil nil nil | |
11a3174d | 781 | (symbol-name gnus-registry-default-mark)))) |
0b6799c3 MB |
782 | (when (stringp mark) |
783 | (intern mark)))) | |
784 | ||
785 | (defun gnus-registry-set-article-mark (&rest articles) | |
786 | "Apply a mark to process-marked ARTICLES." | |
787 | (interactive (gnus-summary-work-articles current-prefix-arg)) | |
11a3174d TZ |
788 | (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) |
789 | articles nil t)) | |
0b6799c3 MB |
790 | |
791 | (defun gnus-registry-remove-article-mark (&rest articles) | |
792 | "Remove a mark from process-marked ARTICLES." | |
793 | (interactive (gnus-summary-work-articles current-prefix-arg)) | |
11a3174d TZ |
794 | (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) |
795 | articles t t)) | |
796 | ||
797 | (defun gnus-registry-set-article-mark-internal (mark | |
798 | articles | |
799 | &optional remove | |
800 | show-message) | |
801 | "Apply or remove MARK across a list of ARTICLES." | |
0b6799c3 | 802 | (let ((article-id-list |
11a3174d | 803 | (mapcar 'gnus-registry-fetch-message-id-fast articles))) |
0b6799c3 | 804 | (dolist (id article-id-list) |
11a3174d TZ |
805 | (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark))) |
806 | (marks (if remove marks (cons mark marks)))) | |
807 | (when show-message | |
808 | (gnus-message 1 "%s mark %s with message ID %s, resulting in %S" | |
809 | (if remove "Removing" "Adding") | |
810 | mark id marks)) | |
811 | (gnus-registry-set-id-key id 'mark marks))))) | |
0b6799c3 MB |
812 | |
813 | (defun gnus-registry-get-article-marks (&rest articles) | |
814 | "Get the Gnus registry marks for ARTICLES and show them if interactive. | |
815 | Uses process/prefix conventions. For multiple articles, | |
816 | only the last one's marks are returned." | |
817 | (interactive (gnus-summary-work-articles 1)) | |
11a3174d TZ |
818 | (let* ((article (last articles)) |
819 | (id (gnus-registry-fetch-message-id-fast article)) | |
820 | (marks (when id (gnus-registry-get-id-key id 'mark)))) | |
0b6799c3 | 821 | (when (interactive-p) |
11a3174d | 822 | (gnus-message 1 "Marks are %S" marks)) |
0b6799c3 MB |
823 | marks)) |
824 | ||
23f87bed MB |
825 | (defun gnus-registry-group-count (id) |
826 | "Get the number of groups of a message, based on the message ID." | |
11a3174d TZ |
827 | (length (gnus-registry-get-id-key id 'group))) |
828 | ||
829 | (defun gnus-registry-get-or-make-entry (id) | |
830 | (let* ((db gnus-registry-db) | |
831 | ;; safe if not found | |
832 | (entries (registry-lookup db (list id)))) | |
833 | ||
834 | (when (null entries) | |
835 | (registry-insert db id (list (list 'creation-time (current-time)) | |
836 | '(group) '(sender) '(subject))) | |
837 | (setq entries (registry-lookup db (list id)))) | |
838 | ||
839 | (nth 1 (assoc id entries)))) | |
840 | ||
42b23765 TZ |
841 | (defun gnus-registry-delete-entries (idlist) |
842 | (registry-delete gnus-registry-db idlist nil)) | |
843 | ||
11a3174d TZ |
844 | (defun gnus-registry-get-id-key (id key) |
845 | (cdr-safe (assq key (gnus-registry-get-or-make-entry id)))) | |
846 | ||
847 | (defun gnus-registry-set-id-key (id key vals) | |
848 | (let* ((db gnus-registry-db) | |
849 | (entry (gnus-registry-get-or-make-entry id))) | |
850 | (registry-delete db (list id) nil) | |
851 | (setq entry (cons (cons key vals) (assq-delete-all key entry))) | |
852 | (registry-insert db id entry) | |
853 | entry)) | |
854 | ||
42b23765 TZ |
855 | (defun gnus-registry-import-eld (file) |
856 | (interactive "fOld registry file to import? ") | |
857 | ;; example content: | |
858 | ;; (setq gnus-registry-alist '( | |
859 | ;; ("<messageID>" ((marks nil) | |
860 | ;; (mtime 19365 1776 440496) | |
861 | ;; (sender . "root (Cron Daemon)") | |
862 | ;; (subject . "Cron")) | |
863 | ;; "cron" "nnml+private:cron") | |
864 | (load file t) | |
865 | (when (boundp 'gnus-registry-alist) | |
866 | (let* ((old (symbol-value 'gnus-registry-alist)) | |
867 | (count 0) | |
868 | (expected (length old)) | |
869 | entry) | |
870 | (while (car-safe old) | |
871 | (incf count) | |
872 | ;; don't use progress reporters for backwards compatibility | |
873 | (when (and (< 0 expected) | |
874 | (= 0 (mod count 100))) | |
875 | (message "importing: %d of %d (%.2f%%)" | |
876 | count expected (/ (* 100 count) expected))) | |
877 | (setq entry (car-safe old) | |
878 | old (cdr-safe old)) | |
879 | (let* ((id (car-safe entry)) | |
880 | (new-entry (gnus-registry-get-or-make-entry id)) | |
881 | (rest (cdr-safe entry)) | |
882 | (groups (loop for p in rest | |
883 | when (stringp p) | |
884 | collect p)) | |
885 | extra-cell key val) | |
886 | ;; remove all the strings from the entry | |
887 | (delete* nil rest :test (lambda (a b) (stringp b))) | |
888 | (gnus-registry-set-id-key id 'group groups) | |
889 | ;; just use the first extra element | |
890 | (setq rest (car-safe rest)) | |
891 | (while (car-safe rest) | |
892 | (setq extra-cell (car-safe rest) | |
893 | key (car-safe extra-cell) | |
894 | val (cdr-safe extra-cell) | |
895 | rest (cdr-safe rest)) | |
896 | (when (and val (atom val)) | |
897 | (setq val (list val))) | |
898 | (gnus-registry-set-id-key id key val)))) | |
899 | (message "Import done, collected %d entries" count)))) | |
11a3174d TZ |
900 | |
901 | (ert-deftest gnus-registry-usage-test () | |
902 | (let* ((n 100) | |
903 | (tempfile (make-temp-file "gnus-registry-persist")) | |
904 | (db (gnus-registry-make-db tempfile)) | |
905 | (gnus-registry-db db) | |
906 | back size) | |
907 | (message "Adding %d keys to the test Gnus registry" n) | |
908 | (dotimes (i n) | |
909 | (let ((id (number-to-string i))) | |
910 | (gnus-registry-handle-action id | |
911 | (if (>= 50 i) "fromgroup" nil) | |
912 | "togroup" | |
913 | (when (>= 70 i) | |
914 | (format "subject %d" (mod i 10))) | |
915 | (when (>= 80 i) | |
916 | (format "sender %d" (mod i 10)))))) | |
917 | (message "Testing Gnus registry size is %d" n) | |
918 | (should (= n (registry-size db))) | |
919 | (message "Looking up individual keys (registry-lookup)") | |
920 | (should (equal (loop for e | |
921 | in (mapcar 'cadr | |
922 | (registry-lookup db '("20" "83" "72"))) | |
923 | collect (assq 'subject e) | |
924 | collect (assq 'sender e) | |
925 | collect (assq 'group e)) | |
926 | '((subject "subject 0") (sender "sender 0") (group "togroup") | |
927 | (subject) (sender) (group "togroup") | |
928 | (subject) (sender "sender 2") (group "togroup")))) | |
929 | ||
930 | (message "Looking up individual keys (gnus-registry-id-key)") | |
931 | (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup"))) | |
932 | (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4"))) | |
933 | (message "Trying to insert a duplicate key") | |
934 | (should-error (registry-insert db "55" '())) | |
935 | (message "Looking up individual keys (gnus-registry-get-or-make-entry)") | |
936 | (should (gnus-registry-get-or-make-entry "22")) | |
937 | (message "Saving the Gnus registry to %s" tempfile) | |
938 | (should (gnus-registry-save tempfile db)) | |
939 | (setq size (nth 7 (file-attributes tempfile))) | |
940 | (message "Saving the Gnus registry to %s: size %d" tempfile size) | |
941 | (should (< 0 size)) | |
942 | (with-temp-buffer | |
943 | (insert-file-contents-literally tempfile) | |
944 | (should (looking-at (concat ";; Object " | |
945 | "Gnus Registry" | |
946 | "\n;; EIEIO PERSISTENT OBJECT")))) | |
947 | (message "Reading Gnus registry back") | |
948 | (setq back (eieio-persistent-read tempfile)) | |
949 | (should back) | |
950 | (message "Read Gnus registry back: %d keys, expected %d==%d" | |
951 | (registry-size back) n (registry-size db)) | |
952 | (should (= (registry-size back) n)) | |
953 | (should (= (registry-size back) (registry-size db))) | |
954 | (delete-file tempfile) | |
955 | (message "Pruning Gnus registry to 0 by setting :max-soft") | |
956 | (oset db :max-soft 0) | |
957 | (registry-prune db) | |
958 | (should (= (registry-size db) 0))) | |
959 | (message "Done with Gnus registry usage testing.")) | |
23f87bed MB |
960 | |
961 | ;;;###autoload | |
962 | (defun gnus-registry-initialize () | |
8f7abae3 | 963 | "Initialize the Gnus registry." |
23f87bed | 964 | (interactive) |
8f7abae3 | 965 | (gnus-message 5 "Initializing the registry") |
11a3174d | 966 | (setq gnus-registry-install t) ; in case it was 'ask or nil |
23f87bed | 967 | (gnus-registry-install-hooks) |
8f7abae3 | 968 | (gnus-registry-install-shortcuts) |
23f87bed MB |
969 | (gnus-registry-read)) |
970 | ||
971 | ;;;###autoload | |
972 | (defun gnus-registry-install-hooks () | |
973 | "Install the registry hooks." | |
974 | (interactive) | |
bf247b6e | 975 | (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) |
23f87bed MB |
976 | (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) |
977 | (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
978 | (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
bf247b6e | 979 | |
23f87bed MB |
980 | (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) |
981 | (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
982 | ||
983 | (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
984 | ||
985 | (defun gnus-registry-unload-hook () | |
986 | "Uninstall the registry hooks." | |
987 | (interactive) | |
bf247b6e | 988 | (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) |
23f87bed MB |
989 | (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) |
990 | (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
991 | (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
bf247b6e | 992 | |
23f87bed MB |
993 | (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) |
994 | (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
995 | ||
996 | (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
997 | ||
6d52545d RS |
998 | (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) |
999 | ||
8f7abae3 MB |
1000 | (defun gnus-registry-install-p () |
1001 | (interactive) | |
1002 | (when (eq gnus-registry-install 'ask) | |
1003 | (setq gnus-registry-install | |
11a3174d TZ |
1004 | (gnus-y-or-n-p |
1005 | (concat "Enable the Gnus registry? " | |
1006 | "See the variable `gnus-registry-install' " | |
1007 | "to get rid of this query permanently. "))) | |
8f7abae3 MB |
1008 | (when gnus-registry-install |
1009 | ;; we just set gnus-registry-install to t, so initialize the registry! | |
1010 | (gnus-registry-initialize))) | |
1011 | ;;; we could call it here: (customize-variable 'gnus-registry-install) | |
1012 | gnus-registry-install) | |
1013 | ||
8f7abae3 | 1014 | ;; TODO: a few things |
23f87bed MB |
1015 | |
1016 | (provide 'gnus-registry) | |
1017 | ||
23f87bed | 1018 | ;;; gnus-registry.el ends here |