cgit.sxemacs.org Git - gnus/blob - lisp/gnus-registry.el

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