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                  (gnus-message
 388                   ;; raise level of messaging if gnus-registry-track-extra
 389                   (if gnus-registry-track-extra 5 9)
 390                   "%s (extra tracking) traced sender %s to group %s"
 391                   "gnus-registry-split-fancy-with-parent"
 392                   sender
 393                   (if res res "nil")))))
 394            gnus-registry-hashtb))
 395         (when (and single-match
 396                    (gnus-registry-track-subject-p)
 397                    subject
 398                    (< gnus-registry-minimum-subject-length (length subject)))
 399           (maphash
 400            (lambda (key value)
 401              (let ((this-subject (cdr
 402                                   (gnus-registry-fetch-extra key 'subject))))
 403                (when (and single-match
 404                           this-subject
 405                           (equal subject this-subject))
 406                  ;; too many matches, bail
 407                  (unless (equal res (gnus-registry-fetch-group key))
 408                    (setq single-match nil))
 409                  (setq res (gnus-registry-fetch-group key))
 410                  (gnus-message
 411                   ;; raise level of messaging if gnus-registry-track-extra
 412                   (if gnus-registry-track-extra 5 9)
 413                   "%s (extra tracking) traced subject %s to group %s"
 414                   "gnus-registry-split-fancy-with-parent"
 415                   subject
 416                   (if res res "nil")))))
 417            gnus-registry-hashtb))
 418         (unless single-match
 419           (gnus-message
 420            5
 421            "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
 422            refstr)
 423           (setq res nil))))
 424     (gnus-message
 425      5
 426      "gnus-registry-split-fancy-with-parent traced %s to group %s"
 427      refstr (if res res "nil"))
 428
 429     (when (and res gnus-registry-use-long-group-names)
 430       (let ((m1 (gnus-find-method-for-group res))
 431             (m2 (or gnus-command-method
 432                     (gnus-find-method-for-group gnus-newsgroup-name)))
 433             (short-res (gnus-group-short-name res)))
 434       (if (gnus-methods-equal-p m1 m2)
 435           (progn
 436             (gnus-message
 437              9
 438              "gnus-registry-split-fancy-with-parent stripped group %s to %s"
 439              res
 440              short-res)
 441             (setq res short-res))
 442         ;; else...
 443         (gnus-message
 444          5
 445          "gnus-registry-split-fancy-with-parent ignored foreign group %s"
 446          res)
 447         (setq res nil))))
 448     res))
 449
 450 (defun gnus-registry-register-message-ids ()
 451   "Register the Message-ID of every article in the group"
 452   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 453     (dolist (article gnus-newsgroup-articles)
 454       (let ((id (gnus-registry-fetch-message-id-fast article)))
 455         (unless (gnus-registry-fetch-group id)
 456           (gnus-message 9 "Registry: Registering article %d with group %s"
 457                         article gnus-newsgroup-name)
 458           (gnus-registry-add-group
 459            (gnus-registry-fetch-message-id-fast article)
 460            gnus-newsgroup-name
 461            (gnus-registry-fetch-simplified-message-subject-fast article)
 462            (gnus-registry-fetch-sender-fast article)))))))
 463
 464 (defun gnus-registry-fetch-message-id-fast (article)
 465   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 466   (if (and (numberp article)
 467            (assoc article (gnus-data-list nil)))
 468       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 469     nil))
 470
 471 (defun gnus-registry-simplify-subject (subject)
 472   (if (stringp subject)
 473       (gnus-simplify-subject subject)
 474     nil))
 475
 476 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 477   "Fetch the Subject quickly, using the internal gnus-data-list function"
 478   (if (and (numberp article)
 479            (assoc article (gnus-data-list nil)))
 480       (gnus-registry-simplify-subject
 481        (mail-header-subject (gnus-data-header
 482                              (assoc article (gnus-data-list nil)))))
 483     nil))
 484
 485 (defun gnus-registry-fetch-sender-fast (article)
 486   "Fetch the Sender quickly, using the internal gnus-data-list function"
 487   (if (and (numberp article)
 488            (assoc article (gnus-data-list nil)))
 489       (mail-header-from (gnus-data-header
 490                          (assoc article (gnus-data-list nil))))
 491     nil))
 492
 493 (defun gnus-registry-grep-in-list (word list)
 494   (when word
 495     (memq nil
 496           (mapcar 'not
 497                   (mapcar
 498                    (lambda (x)
 499                      (string-match x word))
 500                    list)))))
 501
 502 (defun gnus-registry-fetch-extra (id &optional entry)
 503   "Get the extra data of a message, based on the message ID.
 504 Returns the first place where the trail finds a nonstring."
 505   (let ((entry-cache (gethash entry gnus-registry-hashtb)))
 506     (if (and entry
 507              (hash-table-p entry-cache)
 508              (gethash id entry-cache))
 509         (gethash id entry-cache)
 510       ;; else, if there is no caching possible...
 511       (let ((trail (gethash id gnus-registry-hashtb)))
 512         (when (listp trail)
 513           (dolist (crumb trail)
 514             (unless (stringp crumb)
 515               (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
 516
 517 (defun gnus-registry-fetch-extra-entry (alist &optional entry id)
 518   "Get the extra data of a message, or a specific entry in it.
 519 Update the entry cache if needed."
 520   (if (and entry id)
 521       (let ((entry-cache (gethash entry gnus-registry-hashtb))
 522             entree)
 523         (when gnus-registry-entry-caching
 524           ;; create the hash table
 525           (unless (hash-table-p entry-cache)
 526             (setq entry-cache (make-hash-table
 527                                :size 4096
 528                                :test 'equal))
 529             (puthash entry entry-cache gnus-registry-hashtb))
 530
 531           ;; get the entree from the hash table or from the alist
 532           (setq entree (gethash id entry-cache)))
 533
 534         (unless entree
 535           (setq entree (assq entry alist))
 536           (when gnus-registry-entry-caching
 537             (puthash id entree entry-cache)))
 538         entree)
 539     alist))
 540
 541 (defun gnus-registry-store-extra (id extra)
 542   "Store the extra data of a message, based on the message ID.
 543 The message must have at least one group name."
 544   (when (gnus-registry-group-count id)
 545     ;; we now know the trail has at least 1 group name, so it's not empty
 546     (let ((trail (gethash id gnus-registry-hashtb))
 547           (old-extra (gnus-registry-fetch-extra id))
 548           entry-cache)
 549       (dolist (crumb trail)
 550         (unless (stringp crumb)
 551           (dolist (entry crumb)
 552             (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
 553           (when entry-cache
 554             (remhash id entry-cache))))
 555       (puthash id (cons extra (delete old-extra trail))
 556                gnus-registry-hashtb)
 557       (setq gnus-registry-dirty t)))))
 558
 559 (defun gnus-registry-store-extra-entry (id key value)
 560   "Put a specific entry in the extras field of the registry entry for id."
 561   (let* ((extra (gnus-registry-fetch-extra id))
 562          (alist (cons (cons key value)
 563                  (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
 564     (gnus-registry-store-extra id alist)))
 565
 566 (defun gnus-registry-fetch-group (id)
 567   "Get the group of a message, based on the message ID.
 568 Returns the first place where the trail finds a group name."
 569   (when (gnus-registry-group-count id)
 570     ;; we now know the trail has at least 1 group name
 571     (let ((trail (gethash id gnus-registry-hashtb)))
 572       (dolist (crumb trail)
 573         (when (stringp crumb)
 574           (return (if gnus-registry-use-long-group-names
 575                        crumb
 576                      (gnus-group-short-name crumb))))))))
 577
 578 (defun gnus-registry-group-count (id)
 579   "Get the number of groups of a message, based on the message ID."
 580   (let ((trail (gethash id gnus-registry-hashtb)))
 581     (if (and trail (listp trail))
 582         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 583       0)))
 584
 585 (defun gnus-registry-delete-group (id group)
 586   "Delete a group for a message, based on the message ID."
 587   (when group
 588     (when id
 589       (let ((trail (gethash id gnus-registry-hashtb))
 590             (group (gnus-group-short-name group)))
 591         (puthash id (if trail
 592                         (delete group trail)
 593                       nil)
 594                  gnus-registry-hashtb))
 595       ;; now, clear the entry if there are no more groups
 596       (when gnus-registry-trim-articles-without-groups
 597         (unless (gnus-registry-group-count id)
 598           (gnus-registry-delete-id id)))
 599       (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 600
 601 (defun gnus-registry-delete-id (id)
 602   "Delete a message ID from the registry."
 603   (when (stringp id)
 604     (remhash id gnus-registry-hashtb)
 605     (maphash
 606      (lambda (key value)
 607        (when (hash-table-p value)
 608          (remhash id value)))
 609      gnus-registry-hashtb)))
 610
 611 (defun gnus-registry-add-group (id group &optional subject sender)
 612   "Add a group for a message, based on the message ID."
 613   (when group
 614     (when (and id
 615                (not (string-match "totally-fudged-out-message-id" id)))
 616       (let ((full-group group)
 617             (group (if gnus-registry-use-long-group-names
 618                        group
 619                      (gnus-group-short-name group))))
 620         (gnus-registry-delete-group id group)
 621
 622         (unless gnus-registry-use-long-group-names ;; unnecessary in this case
 623           (gnus-registry-delete-group id full-group))
 624
 625         (let ((trail (gethash id gnus-registry-hashtb)))
 626           (puthash id (if trail
 627                           (cons group trail)
 628                         (list group))
 629                    gnus-registry-hashtb)
 630
 631           (when (and (gnus-registry-track-subject-p)
 632                      subject)
 633             (gnus-registry-store-extra-entry
 634              id
 635              'subject
 636              (gnus-registry-simplify-subject subject)))
 637           (when (and (gnus-registry-track-sender-p)
 638                      sender)
 639             (gnus-registry-store-extra-entry
 640              id
 641              'sender
 642              sender))
 643
 644           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 645
 646 (defun gnus-registry-clear ()
 647   "Clear the Gnus registry."
 648   (interactive)
 649   (setq gnus-registry-alist nil)
 650   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
 651   (setq gnus-registry-dirty t))
 652
 653 ;;;###autoload
 654 (defun gnus-registry-initialize ()
 655   (interactive)
 656   (setq gnus-registry-install t)
 657   (gnus-registry-install-hooks)
 658   (gnus-registry-read))
 659
 660 ;;;###autoload
 661 (defun gnus-registry-install-hooks ()
 662   "Install the registry hooks."
 663   (interactive)
 664   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 665   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 666   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 667   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 668
 669   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 670   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 671
 672   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 673
 674 (defun gnus-registry-unload-hook ()
 675   "Uninstall the registry hooks."
 676   (interactive)
 677   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 678   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 679   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 680   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 681
 682   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 683   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 684
 685   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 686
 687 (when gnus-registry-install
 688   (gnus-registry-install-hooks)
 689   (gnus-registry-read))
 690
 691 ;; TODO: a lot of things
 692
 693 (provide 'gnus-registry)
 694
 695 ;;; gnus-registry.el ends here