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