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