lisp/gnus/gnus-registry.el

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