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