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

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