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                      (with-no-warnings
 303                        (eieio-persistent-read file 'registry-db))
 304                    ;; Older EIEIO versions do not check the class name.
 305                    ('wrong-number-of-arguments
 306                     (eieio-persistent-read file)))))
 307           (gnus-message 5 "Reading Gnus registry from %s...done" file))
 308       (error
 309        (gnus-message
 310         1
 311         "The Gnus registry could not be loaded from %s, creating a new one"
 312         file)
 313        (gnus-registry-remake-db t)))))
 314
 315 (defun gnus-registry-save (&optional file db)
 316   "Save the registry cache file."
 317   (interactive)
 318   (let ((file (or file gnus-registry-cache-file))
 319         (db (or db gnus-registry-db)))
 320     (gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
 321                   (registry-size db) file)
 322     (registry-prune db)
 323     ;; TODO: call (gnus-string-remove-all-properties v) on all elements?
 324     (eieio-persistent-save db file)
 325     (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
 326                   (registry-size db) file)))
 327
 328 (defun gnus-registry-remove-ignored ()
 329   (interactive)
 330   (let* ((db gnus-registry-db)
 331          (grouphashtb (registry-lookup-secondary db 'group))
 332          (old-size (registry-size db)))
 333     (registry-reindex db)
 334     (loop for k being the hash-keys of grouphashtb
 335           using (hash-values v)
 336           when (gnus-registry-ignore-group-p k)
 337           do (registry-delete db v nil))
 338     (registry-reindex db)
 339     (gnus-message 4 "Removed %d ignored entries from the Gnus registry"
 340                   (- old-size (registry-size db)))))
 341
 342 ;; article move/copy/spool/delete actions
 343 (defun gnus-registry-action (action data-header from &optional to method)
 344   (let* ((id (mail-header-id data-header))
 345          (subject (mail-header-subject data-header))
 346          (extra (mail-header-extra data-header))
 347          (recipients (gnus-registry-sort-addresses
 348                       (or (cdr-safe (assq 'Cc extra)) "")
 349                       (or (cdr-safe (assq 'To extra)) "")))
 350          (sender (nth 0 (gnus-registry-extract-addresses
 351                          (mail-header-from data-header))))
 352          (from (gnus-group-guess-full-name-from-command-method from))
 353          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
 354          (to-name (if to to "the Bit Bucket")))
 355     (gnus-message 7 "Gnus registry: article %s %s from %s to %s"
 356                   id (if method "respooling" "going") from to)
 357
 358     (gnus-registry-handle-action
 359      id
 360      ;; unless copying, remove the old "from" group
 361      (if (not (equal 'copy action)) from nil)
 362      to subject sender recipients)))
 363
 364 (defun gnus-registry-spool-action (id group &optional subject sender recipients)
 365   (let ((to (gnus-group-guess-full-name-from-command-method group))
 366         (recipients (or recipients
 367                         (gnus-registry-sort-addresses
 368                          (or (message-fetch-field "cc") "")
 369                          (or (message-fetch-field "to") ""))))
 370         (subject (or subject (message-fetch-field "subject")))
 371         (sender (or sender (message-fetch-field "from"))))
 372     (when (and (stringp id) (string-match "\r$" id))
 373       (setq id (substring id 0 -1)))
 374     (gnus-message 7 "Gnus registry: article %s spooled to %s"
 375                   id
 376                   to)
 377     (gnus-registry-handle-action id nil to subject sender recipients)))
 378
 379 (defun gnus-registry-handle-action (id from to subject sender
 380                                        &optional recipients)
 381   (gnus-message
 382    10
 383    "gnus-registry-handle-action %S" (list id from to subject sender recipients))
 384   (let ((db gnus-registry-db)
 385         ;; if the group is ignored, set the destination to nil (same as delete)
 386         (to (if (gnus-registry-ignore-group-p to) nil to))
 387         ;; safe if not found
 388         (entry (gnus-registry-get-or-make-entry id))
 389         (subject (gnus-string-remove-all-properties
 390                   (gnus-registry-simplify-subject subject)))
 391         (sender (gnus-string-remove-all-properties sender)))
 392
 393     ;; this could be done by calling `gnus-registry-set-id-key'
 394     ;; several times but it's better to bunch the transactions
 395     ;; together
 396
 397     (registry-delete db (list id) nil)
 398     (when from
 399       (setq entry (cons (delete from (assoc 'group entry))
 400                         (assq-delete-all 'group entry))))
 401
 402     (dolist (kv `((group ,to)
 403                   (sender ,sender)
 404                   (recipient ,@recipients)
 405                   (subject ,subject)))
 406       (when (second kv)
 407         (let ((new (or (assq (first kv) entry)
 408                        (list (first kv)))))
 409           (dolist (toadd (cdr kv))
 410             (add-to-list 'new toadd t))
 411           (setq entry (cons new
 412                             (assq-delete-all (first kv) entry))))))
 413     (gnus-message 10 "Gnus registry: new entry for %s is %S"
 414                   id
 415                   entry)
 416     (gnus-registry-insert db id entry)))
 417
 418 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 419 ;; the cache and if a match is found, return that group.
 420 (defun gnus-registry-split-fancy-with-parent ()
 421   "Split this message into the same group as its parent.
 422 The parent is obtained from the registry.  This function can be used as an
 423 entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 424 this: (: gnus-registry-split-fancy-with-parent)
 425
 426 This function tracks ALL backends, unlike
 427 `nnmail-split-fancy-with-parent' which tracks only nnmail
 428 messages.
 429
 430 For a message to be split, it looks for the parent message in the
 431 References or In-Reply-To header and then looks in the registry
 432 to see which group that message was put in.  This group is
 433 returned, unless `gnus-registry-follow-group-p' return nil for
 434 that group.
 435
 436 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 437   (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
 438          (reply-to (message-fetch-field "in-reply-to"))      ; may be nil
 439          ;; now, if reply-to is valid, append it to the References
 440          (refstr (if reply-to
 441                      (concat refstr " " reply-to)
 442                    refstr))
 443          (references (and refstr (gnus-extract-references refstr)))
 444          ;; these may not be used, but the code is cleaner having them up here
 445          (sender (gnus-string-remove-all-properties
 446                   (message-fetch-field "from")))
 447          (recipients (gnus-registry-sort-addresses
 448                       (or (message-fetch-field "cc") "")
 449                       (or (message-fetch-field "to") "")))
 450          (subject (gnus-string-remove-all-properties
 451                    (gnus-registry-simplify-subject
 452                     (message-fetch-field "subject"))))
 453
 454          (nnmail-split-fancy-with-parent-ignore-groups
 455           (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 456               nnmail-split-fancy-with-parent-ignore-groups
 457             (list nnmail-split-fancy-with-parent-ignore-groups))))
 458     (gnus-registry--split-fancy-with-parent-internal
 459      :references references
 460      :refstr refstr
 461      :sender sender
 462      :recipients recipients
 463      :subject subject
 464      :log-agent "Gnus registry fancy splitting with parent")))
 465
 466 (defun* gnus-registry--split-fancy-with-parent-internal
 467     (&rest spec
 468            &key references refstr sender subject recipients log-agent
 469            &allow-other-keys)
 470   (gnus-message
 471    10
 472    "gnus-registry--split-fancy-with-parent-internal %S" spec)
 473   (let ((db gnus-registry-db)
 474         found)
 475     ;; this is a big chain of statements.  it uses
 476     ;; gnus-registry-post-process-groups to filter the results after
 477     ;; every step.
 478     ;; the references string must be valid and parse to valid references
 479     (when references
 480       (gnus-message
 481        9
 482        "%s is tracing references %s"
 483        log-agent refstr)
 484       (dolist (reference (nreverse references))
 485         (gnus-message 9 "%s is looking up %s" log-agent reference)
 486         (loop for group in (gnus-registry-get-id-key reference 'group)
 487               when (gnus-registry-follow-group-p group)
 488               do
 489               (progn
 490                 (gnus-message 7 "%s traced %s to %s" log-agent reference group)
 491                 (push group found))))
 492       ;; filter the found groups and return them
 493       ;; the found groups are the full groups
 494       (setq found (gnus-registry-post-process-groups
 495                    "references" refstr found)))
 496
 497      ;; else: there were no matches, now try the extra tracking by subject
 498      (when (and (null found)
 499                 (memq 'subject gnus-registry-track-extra)
 500                 subject
 501                 (< gnus-registry-minimum-subject-length (length subject)))
 502        (let ((groups (apply
 503                       'append
 504                       (mapcar
 505                        (lambda (reference)
 506                          (gnus-registry-get-id-key reference 'group))
 507                        (registry-lookup-secondary-value db 'subject subject)))))
 508          (setq found
 509                (loop for group in groups
 510                      when (gnus-registry-follow-group-p group)
 511                      do (gnus-message
 512                          ;; warn more if gnus-registry-track-extra
 513                          (if gnus-registry-track-extra 7 9)
 514                          "%s (extra tracking) traced subject '%s' to %s"
 515                          log-agent subject group)
 516                     and collect group))
 517          ;; filter the found groups and return them
 518          ;; the found groups are NOT the full groups
 519          (setq found (gnus-registry-post-process-groups
 520                       "subject" subject found))))
 521
 522      ;; else: there were no matches, try the extra tracking by sender
 523      (when (and (null found)
 524                 (memq 'sender gnus-registry-track-extra)
 525                 sender
 526                 (not (gnus-grep-in-list
 527                       sender
 528                       gnus-registry-unfollowed-addresses)))
 529        (let ((groups (apply
 530                       'append
 531                       (mapcar
 532                        (lambda (reference)
 533                          (gnus-registry-get-id-key reference 'group))
 534                        (registry-lookup-secondary-value db 'sender sender)))))
 535          (setq found
 536                (loop for group in groups
 537                      when (gnus-registry-follow-group-p group)
 538                      do (gnus-message
 539                          ;; warn more if gnus-registry-track-extra
 540                          (if gnus-registry-track-extra 7 9)
 541                          "%s (extra tracking) traced sender '%s' to %s"
 542                          log-agent sender group)
 543                      and collect group)))
 544
 545        ;; filter the found groups and return them
 546        ;; the found groups are NOT the full groups
 547        (setq found (gnus-registry-post-process-groups
 548                     "sender" sender found)))
 549
 550      ;; else: there were no matches, try the extra tracking by recipient
 551      (when (and (null found)
 552                 (memq 'recipient gnus-registry-track-extra)
 553                 recipients)
 554        (dolist (recp recipients)
 555          (when (and (null found)
 556                     (not (gnus-grep-in-list
 557                           recp
 558                           gnus-registry-unfollowed-addresses)))
 559            (let ((groups (apply 'append
 560                                 (mapcar
 561                                  (lambda (reference)
 562                                    (gnus-registry-get-id-key reference 'group))
 563                                  (registry-lookup-secondary-value
 564                                   db 'recipient recp)))))
 565              (setq found
 566                    (loop for group in groups
 567                          when (gnus-registry-follow-group-p group)
 568                          do (gnus-message
 569                              ;; warn more if gnus-registry-track-extra
 570                              (if gnus-registry-track-extra 7 9)
 571                              "%s (extra tracking) traced recipient '%s' to %s"
 572                              log-agent recp group)
 573                         and collect group)))))
 574
 575        ;; filter the found groups and return them
 576        ;; the found groups are NOT the full groups
 577        (setq found (gnus-registry-post-process-groups
 578                     "recipients" (mapconcat 'identity recipients ", ") found)))
 579
 580      ;; after the (cond) we extract the actual value safely
 581      (car-safe found)))
 582
 583 (defun gnus-registry-post-process-groups (mode key groups)
 584   "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
 585
 586 MODE can be 'subject' or 'sender' for example.  The KEY is the
 587 value by which MODE was searched.
 588
 589 Transforms each group name to the equivalent short name.
 590
 591 Checks if the current Gnus method (from `gnus-command-method' or
 592 from `gnus-newsgroup-name') is the same as the group's method.
 593 Foreign methods are not supported so they are rejected.
 594
 595 Reduces the list to a single group, or complains if that's not
 596 possible.  Uses `gnus-registry-split-strategy'."
 597   (let ((log-agent "gnus-registry-post-process-group")
 598         (desc (format "%d groups" (length groups)))
 599         out chosen)
 600     ;; the strategy can be nil, in which case chosen is nil
 601     (setq chosen
 602           (case gnus-registry-split-strategy
 603             ;; default, take only one-element lists into chosen
 604             ((nil)
 605              (and (= (length groups) 1)
 606                   (car-safe groups)))
 607
 608             ((first)
 609              (car-safe groups))
 610
 611             ((majority)
 612              (let ((freq (make-hash-table
 613                           :size 256
 614                           :test 'equal)))
 615                (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
 616                               (puthash x (1+ (gethash x freq 0)) freq)))
 617                      groups)
 618                (setq desc (format "%d groups, %d unique"
 619                                   (length groups)
 620                                   (hash-table-count freq)))
 621                (car-safe
 622                 (sort groups
 623                       (lambda (a b)
 624                         (> (gethash (gnus-group-short-name a) freq 0)
 625                            (gethash (gnus-group-short-name b) freq 0)))))))))
 626
 627     (if chosen
 628         (gnus-message
 629          9
 630          "%s: strategy %s on %s produced %s"
 631          log-agent gnus-registry-split-strategy desc chosen)
 632       (gnus-message
 633        9
 634        "%s: strategy %s on %s did not produce an answer"
 635        log-agent
 636        (or gnus-registry-split-strategy "default")
 637        desc))
 638
 639     (setq groups (and chosen (list chosen)))
 640
 641     (dolist (group groups)
 642       (let ((m1 (gnus-find-method-for-group group))
 643             (m2 (or gnus-command-method
 644                     (gnus-find-method-for-group gnus-newsgroup-name)))
 645             (short-name (gnus-group-short-name group)))
 646         (if (gnus-methods-equal-p m1 m2)
 647             (progn
 648               ;; this is REALLY just for debugging
 649               (when (not (equal group short-name))
 650                 (gnus-message
 651                  10
 652                  "%s: stripped group %s to %s"
 653                  log-agent group short-name))
 654               (add-to-list 'out short-name))
 655           ;; else...
 656           (gnus-message
 657            7
 658            "%s: ignored foreign group %s"
 659            log-agent group))))
 660
 661     (setq out (delq nil out))
 662
 663     (cond
 664      ((= (length out) 1) out)
 665      ((null out)
 666       (gnus-message
 667        5
 668        "%s: no matches for %s '%s'."
 669        log-agent mode key)
 670       nil)
 671      (t (gnus-message
 672          5
 673          "%s: too many extra matches (%s) for %s '%s'.  Returning none."
 674          log-agent out mode key)
 675         nil))))
 676
 677 (defun gnus-registry-follow-group-p (group)
 678   "Determines if a group name should be followed.
 679 Consults `gnus-registry-unfollowed-groups' and
 680 `nnmail-split-fancy-with-parent-ignore-groups'."
 681   (and group
 682        (not (or (gnus-grep-in-list
 683                  group
 684                  gnus-registry-unfollowed-groups)
 685                 (gnus-grep-in-list
 686                  group
 687                  nnmail-split-fancy-with-parent-ignore-groups)))))
 688
 689 ;; note that gnus-registry-ignored-groups is defined in gnus.el as a
 690 ;; group/topic parameter and an associated variable!
 691
 692 ;; we do special logic for ignoring to accept regular expressions and
 693 ;; nnmail-split-fancy-with-parent-ignore-groups as well
 694 (defun gnus-registry-ignore-group-p (group)
 695   "Determines if a group name should be ignored.
 696 Consults `gnus-registry-ignored-groups' and
 697 `nnmail-split-fancy-with-parent-ignore-groups'."
 698   (and group
 699        (or (gnus-grep-in-list
 700             group
 701             (delq nil (mapcar (lambda (g)
 702                                 (cond
 703                                  ((stringp g) g)
 704                                  ((and (listp g) (nth 1 g))
 705                                   (nth 0 g))
 706                                  (t nil))) gnus-registry-ignored-groups)))
 707            ;; only use `gnus-parameter-registry-ignore' if
 708            ;; `gnus-registry-ignored-groups' is a list of lists
 709            ;; (it can be a list of regexes)
 710            (and (listp (nth 0 gnus-registry-ignored-groups))
 711                 (get-buffer "*Group*")  ; in automatic tests this is false
 712                 (gnus-parameter-registry-ignore group))
 713            (gnus-grep-in-list
 714             group
 715             nnmail-split-fancy-with-parent-ignore-groups))))
 716
 717 (defun gnus-registry-wash-for-keywords (&optional force)
 718   "Get the keywords of the current article.
 719 Overrides existing keywords with FORCE set non-nil."
 720   (interactive)
 721   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
 722         word words)
 723     (if (or (not (gnus-registry-get-id-key id 'keyword))
 724             force)
 725         (with-current-buffer gnus-article-buffer
 726           (article-goto-body)
 727           (save-window-excursion
 728             (save-restriction
 729               (narrow-to-region (point) (point-max))
 730               (with-syntax-table gnus-adaptive-word-syntax-table
 731                 (while (re-search-forward "\\b\\w+\\b" nil t)
 732                   (setq word (gnus-string-remove-all-properties
 733                               (downcase (buffer-substring
 734                                          (match-beginning 0) (match-end 0)))))
 735                   (if (> (length word) 2)
 736                       (push word words))))))
 737           (gnus-registry-set-id-key id 'keyword words)))))
 738
 739 (defun gnus-registry-keywords ()
 740   (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
 741     (when table (maphash (lambda (k v) k) table))))
 742
 743 (defun gnus-registry-find-keywords (keyword)
 744   (interactive (list
 745                 (completing-read "Keyword: " (gnus-registry-keywords) nil t)))
 746   (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
 747
 748 (defun gnus-registry-register-message-ids ()
 749   "Register the Message-ID of every article in the group."
 750   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 751     (dolist (article gnus-newsgroup-articles)
 752       (let* ((id (gnus-registry-fetch-message-id-fast article))
 753              (groups (gnus-registry-get-id-key id 'group)))
 754         (unless (member gnus-newsgroup-name groups)
 755           (gnus-message 9 "Registry: Registering article %d with group %s"
 756                         article gnus-newsgroup-name)
 757           (gnus-registry-handle-action id nil gnus-newsgroup-name
 758            (gnus-registry-fetch-simplified-message-subject-fast article)
 759            (gnus-registry-fetch-sender-fast article)
 760            (gnus-registry-fetch-recipients-fast article)))))))
 761
 762 ;; message field fetchers
 763 (defun gnus-registry-fetch-message-id-fast (article)
 764   "Fetch the Message-ID quickly, using the internal gnus-data-list function."
 765   (if (and (numberp article)
 766            (assoc article (gnus-data-list nil)))
 767       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 768     nil))
 769
 770 (defun gnus-registry-extract-addresses (text)
 771   "Extract all the addresses in a normalized way from TEXT.
 772 Returns an unsorted list of strings in the name <address> format.
 773 Addresses without a name will say \"noname\"."
 774   (mapcar (lambda (add)
 775             (gnus-string-remove-all-properties
 776              (let* ((name (or (nth 0 add) "noname"))
 777                     (addr (nth 1 add))
 778                     (addr (if (bufferp addr)
 779                               (with-current-buffer addr
 780                                 (buffer-string))
 781                             addr)))
 782                (format "%s <%s>" name addr))))
 783           (mail-extract-address-components text t)))
 784
 785 (defun gnus-registry-sort-addresses (&rest addresses)
 786   "Return a normalized and sorted list of ADDRESSES."
 787   (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
 788         'string-lessp))
 789
 790 (defun gnus-registry-simplify-subject (subject)
 791   (if (stringp subject)
 792       (gnus-simplify-subject subject)
 793     nil))
 794
 795 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 796   "Fetch the Subject quickly, using the internal gnus-data-list function."
 797   (if (and (numberp article)
 798            (assoc article (gnus-data-list nil)))
 799       (gnus-string-remove-all-properties
 800        (gnus-registry-simplify-subject
 801         (mail-header-subject (gnus-data-header
 802                               (assoc article (gnus-data-list nil))))))
 803     nil))
 804
 805 (defun gnus-registry-fetch-sender-fast (article)
 806   (gnus-registry-fetch-header-fast "from" article))
 807
 808 (defun gnus-registry-fetch-recipients-fast (article)
 809   (gnus-registry-sort-addresses
 810    (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
 811    (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
 812
 813 (defun gnus-registry-fetch-header-fast (article header)
 814   "Fetch the HEADER quickly, using the internal gnus-data-list function."
 815   (if (and (numberp article)
 816            (assoc article (gnus-data-list nil)))
 817       (gnus-string-remove-all-properties
 818        (cdr (assq header (gnus-data-header
 819                           (assoc article (gnus-data-list nil))))))
 820     nil))
 821
 822 ;; registry marks glue
 823 (defun gnus-registry-do-marks (type function)
 824   "For each known mark, call FUNCTION for each cell of type TYPE.
 825
 826 FUNCTION should take two parameters, a mark symbol and the cell value."
 827   (dolist (mark-info gnus-registry-marks)
 828     (let* ((mark (car-safe mark-info))
 829            (data (cdr-safe mark-info))
 830            (cell-data (plist-get data type)))
 831       (when cell-data
 832         (funcall function mark cell-data)))))
 833
 834 ;; FIXME: Why not merge gnus-registry--set/remove-mark and
 835 ;; gnus-registry-set-article-mark-internal?
 836 (defun gnus-registry--set/remove-mark (remove mark articles)
 837   "Set/remove the MARK over process-marked ARTICLES."
 838   ;; If this is called and the user doesn't want the
 839   ;; registry enabled, we'll ask anyhow.
 840   (unless gnus-registry-install
 841     (let ((gnus-registry-install 'ask))
 842       (gnus-registry-install-p)))
 843
 844   ;; Now the user is asked if gnus-registry-install is `ask'.
 845   (when (gnus-registry-install-p)
 846     (gnus-registry-set-article-mark-internal
 847      ;; All this just to get the mark, I must be doing it wrong.
 848      mark articles remove t)
 849     ;; FIXME: Why do we do the above only here and not directly inside
 850     ;; gnus-registry-set-article-mark-internal?  I.e. we wouldn't we want to do
 851     ;; the things below when gnus-registry-set-article-mark-internal is called
 852     ;; from gnus-registry-set-article-mark or
 853     ;; gnus-registry-remove-article-mark?
 854     (gnus-message 9 "Applying mark %s to %d articles"
 855                   mark (length articles))
 856     (dolist (article articles)
 857       (gnus-summary-update-article
 858        article
 859        (assoc article (gnus-data-list nil))))))
 860
 861 ;; This is ugly code, but I don't know how to do it better.
 862 (defun gnus-registry-install-shortcuts ()
 863   "Install the keyboard shortcuts and menus for the registry.
 864 Uses `gnus-registry-marks' to find what shortcuts to install."
 865   (let (keys-plist)
 866     (setq gnus-registry-misc-menus nil)
 867     (gnus-registry-do-marks
 868      :char
 869      (lambda (mark data)
 870        (let ((function-format
 871               (format "gnus-registry-%%s-article-%s-mark" mark)))
 872
 873 ;;;  The following generates these functions:
 874 ;;;  (defun gnus-registry-set-article-Important-mark (&rest articles)
 875 ;;;    "Apply the Important mark to process-marked ARTICLES."
 876 ;;;    (interactive (gnus-summary-work-articles current-prefix-arg))
 877 ;;;    (gnus-registry-set-article-mark-internal 'Important articles nil t))
 878 ;;;  (defun gnus-registry-remove-article-Important-mark (&rest articles)
 879 ;;;    "Apply the Important mark to process-marked ARTICLES."
 880 ;;;    (interactive (gnus-summary-work-articles current-prefix-arg))
 881 ;;;    (gnus-registry-set-article-mark-internal 'Important articles t t))
 882
 883          (dolist (remove '(t nil))
 884            (let* ((variant-name (if remove "remove" "set"))
 885                   (function-name
 886                    (intern (format function-format variant-name)))
 887                   (shortcut (format "%c" (if remove (upcase data) data))))
 888              (defalias function-name
 889                ;; If it weren't for the function's docstring, we could
 890                ;; use a closure, with lexical-let :-(
 891                `(lambda (&rest articles)
 892                   ,(format
 893                     "%s the %s mark over process-marked ARTICLES."
 894                     (upcase-initials variant-name)
 895                     mark)
 896                   (interactive
 897                    (gnus-summary-work-articles current-prefix-arg))
 898                   (gnus-registry--set/remove-mark ',mark ',remove articles)))
 899              (push function-name keys-plist)
 900              (push shortcut keys-plist)
 901              (push (vector (format "%s %s"
 902                                    (upcase-initials variant-name)
 903                                    (symbol-name mark))
 904                            function-name t)
 905                    gnus-registry-misc-menus)
 906              (gnus-message 9 "Defined mark handling function %s"
 907                            function-name))))))
 908     (gnus-define-keys-1
 909      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
 910      keys-plist)
 911     (add-hook 'gnus-summary-menu-hook
 912               (lambda ()
 913                 (easy-menu-add-item
 914                  gnus-summary-misc-menu
 915                  nil
 916                  (cons "Registry Marks" gnus-registry-misc-menus))))))
 917
 918 (make-obsolete 'gnus-registry-user-format-function-M
 919                'gnus-registry-article-marks-to-chars "24.1") ?
 920
 921 (defalias 'gnus-registry-user-format-function-M
 922   'gnus-registry-article-marks-to-chars)
 923
 924 ;; use like this:
 925 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
 926 (defun gnus-registry-article-marks-to-chars (headers)
 927   "Show the marks for an article by the :char property."
 928   (let* ((id (mail-header-message-id headers))
 929          (marks (when id (gnus-registry-get-id-key id 'mark))))
 930     (mapconcat (lambda (mark)
 931                  (plist-get
 932                   (cdr-safe
 933                    (assoc mark gnus-registry-marks))
 934                   :char))
 935                marks "")))
 936
 937 ;; use like this:
 938 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
 939 (defun gnus-registry-article-marks-to-names (headers)
 940   "Show the marks for an article by name."
 941   (let* ((id (mail-header-message-id headers))
 942          (marks (when id (gnus-registry-get-id-key id 'mark))))
 943     (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
 944
 945 (defun gnus-registry-read-mark ()
 946   "Read a mark name from the user with completion."
 947   (let ((mark (gnus-completing-read
 948                "Label"
 949                (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
 950                nil nil nil
 951                (symbol-name gnus-registry-default-mark))))
 952     (when (stringp mark)
 953       (intern mark))))
 954
 955 (defun gnus-registry-set-article-mark (&rest articles)
 956   "Apply a mark to process-marked ARTICLES."
 957   (interactive (gnus-summary-work-articles current-prefix-arg))
 958   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
 959                                            articles nil t))
 960
 961 (defun gnus-registry-remove-article-mark (&rest articles)
 962   "Remove a mark from process-marked ARTICLES."
 963   (interactive (gnus-summary-work-articles current-prefix-arg))
 964   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
 965                                            articles t t))
 966
 967 (defun gnus-registry-set-article-mark-internal (mark
 968                                                 articles
 969                                                 &optional remove
 970                                                 show-message)
 971   "Apply or remove MARK across a list of ARTICLES."
 972   (let ((article-id-list
 973          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
 974     (dolist (id article-id-list)
 975       (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
 976              (marks (if remove marks (cons mark marks))))
 977         (when show-message
 978           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
 979                         (if remove "Removing" "Adding")
 980                         mark id marks))
 981         (gnus-registry-set-id-key id 'mark marks)))))
 982
 983 (defun gnus-registry-get-article-marks (&rest articles)
 984   "Get the Gnus registry marks for ARTICLES and show them if interactive.
 985 Uses process/prefix conventions.  For multiple articles,
 986 only the last one's marks are returned."
 987   (interactive (gnus-summary-work-articles 1))
 988   (let* ((article (last articles))
 989          (id (gnus-registry-fetch-message-id-fast article))
 990          (marks (when id (gnus-registry-get-id-key id 'mark))))
 991     (when (gmm-called-interactively-p 'any)
 992       (gnus-message 1 "Marks are %S" marks))
 993     marks))
 994
 995 (defun gnus-registry-group-count (id)
 996   "Get the number of groups of a message, based on the message ID."
 997   (length (gnus-registry-get-id-key id 'group)))
 998
 999 (defun gnus-registry-get-or-make-entry (id)
1000   (let* ((db gnus-registry-db)
1001          ;; safe if not found
1002          (entries (registry-lookup db (list id))))
1003
1004     (when (null entries)
1005       (gnus-registry-insert db id (list (list 'creation-time (current-time))
1006                                         '(group) '(sender) '(subject)))
1007       (setq entries (registry-lookup db (list id))))
1008
1009     (nth 1 (assoc id entries))))
1010
1011 (defun gnus-registry-delete-entries (idlist)
1012   (registry-delete gnus-registry-db idlist nil))
1013
1014 (defun gnus-registry-get-id-key (id key)
1015   (cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
1016
1017 (defun gnus-registry-set-id-key (id key vals)
1018   (let* ((db gnus-registry-db)
1019          (entry (gnus-registry-get-or-make-entry id)))
1020     (registry-delete db (list id) nil)
1021     (setq entry (cons (cons key vals) (assq-delete-all key entry)))
1022     (gnus-registry-insert db id entry)
1023     entry))
1024
1025 (defun gnus-registry-insert (db id entry)
1026   "Just like `registry-insert' but tries to prune on error."
1027   (when (registry-full db)
1028     (message "Trying to prune the registry because it's full")
1029     (registry-prune db))
1030   (registry-insert db id entry)
1031   entry)
1032
1033 (defun gnus-registry-import-eld (file)
1034   (interactive "fOld registry file to import? ")
1035   ;; example content:
1036   ;;   (setq gnus-registry-alist '(
1037   ;; ("<messageID>" ((marks nil)
1038   ;;                 (mtime 19365 1776 440496)
1039   ;;                 (sender . "root (Cron Daemon)")
1040   ;;                 (subject . "Cron"))
1041   ;;  "cron" "nnml+private:cron")
1042   (load file t)
1043   (when (boundp 'gnus-registry-alist)
1044     (let* ((old (symbol-value 'gnus-registry-alist))
1045            (count 0)
1046            (expected (length old))
1047            entry)
1048       (while (car-safe old)
1049         (incf count)
1050         ;; don't use progress reporters for backwards compatibility
1051         (when (and (< 0 expected)
1052                    (= 0 (mod count 100)))
1053           (message "importing: %d of %d (%.2f%%)"
1054                    count expected (/ (* 100 count) expected)))
1055         (setq entry (car-safe old)
1056               old (cdr-safe old))
1057         (let* ((id (car-safe entry))
1058                (new-entry (gnus-registry-get-or-make-entry id))
1059                (rest (cdr-safe entry))
1060                (groups (loop for p in rest
1061                              when (stringp p)
1062                              collect p))
1063                extra-cell key val)
1064           ;; remove all the strings from the entry
1065           (dolist (elem rest)
1066             (if (stringp elem) (setq rest (delq elem rest))))
1067           (gnus-registry-set-id-key id 'group groups)
1068           ;; just use the first extra element
1069           (setq rest (car-safe rest))
1070           (while (car-safe rest)
1071             (setq extra-cell (car-safe rest)
1072                   key (car-safe extra-cell)
1073                   val (cdr-safe extra-cell)
1074                   rest (cdr-safe rest))
1075             (when (and val (atom val))
1076               (setq val (list val)))
1077             (gnus-registry-set-id-key id key val))))
1078       (message "Import done, collected %d entries" count))))
1079
1080 ;;;###autoload
1081 (defun gnus-registry-initialize ()
1082   "Initialize the Gnus registry."
1083   (interactive)
1084   (gnus-message 5 "Initializing the registry")
1085   (gnus-registry-install-hooks)
1086   (gnus-registry-install-shortcuts)
1087   (gnus-registry-read))
1088
1089 ;; FIXME: Why autoload this function?
1090 ;;;###autoload
1091 (defun gnus-registry-install-hooks ()
1092   "Install the registry hooks."
1093   (interactive)
1094   (setq gnus-registry-enabled t)
1095   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1096   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1097   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1098   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1099
1100   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1101   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1102
1103   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1104
1105 (defun gnus-registry-unload-hook ()
1106   "Uninstall the registry hooks."
1107   (interactive)
1108   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1109   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1110   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1111   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1112
1113   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1114   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1115
1116   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
1117   (setq gnus-registry-enabled nil))
1118
1119 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
1120
1121 (defun gnus-registry-install-p ()
1122   "If the registry is not already enabled, and `gnus-registry-install' is t,
1123 the registry is enabled.  If `gnus-registry-install' is `ask',
1124 the user is asked first.  Returns non-nil iff the registry is enabled."
1125   (interactive)
1126   (unless gnus-registry-enabled
1127     (when (if (eq gnus-registry-install 'ask)
1128               (gnus-y-or-n-p
1129                (concat "Enable the Gnus registry?  "
1130                        "See the variable `gnus-registry-install' "
1131                        "to get rid of this query permanently. "))
1132             gnus-registry-install)
1133       (gnus-registry-initialize)))
1134   gnus-registry-enabled)
1135
1136 ;; largely based on nnir-warp-to-article
1137 (defun gnus-try-warping-via-registry ()
1138   "Try to warp via the registry.
1139 This will be done via the current article's source group based on
1140 data stored in the registry."
1141   (interactive)
1142   (when (gnus-summary-article-header)
1143     (let* ((message-id (mail-header-id (gnus-summary-article-header)))
1144            ;; Retrieve the message's group(s) from the registry
1145            (groups (gnus-registry-get-id-key message-id 'group))
1146            ;; If starting from an ephemeral group, this describes
1147            ;; how to restore the window configuration
1148            (quit-config
1149             (gnus-ephemeral-group-p gnus-newsgroup-name))
1150            (seen-groups (list (gnus-group-group-name))))
1151
1152       (catch 'found
1153         (dolist (group (mapcar 'gnus-simplify-group-name groups))
1154
1155           ;; skip over any groups we really don't want to warp to.
1156           (unless (or (member group seen-groups)
1157                       (gnus-ephemeral-group-p group) ;; any ephemeral group
1158                       (memq (car (gnus-find-method-for-group group))
1159                             ;; Specific methods; this list may need to expand.
1160                             '(nnir)))
1161
1162             ;; remember that we've seen this group already
1163             (push group seen-groups)
1164
1165             ;; first exit from any ephemeral summary buffer.
1166             (when quit-config
1167               (gnus-summary-exit)
1168               ;; and if the ephemeral summary buffer in turn came from
1169               ;; another summary buffer we have to clean that summary
1170               ;; up too.
1171               (when (eq (cdr quit-config) 'summary)
1172                 (gnus-summary-exit))
1173               ;; remember that we've already done this part
1174               (setq quit-config nil))
1175
1176             ;; Try to activate the group.  If that fails, just move
1177             ;; along.  We may have more groups to work with
1178             (when
1179                 (ignore-errors
1180                   (gnus-select-group-with-message-id group message-id) t)
1181               (throw 'found t))))))))
1182
1183 ;; TODO: a few things
1184
1185 (provide 'gnus-registry)
1186
1187 ;;; gnus-registry.el ends here