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