/[emacs]/emacs/lisp/gnus/gnus-registry.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-registry.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26