cgit.sxemacs.org Git - gnus/blob - lisp/gnus-registry.el

   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 (defun gnus-registry-track-subject-p ()
 133   (memq 'subject gnus-registry-track-extra))
 134
 135 (defun gnus-registry-track-sender-p ()
 136   (memq 'sender gnus-registry-track-extra))
 137
 138 (defun gnus-registry-cache-read ()
 139   "Read the registry cache file."
 140   (interactive)
 141   (let ((file gnus-registry-cache-file))
 142     (when (file-exists-p file)
 143       (gnus-message 5 "Reading %s..." file)
 144       (gnus-load file)
 145       (gnus-message 5 "Reading %s...done" file))))
 146
 147 (defun gnus-registry-cache-save ()
 148   "Save the registry cache file."
 149   (interactive)
 150   (let ((file gnus-registry-cache-file))
 151     (save-excursion
 152       (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
 153       (make-local-variable 'version-control)
 154     (setq version-control gnus-backup-startup-file)
 155     (setq buffer-file-name file)
 156     (setq default-directory (file-name-directory buffer-file-name))
 157     (buffer-disable-undo)
 158     (erase-buffer)
 159     (gnus-message 5 "Saving %s..." file)
 160     (if gnus-save-startup-file-via-temp-buffer
 161         (let ((coding-system-for-write gnus-ding-file-coding-system)
 162               (standard-output (current-buffer)))
 163           (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)
 164           (gnus-registry-cache-whitespace file)
 165           (save-buffer))
 166       (let ((coding-system-for-write gnus-ding-file-coding-system)
 167             (version-control gnus-backup-startup-file)
 168             (startup-file file)
 169             (working-dir (file-name-directory file))
 170             working-file
 171             (i -1))
 172         ;; Generate the name of a non-existent file.
 173         (while (progn (setq working-file
 174                             (format
 175                              (if (and (eq system-type 'ms-dos)
 176                                       (not (gnus-long-file-names)))
 177                                  "%s#%d.tm#" ; MSDOS limits files to 8+3
 178                                (if (memq system-type '(vax-vms axp-vms))
 179                                    "%s$tmp$%d"
 180                                  "%s#tmp#%d"))
 181                              working-dir (setq i (1+ i))))
 182                       (file-exists-p working-file)))
 183
 184         (unwind-protect
 185             (progn
 186               (gnus-with-output-to-file working-file
 187                 (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
 188
 189               ;; These bindings will mislead the current buffer
 190               ;; into thinking that it is visiting the startup
 191               ;; file.
 192               (let ((buffer-backed-up nil)
 193                     (buffer-file-name startup-file)
 194                     (file-precious-flag t)
 195                     (setmodes (file-modes startup-file)))
 196                 ;; Backup the current version of the startup file.
 197                 (backup-buffer)
 198
 199                 ;; Replace the existing startup file with the temp file.
 200                 (rename-file working-file startup-file t)
 201                 (set-file-modes startup-file setmodes)))
 202           (condition-case nil
 203               (delete-file working-file)
 204             (file-error nil)))))
 205
 206     (gnus-kill-buffer (current-buffer))
 207     (gnus-message 5 "Saving %s...done" file))))
 208
 209 ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
 210 ;; Save the gnus-registry file with extra line breaks.
 211 (defun gnus-registry-cache-whitespace (filename)
 212   (gnus-message 5 "Adding whitespace to %s" filename)
 213   (save-excursion
 214     (goto-char (point-min))
 215     (while (re-search-forward "^(\\|(\\\"" nil t)
 216       (replace-match "\n\\&" t))
 217     (goto-char (point-min))
 218     (while (re-search-forward " $" nil t)
 219       (replace-match "" t t))))
 220
 221 (defun gnus-registry-save (&optional force)
 222   (when (or gnus-registry-dirty force)
 223     (let ((caching gnus-registry-entry-caching))
 224       ;; turn off entry caching, so mtime doesn't get recorded
 225       (setq gnus-registry-entry-caching nil)
 226       ;; remove entry caches
 227       (maphash
 228        (lambda (key value)
 229          (if (hash-table-p value)
 230              (remhash key gnus-registry-hashtb)))
 231        gnus-registry-hashtb)
 232       ;; remove empty entries
 233       (when gnus-registry-clean-empty
 234         (gnus-registry-clean-empty-function))
 235       ;; now trim the registry appropriately
 236       (setq gnus-registry-alist (gnus-registry-trim
 237                                  (hashtable-to-alist gnus-registry-hashtb)))
 238       ;; really save
 239       (gnus-registry-cache-save)
 240       (setq gnus-registry-entry-caching caching)
 241       (setq gnus-registry-dirty nil))))
 242
 243 (defun gnus-registry-clean-empty-function ()
 244   "Remove all empty entries from the registry.  Returns count thereof."
 245   (let ((count 0))
 246     (maphash
 247      (lambda (key value)
 248        (unless (gnus-registry-fetch-group key)
 249          (incf count)
 250          (remhash key gnus-registry-hashtb)))
 251      gnus-registry-hashtb)
 252     count))
 253
 254 (defun gnus-registry-read ()
 255   (gnus-registry-cache-read)
 256   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
 257   (setq gnus-registry-dirty nil))
 258
 259 (defun gnus-registry-trim (alist)
 260   "Trim alist to size, using gnus-registry-max-entries."
 261   (if (null gnus-registry-max-entries)
 262       alist                             ; just return the alist
 263     ;; else, when given max-entries, trim the alist
 264     (let ((timehash (make-hash-table
 265                      :size 4096
 266                      :test 'equal)))
 267       (maphash
 268        (lambda (key value)
 269          (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
 270        gnus-registry-hashtb)
 271
 272       ;; we use the return value of this setq, which is the trimmed alist
 273       (setq alist
 274             (nthcdr
 275              (- (length alist) gnus-registry-max-entries)
 276              (sort alist
 277                    (lambda (a b)
 278                      (time-less-p
 279                       (cdr (gethash (car a) timehash))
 280                       (cdr (gethash (car b) timehash))))))))))
 281
 282 (defun alist-to-hashtable (alist)
 283   "Build a hashtable from the values in ALIST."
 284   (let ((ht (make-hash-table
 285              :size 4096
 286              :test 'equal)))
 287     (mapc
 288      (lambda (kv-pair)
 289        (puthash (car kv-pair) (cdr kv-pair) ht))
 290      alist)
 291      ht))
 292
 293 (defun hashtable-to-alist (hash)
 294   "Build an alist from the values in HASH."
 295   (let ((list nil))
 296     (maphash
 297      (lambda (key value)
 298        (setq list (cons (cons key value) list)))
 299      hash)
 300     list))
 301
 302 (defun gnus-registry-action (action data-header from &optional to method)
 303   (let* ((id (mail-header-id data-header))
 304          (subject (gnus-registry-simplify-subject
 305                    (mail-header-subject data-header)))
 306          (sender (mail-header-from data-header))
 307          (from (gnus-group-guess-full-name-from-command-method from))
 308          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
 309          (to-name (if to to "the Bit Bucket"))
 310          (old-entry (gethash id gnus-registry-hashtb)))
 311     (gnus-message 5 "Registry: article %s %s from %s to %s"
 312                   id
 313                   (if method "respooling" "going")
 314                   from
 315                   to)
 316
 317     ;; All except copy will need a delete
 318     (gnus-registry-delete-group id from)
 319
 320     (when (equal 'copy action)
 321       (gnus-registry-add-group id from subject sender)) ; undo the delete
 322
 323     (gnus-registry-add-group id to subject sender)))
 324
 325 (defun gnus-registry-spool-action (id group &optional subject sender)
 326   (let ((group (gnus-group-guess-full-name-from-command-method group)))
 327     (when (and (stringp id) (string-match "\r$" id))
 328       (setq id (substring id 0 -1)))
 329     (gnus-message 5 "Registry: article %s spooled to %s"
 330                   id
 331                   group)
 332     (gnus-registry-add-group id group subject sender)))
 333
 334 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 335 ;; the cache and if a match is found, return that group.
 336 (defun gnus-registry-split-fancy-with-parent ()
 337   "Split this message into the same group as its parent.  The parent
 338 is obtained from the registry.  This function can be used as an entry
 339 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 340 this: (: gnus-registry-split-fancy-with-parent)
 341
 342 For a message to be split, it looks for the parent message in the
 343 References or In-Reply-To header and then looks in the registry to
 344 see which group that message was put in.  This group is returned.
 345
 346 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 347   (let ((refstr (or (message-fetch-field "references")
 348                     (message-fetch-field "in-reply-to")))
 349         (nnmail-split-fancy-with-parent-ignore-groups
 350          (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 351              nnmail-split-fancy-with-parent-ignore-groups
 352            (list nnmail-split-fancy-with-parent-ignore-groups)))
 353         references res)
 354     (if refstr
 355         (progn
 356           (setq references (nreverse (gnus-split-references refstr)))
 357           (mapcar (lambda (x)
 358                     (setq res (or (gnus-registry-fetch-group x) res))
 359                     (when (or (gnus-registry-grep-in-list
 360                                res
 361                                gnus-registry-unfollowed-groups)
 362                               (gnus-registry-grep-in-list
 363                                res
 364                                nnmail-split-fancy-with-parent-ignore-groups))
 365                       (setq res nil)))
 366                   references))
 367
 368       ;; else: there were no references, now try the extra tracking
 369       (let ((sender (message-fetch-field "from"))
 370             (subject (gnus-registry-simplify-subject
 371                       (message-fetch-field "subject")))
 372             (single-match t))
 373         (when (and single-match
 374                    (gnus-registry-track-sender-p)
 375                    sender)
 376           (maphash
 377            (lambda (key value)
 378              (let ((this-sender (cdr
 379                                  (gnus-registry-fetch-extra key 'sender))))
 380                (when (and single-match
 381                           this-sender
 382                           (equal sender this-sender))
 383                  ;; too many matches, bail
 384                  (unless (equal res (gnus-registry-fetch-group key))
 385                    (setq single-match nil))
 386                  (setq res (gnus-registry-fetch-group key))
 387                  (when (and sender res)
 388                    (gnus-message
 389                     ;; raise level of messaging if gnus-registry-track-extra
 390                     (if gnus-registry-track-extra 5 9)
 391                     "%s (extra tracking) traced sender %s to group %s"
 392                     "gnus-registry-split-fancy-with-parent"
 393                     sender
 394                     res)))))
 395            gnus-registry-hashtb))
 396         (when (and single-match
 397                    (gnus-registry-track-subject-p)
 398                    subject
 399                    (< gnus-registry-minimum-subject-length (length subject)))
 400           (maphash
 401            (lambda (key value)
 402              (let ((this-subject (cdr
 403                                   (gnus-registry-fetch-extra key 'subject))))
 404                (when (and single-match
 405                           this-subject
 406                           (equal subject this-subject))
 407                  ;; too many matches, bail
 408                  (unless (equal res (gnus-registry-fetch-group key))
 409                    (setq single-match nil))
 410                  (setq res (gnus-registry-fetch-group key))
 411                  (when (and subject res)
 412                    (gnus-message
 413                     ;; raise level of messaging if gnus-registry-track-extra
 414                     (if gnus-registry-track-extra 5 9)
 415                     "%s (extra tracking) traced subject %s to group %s"
 416                     "gnus-registry-split-fancy-with-parent"
 417                     subject
 418                     res)))))
 419            gnus-registry-hashtb))
 420         (unless single-match
 421           (gnus-message
 422            5
 423            "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
 424            refstr)
 425           (setq res nil))))
 426     (when (and refstr res)
 427       (gnus-message
 428        5
 429        "gnus-registry-split-fancy-with-parent traced %s to group %s"
 430        refstr res))
 431
 432     (when (and res gnus-registry-use-long-group-names)
 433       (let ((m1 (gnus-find-method-for-group res))
 434             (m2 (or gnus-command-method
 435                     (gnus-find-method-for-group gnus-newsgroup-name)))
 436             (short-res (gnus-group-short-name res)))
 437       (if (gnus-methods-equal-p m1 m2)
 438           (progn
 439             (gnus-message
 440              9
 441              "gnus-registry-split-fancy-with-parent stripped group %s to %s"
 442              res
 443              short-res)
 444             (setq res short-res))
 445         ;; else...
 446         (gnus-message
 447          5
 448          "gnus-registry-split-fancy-with-parent ignored foreign group %s"
 449          res)
 450         (setq res nil))))
 451     res))
 452
 453 (defun gnus-registry-register-message-ids ()
 454   "Register the Message-ID of every article in the group"
 455   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 456     (dolist (article gnus-newsgroup-articles)
 457       (let ((id (gnus-registry-fetch-message-id-fast article)))
 458         (unless (gnus-registry-fetch-group id)
 459           (gnus-message 9 "Registry: Registering article %d with group %s"
 460                         article gnus-newsgroup-name)
 461           (gnus-registry-add-group
 462            (gnus-registry-fetch-message-id-fast article)
 463            gnus-newsgroup-name
 464            (gnus-registry-fetch-simplified-message-subject-fast article)
 465            (gnus-registry-fetch-sender-fast article)))))))
 466
 467 (defun gnus-registry-fetch-message-id-fast (article)
 468   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 469   (if (and (numberp article)
 470            (assoc article (gnus-data-list nil)))
 471       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 472     nil))
 473
 474 (defun gnus-registry-simplify-subject (subject)
 475   (if (stringp subject)
 476       (gnus-simplify-subject subject)
 477     nil))
 478
 479 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 480   "Fetch the Subject quickly, using the internal gnus-data-list function"
 481   (if (and (numberp article)
 482            (assoc article (gnus-data-list nil)))
 483       (gnus-registry-simplify-subject
 484        (mail-header-subject (gnus-data-header
 485                              (assoc article (gnus-data-list nil)))))
 486     nil))
 487
 488 (defun gnus-registry-fetch-sender-fast (article)
 489   "Fetch the Sender quickly, using the internal gnus-data-list function"
 490   (if (and (numberp article)
 491            (assoc article (gnus-data-list nil)))
 492       (mail-header-from (gnus-data-header
 493                          (assoc article (gnus-data-list nil))))
 494     nil))
 495
 496 (defun gnus-registry-grep-in-list (word list)
 497   (when word
 498     (memq nil
 499           (mapcar 'not
 500                   (mapcar
 501                    (lambda (x)
 502                      (string-match x word))
 503                    list)))))
 504
 505 (defun gnus-registry-fetch-extra (id &optional entry)
 506   "Get the extra data of a message, based on the message ID.
 507 Returns the first place where the trail finds a nonstring."
 508   (let ((entry-cache (gethash entry gnus-registry-hashtb)))
 509     (if (and entry
 510              (hash-table-p entry-cache)
 511              (gethash id entry-cache))
 512         (gethash id entry-cache)
 513       ;; else, if there is no caching possible...
 514       (let ((trail (gethash id gnus-registry-hashtb)))
 515         (when (listp trail)
 516           (dolist (crumb trail)
 517             (unless (stringp crumb)
 518               (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
 519
 520 (defun gnus-registry-fetch-extra-entry (alist &optional entry id)
 521   "Get the extra data of a message, or a specific entry in it.
 522 Update the entry cache if needed."
 523   (if (and entry id)
 524       (let ((entry-cache (gethash entry gnus-registry-hashtb))
 525             entree)
 526         (when gnus-registry-entry-caching
 527           ;; create the hash table
 528           (unless (hash-table-p entry-cache)
 529             (setq entry-cache (make-hash-table
 530                                :size 4096
 531                                :test 'equal))
 532             (puthash entry entry-cache gnus-registry-hashtb))
 533
 534           ;; get the entree from the hash table or from the alist
 535           (setq entree (gethash id entry-cache)))
 536
 537         (unless entree
 538           (setq entree (assq entry alist))
 539           (when gnus-registry-entry-caching
 540             (puthash id entree entry-cache)))
 541         entree)
 542     alist))
 543
 544 (defun gnus-registry-store-extra (id extra)
 545   "Store the extra data of a message, based on the message ID.
 546 The message must have at least one group name."
 547   (when (gnus-registry-group-count id)
 548     ;; we now know the trail has at least 1 group name, so it's not empty
 549     (let ((trail (gethash id gnus-registry-hashtb))
 550           (old-extra (gnus-registry-fetch-extra id))
 551           entry-cache)
 552       (dolist (crumb trail)
 553         (unless (stringp crumb)
 554           (dolist (entry crumb)
 555             (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
 556           (when entry-cache
 557             (remhash id entry-cache))))
 558       (puthash id (cons extra (delete old-extra trail))
 559                gnus-registry-hashtb)
 560       (setq gnus-registry-dirty t)))))
 561
 562 (defun gnus-registry-store-extra-entry (id key value)
 563   "Put a specific entry in the extras field of the registry entry for id."
 564   (let* ((extra (gnus-registry-fetch-extra id))
 565          (alist (cons (cons key value)
 566                  (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
 567     (gnus-registry-store-extra id alist)))
 568
 569 (defun gnus-registry-fetch-group (id)
 570   "Get the group of a message, based on the message ID.
 571 Returns the first place where the trail finds a group name."
 572   (when (gnus-registry-group-count id)
 573     ;; we now know the trail has at least 1 group name
 574     (let ((trail (gethash id gnus-registry-hashtb)))
 575       (dolist (crumb trail)
 576         (when (stringp crumb)
 577           (return (if gnus-registry-use-long-group-names
 578                        crumb
 579                      (gnus-group-short-name crumb))))))))
 580
 581 (defun gnus-registry-group-count (id)
 582   "Get the number of groups of a message, based on the message ID."
 583   (let ((trail (gethash id gnus-registry-hashtb)))
 584     (if (and trail (listp trail))
 585         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 586       0)))
 587
 588 (defun gnus-registry-delete-group (id group)
 589   "Delete a group for a message, based on the message ID."
 590   (when group
 591     (when id
 592       (let ((trail (gethash id gnus-registry-hashtb))
 593             (group (gnus-group-short-name group)))
 594         (puthash id (if trail
 595                         (delete group trail)
 596                       nil)
 597                  gnus-registry-hashtb))
 598       ;; now, clear the entry if there are no more groups
 599       (when gnus-registry-trim-articles-without-groups
 600         (unless (gnus-registry-group-count id)
 601           (gnus-registry-delete-id id)))
 602       (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 603
 604 (defun gnus-registry-delete-id (id)
 605   "Delete a message ID from the registry."
 606   (when (stringp id)
 607     (remhash id gnus-registry-hashtb)
 608     (maphash
 609      (lambda (key value)
 610        (when (hash-table-p value)
 611          (remhash id value)))
 612      gnus-registry-hashtb)))
 613
 614 (defun gnus-registry-add-group (id group &optional subject sender)
 615   "Add a group for a message, based on the message ID."
 616   (when group
 617     (when (and id
 618                (not (string-match "totally-fudged-out-message-id" id)))
 619       (let ((full-group group)
 620             (group (if gnus-registry-use-long-group-names
 621                        group
 622                      (gnus-group-short-name group))))
 623         (gnus-registry-delete-group id group)
 624
 625         (unless gnus-registry-use-long-group-names ;; unnecessary in this case
 626           (gnus-registry-delete-group id full-group))
 627
 628         (let ((trail (gethash id gnus-registry-hashtb)))
 629           (puthash id (if trail
 630                           (cons group trail)
 631                         (list group))
 632                    gnus-registry-hashtb)
 633
 634           (when (and (gnus-registry-track-subject-p)
 635                      subject)
 636             (gnus-registry-store-extra-entry
 637              id
 638              'subject
 639              (gnus-registry-simplify-subject subject)))
 640           (when (and (gnus-registry-track-sender-p)
 641                      sender)
 642             (gnus-registry-store-extra-entry
 643              id
 644              'sender
 645              sender))
 646
 647           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 648
 649 (defun gnus-registry-clear ()
 650   "Clear the Gnus registry."
 651   (interactive)
 652   (setq gnus-registry-alist nil)
 653   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
 654   (setq gnus-registry-dirty t))
 655
 656 ;;;###autoload
 657 (defun gnus-registry-initialize ()
 658   (interactive)
 659   (setq gnus-registry-install t)
 660   (gnus-registry-install-hooks)
 661   (gnus-registry-read))
 662
 663 ;;;###autoload
 664 (defun gnus-registry-install-hooks ()
 665   "Install the registry hooks."
 666   (interactive)
 667   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 668   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 669   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 670   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 671
 672   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 673   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 674
 675   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 676
 677 (defun gnus-registry-unload-hook ()
 678   "Uninstall the registry hooks."
 679   (interactive)
 680   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 681   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 682   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 683   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 684
 685   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 686   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 687
 688   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 689
 690 (when gnus-registry-install
 691   (gnus-registry-install-hooks)
 692   (gnus-registry-read))
 693
 694 ;; TODO: a lot of things
 695
 696 (provide 'gnus-registry)
 697
 698 ;;; gnus-registry.el ends here