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

   1 ;;; gnus-registry.el --- article registry for Gnus
   2
   3 ;; Copyright (C) 2002-2012  Free Software Foundation, Inc.
   4
   5 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: news registry
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This is the gnus-registry.el package, which works with all
  26 ;; Gnus backends, not just nnmail.  The major issue is that it
  27 ;; doesn't go across backends, so for instance if an article is in
  28 ;; nnml:sys and you see a reference to it in nnimap splitting, the
  29 ;; article will end up in nnimap:sys
  30
  31 ;; gnus-registry.el intercepts article respooling, moving, deleting,
  32 ;; and copying for all backends.  If it doesn't work correctly for
  33 ;; you, submit a bug report and I'll be glad to fix it.  It needs
  34 ;; better documentation in the manual (also on my to-do list).
  35
  36 ;; If you want to track recipients (and you should to make the
  37 ;; gnus-registry splitting work better), you need the To and Cc
  38 ;; headers collected by Gnus.  Note that in more recent Gnus versions
  39 ;; this is already the case: look at `gnus-extra-headers' to be sure.
  40
  41 ;; ;;; you may also want Gcc Newsgroups Keywords X-Face
  42 ;; (add-to-list 'gnus-extra-headers 'To)
  43 ;; (add-to-list 'gnus-extra-headers 'Cc)
  44 ;; (setq nnmail-extra-headers gnus-extra-headers)
  45
  46 ;; Put this in your startup file (~/.gnus.el for instance) or use Customize:
  47
  48 ;; (setq gnus-registry-max-entries 2500
  49 ;;       gnus-registry-track-extra '(sender subject recipient))
  50
  51 ;; (gnus-registry-initialize)
  52
  53 ;; Then use this in your fancy-split:
  54
  55 ;; (: gnus-registry-split-fancy-with-parent)
  56
  57 ;; You should also consider using the nnregistry backend to look up
  58 ;; articles.  See the Gnus manual for more information.
  59
  60 ;; Finally, you can put %uM in your summary line format to show the
  61 ;; registry marks if you do this:
  62
  63 ;; show the marks as single characters (see the :char property in
  64 ;; `gnus-registry-marks'):
  65 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
  66
  67 ;; show the marks by name (see `gnus-registry-marks'):
  68 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
  69
  70 ;; TODO:
  71
  72 ;; - get the correct group on spool actions
  73
  74 ;; - articles that are spooled to a different backend should be moved
  75 ;;   after splitting
  76
  77 ;;; Code:
  78
  79 (eval-when-compile (require 'cl))
  80
  81 (eval-when-compile
  82   (when (null (ignore-errors (require 'ert)))
  83     (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
  84
  85 (ignore-errors
  86   (require 'ert))
  87 (require 'gnus)
  88 (require 'gnus-int)
  89 (require 'gnus-sum)
  90 (require 'gnus-art)
  91 (require 'gnus-util)
  92 (require 'nnmail)
  93 (require 'easymenu)
  94 (require 'registry)
  95
  96 (defvar gnus-adaptive-word-syntax-table)
  97
  98 (defvar gnus-registry-dirty t
  99  "Boolean set to t when the registry is modified")
 100
 101 (defgroup gnus-registry nil
 102   "The Gnus registry."
 103   :version "22.1"
 104   :group 'gnus)
 105
 106 (defvar gnus-registry-marks
 107   '((Important
 108      :char ?i
 109      :image "summary_important")
 110     (Work
 111      :char ?w
 112      :image "summary_work")
 113     (Personal
 114      :char ?p
 115      :image "summary_personal")
 116     (To-Do
 117      :char ?t
 118      :image "summary_todo")
 119     (Later
 120      :char ?l
 121      :image "summary_later"))
 122
 123   "List of registry marks and their options.
 124
 125 `gnus-registry-mark-article' will offer symbols from this list
 126 for completion.
 127
 128 Each entry must have a character to be useful for summary mode
 129 line display and for keyboard shortcuts.
 130
 131 Each entry must have an image string to be useful for visual
 132 display.")
 133
 134 (defcustom gnus-registry-default-mark 'To-Do
 135   "The default mark.  Should be a valid key for `gnus-registry-marks'."
 136   :group 'gnus-registry
 137   :type 'symbol)
 138
 139 (defcustom gnus-registry-unfollowed-addresses
 140   (list (regexp-quote user-mail-address))
 141   "List of addresses that gnus-registry-split-fancy-with-parent won't trace.
 142 The addresses are matched, they don't have to be fully qualified.
 143 In the messages, these addresses can be the sender or the
 144 recipients."
 145   :group 'gnus-registry
 146   :type '(repeat regexp))
 147
 148 (defcustom gnus-registry-unfollowed-groups
 149   '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive")
 150   "List of groups that gnus-registry-split-fancy-with-parent won't return.
 151 The group names are matched, they don't have to be fully
 152 qualified.  This parameter tells the Gnus registry 'never split a
 153 message into a group that matches one of these, regardless of
 154 references.'
 155
 156 nnmairix groups are specifically excluded because they are ephemeral."
 157   :group 'gnus-registry
 158   :type '(repeat regexp))
 159
 160 (defcustom gnus-registry-install 'ask
 161   "Whether the registry should be installed."
 162   :group 'gnus-registry
 163   :type '(choice (const :tag "Never Install" nil)
 164                  (const :tag "Always Install" t)
 165                  (const :tag "Ask Me" ask)))
 166
 167 (defvar gnus-registry-enabled nil)
 168
 169 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
 170
 171 (defvar gnus-registry-misc-menus nil)   ; ugly way to keep the menus
 172
 173 (make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
 174 (make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
 175 (make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
 176 (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
 177 (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
 178
 179 (defcustom gnus-registry-track-extra '(subject sender recipient)
 180   "Whether the registry should track extra data about a message.
 181 The subject, recipients (To: and Cc:), and Sender (From:) headers
 182 are tracked this way by default."
 183   :group 'gnus-registry
 184   :type
 185   '(set :tag "Tracking choices"
 186     (const :tag "Track by subject (Subject: header)" subject)
 187     (const :tag "Track by recipient (To: and Cc: headers)" recipient)
 188     (const :tag "Track by sender (From: header)"  sender)))
 189
 190 (defcustom gnus-registry-split-strategy nil
 191   "The splitting strategy applied to the keys in `gnus-registry-track-extra'.
 192
 193 Given a set of unique found groups G and counts for each element
 194 of G, and a key K (typically 'sender or 'subject):
 195
 196 When nil, if G has only one element, use it.  Otherwise give up.
 197 This is the fastest but also least useful strategy.
 198
 199 When 'majority, use the majority by count.  So if there is a
 200 group with the most articles counted by K, use that.  Ties are
 201 resolved in no particular order, simply the first one found wins.
 202 This is the slowest strategy but also the most accurate one.
 203
 204 When 'first, the first element of G wins.  This is fast and
 205 should be OK if your senders and subjects don't \"bleed\" across
 206 groups."
 207   :group 'gnus-registry
 208   :type
 209   '(choice :tag "Splitting strategy"
 210            (const :tag "Only use single choices, discard multiple matches" nil)
 211            (const :tag "Majority of matches wins" majority)
 212            (const :tag "First found wins"  first)))
 213
 214 (defcustom gnus-registry-minimum-subject-length 5
 215   "The minimum length of a subject before it's considered trackable."
 216   :group 'gnus-registry
 217   :type 'integer)
 218
 219 (defcustom gnus-registry-extra-entries-precious '(mark)
 220   "What extra keys are precious, meaning entries with them won't get pruned.
 221 By default, 'mark is included, so articles with marks are
 222 considered precious.
 223
 224 Before you save the Gnus registry, it's pruned.  Any entries with
 225 keys in this list will not be pruned.  All other entries go to
 226 the Bit Bucket."
 227   :group 'gnus-registry
 228   :type '(repeat symbol))
 229
 230 (defcustom gnus-registry-cache-file
 231   (nnheader-concat
 232    (or gnus-dribble-directory gnus-home-directory "~/")
 233    ".gnus.registry.eioio")
 234   "File where the Gnus registry will be stored."
 235   :group 'gnus-registry
 236   :type 'file)
 237
 238 (defcustom gnus-registry-max-entries nil
 239   "Maximum number of entries in the registry, nil for unlimited."
 240   :group 'gnus-registry
 241   :type '(radio (const :format "Unlimited " nil)
 242                 (integer :format "Maximum number: %v")))
 243
 244 (defcustom gnus-registry-max-pruned-entries nil
 245   "Maximum number of pruned entries in the registry, nil for unlimited."
 246   :group 'gnus-registry
 247   :type '(radio (const :format "Unlimited " nil)
 248                 (integer :format "Maximum number: %v")))
 249
 250 (defun gnus-registry-fixup-registry (db)
 251   (when db
 252     (let ((old (oref db :tracked)))
 253       (oset db :precious
 254             (append gnus-registry-extra-entries-precious
 255                     '()))
 256       (oset db :max-hard
 257             (or gnus-registry-max-entries
 258                 most-positive-fixnum))
 259       (oset db :prune-factor
 260             0.1)
 261       (oset db :max-soft
 262             (or gnus-registry-max-pruned-entries
 263                 most-positive-fixnum))
 264       (oset db :tracked
 265             (append gnus-registry-track-extra
 266                     '(mark group keyword)))
 267       (when (not (equal old (oref db :tracked)))
 268         (gnus-message 9 "Reindexing the Gnus registry (tracked change)")
 269         (registry-reindex db))))
 270   db)
 271
 272 (defun gnus-registry-make-db (&optional file)
 273   (interactive "fGnus registry persistence file: \n")
 274   (gnus-registry-fixup-registry
 275    (registry-db
 276     "Gnus Registry"
 277     :file (or file gnus-registry-cache-file)
 278     ;; these parameters are set in `gnus-registry-fixup-registry'
 279     :max-hard most-positive-fixnum
 280     :max-soft most-positive-fixnum
 281     :precious nil
 282     :tracked nil)))
 283
 284 (defvar gnus-registry-db (gnus-registry-make-db)
 285   "*The article registry by Message ID.  See `registry-db'")
 286
 287 ;; top-level registry data management
 288 (defun gnus-registry-remake-db (&optional forsure)
 289   "Remake the registry database after customization.
 290 This is not required after changing `gnus-registry-cache-file'."
 291   (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
 292   (when forsure
 293     (gnus-message 4 "Remaking the Gnus registry")
 294     (setq gnus-registry-db (gnus-registry-make-db))))
 295
 296 (defun gnus-registry-read ()
 297   "Read the registry cache file."
 298   (interactive)
 299   (let ((file gnus-registry-cache-file))
 300     (condition-case nil
 301         (progn
 302           (gnus-message 5 "Reading Gnus registry from %s..." file)
 303           (setq gnus-registry-db (gnus-registry-fixup-registry
 304                                   (eieio-persistent-read file)))
 305           (gnus-message 5 "Reading Gnus registry from %s...done" file))
 306       (error
 307        (gnus-message
 308         1
 309         "The Gnus registry could not be loaded from %s, creating a new one"
 310         file)
 311        (gnus-registry-remake-db t)))))
 312
 313 (defun gnus-registry-save (&optional file db)
 314   "Save the registry cache file."
 315   (interactive)
 316   (let ((file (or file gnus-registry-cache-file))
 317         (db (or db gnus-registry-db)))
 318     (gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
 319                   (registry-size db) file)
 320     (registry-prune db)
 321     ;; TODO: call (gnus-string-remove-all-properties v) on all elements?
 322     (eieio-persistent-save db file)
 323     (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
 324                   (registry-size db) file)))
 325
 326 (defun gnus-registry-remove-ignored ()
 327   (interactive)
 328   (let* ((db gnus-registry-db)
 329          (grouphashtb (registry-lookup-secondary db 'group))
 330          (old-size (registry-size db)))
 331     (registry-reindex db)
 332     (loop for k being the hash-keys of grouphashtb
 333           using (hash-values v)
 334           when (gnus-registry-ignore-group-p k)
 335           do (registry-delete db v nil))
 336     (registry-reindex db)
 337     (gnus-message 4 "Removed %d ignored entries from the Gnus registry"
 338                   (- old-size (registry-size db)))))
 339
 340 ;; article move/copy/spool/delete actions
 341 (defun gnus-registry-action (action data-header from &optional to method)
 342   (let* ((id (mail-header-id data-header))
 343          (subject (mail-header-subject data-header))
 344          (extra (mail-header-extra data-header))
 345          (recipients (gnus-registry-sort-addresses
 346                       (or (cdr-safe (assq 'Cc extra)) "")
 347                       (or (cdr-safe (assq 'To extra)) "")))
 348          (sender (nth 0 (gnus-registry-extract-addresses
 349                          (mail-header-from data-header))))
 350          (from (gnus-group-guess-full-name-from-command-method from))
 351          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
 352          (to-name (if to to "the Bit Bucket")))
 353     (gnus-message 7 "Gnus registry: article %s %s from %s to %s"
 354                   id (if method "respooling" "going") from to)
 355
 356     (gnus-registry-handle-action
 357      id
 358      ;; unless copying, remove the old "from" group
 359      (if (not (equal 'copy action)) from nil)
 360      to subject sender recipients)))
 361
 362 (defun gnus-registry-spool-action (id group &optional subject sender recipients)
 363   (let ((to (gnus-group-guess-full-name-from-command-method group))
 364         (recipients (or recipients
 365                         (gnus-registry-sort-addresses
 366                          (or (message-fetch-field "cc") "")
 367                          (or (message-fetch-field "to") ""))))
 368         (subject (or subject (message-fetch-field "subject")))
 369         (sender (or sender (message-fetch-field "from"))))
 370     (when (and (stringp id) (string-match "\r$" id))
 371       (setq id (substring id 0 -1)))
 372     (gnus-message 7 "Gnus registry: article %s spooled to %s"
 373                   id
 374                   to)
 375     (gnus-registry-handle-action id nil to subject sender recipients)))
 376
 377 (defun gnus-registry-handle-action (id from to subject sender
 378                                        &optional recipients)
 379   (gnus-message
 380    10
 381    "gnus-registry-handle-action %S" (list id from to subject sender recipients))
 382   (let ((db gnus-registry-db)
 383         ;; if the group is ignored, set the destination to nil (same as delete)
 384         (to (if (gnus-registry-ignore-group-p to) nil to))
 385         ;; safe if not found
 386         (entry (gnus-registry-get-or-make-entry id))
 387         (subject (gnus-string-remove-all-properties
 388                   (gnus-registry-simplify-subject subject)))
 389         (sender (gnus-string-remove-all-properties sender)))
 390
 391     ;; this could be done by calling `gnus-registry-set-id-key'
 392     ;; several times but it's better to bunch the transactions
 393     ;; together
 394
 395     (registry-delete db (list id) nil)
 396     (when from
 397       (setq entry (cons (delete from (assoc 'group entry))
 398                         (assq-delete-all 'group entry))))
 399
 400     (dolist (kv `((group ,to)
 401                   (sender ,sender)
 402                   (recipient ,@recipients)
 403                   (subject ,subject)))
 404       (when (second kv)
 405         (let ((new (or (assq (first kv) entry)
 406                        (list (first kv)))))
 407           (dolist (toadd (cdr kv))
 408             (add-to-list 'new toadd t))
 409           (setq entry (cons new
 410                             (assq-delete-all (first kv) entry))))))
 411     (gnus-message 10 "Gnus registry: new entry for %s is %S"
 412                   id
 413                   entry)
 414     (gnus-registry-insert db id entry)))
 415
 416 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 417 ;; the cache and if a match is found, return that group.
 418 (defun gnus-registry-split-fancy-with-parent ()
 419   "Split this message into the same group as its parent.  The parent
 420 is obtained from the registry.  This function can be used as an entry
 421 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 422 this: (: gnus-registry-split-fancy-with-parent)
 423
 424 This function tracks ALL backends, unlike
 425 `nnmail-split-fancy-with-parent' which tracks only nnmail
 426 messages.
 427
 428 For a message to be split, it looks for the parent message in the
 429 References or In-Reply-To header and then looks in the registry
 430 to see which group that message was put in.  This group is
 431 returned, unless `gnus-registry-follow-group-p' return nil for
 432 that group.
 433
 434 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 435   (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
 436          (reply-to (message-fetch-field "in-reply-to"))      ; may be nil
 437          ;; now, if reply-to is valid, append it to the References
 438          (refstr (if reply-to
 439                      (concat refstr " " reply-to)
 440                    refstr))
 441          (references (and refstr (gnus-extract-references refstr)))
 442          ;; these may not be used, but the code is cleaner having them up here
 443          (sender (gnus-string-remove-all-properties
 444                   (message-fetch-field "from")))
 445          (recipients (gnus-registry-sort-addresses
 446                       (or (message-fetch-field "cc") "")
 447                       (or (message-fetch-field "to") "")))
 448          (subject (gnus-string-remove-all-properties
 449                    (gnus-registry-simplify-subject
 450                     (message-fetch-field "subject"))))
 451
 452          (nnmail-split-fancy-with-parent-ignore-groups
 453           (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 454               nnmail-split-fancy-with-parent-ignore-groups
 455             (list nnmail-split-fancy-with-parent-ignore-groups))))
 456     (gnus-registry--split-fancy-with-parent-internal
 457      :references references
 458      :refstr refstr
 459      :sender sender
 460      :recipients recipients
 461      :subject subject
 462      :log-agent "Gnus registry fancy splitting with parent")))
 463
 464 (defun* gnus-registry--split-fancy-with-parent-internal
 465     (&rest spec
 466            &key references refstr sender subject recipients log-agent
 467            &allow-other-keys)
 468   (gnus-message
 469    10
 470    "gnus-registry--split-fancy-with-parent-internal %S" spec)
 471   (let ((db gnus-registry-db)
 472         found)
 473     ;; this is a big chain of statements.  it uses
 474     ;; gnus-registry-post-process-groups to filter the results after
 475     ;; every step.
 476     ;; the references string must be valid and parse to valid references
 477     (when references
 478       (gnus-message
 479        9
 480        "%s is tracing references %s"
 481        log-agent refstr)
 482       (dolist (reference (nreverse references))
 483         (gnus-message 9 "%s is looking up %s" log-agent reference)
 484         (loop for group in (gnus-registry-get-id-key reference 'group)
 485               when (gnus-registry-follow-group-p group)
 486               do
 487               (progn
 488                 (gnus-message 7 "%s traced %s to %s" log-agent reference group)
 489                 (push group found))))
 490       ;; filter the found groups and return them
 491       ;; the found groups are the full groups
 492       (setq found (gnus-registry-post-process-groups
 493                    "references" refstr found)))
 494
 495      ;; else: there were no matches, now try the extra tracking by subject
 496      (when (and (null found)
 497                 (memq 'subject gnus-registry-track-extra)
 498                 subject
 499                 (< gnus-registry-minimum-subject-length (length subject)))
 500        (let ((groups (apply
 501                       'append
 502                       (mapcar
 503                        (lambda (reference)
 504                          (gnus-registry-get-id-key reference 'group))
 505                        (registry-lookup-secondary-value db 'subject subject)))))
 506          (setq found
 507                (loop for group in groups
 508                      when (gnus-registry-follow-group-p group)
 509                      do (gnus-message
 510                          ;; warn more if gnus-registry-track-extra
 511                          (if gnus-registry-track-extra 7 9)
 512                          "%s (extra tracking) traced subject '%s' to %s"
 513                          log-agent subject group)
 514                     and collect group))
 515          ;; filter the found groups and return them
 516          ;; the found groups are NOT the full groups
 517          (setq found (gnus-registry-post-process-groups
 518                       "subject" subject found))))
 519
 520      ;; else: there were no matches, try the extra tracking by sender
 521      (when (and (null found)
 522                 (memq 'sender gnus-registry-track-extra)
 523                 sender
 524                 (not (gnus-grep-in-list
 525                       sender
 526                       gnus-registry-unfollowed-addresses)))
 527        (let ((groups (apply
 528                       'append
 529                       (mapcar
 530                        (lambda (reference)
 531                          (gnus-registry-get-id-key reference 'group))
 532                        (registry-lookup-secondary-value db 'sender sender)))))
 533          (setq found
 534                (loop for group in groups
 535                      when (gnus-registry-follow-group-p group)
 536                      do (gnus-message
 537                          ;; warn more if gnus-registry-track-extra
 538                          (if gnus-registry-track-extra 7 9)
 539                          "%s (extra tracking) traced sender '%s' to %s"
 540                          log-agent sender group)
 541                      and collect group)))
 542
 543        ;; filter the found groups and return them
 544        ;; the found groups are NOT the full groups
 545        (setq found (gnus-registry-post-process-groups
 546                     "sender" sender found)))
 547
 548      ;; else: there were no matches, try the extra tracking by recipient
 549      (when (and (null found)
 550                 (memq 'recipient gnus-registry-track-extra)
 551                 recipients)
 552        (dolist (recp recipients)
 553          (when (and (null found)
 554                     (not (gnus-grep-in-list
 555                           recp
 556                           gnus-registry-unfollowed-addresses)))
 557            (let ((groups (apply 'append
 558                                 (mapcar
 559                                  (lambda (reference)
 560                                    (gnus-registry-get-id-key reference 'group))
 561                                  (registry-lookup-secondary-value
 562                                   db 'recipient recp)))))
 563              (setq found
 564                    (loop for group in groups
 565                          when (gnus-registry-follow-group-p group)
 566                          do (gnus-message
 567                              ;; warn more if gnus-registry-track-extra
 568                              (if gnus-registry-track-extra 7 9)
 569                              "%s (extra tracking) traced recipient '%s' to %s"
 570                              log-agent recp group)
 571                         and collect group)))))
 572
 573        ;; filter the found groups and return them
 574        ;; the found groups are NOT the full groups
 575        (setq found (gnus-registry-post-process-groups
 576                     "recipients" (mapconcat 'identity recipients ", ") found)))
 577
 578      ;; after the (cond) we extract the actual value safely
 579      (car-safe found)))
 580
 581 (defun gnus-registry-post-process-groups (mode key groups)
 582   "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
 583
 584 MODE can be 'subject' or 'sender' for example.  The KEY is the
 585 value by which MODE was searched.
 586
 587 Transforms each group name to the equivalent short name.
 588
 589 Checks if the current Gnus method (from `gnus-command-method' or
 590 from `gnus-newsgroup-name') is the same as the group's method.
 591 Foreign methods are not supported so they are rejected.
 592
 593 Reduces the list to a single group, or complains if that's not
 594 possible.  Uses `gnus-registry-split-strategy'."
 595   (let ((log-agent "gnus-registry-post-process-group")
 596         (desc (format "%d groups" (length groups)))
 597         out chosen)
 598     ;; the strategy can be nil, in which case chosen is nil
 599     (setq chosen
 600           (case gnus-registry-split-strategy
 601             ;; default, take only one-element lists into chosen
 602             ((nil)
 603              (and (= (length groups) 1)
 604                   (car-safe groups)))
 605
 606             ((first)
 607              (car-safe groups))
 608
 609             ((majority)
 610              (let ((freq (make-hash-table
 611                           :size 256
 612                           :test 'equal)))
 613                (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
 614                               (puthash x (1+ (gethash x freq 0)) freq)))
 615                      groups)
 616                (setq desc (format "%d groups, %d unique"
 617                                   (length groups)
 618                                   (hash-table-count freq)))
 619                (car-safe
 620                 (sort groups
 621                       (lambda (a b)
 622                         (> (gethash (gnus-group-short-name a) freq 0)
 623                            (gethash (gnus-group-short-name b) freq 0)))))))))
 624
 625     (if chosen
 626         (gnus-message
 627          9
 628          "%s: strategy %s on %s produced %s"
 629          log-agent gnus-registry-split-strategy desc chosen)
 630       (gnus-message
 631        9
 632        "%s: strategy %s on %s did not produce an answer"
 633        log-agent
 634        (or gnus-registry-split-strategy "default")
 635        desc))
 636
 637     (setq groups (and chosen (list chosen)))
 638
 639     (dolist (group groups)
 640       (let ((m1 (gnus-find-method-for-group group))
 641             (m2 (or gnus-command-method
 642                     (gnus-find-method-for-group gnus-newsgroup-name)))
 643             (short-name (gnus-group-short-name group)))
 644         (if (gnus-methods-equal-p m1 m2)
 645             (progn
 646               ;; this is REALLY just for debugging
 647               (when (not (equal group short-name))
 648                 (gnus-message
 649                  10
 650                  "%s: stripped group %s to %s"
 651                  log-agent group short-name))
 652               (add-to-list 'out short-name))
 653           ;; else...
 654           (gnus-message
 655            7
 656            "%s: ignored foreign group %s"
 657            log-agent group))))
 658
 659     (setq out (delq nil out))
 660
 661     (cond
 662      ((= (length out) 1) out)
 663      ((null out)
 664       (gnus-message
 665        5
 666        "%s: no matches for %s '%s'."
 667        log-agent mode key)
 668       nil)
 669      (t (gnus-message
 670          5
 671          "%s: too many extra matches (%s) for %s '%s'.  Returning none."
 672          log-agent out mode key)
 673         nil))))
 674
 675 (defun gnus-registry-follow-group-p (group)
 676   "Determines if a group name should be followed.
 677 Consults `gnus-registry-unfollowed-groups' and
 678 `nnmail-split-fancy-with-parent-ignore-groups'."
 679   (and group
 680        (not (or (gnus-grep-in-list
 681                  group
 682                  gnus-registry-unfollowed-groups)
 683                 (gnus-grep-in-list
 684                  group
 685                  nnmail-split-fancy-with-parent-ignore-groups)))))
 686
 687 ;; note that gnus-registry-ignored-groups is defined in gnus.el as a
 688 ;; group/topic parameter and an associated variable!
 689
 690 ;; we do special logic for ignoring to accept regular expressions and
 691 ;; nnmail-split-fancy-with-parent-ignore-groups as well
 692 (defun gnus-registry-ignore-group-p (group)
 693   "Determines if a group name should be ignored.
 694 Consults `gnus-registry-ignored-groups' and
 695 `nnmail-split-fancy-with-parent-ignore-groups'."
 696   (and group
 697        (or (gnus-grep-in-list
 698             group
 699             (delq nil (mapcar (lambda (g)
 700                                 (cond
 701                                  ((stringp g) g)
 702                                  ((and (listp g) (nth 1 g))
 703                                   (nth 0 g))
 704                                  (t nil))) gnus-registry-ignored-groups)))
 705            ;; only use `gnus-parameter-registry-ignore' if
 706            ;; `gnus-registry-ignored-groups' is a list of lists
 707            ;; (it can be a list of regexes)
 708            (and (listp (nth 0 gnus-registry-ignored-groups))
 709                 (get-buffer "*Group*")  ; in automatic tests this is false
 710                 (gnus-parameter-registry-ignore group))
 711            (gnus-grep-in-list
 712             group
 713             nnmail-split-fancy-with-parent-ignore-groups))))
 714
 715 (defun gnus-registry-wash-for-keywords (&optional force)
 716   "Get the keywords of the current article.
 717 Overrides existing keywords with FORCE set non-nil."
 718   (interactive)
 719   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
 720         word words)
 721     (if (or (not (gnus-registry-get-id-key id 'keyword))
 722             force)
 723         (with-current-buffer gnus-article-buffer
 724           (article-goto-body)
 725           (save-window-excursion
 726             (save-restriction
 727               (narrow-to-region (point) (point-max))
 728               (with-syntax-table gnus-adaptive-word-syntax-table
 729                 (while (re-search-forward "\\b\\w+\\b" nil t)
 730                   (setq word (gnus-string-remove-all-properties
 731                               (downcase (buffer-substring
 732                                          (match-beginning 0) (match-end 0)))))
 733                   (if (> (length word) 2)
 734                       (push word words))))))
 735           (gnus-registry-set-id-key id 'keyword words)))))
 736
 737 (defun gnus-registry-keywords ()
 738   (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
 739     (when table (maphash (lambda (k v) k) table))))
 740
 741 (defun gnus-registry-find-keywords (keyword)
 742   (interactive (list
 743                 (completing-read "Keyword: " (gnus-registry-keywords) nil t)))
 744   (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
 745
 746 (defun gnus-registry-register-message-ids ()
 747   "Register the Message-ID of every article in the group"
 748   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 749     (dolist (article gnus-newsgroup-articles)
 750       (let* ((id (gnus-registry-fetch-message-id-fast article))
 751              (groups (gnus-registry-get-id-key id 'group)))
 752         (unless (member gnus-newsgroup-name groups)
 753           (gnus-message 9 "Registry: Registering article %d with group %s"
 754                         article gnus-newsgroup-name)
 755           (gnus-registry-handle-action id nil gnus-newsgroup-name
 756            (gnus-registry-fetch-simplified-message-subject-fast article)
 757            (gnus-registry-fetch-sender-fast article)
 758            (gnus-registry-fetch-recipients-fast article)))))))
 759
 760 ;; message field fetchers
 761 (defun gnus-registry-fetch-message-id-fast (article)
 762   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 763   (if (and (numberp article)
 764            (assoc article (gnus-data-list nil)))
 765       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 766     nil))
 767
 768 (defun gnus-registry-extract-addresses (text)
 769   "Extract all the addresses in a normalized way from TEXT.
 770 Returns an unsorted list of strings in the name <address> format.
 771 Addresses without a name will say \"noname\"."
 772   (mapcar (lambda (add)
 773             (gnus-string-remove-all-properties
 774              (let* ((name (or (nth 0 add) "noname"))
 775                     (addr (nth 1 add))
 776                     (addr (if (bufferp addr)
 777                               (with-current-buffer addr
 778                                 (buffer-string))
 779                             addr)))
 780                (format "%s <%s>" name addr))))
 781           (mail-extract-address-components text t)))
 782
 783 (defun gnus-registry-sort-addresses (&rest addresses)
 784   "Return a normalized and sorted list of ADDRESSES."
 785   (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
 786         'string-lessp))
 787
 788 (defun gnus-registry-simplify-subject (subject)
 789   (if (stringp subject)
 790       (gnus-simplify-subject subject)
 791     nil))
 792
 793 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 794   "Fetch the Subject quickly, using the internal gnus-data-list function"
 795   (if (and (numberp article)
 796            (assoc article (gnus-data-list nil)))
 797       (gnus-string-remove-all-properties
 798        (gnus-registry-simplify-subject
 799         (mail-header-subject (gnus-data-header
 800                               (assoc article (gnus-data-list nil))))))
 801     nil))
 802
 803 (defun gnus-registry-fetch-sender-fast (article)
 804   (gnus-registry-fetch-header-fast "from" article))
 805
 806 (defun gnus-registry-fetch-recipients-fast (article)
 807   (gnus-registry-sort-addresses
 808    (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
 809    (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
 810
 811 (defun gnus-registry-fetch-header-fast (article header)
 812   "Fetch the HEADER quickly, using the internal gnus-data-list function"
 813   (if (and (numberp article)
 814            (assoc article (gnus-data-list nil)))
 815       (gnus-string-remove-all-properties
 816        (cdr (assq header (gnus-data-header
 817                           (assoc article (gnus-data-list nil))))))
 818     nil))
 819
 820 ;; registry marks glue
 821 (defun gnus-registry-do-marks (type function)
 822   "For each known mark, call FUNCTION for each cell of type TYPE.
 823
 824 FUNCTION should take two parameters, a mark symbol and the cell value."
 825   (dolist (mark-info gnus-registry-marks)
 826     (let* ((mark (car-safe mark-info))
 827            (data (cdr-safe mark-info))
 828            (cell-data (plist-get data type)))
 829       (when cell-data
 830         (funcall function mark cell-data)))))
 831
 832 ;;; this is ugly code, but I don't know how to do it better
 833 (defun gnus-registry-install-shortcuts ()
 834   "Install the keyboard shortcuts and menus for the registry.
 835 Uses `gnus-registry-marks' to find what shortcuts to install."
 836   (let (keys-plist)
 837     (setq gnus-registry-misc-menus nil)
 838     (gnus-registry-do-marks
 839      :char
 840      (lambda (mark data)
 841        (let ((function-format
 842               (format "gnus-registry-%%s-article-%s-mark" mark)))
 843
 844 ;;; The following generates these functions:
 845 ;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
 846 ;;;   "Apply the Important mark to process-marked ARTICLES."
 847 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 848 ;;;   (gnus-registry-set-article-mark-internal 'Important articles nil t))
 849 ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
 850 ;;;   "Apply the Important mark to process-marked ARTICLES."
 851 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 852 ;;;   (gnus-registry-set-article-mark-internal 'Important articles t t))
 853
 854          (dolist (remove '(t nil))
 855            (let* ((variant-name (if remove "remove" "set"))
 856                   (function-name (format function-format variant-name))
 857                   (shortcut (format "%c" data))
 858                   (shortcut (if remove (upcase shortcut) shortcut)))
 859              (unintern function-name obarray)
 860              (eval
 861               `(defun
 862                  ;; function name
 863                  ,(intern function-name)
 864                  ;; parameter definition
 865                  (&rest articles)
 866                  ;; documentation
 867                  ,(format
 868                    "%s the %s mark over process-marked ARTICLES."
 869                    (upcase-initials variant-name)
 870                    mark)
 871                  ;; interactive definition
 872                  (interactive
 873                   (gnus-summary-work-articles current-prefix-arg))
 874                  ;; actual code
 875
 876                  ;; if this is called and the user doesn't want the
 877                  ;; registry enabled, we'll ask anyhow
 878                  (unless gnus-registry-install
 879                    (let ((gnus-registry-install 'ask))
 880                      (gnus-registry-install-p)))
 881
 882                  ;; now the user is asked if gnus-registry-install is 'ask
 883                  (when (gnus-registry-install-p)
 884                    (gnus-registry-set-article-mark-internal
 885                     ;; all this just to get the mark, I must be doing it wrong
 886                     (intern ,(symbol-name mark))
 887                     articles ,remove t)
 888                    (gnus-message
 889                     9
 890                     "Applying mark %s to %d articles"
 891                     ,(symbol-name mark) (length articles))
 892                    (dolist (article articles)
 893                      (gnus-summary-update-article
 894                       article
 895                       (assoc article (gnus-data-list nil)))))))
 896              (push (intern function-name) keys-plist)
 897              (push shortcut keys-plist)
 898              (push (vector (format "%s %s"
 899                                    (upcase-initials variant-name)
 900                                    (symbol-name mark))
 901                            (intern function-name) t)
 902                    gnus-registry-misc-menus)
 903              (gnus-message
 904               9
 905               "Defined mark handling function %s"
 906               function-name))))))
 907     (gnus-define-keys-1
 908      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
 909      keys-plist)
 910     (add-hook 'gnus-summary-menu-hook
 911               (lambda ()
 912                 (easy-menu-add-item
 913                  gnus-summary-misc-menu
 914                  nil
 915                  (cons "Registry Marks" gnus-registry-misc-menus))))))
 916
 917 (make-obsolete 'gnus-registry-user-format-function-M
 918                'gnus-registry-article-marks-to-chars "24.1") ?
 919
 920 (defalias 'gnus-registry-user-format-function-M
 921   'gnus-registry-article-marks-to-chars)
 922
 923 ;; use like this:
 924 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
 925 (defun gnus-registry-article-marks-to-chars (headers)
 926   "Show the marks for an article by the :char property"
 927   (let* ((id (mail-header-message-id headers))
 928          (marks (when id (gnus-registry-get-id-key id 'mark))))
 929     (mapconcat (lambda (mark)
 930                  (plist-get
 931                   (cdr-safe
 932                    (assoc mark gnus-registry-marks))
 933                   :char))
 934                marks "")))
 935
 936 ;; use like this:
 937 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
 938 (defun gnus-registry-article-marks-to-names (headers)
 939   "Show the marks for an article by name"
 940   (let* ((id (mail-header-message-id headers))
 941          (marks (when id (gnus-registry-get-id-key id 'mark))))
 942     (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
 943
 944 (defun gnus-registry-read-mark ()
 945   "Read a mark name from the user with completion."
 946   (let ((mark (gnus-completing-read
 947                "Label"
 948                (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
 949                nil nil nil
 950                (symbol-name gnus-registry-default-mark))))
 951     (when (stringp mark)
 952       (intern mark))))
 953
 954 (defun gnus-registry-set-article-mark (&rest articles)
 955   "Apply a mark to process-marked ARTICLES."
 956   (interactive (gnus-summary-work-articles current-prefix-arg))
 957   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
 958                                            articles nil t))
 959
 960 (defun gnus-registry-remove-article-mark (&rest articles)
 961   "Remove a mark from process-marked ARTICLES."
 962   (interactive (gnus-summary-work-articles current-prefix-arg))
 963   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
 964                                            articles t t))
 965
 966 (defun gnus-registry-set-article-mark-internal (mark
 967                                                 articles
 968                                                 &optional remove
 969                                                 show-message)
 970   "Apply or remove MARK across a list of ARTICLES."
 971   (let ((article-id-list
 972          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
 973     (dolist (id article-id-list)
 974       (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
 975              (marks (if remove marks (cons mark marks))))
 976         (when show-message
 977           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
 978                         (if remove "Removing" "Adding")
 979                         mark id marks))
 980         (gnus-registry-set-id-key id 'mark marks)))))
 981
 982 (defun gnus-registry-get-article-marks (&rest articles)
 983   "Get the Gnus registry marks for ARTICLES and show them if interactive.
 984 Uses process/prefix conventions.  For multiple articles,
 985 only the last one's marks are returned."
 986   (interactive (gnus-summary-work-articles 1))
 987   (let* ((article (last articles))
 988          (id (gnus-registry-fetch-message-id-fast article))
 989          (marks (when id (gnus-registry-get-id-key id 'mark))))
 990     (when (interactive-p)
 991       (gnus-message 1 "Marks are %S" marks))
 992     marks))
 993
 994 (defun gnus-registry-group-count (id)
 995   "Get the number of groups of a message, based on the message ID."
 996   (length (gnus-registry-get-id-key id 'group)))
 997
 998 (defun gnus-registry-get-or-make-entry (id)
 999   (let* ((db gnus-registry-db)
1000          ;; safe if not found
1001          (entries (registry-lookup db (list id))))
1002
1003     (when (null entries)
1004       (gnus-registry-insert db id (list (list 'creation-time (current-time))
1005                                         '(group) '(sender) '(subject)))
1006       (setq entries (registry-lookup db (list id))))
1007
1008     (nth 1 (assoc id entries))))
1009
1010 (defun gnus-registry-delete-entries (idlist)
1011   (registry-delete gnus-registry-db idlist nil))
1012
1013 (defun gnus-registry-get-id-key (id key)
1014   (cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
1015
1016 (defun gnus-registry-set-id-key (id key vals)
1017   (let* ((db gnus-registry-db)
1018          (entry (gnus-registry-get-or-make-entry id)))
1019     (registry-delete db (list id) nil)
1020     (setq entry (cons (cons key vals) (assq-delete-all key entry)))
1021     (gnus-registry-insert db id entry)
1022     entry))
1023
1024 (defun gnus-registry-insert (db id entry)
1025   "Just like `registry-insert' but tries to prune on error."
1026   (when (registry-full db)
1027     (message "Trying to prune the registry because it's full")
1028     (registry-prune db))
1029   (registry-insert db id entry)
1030   entry)
1031
1032 (defun gnus-registry-import-eld (file)
1033   (interactive "fOld registry file to import? ")
1034   ;; example content:
1035   ;;   (setq gnus-registry-alist '(
1036   ;; ("<messageID>" ((marks nil)
1037   ;;                 (mtime 19365 1776 440496)
1038   ;;                 (sender . "root (Cron Daemon)")
1039   ;;                 (subject . "Cron"))
1040   ;;  "cron" "nnml+private:cron")
1041   (load file t)
1042   (when (boundp 'gnus-registry-alist)
1043     (let* ((old (symbol-value 'gnus-registry-alist))
1044            (count 0)
1045            (expected (length old))
1046            entry)
1047       (while (car-safe old)
1048         (incf count)
1049         ;; don't use progress reporters for backwards compatibility
1050         (when (and (< 0 expected)
1051                    (= 0 (mod count 100)))
1052           (message "importing: %d of %d (%.2f%%)"
1053                    count expected (/ (* 100 count) expected)))
1054         (setq entry (car-safe old)
1055               old (cdr-safe old))
1056         (let* ((id (car-safe entry))
1057                (new-entry (gnus-registry-get-or-make-entry id))
1058                (rest (cdr-safe entry))
1059                (groups (loop for p in rest
1060                              when (stringp p)
1061                              collect p))
1062                extra-cell key val)
1063           ;; remove all the strings from the entry
1064           (dolist (elem rest)
1065             (if (stringp elem) (setq rest (delq elem rest))))
1066           (gnus-registry-set-id-key id 'group groups)
1067           ;; just use the first extra element
1068           (setq rest (car-safe rest))
1069           (while (car-safe rest)
1070             (setq extra-cell (car-safe rest)
1071                   key (car-safe extra-cell)
1072                   val (cdr-safe extra-cell)
1073                   rest (cdr-safe rest))
1074             (when (and val (atom val))
1075               (setq val (list val)))
1076             (gnus-registry-set-id-key id key val))))
1077       (message "Import done, collected %d entries" count))))
1078
1079 (ert-deftest gnus-registry-misc-test ()
1080   (should-error (gnus-registry-extract-addresses '("" "")))
1081
1082   (should (equal '("Ted Zlatanov <tzz@lifelogs.com>"
1083                    "noname <ed@you.me>"
1084                    "noname <cyd@stupidchicken.com>"
1085                    "noname <tzz@lifelogs.com>")
1086                  (gnus-registry-extract-addresses
1087                   (concat "Ted Zlatanov <tzz@lifelogs.com>, "
1088                           "ed <ed@you.me>, " ; "ed" is not a valid name here
1089                           "cyd@stupidchicken.com, "
1090                           "tzz@lifelogs.com")))))
1091
1092 (ert-deftest gnus-registry-usage-test ()
1093   (let* ((n 100)
1094          (tempfile (make-temp-file "gnus-registry-persist"))
1095          (db (gnus-registry-make-db tempfile))
1096          (gnus-registry-db db)
1097          back size)
1098     (message "Adding %d keys to the test Gnus registry" n)
1099     (dotimes (i n)
1100       (let ((id (number-to-string i)))
1101         (gnus-registry-handle-action id
1102                                      (if (>= 50 i) "fromgroup" nil)
1103                                      "togroup"
1104                                      (when (>= 70 i)
1105                                        (format "subject %d" (mod i 10)))
1106                                      (when (>= 80 i)
1107                                        (format "sender %d" (mod i 10))))))
1108     (message "Testing Gnus registry size is %d" n)
1109     (should (= n (registry-size db)))
1110     (message "Looking up individual keys (registry-lookup)")
1111     (should (equal (loop for e
1112                          in (mapcar 'cadr
1113                                     (registry-lookup db '("20" "83" "72")))
1114                          collect (assq 'subject e)
1115                          collect (assq 'sender e)
1116                          collect (assq 'group e))
1117                    '((subject "subject 0") (sender "sender 0") (group "togroup")
1118                      (subject) (sender) (group "togroup")
1119                      (subject) (sender "sender 2") (group "togroup"))))
1120
1121     (message "Looking up individual keys (gnus-registry-id-key)")
1122     (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
1123     (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4")))
1124     (message "Trying to insert a duplicate key")
1125     (should-error (gnus-registry-insert db "55" '()))
1126     (message "Looking up individual keys (gnus-registry-get-or-make-entry)")
1127     (should (gnus-registry-get-or-make-entry "22"))
1128     (message "Saving the Gnus registry to %s" tempfile)
1129     (should (gnus-registry-save tempfile db))
1130     (setq size (nth 7 (file-attributes tempfile)))
1131     (message "Saving the Gnus registry to %s: size %d" tempfile size)
1132     (should (< 0 size))
1133     (with-temp-buffer
1134       (insert-file-contents-literally tempfile)
1135       (should (looking-at (concat ";; Object "
1136                                   "Gnus Registry"
1137                                   "\n;; EIEIO PERSISTENT OBJECT"))))
1138     (message "Reading Gnus registry back")
1139     (setq back (eieio-persistent-read tempfile))
1140     (should back)
1141     (message "Read Gnus registry back: %d keys, expected %d==%d"
1142              (registry-size back) n (registry-size db))
1143     (should (= (registry-size back) n))
1144     (should (= (registry-size back) (registry-size db)))
1145     (delete-file tempfile)
1146     (message "Pruning Gnus registry to 0 by setting :max-soft")
1147     (oset db :max-soft 0)
1148     (registry-prune db)
1149     (should (= (registry-size db) 0)))
1150   (message "Done with Gnus registry usage testing."))
1151
1152 ;;;###autoload
1153 (defun gnus-registry-initialize ()
1154 "Initialize the Gnus registry."
1155   (interactive)
1156   (gnus-message 5 "Initializing the registry")
1157   (gnus-registry-install-hooks)
1158   (gnus-registry-install-shortcuts)
1159   (gnus-registry-read))
1160
1161 ;;;###autoload
1162 (defun gnus-registry-install-hooks ()
1163   "Install the registry hooks."
1164   (interactive)
1165   (setq gnus-registry-enabled t)
1166   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1167   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1168   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1169   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1170
1171   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1172   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1173
1174   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1175
1176 (defun gnus-registry-unload-hook ()
1177   "Uninstall the registry hooks."
1178   (interactive)
1179   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1180   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1181   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1182   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1183
1184   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1185   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1186
1187   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
1188   (setq gnus-registry-enabled nil))
1189
1190 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
1191
1192 (defun gnus-registry-install-p ()
1193   "If the registry is not already enabled, and `gnus-registry-install' is t,
1194 the registry is enabled.  If `gnus-registry-install' is `ask',
1195 the user is asked first.  Returns non-nil iff the registry is enabled."
1196   (interactive)
1197   (unless gnus-registry-enabled
1198     (when (if (eq gnus-registry-install 'ask)
1199               (gnus-y-or-n-p
1200                (concat "Enable the Gnus registry?  "
1201                        "See the variable `gnus-registry-install' "
1202                        "to get rid of this query permanently. "))
1203             gnus-registry-install)
1204       (gnus-registry-initialize)))
1205   gnus-registry-enabled)
1206
1207 ;; TODO: a few things
1208
1209 (provide 'gnus-registry)
1210
1211 ;;; gnus-registry.el ends here