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