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