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

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