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