Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; gnus-registry.el --- article registry for Gnus |
e84b4b86 | 2 | |
ba318903 | 3 | ;; Copyright (C) 2002-2014 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 | |
c024b021 TZ |
34 | ;; better documentation in the manual (also on my to-do list). |
35 | ||
36 | ;; If you want to track recipients (and you should to make the | |
37 | ;; gnus-registry splitting work better), you need the To and Cc | |
a6e77075 TZ |
38 | ;; headers collected by Gnus. Note that in more recent Gnus versions |
39 | ;; this is already the case: look at `gnus-extra-headers' to be sure. | |
c024b021 TZ |
40 | |
41 | ;; ;;; you may also want Gcc Newsgroups Keywords X-Face | |
42 | ;; (add-to-list 'gnus-extra-headers 'To) | |
43 | ;; (add-to-list 'gnus-extra-headers 'Cc) | |
44 | ;; (setq nnmail-extra-headers gnus-extra-headers) | |
23f87bed | 45 | |
c3c65d73 | 46 | ;; Put this in your startup file (~/.gnus.el for instance) or use Customize: |
23f87bed | 47 | |
c3c65d73 | 48 | ;; (setq gnus-registry-max-entries 2500 |
cf8b0c27 | 49 | ;; gnus-registry-track-extra '(sender subject recipient)) |
23f87bed MB |
50 | |
51 | ;; (gnus-registry-initialize) | |
52 | ||
53 | ;; Then use this in your fancy-split: | |
54 | ||
55 | ;; (: gnus-registry-split-fancy-with-parent) | |
56 | ||
36d3245f G |
57 | ;; You should also consider using the nnregistry backend to look up |
58 | ;; articles. See the Gnus manual for more information. | |
59 | ||
627abcdd TZ |
60 | ;; Finally, you can put %uM in your summary line format to show the |
61 | ;; registry marks if you do this: | |
62 | ||
63 | ;; show the marks as single characters (see the :char property in | |
64 | ;; `gnus-registry-marks'): | |
2da9c605 | 65 | ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) |
627abcdd TZ |
66 | |
67 | ;; show the marks by name (see `gnus-registry-marks'): | |
2da9c605 | 68 | ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) |
627abcdd | 69 | |
23f87bed MB |
70 | ;; TODO: |
71 | ||
72 | ;; - get the correct group on spool actions | |
73 | ||
11a3174d TZ |
74 | ;; - articles that are spooled to a different backend should be moved |
75 | ;; after splitting | |
23f87bed MB |
76 | |
77 | ;;; Code: | |
78 | ||
79 | (eval-when-compile (require 'cl)) | |
80 | ||
81 | (require 'gnus) | |
82 | (require 'gnus-int) | |
83 | (require 'gnus-sum) | |
11a3174d | 84 | (require 'gnus-art) |
996aa8c1 | 85 | (require 'gnus-util) |
23f87bed | 86 | (require 'nnmail) |
ec7995fa | 87 | (require 'easymenu) |
11a3174d | 88 | (require 'registry) |
23f87bed | 89 | |
82fcf982 DE |
90 | ;; Silence XEmacs byte compiler, which will otherwise complain about |
91 | ;; call to `eieio-persistent-read'. | |
92 | (when (featurep 'xemacs) | |
93 | (byte-compiler-options | |
94 | (warnings (- callargs)))) | |
95 | ||
9efa445f DN |
96 | (defvar gnus-adaptive-word-syntax-table) |
97 | ||
23f87bed | 98 | (defvar gnus-registry-dirty t |
245101e5 | 99 | "Boolean set to t when the registry is modified.") |
23f87bed MB |
100 | |
101 | (defgroup gnus-registry nil | |
102 | "The Gnus registry." | |
bf247b6e | 103 | :version "22.1" |
23f87bed MB |
104 | :group 'gnus) |
105 | ||
11a3174d | 106 | (defvar gnus-registry-marks |
14e8de0c | 107 | '((Important |
8f7abae3 MB |
108 | :char ?i |
109 | :image "summary_important") | |
14e8de0c | 110 | (Work |
8f7abae3 MB |
111 | :char ?w |
112 | :image "summary_work") | |
14e8de0c | 113 | (Personal |
8f7abae3 MB |
114 | :char ?p |
115 | :image "summary_personal") | |
14e8de0c | 116 | (To-Do |
8f7abae3 MB |
117 | :char ?t |
118 | :image "summary_todo") | |
14e8de0c | 119 | (Later |
8f7abae3 MB |
120 | :char ?l |
121 | :image "summary_later")) | |
14e8de0c MB |
122 | |
123 | "List of registry marks and their options. | |
124 | ||
125 | `gnus-registry-mark-article' will offer symbols from this list | |
c9fc72fa | 126 | for completion. |
14e8de0c MB |
127 | |
128 | Each entry must have a character to be useful for summary mode | |
129 | line display and for keyboard shortcuts. | |
130 | ||
131 | Each entry must have an image string to be useful for visual | |
11a3174d | 132 | display.") |
0b6799c3 MB |
133 | |
134 | (defcustom gnus-registry-default-mark 'To-Do | |
14e8de0c | 135 | "The default mark. Should be a valid key for `gnus-registry-marks'." |
0b6799c3 MB |
136 | :group 'gnus-registry |
137 | :type 'symbol) | |
138 | ||
11a3174d TZ |
139 | (defcustom gnus-registry-unfollowed-addresses |
140 | (list (regexp-quote user-mail-address)) | |
141 | "List of addresses that gnus-registry-split-fancy-with-parent won't trace. | |
cf8b0c27 TZ |
142 | The addresses are matched, they don't have to be fully qualified. |
143 | In the messages, these addresses can be the sender or the | |
144 | recipients." | |
2bed3f04 | 145 | :version "24.1" |
11a3174d TZ |
146 | :group 'gnus-registry |
147 | :type '(repeat regexp)) | |
148 | ||
c9fc72fa | 149 | (defcustom gnus-registry-unfollowed-groups |
a5954fa5 | 150 | '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive") |
01c52d31 MB |
151 | "List of groups that gnus-registry-split-fancy-with-parent won't return. |
152 | The group names are matched, they don't have to be fully | |
11a3174d | 153 | qualified. This parameter tells the Gnus registry 'never split a |
01c52d31 | 154 | message into a group that matches one of these, regardless of |
6b958814 G |
155 | references.' |
156 | ||
157 | nnmairix groups are specifically excluded because they are ephemeral." | |
23f87bed | 158 | :group 'gnus-registry |
01c52d31 | 159 | :type '(repeat regexp)) |
23f87bed | 160 | |
8f7abae3 | 161 | (defcustom gnus-registry-install 'ask |
23f87bed MB |
162 | "Whether the registry should be installed." |
163 | :group 'gnus-registry | |
8f7abae3 | 164 | :type '(choice (const :tag "Never Install" nil) |
11a3174d TZ |
165 | (const :tag "Always Install" t) |
166 | (const :tag "Ask Me" ask))) | |
23f87bed | 167 | |
614ce227 | 168 | (defvar gnus-registry-enabled nil) |
aa22bff2 | 169 | |
ec7995fa KY |
170 | (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. |
171 | ||
11a3174d | 172 | (defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus |
23f87bed | 173 | |
11a3174d TZ |
174 | (make-obsolete-variable 'gnus-registry-clean-empty nil "23.4") |
175 | (make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4") | |
176 | (make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4") | |
177 | (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4") | |
178 | (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4") | |
b86402ab | 179 | |
cf8b0c27 | 180 | (defcustom gnus-registry-track-extra '(subject sender recipient) |
23f87bed | 181 | "Whether the registry should track extra data about a message. |
cf8b0c27 TZ |
182 | The subject, recipients (To: and Cc:), and Sender (From:) headers |
183 | are tracked this way by default." | |
23f87bed | 184 | :group 'gnus-registry |
bf247b6e | 185 | :type |
23f87bed MB |
186 | '(set :tag "Tracking choices" |
187 | (const :tag "Track by subject (Subject: header)" subject) | |
cf8b0c27 | 188 | (const :tag "Track by recipient (To: and Cc: headers)" recipient) |
23f87bed MB |
189 | (const :tag "Track by sender (From: header)" sender))) |
190 | ||
58a67d68 | 191 | (defcustom gnus-registry-split-strategy nil |
11a3174d | 192 | "The splitting strategy applied to the keys in `gnus-registry-track-extra'. |
58a67d68 | 193 | |
11a3174d TZ |
194 | Given a set of unique found groups G and counts for each element |
195 | of G, and a key K (typically 'sender or 'subject): | |
196 | ||
197 | When nil, if G has only one element, use it. Otherwise give up. | |
198 | This is the fastest but also least useful strategy. | |
199 | ||
200 | When 'majority, use the majority by count. So if there is a | |
201 | group with the most articles counted by K, use that. Ties are | |
202 | resolved in no particular order, simply the first one found wins. | |
203 | This is the slowest strategy but also the most accurate one. | |
204 | ||
205 | When 'first, the first element of G wins. This is fast and | |
206 | should be OK if your senders and subjects don't \"bleed\" across | |
207 | groups." | |
23f87bed | 208 | :group 'gnus-registry |
11a3174d TZ |
209 | :type |
210 | '(choice :tag "Splitting strategy" | |
211 | (const :tag "Only use single choices, discard multiple matches" nil) | |
212 | (const :tag "Majority of matches wins" majority) | |
213 | (const :tag "First found wins" first))) | |
23f87bed MB |
214 | |
215 | (defcustom gnus-registry-minimum-subject-length 5 | |
216 | "The minimum length of a subject before it's considered trackable." | |
217 | :group 'gnus-registry | |
218 | :type 'integer) | |
219 | ||
11a3174d TZ |
220 | (defcustom gnus-registry-extra-entries-precious '(mark) |
221 | "What extra keys are precious, meaning entries with them won't get pruned. | |
222 | By default, 'mark is included, so articles with marks are | |
223 | considered precious. | |
224 | ||
225 | Before you save the Gnus registry, it's pruned. Any entries with | |
226 | keys in this list will not be pruned. All other entries go to | |
227 | the Bit Bucket." | |
0b6799c3 MB |
228 | :group 'gnus-registry |
229 | :type '(repeat symbol)) | |
230 | ||
c9fc72fa LMI |
231 | (defcustom gnus-registry-cache-file |
232 | (nnheader-concat | |
233 | (or gnus-dribble-directory gnus-home-directory "~/") | |
11a3174d | 234 | ".gnus.registry.eioio") |
23f87bed MB |
235 | "File where the Gnus registry will be stored." |
236 | :group 'gnus-registry | |
237 | :type 'file) | |
238 | ||
239 | (defcustom gnus-registry-max-entries nil | |
240 | "Maximum number of entries in the registry, nil for unlimited." | |
241 | :group 'gnus-registry | |
242 | :type '(radio (const :format "Unlimited " nil) | |
11a3174d | 243 | (integer :format "Maximum number: %v"))) |
23f87bed | 244 | |
11a3174d TZ |
245 | (defcustom gnus-registry-max-pruned-entries nil |
246 | "Maximum number of pruned entries in the registry, nil for unlimited." | |
2bed3f04 | 247 | :version "24.1" |
11a3174d TZ |
248 | :group 'gnus-registry |
249 | :type '(radio (const :format "Unlimited " nil) | |
250 | (integer :format "Maximum number: %v"))) | |
251 | ||
252 | (defun gnus-registry-fixup-registry (db) | |
253 | (when db | |
cf8b0c27 TZ |
254 | (let ((old (oref db :tracked))) |
255 | (oset db :precious | |
256 | (append gnus-registry-extra-entries-precious | |
257 | '())) | |
258 | (oset db :max-hard | |
259 | (or gnus-registry-max-entries | |
260 | most-positive-fixnum)) | |
652aa465 TZ |
261 | (oset db :prune-factor |
262 | 0.1) | |
cf8b0c27 TZ |
263 | (oset db :max-soft |
264 | (or gnus-registry-max-pruned-entries | |
265 | most-positive-fixnum)) | |
266 | (oset db :tracked | |
267 | (append gnus-registry-track-extra | |
268 | '(mark group keyword))) | |
269 | (when (not (equal old (oref db :tracked))) | |
89b163db | 270 | (gnus-message 9 "Reindexing the Gnus registry (tracked change)") |
cf8b0c27 | 271 | (registry-reindex db)))) |
11a3174d TZ |
272 | db) |
273 | ||
274 | (defun gnus-registry-make-db (&optional file) | |
275 | (interactive "fGnus registry persistence file: \n") | |
276 | (gnus-registry-fixup-registry | |
277 | (registry-db | |
278 | "Gnus Registry" | |
279 | :file (or file gnus-registry-cache-file) | |
280 | ;; these parameters are set in `gnus-registry-fixup-registry' | |
281 | :max-hard most-positive-fixnum | |
282 | :max-soft most-positive-fixnum | |
283 | :precious nil | |
284 | :tracked nil))) | |
285 | ||
286 | (defvar gnus-registry-db (gnus-registry-make-db) | |
245101e5 | 287 | "The article registry by Message ID. See `registry-db'.") |
11a3174d TZ |
288 | |
289 | ;; top-level registry data management | |
290 | (defun gnus-registry-remake-db (&optional forsure) | |
291 | "Remake the registry database after customization. | |
292 | This is not required after changing `gnus-registry-cache-file'." | |
293 | (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? "))) | |
294 | (when forsure | |
1e3b6001 | 295 | (gnus-message 4 "Remaking the Gnus registry") |
11a3174d | 296 | (setq gnus-registry-db (gnus-registry-make-db)))) |
23f87bed | 297 | |
11a3174d | 298 | (defun gnus-registry-read () |
23f87bed MB |
299 | "Read the registry cache file." |
300 | (interactive) | |
301 | (let ((file gnus-registry-cache-file)) | |
11a3174d TZ |
302 | (condition-case nil |
303 | (progn | |
304 | (gnus-message 5 "Reading Gnus registry from %s..." file) | |
800d2689 DE |
305 | (setq gnus-registry-db |
306 | (gnus-registry-fixup-registry | |
307 | (condition-case nil | |
308 | (with-no-warnings | |
309 | (eieio-persistent-read file 'registry-db)) | |
310 | ;; Older EIEIO versions do not check the class name. | |
311 | ('wrong-number-of-arguments | |
312 | (eieio-persistent-read file))))) | |
11a3174d TZ |
313 | (gnus-message 5 "Reading Gnus registry from %s...done" file)) |
314 | (error | |
315 | (gnus-message | |
316 | 1 | |
317 | "The Gnus registry could not be loaded from %s, creating a new one" | |
318 | file) | |
319 | (gnus-registry-remake-db t))))) | |
320 | ||
321 | (defun gnus-registry-save (&optional file db) | |
23f87bed MB |
322 | "Save the registry cache file." |
323 | (interactive) | |
11a3174d TZ |
324 | (let ((file (or file gnus-registry-cache-file)) |
325 | (db (or db gnus-registry-db))) | |
326 | (gnus-message 5 "Saving Gnus registry (%d entries) to %s..." | |
327 | (registry-size db) file) | |
328 | (registry-prune db) | |
329 | ;; TODO: call (gnus-string-remove-all-properties v) on all elements? | |
330 | (eieio-persistent-save db file) | |
331 | (gnus-message 5 "Saving Gnus registry (size %d) to %s...done" | |
332 | (registry-size db) file))) | |
333 | ||
8d009f4a TZ |
334 | (defun gnus-registry-remove-ignored () |
335 | (interactive) | |
336 | (let* ((db gnus-registry-db) | |
337 | (grouphashtb (registry-lookup-secondary db 'group)) | |
338 | (old-size (registry-size db))) | |
339 | (registry-reindex db) | |
340 | (loop for k being the hash-keys of grouphashtb | |
341 | using (hash-values v) | |
342 | when (gnus-registry-ignore-group-p k) | |
343 | do (registry-delete db v nil)) | |
344 | (registry-reindex db) | |
345 | (gnus-message 4 "Removed %d ignored entries from the Gnus registry" | |
346 | (- old-size (registry-size db))))) | |
347 | ||
11a3174d | 348 | ;; article move/copy/spool/delete actions |
23f87bed MB |
349 | (defun gnus-registry-action (action data-header from &optional to method) |
350 | (let* ((id (mail-header-id data-header)) | |
d515dc24 | 351 | (subject (mail-header-subject data-header)) |
c024b021 | 352 | (extra (mail-header-extra data-header)) |
8d6d9c8f | 353 | (recipients (gnus-registry-sort-addresses |
c024b021 TZ |
354 | (or (cdr-safe (assq 'Cc extra)) "") |
355 | (or (cdr-safe (assq 'To extra)) ""))) | |
cf8b0c27 TZ |
356 | (sender (nth 0 (gnus-registry-extract-addresses |
357 | (mail-header-from data-header)))) | |
11a3174d TZ |
358 | (from (gnus-group-guess-full-name-from-command-method from)) |
359 | (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) | |
360 | (to-name (if to to "the Bit Bucket"))) | |
361 | (gnus-message 7 "Gnus registry: article %s %s from %s to %s" | |
362 | id (if method "respooling" "going") from to) | |
363 | ||
364 | (gnus-registry-handle-action | |
365 | id | |
366 | ;; unless copying, remove the old "from" group | |
367 | (if (not (equal 'copy action)) from nil) | |
cf8b0c27 | 368 | to subject sender recipients))) |
23f87bed | 369 | |
cf8b0c27 | 370 | (defun gnus-registry-spool-action (id group &optional subject sender recipients) |
d515dc24 | 371 | (let ((to (gnus-group-guess-full-name-from-command-method group)) |
cf8b0c27 | 372 | (recipients (or recipients |
c024b021 TZ |
373 | (gnus-registry-sort-addresses |
374 | (or (message-fetch-field "cc") "") | |
375 | (or (message-fetch-field "to") "")))) | |
d515dc24 TZ |
376 | (subject (or subject (message-fetch-field "subject"))) |
377 | (sender (or sender (message-fetch-field "from")))) | |
23f87bed MB |
378 | (when (and (stringp id) (string-match "\r$" id)) |
379 | (setq id (substring id 0 -1))) | |
11a3174d TZ |
380 | (gnus-message 7 "Gnus registry: article %s spooled to %s" |
381 | id | |
382 | to) | |
cf8b0c27 | 383 | (gnus-registry-handle-action id nil to subject sender recipients))) |
11a3174d | 384 | |
cf8b0c27 TZ |
385 | (defun gnus-registry-handle-action (id from to subject sender |
386 | &optional recipients) | |
4523dc7f G |
387 | (gnus-message |
388 | 10 | |
cf8b0c27 | 389 | "gnus-registry-handle-action %S" (list id from to subject sender recipients)) |
11a3174d | 390 | (let ((db gnus-registry-db) |
20113380 TZ |
391 | ;; if the group is ignored, set the destination to nil (same as delete) |
392 | (to (if (gnus-registry-ignore-group-p to) nil to)) | |
11a3174d | 393 | ;; safe if not found |
d515dc24 TZ |
394 | (entry (gnus-registry-get-or-make-entry id)) |
395 | (subject (gnus-string-remove-all-properties | |
396 | (gnus-registry-simplify-subject subject))) | |
397 | (sender (gnus-string-remove-all-properties sender))) | |
11a3174d TZ |
398 | |
399 | ;; this could be done by calling `gnus-registry-set-id-key' | |
400 | ;; several times but it's better to bunch the transactions | |
401 | ;; together | |
402 | ||
403 | (registry-delete db (list id) nil) | |
404 | (when from | |
405 | (setq entry (cons (delete from (assoc 'group entry)) | |
406 | (assq-delete-all 'group entry)))) | |
407 | ||
cf8b0c27 TZ |
408 | (dolist (kv `((group ,to) |
409 | (sender ,sender) | |
410 | (recipient ,@recipients) | |
411 | (subject ,subject))) | |
11a3174d TZ |
412 | (when (second kv) |
413 | (let ((new (or (assq (first kv) entry) | |
414 | (list (first kv))))) | |
cf8b0c27 TZ |
415 | (dolist (toadd (cdr kv)) |
416 | (add-to-list 'new toadd t)) | |
11a3174d TZ |
417 | (setq entry (cons new |
418 | (assq-delete-all (first kv) entry)))))) | |
419 | (gnus-message 10 "Gnus registry: new entry for %s is %S" | |
420 | id | |
421 | entry) | |
81d7704c | 422 | (gnus-registry-insert db id entry))) |
23f87bed MB |
423 | |
424 | ;; Function for nn{mail|imap}-split-fancy: look up all references in | |
425 | ;; the cache and if a match is found, return that group. | |
426 | (defun gnus-registry-split-fancy-with-parent () | |
245101e5 SM |
427 | "Split this message into the same group as its parent. |
428 | The parent is obtained from the registry. This function can be used as an | |
429 | entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like | |
bf247b6e | 430 | this: (: gnus-registry-split-fancy-with-parent) |
23f87bed | 431 | |
01c52d31 MB |
432 | This function tracks ALL backends, unlike |
433 | `nnmail-split-fancy-with-parent' which tracks only nnmail | |
434 | messages. | |
435 | ||
23f87bed | 436 | For a message to be split, it looks for the parent message in the |
01c52d31 MB |
437 | References or In-Reply-To header and then looks in the registry |
438 | to see which group that message was put in. This group is | |
14e8de0c MB |
439 | returned, unless `gnus-registry-follow-group-p' return nil for |
440 | that group. | |
23f87bed MB |
441 | |
442 | See the Info node `(gnus)Fancy Mail Splitting' for more details." | |
14e8de0c | 443 | (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed |
11a3174d TZ |
444 | (reply-to (message-fetch-field "in-reply-to")) ; may be nil |
445 | ;; now, if reply-to is valid, append it to the References | |
446 | (refstr (if reply-to | |
447 | (concat refstr " " reply-to) | |
448 | refstr)) | |
449 | (references (and refstr (gnus-extract-references refstr))) | |
450 | ;; these may not be used, but the code is cleaner having them up here | |
451 | (sender (gnus-string-remove-all-properties | |
452 | (message-fetch-field "from"))) | |
8d6d9c8f | 453 | (recipients (gnus-registry-sort-addresses |
c024b021 TZ |
454 | (or (message-fetch-field "cc") "") |
455 | (or (message-fetch-field "to") ""))) | |
11a3174d TZ |
456 | (subject (gnus-string-remove-all-properties |
457 | (gnus-registry-simplify-subject | |
458 | (message-fetch-field "subject")))) | |
459 | ||
460 | (nnmail-split-fancy-with-parent-ignore-groups | |
461 | (if (listp nnmail-split-fancy-with-parent-ignore-groups) | |
462 | nnmail-split-fancy-with-parent-ignore-groups | |
463 | (list nnmail-split-fancy-with-parent-ignore-groups)))) | |
464 | (gnus-registry--split-fancy-with-parent-internal | |
465 | :references references | |
466 | :refstr refstr | |
467 | :sender sender | |
cf8b0c27 | 468 | :recipients recipients |
11a3174d TZ |
469 | :subject subject |
470 | :log-agent "Gnus registry fancy splitting with parent"))) | |
471 | ||
472 | (defun* gnus-registry--split-fancy-with-parent-internal | |
473 | (&rest spec | |
cf8b0c27 | 474 | &key references refstr sender subject recipients log-agent |
11a3174d TZ |
475 | &allow-other-keys) |
476 | (gnus-message | |
477 | 10 | |
2237da9c | 478 | "gnus-registry--split-fancy-with-parent-internal %S" spec) |
11a3174d TZ |
479 | (let ((db gnus-registry-db) |
480 | found) | |
2237da9c | 481 | ;; this is a big chain of statements. it uses |
14e8de0c MB |
482 | ;; gnus-registry-post-process-groups to filter the results after |
483 | ;; every step. | |
2237da9c G |
484 | ;; the references string must be valid and parse to valid references |
485 | (when references | |
486 | (gnus-message | |
487 | 9 | |
488 | "%s is tracing references %s" | |
489 | log-agent refstr) | |
11a3174d | 490 | (dolist (reference (nreverse references)) |
2237da9c G |
491 | (gnus-message 9 "%s is looking up %s" log-agent reference) |
492 | (loop for group in (gnus-registry-get-id-key reference 'group) | |
493 | when (gnus-registry-follow-group-p group) | |
20113380 TZ |
494 | do |
495 | (progn | |
496 | (gnus-message 7 "%s traced %s to %s" log-agent reference group) | |
497 | (push group found)))) | |
14e8de0c | 498 | ;; filter the found groups and return them |
58a67d68 | 499 | ;; the found groups are the full groups |
c9fc72fa | 500 | (setq found (gnus-registry-post-process-groups |
11a3174d TZ |
501 | "references" refstr found))) |
502 | ||
ba3bd5b6 TZ |
503 | ;; else: there were no matches, now try the extra tracking by subject |
504 | (when (and (null found) | |
505 | (memq 'subject gnus-registry-track-extra) | |
506 | subject | |
507 | (< gnus-registry-minimum-subject-length (length subject))) | |
508 | (let ((groups (apply | |
509 | 'append | |
510 | (mapcar | |
511 | (lambda (reference) | |
512 | (gnus-registry-get-id-key reference 'group)) | |
513 | (registry-lookup-secondary-value db 'subject subject))))) | |
514 | (setq found | |
515 | (loop for group in groups | |
516 | when (gnus-registry-follow-group-p group) | |
517 | do (gnus-message | |
518 | ;; warn more if gnus-registry-track-extra | |
519 | (if gnus-registry-track-extra 7 9) | |
520 | "%s (extra tracking) traced subject '%s' to %s" | |
521 | log-agent subject group) | |
20113380 | 522 | and collect group)) |
ba3bd5b6 TZ |
523 | ;; filter the found groups and return them |
524 | ;; the found groups are NOT the full groups | |
525 | (setq found (gnus-registry-post-process-groups | |
526 | "subject" subject found)))) | |
527 | ||
11a3174d | 528 | ;; else: there were no matches, try the extra tracking by sender |
2237da9c G |
529 | (when (and (null found) |
530 | (memq 'sender gnus-registry-track-extra) | |
531 | sender | |
1e3b6001 G |
532 | (not (gnus-grep-in-list |
533 | sender | |
534 | gnus-registry-unfollowed-addresses))) | |
2237da9c G |
535 | (let ((groups (apply |
536 | 'append | |
537 | (mapcar | |
538 | (lambda (reference) | |
539 | (gnus-registry-get-id-key reference 'group)) | |
540 | (registry-lookup-secondary-value db 'sender sender))))) | |
541 | (setq found | |
542 | (loop for group in groups | |
543 | when (gnus-registry-follow-group-p group) | |
544 | do (gnus-message | |
545 | ;; warn more if gnus-registry-track-extra | |
546 | (if gnus-registry-track-extra 7 9) | |
547 | "%s (extra tracking) traced sender '%s' to %s" | |
548 | log-agent sender group) | |
20113380 | 549 | and collect group))) |
2237da9c G |
550 | |
551 | ;; filter the found groups and return them | |
552 | ;; the found groups are NOT the full groups | |
553 | (setq found (gnus-registry-post-process-groups | |
554 | "sender" sender found))) | |
c9fc72fa | 555 | |
cf8b0c27 TZ |
556 | ;; else: there were no matches, try the extra tracking by recipient |
557 | (when (and (null found) | |
558 | (memq 'recipient gnus-registry-track-extra) | |
559 | recipients) | |
560 | (dolist (recp recipients) | |
561 | (when (and (null found) | |
562 | (not (gnus-grep-in-list | |
563 | recp | |
564 | gnus-registry-unfollowed-addresses))) | |
565 | (let ((groups (apply 'append | |
566 | (mapcar | |
567 | (lambda (reference) | |
568 | (gnus-registry-get-id-key reference 'group)) | |
569 | (registry-lookup-secondary-value | |
570 | db 'recipient recp))))) | |
571 | (setq found | |
572 | (loop for group in groups | |
573 | when (gnus-registry-follow-group-p group) | |
574 | do (gnus-message | |
575 | ;; warn more if gnus-registry-track-extra | |
576 | (if gnus-registry-track-extra 7 9) | |
577 | "%s (extra tracking) traced recipient '%s' to %s" | |
578 | log-agent recp group) | |
20113380 | 579 | and collect group))))) |
cf8b0c27 TZ |
580 | |
581 | ;; filter the found groups and return them | |
582 | ;; the found groups are NOT the full groups | |
583 | (setq found (gnus-registry-post-process-groups | |
584 | "recipients" (mapconcat 'identity recipients ", ") found))) | |
585 | ||
2237da9c G |
586 | ;; after the (cond) we extract the actual value safely |
587 | (car-safe found))) | |
14e8de0c | 588 | |
11a3174d TZ |
589 | (defun gnus-registry-post-process-groups (mode key groups) |
590 | "Inspects GROUPS found by MODE for KEY to determine which ones to follow. | |
14e8de0c MB |
591 | |
592 | MODE can be 'subject' or 'sender' for example. The KEY is the | |
593 | value by which MODE was searched. | |
594 | ||
595 | Transforms each group name to the equivalent short name. | |
596 | ||
597 | Checks if the current Gnus method (from `gnus-command-method' or | |
598 | from `gnus-newsgroup-name') is the same as the group's method. | |
11a3174d | 599 | Foreign methods are not supported so they are rejected. |
14e8de0c MB |
600 | |
601 | Reduces the list to a single group, or complains if that's not | |
11a3174d | 602 | possible. Uses `gnus-registry-split-strategy'." |
14e8de0c | 603 | (let ((log-agent "gnus-registry-post-process-group") |
2237da9c G |
604 | (desc (format "%d groups" (length groups))) |
605 | out chosen) | |
606 | ;; the strategy can be nil, in which case chosen is nil | |
607 | (setq chosen | |
11a3174d | 608 | (case gnus-registry-split-strategy |
2237da9c G |
609 | ;; default, take only one-element lists into chosen |
610 | ((nil) | |
611 | (and (= (length groups) 1) | |
612 | (car-safe groups))) | |
613 | ||
11a3174d | 614 | ((first) |
2237da9c | 615 | (car-safe groups)) |
11a3174d TZ |
616 | |
617 | ((majority) | |
618 | (let ((freq (make-hash-table | |
619 | :size 256 | |
620 | :test 'equal))) | |
2237da9c G |
621 | (mapc (lambda (x) (let ((x (gnus-group-short-name x))) |
622 | (puthash x (1+ (gethash x freq 0)) freq))) | |
11a3174d | 623 | groups) |
2237da9c G |
624 | (setq desc (format "%d groups, %d unique" |
625 | (length groups) | |
626 | (hash-table-count freq))) | |
627 | (car-safe | |
628 | (sort groups | |
629 | (lambda (a b) | |
630 | (> (gethash (gnus-group-short-name a) freq 0) | |
631 | (gethash (gnus-group-short-name b) freq 0))))))))) | |
632 | ||
633 | (if chosen | |
634 | (gnus-message | |
635 | 9 | |
636 | "%s: strategy %s on %s produced %s" | |
637 | log-agent gnus-registry-split-strategy desc chosen) | |
638 | (gnus-message | |
639 | 9 | |
640 | "%s: strategy %s on %s did not produce an answer" | |
641 | log-agent | |
642 | (or gnus-registry-split-strategy "default") | |
643 | desc)) | |
644 | ||
645 | (setq groups (and chosen (list chosen))) | |
11a3174d TZ |
646 | |
647 | (dolist (group groups) | |
648 | (let ((m1 (gnus-find-method-for-group group)) | |
649 | (m2 (or gnus-command-method | |
650 | (gnus-find-method-for-group gnus-newsgroup-name))) | |
651 | (short-name (gnus-group-short-name group))) | |
652 | (if (gnus-methods-equal-p m1 m2) | |
653 | (progn | |
654 | ;; this is REALLY just for debugging | |
2237da9c G |
655 | (when (not (equal group short-name)) |
656 | (gnus-message | |
657 | 10 | |
658 | "%s: stripped group %s to %s" | |
659 | log-agent group short-name)) | |
11a3174d TZ |
660 | (add-to-list 'out short-name)) |
661 | ;; else... | |
662 | (gnus-message | |
663 | 7 | |
2237da9c | 664 | "%s: ignored foreign group %s" |
11a3174d TZ |
665 | log-agent group)))) |
666 | ||
2237da9c G |
667 | (setq out (delq nil out)) |
668 | ||
11a3174d TZ |
669 | (cond |
670 | ((= (length out) 1) out) | |
671 | ((null out) | |
672 | (gnus-message | |
673 | 5 | |
1e3b6001 G |
674 | "%s: no matches for %s '%s'." |
675 | log-agent mode key) | |
11a3174d TZ |
676 | nil) |
677 | (t (gnus-message | |
678 | 5 | |
1e3b6001 | 679 | "%s: too many extra matches (%s) for %s '%s'. Returning none." |
11a3174d TZ |
680 | log-agent out mode key) |
681 | nil)))) | |
14e8de0c MB |
682 | |
683 | (defun gnus-registry-follow-group-p (group) | |
684 | "Determines if a group name should be followed. | |
685 | Consults `gnus-registry-unfollowed-groups' and | |
686 | `nnmail-split-fancy-with-parent-ignore-groups'." | |
11a3174d TZ |
687 | (and group |
688 | (not (or (gnus-grep-in-list | |
689 | group | |
690 | gnus-registry-unfollowed-groups) | |
691 | (gnus-grep-in-list | |
692 | group | |
693 | nnmail-split-fancy-with-parent-ignore-groups))))) | |
23f87bed | 694 | |
c024b021 TZ |
695 | ;; note that gnus-registry-ignored-groups is defined in gnus.el as a |
696 | ;; group/topic parameter and an associated variable! | |
697 | ||
698 | ;; we do special logic for ignoring to accept regular expressions and | |
699 | ;; nnmail-split-fancy-with-parent-ignore-groups as well | |
20113380 TZ |
700 | (defun gnus-registry-ignore-group-p (group) |
701 | "Determines if a group name should be ignored. | |
702 | Consults `gnus-registry-ignored-groups' and | |
703 | `nnmail-split-fancy-with-parent-ignore-groups'." | |
704 | (and group | |
74db886b | 705 | (or (gnus-grep-in-list |
c024b021 TZ |
706 | group |
707 | (delq nil (mapcar (lambda (g) | |
708 | (cond | |
709 | ((stringp g) g) | |
710 | ((and (listp g) (nth 1 g)) | |
711 | (nth 0 g)) | |
712 | (t nil))) gnus-registry-ignored-groups))) | |
74db886b TZ |
713 | ;; only use `gnus-parameter-registry-ignore' if |
714 | ;; `gnus-registry-ignored-groups' is a list of lists | |
715 | ;; (it can be a list of regexes) | |
716 | (and (listp (nth 0 gnus-registry-ignored-groups)) | |
e2822bd2 | 717 | (get-buffer "*Group*") ; in automatic tests this is false |
74db886b | 718 | (gnus-parameter-registry-ignore group)) |
c024b021 TZ |
719 | (gnus-grep-in-list |
720 | group | |
721 | nnmail-split-fancy-with-parent-ignore-groups)))) | |
20113380 | 722 | |
01c52d31 | 723 | (defun gnus-registry-wash-for-keywords (&optional force) |
11a3174d TZ |
724 | "Get the keywords of the current article. |
725 | Overrides existing keywords with FORCE set non-nil." | |
01c52d31 MB |
726 | (interactive) |
727 | (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article)) | |
11a3174d TZ |
728 | word words) |
729 | (if (or (not (gnus-registry-get-id-key id 'keyword)) | |
730 | force) | |
731 | (with-current-buffer gnus-article-buffer | |
732 | (article-goto-body) | |
733 | (save-window-excursion | |
734 | (save-restriction | |
735 | (narrow-to-region (point) (point-max)) | |
736 | (with-syntax-table gnus-adaptive-word-syntax-table | |
737 | (while (re-search-forward "\\b\\w+\\b" nil t) | |
738 | (setq word (gnus-string-remove-all-properties | |
739 | (downcase (buffer-substring | |
740 | (match-beginning 0) (match-end 0))))) | |
741 | (if (> (length word) 2) | |
742 | (push word words)))))) | |
743 | (gnus-registry-set-id-key id 'keyword words))))) | |
744 | ||
745 | (defun gnus-registry-keywords () | |
746 | (let ((table (registry-lookup-secondary gnus-registry-db 'keyword))) | |
747 | (when table (maphash (lambda (k v) k) table)))) | |
01c52d31 MB |
748 | |
749 | (defun gnus-registry-find-keywords (keyword) | |
11a3174d TZ |
750 | (interactive (list |
751 | (completing-read "Keyword: " (gnus-registry-keywords) nil t))) | |
752 | (registry-lookup-secondary-value gnus-registry-db 'keyword keyword)) | |
01c52d31 | 753 | |
23f87bed | 754 | (defun gnus-registry-register-message-ids () |
245101e5 | 755 | "Register the Message-ID of every article in the group." |
23f87bed MB |
756 | (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) |
757 | (dolist (article gnus-newsgroup-articles) | |
11a3174d TZ |
758 | (let* ((id (gnus-registry-fetch-message-id-fast article)) |
759 | (groups (gnus-registry-get-id-key id 'group))) | |
760 | (unless (member gnus-newsgroup-name groups) | |
761 | (gnus-message 9 "Registry: Registering article %d with group %s" | |
762 | article gnus-newsgroup-name) | |
763 | (gnus-registry-handle-action id nil gnus-newsgroup-name | |
764 | (gnus-registry-fetch-simplified-message-subject-fast article) | |
cf8b0c27 TZ |
765 | (gnus-registry-fetch-sender-fast article) |
766 | (gnus-registry-fetch-recipients-fast article))))))) | |
11a3174d TZ |
767 | |
768 | ;; message field fetchers | |
23f87bed | 769 | (defun gnus-registry-fetch-message-id-fast (article) |
245101e5 | 770 | "Fetch the Message-ID quickly, using the internal gnus-data-list function." |
23f87bed | 771 | (if (and (numberp article) |
11a3174d | 772 | (assoc article (gnus-data-list nil))) |
23f87bed MB |
773 | (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) |
774 | nil)) | |
775 | ||
cf8b0c27 TZ |
776 | (defun gnus-registry-extract-addresses (text) |
777 | "Extract all the addresses in a normalized way from TEXT. | |
778 | Returns an unsorted list of strings in the name <address> format. | |
779 | Addresses without a name will say \"noname\"." | |
780 | (mapcar (lambda (add) | |
781 | (gnus-string-remove-all-properties | |
782 | (let* ((name (or (nth 0 add) "noname")) | |
783 | (addr (nth 1 add)) | |
784 | (addr (if (bufferp addr) | |
785 | (with-current-buffer addr | |
786 | (buffer-string)) | |
787 | addr))) | |
788 | (format "%s <%s>" name addr)))) | |
789 | (mail-extract-address-components text t))) | |
790 | ||
8d6d9c8f KY |
791 | (defun gnus-registry-sort-addresses (&rest addresses) |
792 | "Return a normalized and sorted list of ADDRESSES." | |
793 | (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses)) | |
c024b021 | 794 | 'string-lessp)) |
8d6d9c8f | 795 | |
23f87bed MB |
796 | (defun gnus-registry-simplify-subject (subject) |
797 | (if (stringp subject) | |
798 | (gnus-simplify-subject subject) | |
799 | nil)) | |
800 | ||
801 | (defun gnus-registry-fetch-simplified-message-subject-fast (article) | |
245101e5 | 802 | "Fetch the Subject quickly, using the internal gnus-data-list function." |
23f87bed | 803 | (if (and (numberp article) |
11a3174d | 804 | (assoc article (gnus-data-list nil))) |
01c52d31 MB |
805 | (gnus-string-remove-all-properties |
806 | (gnus-registry-simplify-subject | |
11a3174d TZ |
807 | (mail-header-subject (gnus-data-header |
808 | (assoc article (gnus-data-list nil)))))) | |
23f87bed MB |
809 | nil)) |
810 | ||
811 | (defun gnus-registry-fetch-sender-fast (article) | |
cf8b0c27 TZ |
812 | (gnus-registry-fetch-header-fast "from" article)) |
813 | ||
814 | (defun gnus-registry-fetch-recipients-fast (article) | |
8d6d9c8f KY |
815 | (gnus-registry-sort-addresses |
816 | (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "") | |
817 | (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) ""))) | |
cf8b0c27 TZ |
818 | |
819 | (defun gnus-registry-fetch-header-fast (article header) | |
245101e5 | 820 | "Fetch the HEADER quickly, using the internal gnus-data-list function." |
23f87bed | 821 | (if (and (numberp article) |
11a3174d | 822 | (assoc article (gnus-data-list nil))) |
01c52d31 | 823 | (gnus-string-remove-all-properties |
6b1f6ce9 | 824 | (cdr (assq header (gnus-data-header |
c024b021 | 825 | (assoc article (gnus-data-list nil)))))) |
23f87bed MB |
826 | nil)) |
827 | ||
11a3174d | 828 | ;; registry marks glue |
14e8de0c MB |
829 | (defun gnus-registry-do-marks (type function) |
830 | "For each known mark, call FUNCTION for each cell of type TYPE. | |
831 | ||
832 | FUNCTION should take two parameters, a mark symbol and the cell value." | |
833 | (dolist (mark-info gnus-registry-marks) | |
8f7abae3 | 834 | (let* ((mark (car-safe mark-info)) |
11a3174d TZ |
835 | (data (cdr-safe mark-info)) |
836 | (cell-data (plist-get data type))) | |
8f7abae3 | 837 | (when cell-data |
11a3174d | 838 | (funcall function mark cell-data))))) |
14e8de0c | 839 | |
245101e5 SM |
840 | ;; FIXME: Why not merge gnus-registry--set/remove-mark and |
841 | ;; gnus-registry-set-article-mark-internal? | |
842 | (defun gnus-registry--set/remove-mark (remove mark articles) | |
843 | "Set/remove the MARK over process-marked ARTICLES." | |
844 | ;; If this is called and the user doesn't want the | |
845 | ;; registry enabled, we'll ask anyhow. | |
846 | (unless gnus-registry-install | |
847 | (let ((gnus-registry-install 'ask)) | |
848 | (gnus-registry-install-p))) | |
849 | ||
850 | ;; Now the user is asked if gnus-registry-install is `ask'. | |
851 | (when (gnus-registry-install-p) | |
852 | (gnus-registry-set-article-mark-internal | |
853 | ;; All this just to get the mark, I must be doing it wrong. | |
854 | mark articles remove t) | |
855 | ;; FIXME: Why do we do the above only here and not directly inside | |
856 | ;; gnus-registry-set-article-mark-internal? I.e. we wouldn't we want to do | |
857 | ;; the things below when gnus-registry-set-article-mark-internal is called | |
858 | ;; from gnus-registry-set-article-mark or | |
859 | ;; gnus-registry-remove-article-mark? | |
860 | (gnus-message 9 "Applying mark %s to %d articles" | |
861 | mark (length articles)) | |
862 | (dolist (article articles) | |
863 | (gnus-summary-update-article | |
864 | article | |
865 | (assoc article (gnus-data-list nil)))))) | |
866 | ||
867 | ;; This is ugly code, but I don't know how to do it better. | |
8f7abae3 | 868 | (defun gnus-registry-install-shortcuts () |
14e8de0c MB |
869 | "Install the keyboard shortcuts and menus for the registry. |
870 | Uses `gnus-registry-marks' to find what shortcuts to install." | |
8f7abae3 | 871 | (let (keys-plist) |
ec7995fa KY |
872 | (setq gnus-registry-misc-menus nil) |
873 | (gnus-registry-do-marks | |
8f7abae3 MB |
874 | :char |
875 | (lambda (mark data) | |
876 | (let ((function-format | |
11a3174d | 877 | (format "gnus-registry-%%s-article-%s-mark" mark))) |
14e8de0c | 878 | |
245101e5 SM |
879 | ;;; The following generates these functions: |
880 | ;;; (defun gnus-registry-set-article-Important-mark (&rest articles) | |
881 | ;;; "Apply the Important mark to process-marked ARTICLES." | |
882 | ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) | |
883 | ;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) | |
884 | ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) | |
885 | ;;; "Apply the Important mark to process-marked ARTICLES." | |
886 | ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) | |
887 | ;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) | |
14e8de0c | 888 | |
11a3174d TZ |
889 | (dolist (remove '(t nil)) |
890 | (let* ((variant-name (if remove "remove" "set")) | |
245101e5 SM |
891 | (function-name |
892 | (intern (format function-format variant-name))) | |
893 | (shortcut (format "%c" (if remove (upcase data) data)))) | |
894 | (defalias function-name | |
895 | ;; If it weren't for the function's docstring, we could | |
896 | ;; use a closure, with lexical-let :-( | |
897 | `(lambda (&rest articles) | |
898 | ,(format | |
899 | "%s the %s mark over process-marked ARTICLES." | |
900 | (upcase-initials variant-name) | |
901 | mark) | |
902 | (interactive | |
903 | (gnus-summary-work-articles current-prefix-arg)) | |
904 | (gnus-registry--set/remove-mark ',mark ',remove articles))) | |
905 | (push function-name keys-plist) | |
11a3174d TZ |
906 | (push shortcut keys-plist) |
907 | (push (vector (format "%s %s" | |
908 | (upcase-initials variant-name) | |
909 | (symbol-name mark)) | |
245101e5 | 910 | function-name t) |
11a3174d | 911 | gnus-registry-misc-menus) |
245101e5 SM |
912 | (gnus-message 9 "Defined mark handling function %s" |
913 | function-name)))))) | |
8f7abae3 | 914 | (gnus-define-keys-1 |
ec7995fa KY |
915 | '(gnus-registry-mark-map "M" gnus-summary-mark-map) |
916 | keys-plist) | |
917 | (add-hook 'gnus-summary-menu-hook | |
11a3174d TZ |
918 | (lambda () |
919 | (easy-menu-add-item | |
920 | gnus-summary-misc-menu | |
921 | nil | |
922 | (cons "Registry Marks" gnus-registry-misc-menus)))))) | |
8f7abae3 | 923 | |
2da9c605 G |
924 | (make-obsolete 'gnus-registry-user-format-function-M |
925 | 'gnus-registry-article-marks-to-chars "24.1") ? | |
926 | ||
c146ad85 LMI |
927 | (defalias 'gnus-registry-user-format-function-M |
928 | 'gnus-registry-article-marks-to-chars) | |
929 | ||
627abcdd | 930 | ;; use like this: |
2da9c605 G |
931 | ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) |
932 | (defun gnus-registry-article-marks-to-chars (headers) | |
245101e5 | 933 | "Show the marks for an article by the :char property." |
627abcdd TZ |
934 | (let* ((id (mail-header-message-id headers)) |
935 | (marks (when id (gnus-registry-get-id-key id 'mark)))) | |
936 | (mapconcat (lambda (mark) | |
937 | (plist-get | |
938 | (cdr-safe | |
939 | (assoc mark gnus-registry-marks)) | |
940 | :char)) | |
941 | marks ""))) | |
942 | ||
943 | ;; use like this: | |
2da9c605 G |
944 | ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) |
945 | (defun gnus-registry-article-marks-to-names (headers) | |
245101e5 | 946 | "Show the marks for an article by name." |
8f7abae3 | 947 | (let* ((id (mail-header-message-id headers)) |
11a3174d | 948 | (marks (when id (gnus-registry-get-id-key id 'mark)))) |
627abcdd | 949 | (mapconcat (lambda (mark) (symbol-name mark)) marks ","))) |
0b6799c3 MB |
950 | |
951 | (defun gnus-registry-read-mark () | |
952 | "Read a mark name from the user with completion." | |
229b59da G |
953 | (let ((mark (gnus-completing-read |
954 | "Label" | |
955 | (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) | |
956 | nil nil nil | |
11a3174d | 957 | (symbol-name gnus-registry-default-mark)))) |
0b6799c3 MB |
958 | (when (stringp mark) |
959 | (intern mark)))) | |
960 | ||
961 | (defun gnus-registry-set-article-mark (&rest articles) | |
962 | "Apply a mark to process-marked ARTICLES." | |
963 | (interactive (gnus-summary-work-articles current-prefix-arg)) | |
11a3174d TZ |
964 | (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) |
965 | articles nil t)) | |
0b6799c3 MB |
966 | |
967 | (defun gnus-registry-remove-article-mark (&rest articles) | |
968 | "Remove a mark from process-marked ARTICLES." | |
969 | (interactive (gnus-summary-work-articles current-prefix-arg)) | |
11a3174d TZ |
970 | (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) |
971 | articles t t)) | |
972 | ||
973 | (defun gnus-registry-set-article-mark-internal (mark | |
974 | articles | |
975 | &optional remove | |
976 | show-message) | |
977 | "Apply or remove MARK across a list of ARTICLES." | |
0b6799c3 | 978 | (let ((article-id-list |
11a3174d | 979 | (mapcar 'gnus-registry-fetch-message-id-fast articles))) |
0b6799c3 | 980 | (dolist (id article-id-list) |
11a3174d TZ |
981 | (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark))) |
982 | (marks (if remove marks (cons mark marks)))) | |
983 | (when show-message | |
984 | (gnus-message 1 "%s mark %s with message ID %s, resulting in %S" | |
985 | (if remove "Removing" "Adding") | |
986 | mark id marks)) | |
987 | (gnus-registry-set-id-key id 'mark marks))))) | |
0b6799c3 MB |
988 | |
989 | (defun gnus-registry-get-article-marks (&rest articles) | |
990 | "Get the Gnus registry marks for ARTICLES and show them if interactive. | |
991 | Uses process/prefix conventions. For multiple articles, | |
992 | only the last one's marks are returned." | |
993 | (interactive (gnus-summary-work-articles 1)) | |
11a3174d TZ |
994 | (let* ((article (last articles)) |
995 | (id (gnus-registry-fetch-message-id-fast article)) | |
996 | (marks (when id (gnus-registry-get-id-key id 'mark)))) | |
da946239 | 997 | (when (gmm-called-interactively-p 'any) |
11a3174d | 998 | (gnus-message 1 "Marks are %S" marks)) |
0b6799c3 MB |
999 | marks)) |
1000 | ||
23f87bed MB |
1001 | (defun gnus-registry-group-count (id) |
1002 | "Get the number of groups of a message, based on the message ID." | |
11a3174d TZ |
1003 | (length (gnus-registry-get-id-key id 'group))) |
1004 | ||
1005 | (defun gnus-registry-get-or-make-entry (id) | |
1006 | (let* ((db gnus-registry-db) | |
1007 | ;; safe if not found | |
1008 | (entries (registry-lookup db (list id)))) | |
1009 | ||
1010 | (when (null entries) | |
81d7704c TZ |
1011 | (gnus-registry-insert db id (list (list 'creation-time (current-time)) |
1012 | '(group) '(sender) '(subject))) | |
11a3174d TZ |
1013 | (setq entries (registry-lookup db (list id)))) |
1014 | ||
1015 | (nth 1 (assoc id entries)))) | |
1016 | ||
42b23765 TZ |
1017 | (defun gnus-registry-delete-entries (idlist) |
1018 | (registry-delete gnus-registry-db idlist nil)) | |
1019 | ||
11a3174d TZ |
1020 | (defun gnus-registry-get-id-key (id key) |
1021 | (cdr-safe (assq key (gnus-registry-get-or-make-entry id)))) | |
1022 | ||
1023 | (defun gnus-registry-set-id-key (id key vals) | |
1024 | (let* ((db gnus-registry-db) | |
1025 | (entry (gnus-registry-get-or-make-entry id))) | |
1026 | (registry-delete db (list id) nil) | |
1027 | (setq entry (cons (cons key vals) (assq-delete-all key entry))) | |
81d7704c | 1028 | (gnus-registry-insert db id entry) |
11a3174d TZ |
1029 | entry)) |
1030 | ||
81d7704c TZ |
1031 | (defun gnus-registry-insert (db id entry) |
1032 | "Just like `registry-insert' but tries to prune on error." | |
1033 | (when (registry-full db) | |
1034 | (message "Trying to prune the registry because it's full") | |
1035 | (registry-prune db)) | |
1036 | (registry-insert db id entry) | |
1037 | entry) | |
1038 | ||
42b23765 TZ |
1039 | (defun gnus-registry-import-eld (file) |
1040 | (interactive "fOld registry file to import? ") | |
1041 | ;; example content: | |
1042 | ;; (setq gnus-registry-alist '( | |
1043 | ;; ("<messageID>" ((marks nil) | |
1044 | ;; (mtime 19365 1776 440496) | |
1045 | ;; (sender . "root (Cron Daemon)") | |
1046 | ;; (subject . "Cron")) | |
1047 | ;; "cron" "nnml+private:cron") | |
1048 | (load file t) | |
1049 | (when (boundp 'gnus-registry-alist) | |
1050 | (let* ((old (symbol-value 'gnus-registry-alist)) | |
1051 | (count 0) | |
1052 | (expected (length old)) | |
1053 | entry) | |
1054 | (while (car-safe old) | |
1055 | (incf count) | |
1056 | ;; don't use progress reporters for backwards compatibility | |
1057 | (when (and (< 0 expected) | |
1058 | (= 0 (mod count 100))) | |
1059 | (message "importing: %d of %d (%.2f%%)" | |
1060 | count expected (/ (* 100 count) expected))) | |
1061 | (setq entry (car-safe old) | |
1062 | old (cdr-safe old)) | |
1063 | (let* ((id (car-safe entry)) | |
1064 | (new-entry (gnus-registry-get-or-make-entry id)) | |
1065 | (rest (cdr-safe entry)) | |
1066 | (groups (loop for p in rest | |
1067 | when (stringp p) | |
1068 | collect p)) | |
1069 | extra-cell key val) | |
1070 | ;; remove all the strings from the entry | |
8d6d9c8f | 1071 | (dolist (elem rest) |
c024b021 | 1072 | (if (stringp elem) (setq rest (delq elem rest)))) |
42b23765 TZ |
1073 | (gnus-registry-set-id-key id 'group groups) |
1074 | ;; just use the first extra element | |
1075 | (setq rest (car-safe rest)) | |
1076 | (while (car-safe rest) | |
1077 | (setq extra-cell (car-safe rest) | |
1078 | key (car-safe extra-cell) | |
1079 | val (cdr-safe extra-cell) | |
1080 | rest (cdr-safe rest)) | |
1081 | (when (and val (atom val)) | |
1082 | (setq val (list val))) | |
1083 | (gnus-registry-set-id-key id key val)))) | |
1084 | (message "Import done, collected %d entries" count)))) | |
11a3174d | 1085 | |
23f87bed MB |
1086 | ;;;###autoload |
1087 | (defun gnus-registry-initialize () | |
245101e5 | 1088 | "Initialize the Gnus registry." |
23f87bed | 1089 | (interactive) |
8f7abae3 | 1090 | (gnus-message 5 "Initializing the registry") |
23f87bed | 1091 | (gnus-registry-install-hooks) |
8f7abae3 | 1092 | (gnus-registry-install-shortcuts) |
23f87bed MB |
1093 | (gnus-registry-read)) |
1094 | ||
245101e5 | 1095 | ;; FIXME: Why autoload this function? |
23f87bed MB |
1096 | ;;;###autoload |
1097 | (defun gnus-registry-install-hooks () | |
1098 | "Install the registry hooks." | |
1099 | (interactive) | |
aa22bff2 | 1100 | (setq gnus-registry-enabled t) |
bf247b6e | 1101 | (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) |
23f87bed MB |
1102 | (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) |
1103 | (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
1104 | (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
bf247b6e | 1105 | |
23f87bed MB |
1106 | (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) |
1107 | (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
1108 | ||
1109 | (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) | |
1110 | ||
1111 | (defun gnus-registry-unload-hook () | |
1112 | "Uninstall the registry hooks." | |
1113 | (interactive) | |
bf247b6e | 1114 | (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) |
23f87bed MB |
1115 | (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) |
1116 | (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) | |
1117 | (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) | |
bf247b6e | 1118 | |
23f87bed MB |
1119 | (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) |
1120 | (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) | |
1121 | ||
aa22bff2 TZ |
1122 | (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) |
1123 | (setq gnus-registry-enabled nil)) | |
23f87bed | 1124 | |
6d52545d RS |
1125 | (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) |
1126 | ||
8f7abae3 | 1127 | (defun gnus-registry-install-p () |
d136f184 GM |
1128 | "Return non-nil if the registry is enabled (and maybe enable it first). |
1129 | If the registry is not already enabled, then if `gnus-registry-install' | |
1130 | is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it." | |
8f7abae3 | 1131 | (interactive) |
aa22bff2 TZ |
1132 | (unless gnus-registry-enabled |
1133 | (when (if (eq gnus-registry-install 'ask) | |
1134 | (gnus-y-or-n-p | |
1135 | (concat "Enable the Gnus registry? " | |
1136 | "See the variable `gnus-registry-install' " | |
1137 | "to get rid of this query permanently. ")) | |
1138 | gnus-registry-install) | |
8f7abae3 | 1139 | (gnus-registry-initialize))) |
aa22bff2 | 1140 | gnus-registry-enabled) |
8f7abae3 | 1141 | |
89b163db G |
1142 | ;; largely based on nnir-warp-to-article |
1143 | (defun gnus-try-warping-via-registry () | |
1144 | "Try to warp via the registry. | |
1145 | This will be done via the current article's source group based on | |
1146 | data stored in the registry." | |
1147 | (interactive) | |
1148 | (when (gnus-summary-article-header) | |
1149 | (let* ((message-id (mail-header-id (gnus-summary-article-header))) | |
1150 | ;; Retrieve the message's group(s) from the registry | |
1151 | (groups (gnus-registry-get-id-key message-id 'group)) | |
1152 | ;; If starting from an ephemeral group, this describes | |
1153 | ;; how to restore the window configuration | |
1154 | (quit-config | |
1155 | (gnus-ephemeral-group-p gnus-newsgroup-name)) | |
1156 | (seen-groups (list (gnus-group-group-name)))) | |
1157 | ||
1158 | (catch 'found | |
1159 | (dolist (group (mapcar 'gnus-simplify-group-name groups)) | |
1160 | ||
1161 | ;; skip over any groups we really don't want to warp to. | |
1162 | (unless (or (member group seen-groups) | |
1163 | (gnus-ephemeral-group-p group) ;; any ephemeral group | |
1164 | (memq (car (gnus-find-method-for-group group)) | |
1165 | ;; Specific methods; this list may need to expand. | |
1166 | '(nnir))) | |
1167 | ||
1168 | ;; remember that we've seen this group already | |
1169 | (push group seen-groups) | |
1170 | ||
1171 | ;; first exit from any ephemeral summary buffer. | |
1172 | (when quit-config | |
1173 | (gnus-summary-exit) | |
1174 | ;; and if the ephemeral summary buffer in turn came from | |
1175 | ;; another summary buffer we have to clean that summary | |
1176 | ;; up too. | |
1177 | (when (eq (cdr quit-config) 'summary) | |
1178 | (gnus-summary-exit)) | |
1179 | ;; remember that we've already done this part | |
1180 | (setq quit-config nil)) | |
1181 | ||
1182 | ;; Try to activate the group. If that fails, just move | |
1183 | ;; along. We may have more groups to work with | |
c20643e2 DA |
1184 | (when |
1185 | (ignore-errors | |
1186 | (gnus-select-group-with-message-id group message-id) t) | |
1187 | (throw 'found t)))))))) | |
89b163db | 1188 | |
c17b81a7 G |
1189 | (defun gnus-registry-remove-extra-data (extra) |
1190 | "Remove tracked EXTRA data from the gnus registry. | |
1191 | EXTRA is a list of symbols. Valid symbols are those contained in | |
1192 | the docs of `gnus-registry-track-extra'. This command is useful | |
1193 | when you stop tracking some extra data and now want to purge it | |
1194 | from your existing entries." | |
1195 | (interactive (list (mapcar 'intern | |
1196 | (completing-read-multiple | |
1197 | "Extra data: " | |
1198 | '("subject" "sender" "recipient"))))) | |
1199 | (when extra | |
1200 | (let ((db gnus-registry-db)) | |
1201 | (registry-reindex db) | |
1202 | (loop for k being the hash-keys of (oref db :data) | |
1203 | using (hash-value v) | |
1204 | do (let ((newv (delq nil (mapcar #'(lambda (entry) | |
1205 | (unless (member (car entry) extra) | |
1206 | entry)) | |
1207 | v)))) | |
1208 | (registry-delete db (list k) nil) | |
1209 | (gnus-registry-insert db k newv))) | |
1210 | (registry-reindex db)))) | |
1211 | ||
8f7abae3 | 1212 | ;; TODO: a few things |
23f87bed MB |
1213 | |
1214 | (provide 'gnus-registry) | |
1215 | ||
23f87bed | 1216 | ;;; gnus-registry.el ends here |