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