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