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

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