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

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