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