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

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