lisp/gnus/gnus-registry.el

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