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