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, now try the extra tracking by subject
 429      (when (and (null found)
 430                 (memq 'subject gnus-registry-track-extra)
 431                 subject
 432                 (< gnus-registry-minimum-subject-length (length subject)))
 433        (let ((groups (apply
 434                       'append
 435                       (mapcar
 436                        (lambda (reference)
 437                          (gnus-registry-get-id-key reference 'group))
 438                        (registry-lookup-secondary-value db 'subject subject)))))
 439          (setq found
 440                (loop for group in groups
 441                      when (gnus-registry-follow-group-p group)
 442                      do (gnus-message
 443                          ;; warn more if gnus-registry-track-extra
 444                          (if gnus-registry-track-extra 7 9)
 445                          "%s (extra tracking) traced subject '%s' to %s"
 446                          log-agent subject group)
 447                      collect group))
 448          ;; filter the found groups and return them
 449          ;; the found groups are NOT the full groups
 450          (setq found (gnus-registry-post-process-groups
 451                       "subject" subject found))))
 452
 453      ;; else: there were no matches, try the extra tracking by sender
 454      (when (and (null found)
 455                 (memq 'sender gnus-registry-track-extra)
 456                 sender
 457                 (not (gnus-grep-in-list
 458                       sender
 459                       gnus-registry-unfollowed-addresses)))
 460        (let ((groups (apply
 461                       'append
 462                       (mapcar
 463                        (lambda (reference)
 464                          (gnus-registry-get-id-key reference 'group))
 465                        (registry-lookup-secondary-value db 'sender sender)))))
 466          (setq found
 467                (loop for group in groups
 468                      when (gnus-registry-follow-group-p group)
 469                      do (gnus-message
 470                          ;; warn more if gnus-registry-track-extra
 471                          (if gnus-registry-track-extra 7 9)
 472                          "%s (extra tracking) traced sender '%s' to %s"
 473                          log-agent sender group)
 474                      collect group)))
 475
 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                     "sender" sender found)))
 480
 481      ;; after the (cond) we extract the actual value safely
 482      (car-safe found)))
 483
 484 (defun gnus-registry-post-process-groups (mode key groups)
 485   "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
 486
 487 MODE can be 'subject' or 'sender' for example.  The KEY is the
 488 value by which MODE was searched.
 489
 490 Transforms each group name to the equivalent short name.
 491
 492 Checks if the current Gnus method (from `gnus-command-method' or
 493 from `gnus-newsgroup-name') is the same as the group's method.
 494 Foreign methods are not supported so they are rejected.
 495
 496 Reduces the list to a single group, or complains if that's not
 497 possible.  Uses `gnus-registry-split-strategy'."
 498   (let ((log-agent "gnus-registry-post-process-group")
 499         (desc (format "%d groups" (length groups)))
 500         out chosen)
 501     ;; the strategy can be nil, in which case chosen is nil
 502     (setq chosen
 503           (case gnus-registry-split-strategy
 504             ;; default, take only one-element lists into chosen
 505             ((nil)
 506              (and (= (length groups) 1)
 507                   (car-safe groups)))
 508
 509             ((first)
 510              (car-safe groups))
 511
 512             ((majority)
 513              (let ((freq (make-hash-table
 514                           :size 256
 515                           :test 'equal)))
 516                (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
 517                               (puthash x (1+ (gethash x freq 0)) freq)))
 518                      groups)
 519                (setq desc (format "%d groups, %d unique"
 520                                   (length groups)
 521                                   (hash-table-count freq)))
 522                (car-safe
 523                 (sort groups
 524                       (lambda (a b)
 525                         (> (gethash (gnus-group-short-name a) freq 0)
 526                            (gethash (gnus-group-short-name b) freq 0)))))))))
 527
 528     (if chosen
 529         (gnus-message
 530          9
 531          "%s: strategy %s on %s produced %s"
 532          log-agent gnus-registry-split-strategy desc chosen)
 533       (gnus-message
 534        9
 535        "%s: strategy %s on %s did not produce an answer"
 536        log-agent
 537        (or gnus-registry-split-strategy "default")
 538        desc))
 539
 540     (setq groups (and chosen (list chosen)))
 541
 542     (dolist (group groups)
 543       (let ((m1 (gnus-find-method-for-group group))
 544             (m2 (or gnus-command-method
 545                     (gnus-find-method-for-group gnus-newsgroup-name)))
 546             (short-name (gnus-group-short-name group)))
 547         (if (gnus-methods-equal-p m1 m2)
 548             (progn
 549               ;; this is REALLY just for debugging
 550               (when (not (equal group short-name))
 551                 (gnus-message
 552                  10
 553                  "%s: stripped group %s to %s"
 554                  log-agent group short-name))
 555               (add-to-list 'out short-name))
 556           ;; else...
 557           (gnus-message
 558            7
 559            "%s: ignored foreign group %s"
 560            log-agent group))))
 561
 562     (setq out (delq nil out))
 563
 564     (cond
 565      ((= (length out) 1) out)
 566      ((null out)
 567       (gnus-message
 568        5
 569        "%s: no matches for %s '%s'."
 570        log-agent mode key)
 571       nil)
 572      (t (gnus-message
 573          5
 574          "%s: too many extra matches (%s) for %s '%s'.  Returning none."
 575          log-agent out mode key)
 576         nil))))
 577
 578 (defun gnus-registry-follow-group-p (group)
 579   "Determines if a group name should be followed.
 580 Consults `gnus-registry-unfollowed-groups' and
 581 `nnmail-split-fancy-with-parent-ignore-groups'."
 582   (and group
 583        (not (or (gnus-grep-in-list
 584                  group
 585                  gnus-registry-unfollowed-groups)
 586                 (gnus-grep-in-list
 587                  group
 588                  nnmail-split-fancy-with-parent-ignore-groups)))))
 589
 590 (defun gnus-registry-wash-for-keywords (&optional force)
 591   "Get the keywords of the current article.
 592 Overrides existing keywords with FORCE set non-nil."
 593   (interactive)
 594   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
 595         word words)
 596     (if (or (not (gnus-registry-get-id-key id 'keyword))
 597             force)
 598         (with-current-buffer gnus-article-buffer
 599           (article-goto-body)
 600           (save-window-excursion
 601             (save-restriction
 602               (narrow-to-region (point) (point-max))
 603               (with-syntax-table gnus-adaptive-word-syntax-table
 604                 (while (re-search-forward "\\b\\w+\\b" nil t)
 605                   (setq word (gnus-string-remove-all-properties
 606                               (downcase (buffer-substring
 607                                          (match-beginning 0) (match-end 0)))))
 608                   (if (> (length word) 2)
 609                       (push word words))))))
 610           (gnus-registry-set-id-key id 'keyword words)))))
 611
 612 (defun gnus-registry-keywords ()
 613   (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
 614     (when table (maphash (lambda (k v) k) table))))
 615
 616 (defun gnus-registry-find-keywords (keyword)
 617   (interactive (list
 618                 (completing-read "Keyword: " (gnus-registry-keywords) nil t)))
 619   (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
 620
 621 (defun gnus-registry-register-message-ids ()
 622   "Register the Message-ID of every article in the group"
 623   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 624     (dolist (article gnus-newsgroup-articles)
 625       (let* ((id (gnus-registry-fetch-message-id-fast article))
 626              (groups (gnus-registry-get-id-key id 'group)))
 627         (unless (member gnus-newsgroup-name groups)
 628           (gnus-message 9 "Registry: Registering article %d with group %s"
 629                         article gnus-newsgroup-name)
 630           (gnus-registry-handle-action id nil gnus-newsgroup-name
 631            (gnus-registry-fetch-simplified-message-subject-fast article)
 632            (gnus-registry-fetch-sender-fast article)))))))
 633
 634 ;; message field fetchers
 635 (defun gnus-registry-fetch-message-id-fast (article)
 636   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 637   (if (and (numberp article)
 638            (assoc article (gnus-data-list nil)))
 639       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 640     nil))
 641
 642 (defun gnus-registry-simplify-subject (subject)
 643   (if (stringp subject)
 644       (gnus-simplify-subject subject)
 645     nil))
 646
 647 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 648   "Fetch the Subject quickly, using the internal gnus-data-list function"
 649   (if (and (numberp article)
 650            (assoc article (gnus-data-list nil)))
 651       (gnus-string-remove-all-properties
 652        (gnus-registry-simplify-subject
 653         (mail-header-subject (gnus-data-header
 654                               (assoc article (gnus-data-list nil))))))
 655     nil))
 656
 657 (defun gnus-registry-fetch-sender-fast (article)
 658   "Fetch the Sender quickly, using the internal gnus-data-list function"
 659   (if (and (numberp article)
 660            (assoc article (gnus-data-list nil)))
 661       (gnus-string-remove-all-properties
 662        (mail-header-from (gnus-data-header
 663                           (assoc article (gnus-data-list nil)))))
 664     nil))
 665
 666 ;; registry marks glue
 667 (defun gnus-registry-do-marks (type function)
 668   "For each known mark, call FUNCTION for each cell of type TYPE.
 669
 670 FUNCTION should take two parameters, a mark symbol and the cell value."
 671   (dolist (mark-info gnus-registry-marks)
 672     (let* ((mark (car-safe mark-info))
 673            (data (cdr-safe mark-info))
 674            (cell-data (plist-get data type)))
 675       (when cell-data
 676         (funcall function mark cell-data)))))
 677
 678 ;;; this is ugly code, but I don't know how to do it better
 679 (defun gnus-registry-install-shortcuts ()
 680   "Install the keyboard shortcuts and menus for the registry.
 681 Uses `gnus-registry-marks' to find what shortcuts to install."
 682   (let (keys-plist)
 683     (setq gnus-registry-misc-menus nil)
 684     (gnus-registry-do-marks
 685      :char
 686      (lambda (mark data)
 687        (let ((function-format
 688               (format "gnus-registry-%%s-article-%s-mark" mark)))
 689
 690 ;;; The following generates these functions:
 691 ;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
 692 ;;;   "Apply the Important mark to process-marked ARTICLES."
 693 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 694 ;;;   (gnus-registry-set-article-mark-internal 'Important articles nil t))
 695 ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
 696 ;;;   "Apply the Important mark to process-marked ARTICLES."
 697 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 698 ;;;   (gnus-registry-set-article-mark-internal 'Important articles t t))
 699
 700          (dolist (remove '(t nil))
 701            (let* ((variant-name (if remove "remove" "set"))
 702                   (function-name (format function-format variant-name))
 703                   (shortcut (format "%c" data))
 704                   (shortcut (if remove (upcase shortcut) shortcut)))
 705              (unintern function-name obarray)
 706              (eval
 707               `(defun
 708                  ;; function name
 709                  ,(intern function-name)
 710                  ;; parameter definition
 711                  (&rest articles)
 712                  ;; documentation
 713                  ,(format
 714                    "%s the %s mark over process-marked ARTICLES."
 715                    (upcase-initials variant-name)
 716                    mark)
 717                  ;; interactive definition
 718                  (interactive
 719                   (gnus-summary-work-articles current-prefix-arg))
 720                  ;; actual code
 721
 722                  ;; if this is called and the user doesn't want the
 723                  ;; registry enabled, we'll ask anyhow
 724                  (when (eq gnus-registry-install nil)
 725                    (setq gnus-registry-install 'ask))
 726
 727                  ;; now the user is asked if gnus-registry-install is 'ask
 728                  (when (gnus-registry-install-p)
 729                    (gnus-registry-set-article-mark-internal
 730                     ;; all this just to get the mark, I must be doing it wrong
 731                     (intern ,(symbol-name mark))
 732                     articles ,remove t)
 733                    (gnus-message
 734                     9
 735                     "Applying mark %s to %d articles"
 736                     ,(symbol-name mark) (length articles))
 737                    (dolist (article articles)
 738                      (gnus-summary-update-article
 739                       article
 740                       (assoc article (gnus-data-list nil)))))))
 741              (push (intern function-name) keys-plist)
 742              (push shortcut keys-plist)
 743              (push (vector (format "%s %s"
 744                                    (upcase-initials variant-name)
 745                                    (symbol-name mark))
 746                            (intern function-name) t)
 747                    gnus-registry-misc-menus)
 748              (gnus-message
 749               9
 750               "Defined mark handling function %s"
 751               function-name))))))
 752     (gnus-define-keys-1
 753      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
 754      keys-plist)
 755     (add-hook 'gnus-summary-menu-hook
 756               (lambda ()
 757                 (easy-menu-add-item
 758                  gnus-summary-misc-menu
 759                  nil
 760                  (cons "Registry Marks" gnus-registry-misc-menus))))))
 761
 762 ;;; use like this:
 763 ;;; (defalias 'gnus-user-format-function-M
 764 ;;;           'gnus-registry-user-format-function-M)
 765 (defun gnus-registry-user-format-function-M (headers)
 766   (let* ((id (mail-header-message-id headers))
 767          (marks (when id (gnus-registry-get-id-key id 'mark))))
 768     (apply 'concat (mapcar (lambda (mark)
 769                              (let ((c
 770                                     (plist-get
 771                                      (cdr-safe
 772                                       (assoc mark gnus-registry-marks))
 773                                      :char)))
 774                                (if c
 775                                    (list c)
 776                                  nil)))
 777                            marks))))
 778
 779 (defun gnus-registry-read-mark ()
 780   "Read a mark name from the user with completion."
 781   (let ((mark (gnus-completing-read
 782                "Label"
 783                (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
 784                nil nil nil
 785                (symbol-name gnus-registry-default-mark))))
 786     (when (stringp mark)
 787       (intern mark))))
 788
 789 (defun gnus-registry-set-article-mark (&rest articles)
 790   "Apply a mark to process-marked ARTICLES."
 791   (interactive (gnus-summary-work-articles current-prefix-arg))
 792   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
 793                                            articles nil t))
 794
 795 (defun gnus-registry-remove-article-mark (&rest articles)
 796   "Remove a mark from process-marked ARTICLES."
 797   (interactive (gnus-summary-work-articles current-prefix-arg))
 798   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
 799                                            articles t t))
 800
 801 (defun gnus-registry-set-article-mark-internal (mark
 802                                                 articles
 803                                                 &optional remove
 804                                                 show-message)
 805   "Apply or remove MARK across a list of ARTICLES."
 806   (let ((article-id-list
 807          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
 808     (dolist (id article-id-list)
 809       (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
 810              (marks (if remove marks (cons mark marks))))
 811         (when show-message
 812           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
 813                         (if remove "Removing" "Adding")
 814                         mark id marks))
 815         (gnus-registry-set-id-key id 'mark marks)))))
 816
 817 (defun gnus-registry-get-article-marks (&rest articles)
 818   "Get the Gnus registry marks for ARTICLES and show them if interactive.
 819 Uses process/prefix conventions.  For multiple articles,
 820 only the last one's marks are returned."
 821   (interactive (gnus-summary-work-articles 1))
 822   (let* ((article (last articles))
 823          (id (gnus-registry-fetch-message-id-fast article))
 824          (marks (when id (gnus-registry-get-id-key id 'mark))))
 825     (when (interactive-p)
 826       (gnus-message 1 "Marks are %S" marks))
 827     marks))
 828
 829 (defun gnus-registry-group-count (id)
 830   "Get the number of groups of a message, based on the message ID."
 831   (length (gnus-registry-get-id-key id 'group)))
 832
 833 (defun gnus-registry-get-or-make-entry (id)
 834   (let* ((db gnus-registry-db)
 835          ;; safe if not found
 836          (entries (registry-lookup db (list id))))
 837
 838     (when (null entries)
 839       (registry-insert db id (list (list 'creation-time (current-time))
 840                                    '(group) '(sender) '(subject)))
 841       (setq entries (registry-lookup db (list id))))
 842
 843     (nth 1 (assoc id entries))))
 844
 845 (defun gnus-registry-delete-entries (idlist)
 846   (registry-delete gnus-registry-db idlist nil))
 847
 848 (defun gnus-registry-get-id-key (id key)
 849   (cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
 850
 851 (defun gnus-registry-set-id-key (id key vals)
 852   (let* ((db gnus-registry-db)
 853          (entry (gnus-registry-get-or-make-entry id)))
 854     (registry-delete db (list id) nil)
 855     (setq entry (cons (cons key vals) (assq-delete-all key entry)))
 856     (registry-insert db id entry)
 857     entry))
 858
 859 (defun gnus-registry-import-eld (file)
 860   (interactive "fOld registry file to import? ")
 861   ;; example content:
 862   ;;   (setq gnus-registry-alist '(
 863   ;; ("<messageID>" ((marks nil)
 864   ;;                 (mtime 19365 1776 440496)
 865   ;;                 (sender . "root (Cron Daemon)")
 866   ;;                 (subject . "Cron"))
 867   ;;  "cron" "nnml+private:cron")
 868   (load file t)
 869   (when (boundp 'gnus-registry-alist)
 870     (let* ((old (symbol-value 'gnus-registry-alist))
 871            (count 0)
 872            (expected (length old))
 873            entry)
 874       (while (car-safe old)
 875         (incf count)
 876         ;; don't use progress reporters for backwards compatibility
 877         (when (and (< 0 expected)
 878                    (= 0 (mod count 100)))
 879           (message "importing: %d of %d (%.2f%%)"
 880                    count expected (/ (* 100 count) expected)))
 881         (setq entry (car-safe old)
 882               old (cdr-safe old))
 883         (let* ((id (car-safe entry))
 884                (new-entry (gnus-registry-get-or-make-entry id))
 885                (rest (cdr-safe entry))
 886                (groups (loop for p in rest
 887                              when (stringp p)
 888                              collect p))
 889                extra-cell key val)
 890           ;; remove all the strings from the entry
 891           (delete* nil rest :test (lambda (a b) (stringp b)))
 892           (gnus-registry-set-id-key id 'group groups)
 893           ;; just use the first extra element
 894           (setq rest (car-safe rest))
 895           (while (car-safe rest)
 896             (setq extra-cell (car-safe rest)
 897                   key (car-safe extra-cell)
 898                   val (cdr-safe extra-cell)
 899                   rest (cdr-safe rest))
 900             (when (and val (atom val))
 901               (setq val (list val)))
 902             (gnus-registry-set-id-key id key val))))
 903       (message "Import done, collected %d entries" count))))
 904
 905 (ert-deftest gnus-registry-usage-test ()
 906   (let* ((n 100)
 907          (tempfile (make-temp-file "gnus-registry-persist"))
 908          (db (gnus-registry-make-db tempfile))
 909          (gnus-registry-db db)
 910          back size)
 911     (message "Adding %d keys to the test Gnus registry" n)
 912     (dotimes (i n)
 913       (let ((id (number-to-string i)))
 914         (gnus-registry-handle-action id
 915                                      (if (>= 50 i) "fromgroup" nil)
 916                                      "togroup"
 917                                      (when (>= 70 i)
 918                                        (format "subject %d" (mod i 10)))
 919                                      (when (>= 80 i)
 920                                        (format "sender %d" (mod i 10))))))
 921     (message "Testing Gnus registry size is %d" n)
 922     (should (= n (registry-size db)))
 923     (message "Looking up individual keys (registry-lookup)")
 924     (should (equal (loop for e
 925                          in (mapcar 'cadr
 926                                     (registry-lookup db '("20" "83" "72")))
 927                          collect (assq 'subject e)
 928                          collect (assq 'sender e)
 929                          collect (assq 'group e))
 930                    '((subject "subject 0") (sender "sender 0") (group "togroup")
 931                      (subject) (sender) (group "togroup")
 932                      (subject) (sender "sender 2") (group "togroup"))))
 933
 934     (message "Looking up individual keys (gnus-registry-id-key)")
 935     (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
 936     (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4")))
 937     (message "Trying to insert a duplicate key")
 938     (should-error (registry-insert db "55" '()))
 939     (message "Looking up individual keys (gnus-registry-get-or-make-entry)")
 940     (should (gnus-registry-get-or-make-entry "22"))
 941     (message "Saving the Gnus registry to %s" tempfile)
 942     (should (gnus-registry-save tempfile db))
 943     (setq size (nth 7 (file-attributes tempfile)))
 944     (message "Saving the Gnus registry to %s: size %d" tempfile size)
 945     (should (< 0 size))
 946     (with-temp-buffer
 947       (insert-file-contents-literally tempfile)
 948       (should (looking-at (concat ";; Object "
 949                                   "Gnus Registry"
 950                                   "\n;; EIEIO PERSISTENT OBJECT"))))
 951     (message "Reading Gnus registry back")
 952     (setq back (eieio-persistent-read tempfile))
 953     (should back)
 954     (message "Read Gnus registry back: %d keys, expected %d==%d"
 955              (registry-size back) n (registry-size db))
 956     (should (= (registry-size back) n))
 957     (should (= (registry-size back) (registry-size db)))
 958     (delete-file tempfile)
 959     (message "Pruning Gnus registry to 0 by setting :max-soft")
 960     (oset db :max-soft 0)
 961     (registry-prune db)
 962     (should (= (registry-size db) 0)))
 963   (message "Done with Gnus registry usage testing."))
 964
 965 ;;;###autoload
 966 (defun gnus-registry-initialize ()
 967 "Initialize the Gnus registry."
 968   (interactive)
 969   (gnus-message 5 "Initializing the registry")
 970   (setq gnus-registry-install t)        ; in case it was 'ask or nil
 971   (gnus-registry-install-hooks)
 972   (gnus-registry-install-shortcuts)
 973   (gnus-registry-read))
 974
 975 ;;;###autoload
 976 (defun gnus-registry-install-hooks ()
 977   "Install the registry hooks."
 978   (interactive)
 979   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 980   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 981   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 982   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 983
 984   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 985   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 986
 987   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 988
 989 (defun gnus-registry-unload-hook ()
 990   "Uninstall the registry hooks."
 991   (interactive)
 992   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 993   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 994   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 995   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 996
 997   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 998   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 999
1000   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1001
1002 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
1003
1004 (defun gnus-registry-install-p ()
1005   (interactive)
1006   (when (eq gnus-registry-install 'ask)
1007     (setq gnus-registry-install
1008           (gnus-y-or-n-p
1009            (concat "Enable the Gnus registry?  "
1010                    "See the variable `gnus-registry-install' "
1011                    "to get rid of this query permanently. ")))
1012     (when gnus-registry-install
1013       ;; we just set gnus-registry-install to t, so initialize the registry!
1014       (gnus-registry-initialize)))
1015 ;;; we could call it here: (customize-variable 'gnus-registry-install)
1016   gnus-registry-install)
1017
1018 ;; TODO: a few things
1019
1020 (provide 'gnus-registry)
1021
1022 ;;; gnus-registry.el ends here