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