lisp/gnus/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 ;; 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            (trim-length (- (length alist) gnus-registry-max-entries))
 275            (trim-length (if (natnump trim-length) trim-length 0)))
 276       (maphash
 277        (lambda (key value)
 278          (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
 279        gnus-registry-hashtb)
 280
 281       ;; we use the return value of this setq, which is the trimmed alist
 282       (setq alist
 283             (nthcdr
 284              trim-length
 285              (sort alist
 286                    (lambda (a b)
 287                      (time-less-p
 288                       (cdr (gethash (car a) timehash))
 289                       (cdr (gethash (car b) timehash))))))))))
 290
 291 (defun alist-to-hashtable (alist)
 292   "Build a hashtable from the values in ALIST."
 293   (let ((ht (make-hash-table
 294              :size 4096
 295              :test 'equal)))
 296     (mapc
 297      (lambda (kv-pair)
 298        (puthash (car kv-pair) (cdr kv-pair) ht))
 299      alist)
 300      ht))
 301
 302 (defun hashtable-to-alist (hash)
 303   "Build an alist from the values in HASH."
 304   (let ((list nil))
 305     (maphash
 306      (lambda (key value)
 307        (setq list (cons (cons key value) list)))
 308      hash)
 309     list))
 310
 311 (defun gnus-registry-action (action data-header from &optional to method)
 312   (let* ((id (mail-header-id data-header))
 313          (subject (gnus-registry-simplify-subject
 314                    (mail-header-subject data-header)))
 315          (sender (mail-header-from data-header))
 316          (from (gnus-group-guess-full-name-from-command-method from))
 317          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
 318          (to-name (if to to "the Bit Bucket"))
 319          (old-entry (gethash id gnus-registry-hashtb)))
 320     (gnus-message 5 "Registry: article %s %s from %s to %s"
 321                   id
 322                   (if method "respooling" "going")
 323                   from
 324                   to)
 325
 326     ;; All except copy will need a delete
 327     (gnus-registry-delete-group id from)
 328
 329     (when (equal 'copy action)
 330       (gnus-registry-add-group id from subject sender)) ; undo the delete
 331
 332     (gnus-registry-add-group id to subject sender)))
 333
 334 (defun gnus-registry-spool-action (id group &optional subject sender)
 335   (let ((group (gnus-group-guess-full-name-from-command-method group)))
 336     (when (and (stringp id) (string-match "\r$" id))
 337       (setq id (substring id 0 -1)))
 338     (gnus-message 5 "Registry: article %s spooled to %s"
 339                   id
 340                   group)
 341     (gnus-registry-add-group id group subject sender)))
 342
 343 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 344 ;; the cache and if a match is found, return that group.
 345 (defun gnus-registry-split-fancy-with-parent ()
 346   "Split this message into the same group as its parent.  The parent
 347 is obtained from the registry.  This function can be used as an entry
 348 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 349 this: (: gnus-registry-split-fancy-with-parent)
 350
 351 For a message to be split, it looks for the parent message in the
 352 References or In-Reply-To header and then looks in the registry to
 353 see which group that message was put in.  This group is returned.
 354
 355 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 356   (let ((refstr (or (message-fetch-field "references")
 357                     (message-fetch-field "in-reply-to")))
 358         (nnmail-split-fancy-with-parent-ignore-groups
 359          (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 360              nnmail-split-fancy-with-parent-ignore-groups
 361            (list nnmail-split-fancy-with-parent-ignore-groups)))
 362         references res)
 363     (if refstr
 364         (progn
 365           (setq references (nreverse (gnus-split-references refstr)))
 366           (mapcar (lambda (x)
 367                     (setq res (or (gnus-registry-fetch-group x) res))
 368                     (when (or (gnus-registry-grep-in-list
 369                                res
 370                                gnus-registry-unfollowed-groups)
 371                               (gnus-registry-grep-in-list
 372                                res
 373                                nnmail-split-fancy-with-parent-ignore-groups))
 374                       (setq res nil)))
 375                   references))
 376
 377       ;; else: there were no references, now try the extra tracking
 378       (let ((sender (message-fetch-field "from"))
 379             (subject (gnus-registry-simplify-subject
 380                       (message-fetch-field "subject")))
 381             (single-match t))
 382         (when (and single-match
 383                    (gnus-registry-track-sender-p)
 384                    sender)
 385           (maphash
 386            (lambda (key value)
 387              (let ((this-sender (cdr
 388                                  (gnus-registry-fetch-extra key 'sender))))
 389                (when (and single-match
 390                           this-sender
 391                           (equal sender this-sender))
 392                  ;; too many matches, bail
 393                  (unless (equal res (gnus-registry-fetch-group key))
 394                    (setq single-match nil))
 395                  (setq res (gnus-registry-fetch-group key))
 396                  (gnus-message
 397                   ;; raise level of messaging if gnus-registry-track-extra
 398                   (if gnus-registry-track-extra 5 9)
 399                   "%s (extra tracking) traced sender %s to group %s"
 400                   "gnus-registry-split-fancy-with-parent"
 401                   sender
 402                   (if res res "nil")))))
 403            gnus-registry-hashtb))
 404         (when (and single-match
 405                    (gnus-registry-track-subject-p)
 406                    subject
 407                    (< gnus-registry-minimum-subject-length (length subject)))
 408           (maphash
 409            (lambda (key value)
 410              (let ((this-subject (cdr
 411                                   (gnus-registry-fetch-extra key 'subject))))
 412                (when (and single-match
 413                           this-subject
 414                           (equal subject this-subject))
 415                  ;; too many matches, bail
 416                  (unless (equal res (gnus-registry-fetch-group key))
 417                    (setq single-match nil))
 418                  (setq res (gnus-registry-fetch-group key))
 419                  (gnus-message
 420                   ;; raise level of messaging if gnus-registry-track-extra
 421                   (if gnus-registry-track-extra 5 9)
 422                   "%s (extra tracking) traced subject %s to group %s"
 423                   "gnus-registry-split-fancy-with-parent"
 424                   subject
 425                   (if res res "nil")))))
 426            gnus-registry-hashtb))
 427         (unless single-match
 428           (gnus-message
 429            5
 430            "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
 431            refstr)
 432           (setq res nil))))
 433     (gnus-message
 434      5
 435      "gnus-registry-split-fancy-with-parent traced %s to group %s"
 436      refstr (if res res "nil"))
 437
 438     (when (and res gnus-registry-use-long-group-names)
 439       (let ((m1 (gnus-find-method-for-group res))
 440             (m2 (or gnus-command-method
 441                     (gnus-find-method-for-group gnus-newsgroup-name)))
 442             (short-res (gnus-group-short-name res)))
 443       (if (gnus-methods-equal-p m1 m2)
 444           (progn
 445             (gnus-message
 446              9
 447              "gnus-registry-split-fancy-with-parent stripped group %s to %s"
 448              res
 449              short-res)
 450             (setq res short-res))
 451         ;; else...
 452         (gnus-message
 453          5
 454          "gnus-registry-split-fancy-with-parent ignored foreign group %s"
 455          res)
 456         (setq res nil))))
 457     res))
 458
 459 (defun gnus-registry-register-message-ids ()
 460   "Register the Message-ID of every article in the group"
 461   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 462     (dolist (article gnus-newsgroup-articles)
 463       (let ((id (gnus-registry-fetch-message-id-fast article)))
 464         (unless (gnus-registry-fetch-group id)
 465           (gnus-message 9 "Registry: Registering article %d with group %s"
 466                         article gnus-newsgroup-name)
 467           (gnus-registry-add-group
 468            (gnus-registry-fetch-message-id-fast article)
 469            gnus-newsgroup-name
 470            (gnus-registry-fetch-simplified-message-subject-fast article)
 471            (gnus-registry-fetch-sender-fast article)))))))
 472
 473 (defun gnus-registry-fetch-message-id-fast (article)
 474   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 475   (if (and (numberp article)
 476            (assoc article (gnus-data-list nil)))
 477       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 478     nil))
 479
 480 (defun gnus-registry-simplify-subject (subject)
 481   (if (stringp subject)
 482       (gnus-simplify-subject subject)
 483     nil))
 484
 485 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 486   "Fetch the Subject quickly, using the internal gnus-data-list function"
 487   (if (and (numberp article)
 488            (assoc article (gnus-data-list nil)))
 489       (gnus-registry-simplify-subject
 490        (mail-header-subject (gnus-data-header
 491                              (assoc article (gnus-data-list nil)))))
 492     nil))
 493
 494 (defun gnus-registry-fetch-sender-fast (article)
 495   "Fetch the Sender quickly, using the internal gnus-data-list function"
 496   (if (and (numberp article)
 497            (assoc article (gnus-data-list nil)))
 498       (mail-header-from (gnus-data-header
 499                          (assoc article (gnus-data-list nil))))
 500     nil))
 501
 502 (defun gnus-registry-grep-in-list (word list)
 503   (when word
 504     (memq nil
 505           (mapcar 'not
 506                   (mapcar
 507                    (lambda (x)
 508                      (string-match x word))
 509                    list)))))
 510
 511 (defun gnus-registry-fetch-extra (id &optional entry)
 512   "Get the extra data of a message, based on the message ID.
 513 Returns the first place where the trail finds a nonstring."
 514   (let ((entry-cache (gethash entry gnus-registry-hashtb)))
 515     (if (and entry
 516              (hash-table-p entry-cache)
 517              (gethash id entry-cache))
 518         (gethash id entry-cache)
 519       ;; else, if there is no caching possible...
 520       (let ((trail (gethash id gnus-registry-hashtb)))
 521         (when (listp trail)
 522           (dolist (crumb trail)
 523             (unless (stringp crumb)
 524               (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
 525
 526 (defun gnus-registry-fetch-extra-entry (alist &optional entry id)
 527   "Get the extra data of a message, or a specific entry in it.
 528 Update the entry cache if needed."
 529   (if (and entry id)
 530       (let ((entry-cache (gethash entry gnus-registry-hashtb))
 531             entree)
 532         (when gnus-registry-entry-caching
 533           ;; create the hash table
 534           (unless (hash-table-p entry-cache)
 535             (setq entry-cache (make-hash-table
 536                                :size 4096
 537                                :test 'equal))
 538             (puthash entry entry-cache gnus-registry-hashtb))
 539
 540           ;; get the entree from the hash table or from the alist
 541           (setq entree (gethash id entry-cache)))
 542
 543         (unless entree
 544           (setq entree (assq entry alist))
 545           (when gnus-registry-entry-caching
 546             (puthash id entree entry-cache)))
 547         entree)
 548     alist))
 549
 550 (defun gnus-registry-store-extra (id extra)
 551   "Store the extra data of a message, based on the message ID.
 552 The message must have at least one group name."
 553   (when (gnus-registry-group-count id)
 554     ;; we now know the trail has at least 1 group name, so it's not empty
 555     (let ((trail (gethash id gnus-registry-hashtb))
 556           (old-extra (gnus-registry-fetch-extra id))
 557           entry-cache)
 558       (dolist (crumb trail)
 559         (unless (stringp crumb)
 560           (dolist (entry crumb)
 561             (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
 562           (when entry-cache
 563             (remhash id entry-cache))))
 564       (puthash id (cons extra (delete old-extra trail))
 565                gnus-registry-hashtb)
 566       (setq gnus-registry-dirty t)))))
 567
 568 (defun gnus-registry-store-extra-entry (id key value)
 569   "Put a specific entry in the extras field of the registry entry for id."
 570   (let* ((extra (gnus-registry-fetch-extra id))
 571          (alist (cons (cons key value)
 572                  (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
 573     (gnus-registry-store-extra id alist)))
 574
 575 (defun gnus-registry-fetch-group (id)
 576   "Get the group of a message, based on the message ID.
 577 Returns the first place where the trail finds a group name."
 578   (when (gnus-registry-group-count id)
 579     ;; we now know the trail has at least 1 group name
 580     (let ((trail (gethash id gnus-registry-hashtb)))
 581       (dolist (crumb trail)
 582         (when (stringp crumb)
 583           (return (if gnus-registry-use-long-group-names
 584                        crumb
 585                      (gnus-group-short-name crumb))))))))
 586
 587 (defun gnus-registry-group-count (id)
 588   "Get the number of groups of a message, based on the message ID."
 589   (let ((trail (gethash id gnus-registry-hashtb)))
 590     (if (and trail (listp trail))
 591         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 592       0)))
 593
 594 (defun gnus-registry-delete-group (id group)
 595   "Delete a group for a message, based on the message ID."
 596   (when group
 597     (when id
 598       (let ((trail (gethash id gnus-registry-hashtb))
 599             (group (gnus-group-short-name group)))
 600         (puthash id (if trail
 601                         (delete group trail)
 602                       nil)
 603                  gnus-registry-hashtb))
 604       ;; now, clear the entry if there are no more groups
 605       (when gnus-registry-trim-articles-without-groups
 606         (unless (gnus-registry-group-count id)
 607           (gnus-registry-delete-id id)))
 608       (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 609
 610 (defun gnus-registry-delete-id (id)
 611   "Delete a message ID from the registry."
 612   (when (stringp id)
 613     (remhash id gnus-registry-hashtb)
 614     (maphash
 615      (lambda (key value)
 616        (when (hash-table-p value)
 617          (remhash id value)))
 618      gnus-registry-hashtb)))
 619
 620 (defun gnus-registry-add-group (id group &optional subject sender)
 621   "Add a group for a message, based on the message ID."
 622   (when group
 623     (when (and id
 624                (not (string-match "totally-fudged-out-message-id" id)))
 625       (let ((full-group group)
 626             (group (if gnus-registry-use-long-group-names
 627                        group
 628                      (gnus-group-short-name group))))
 629         (gnus-registry-delete-group id group)
 630
 631         (unless gnus-registry-use-long-group-names ;; unnecessary in this case
 632           (gnus-registry-delete-group id full-group))
 633
 634         (let ((trail (gethash id gnus-registry-hashtb)))
 635           (puthash id (if trail
 636                           (cons group trail)
 637                         (list group))
 638                    gnus-registry-hashtb)
 639
 640           (when (and (gnus-registry-track-subject-p)
 641                      subject)
 642             (gnus-registry-store-extra-entry
 643              id
 644              'subject
 645              (gnus-registry-simplify-subject subject)))
 646           (when (and (gnus-registry-track-sender-p)
 647                      sender)
 648             (gnus-registry-store-extra-entry
 649              id
 650              'sender
 651              sender))
 652
 653           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 654
 655 (defun gnus-registry-clear ()
 656   "Clear the Gnus registry."
 657   (interactive)
 658   (setq gnus-registry-alist nil)
 659   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
 660   (setq gnus-registry-dirty t))
 661
 662 ;;;###autoload
 663 (defun gnus-registry-initialize ()
 664   (interactive)
 665   (setq gnus-registry-install t)
 666   (gnus-registry-install-hooks)
 667   (gnus-registry-read))
 668
 669 ;;;###autoload
 670 (defun gnus-registry-install-hooks ()
 671   "Install the registry hooks."
 672   (interactive)
 673   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 674   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 675   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 676   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 677
 678   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 679   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 680
 681   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 682
 683 (defun gnus-registry-unload-hook ()
 684   "Uninstall the registry hooks."
 685   (interactive)
 686   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 687   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 688   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 689   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 690
 691   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 692   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 693
 694   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 695
 696 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
 697
 698 (when gnus-registry-install
 699   (gnus-registry-install-hooks)
 700   (gnus-registry-read))
 701
 702 ;; TODO: a lot of things
 703
 704 (provide 'gnus-registry)
 705
 706 ;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
 707 ;;; gnus-registry.el ends here