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