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