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

   1 ;;; gnus-registry.el --- article registry for Gnus
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This is the gnus-registry.el package, which works with all
  29 ;; backends, not just nnmail (e.g. NNTP).  The major issue is that it
  30 ;; doesn't go across backends, so for instance if an article is in
  31 ;; nnml:sys and you see a reference to it in nnimap splitting, the
  32 ;; article will end up in nnimap:sys
  33
  34 ;; gnus-registry.el intercepts article respooling, moving, deleting,
  35 ;; and copying for all backends.  If it doesn't work correctly for
  36 ;; you, submit a bug report and I'll be glad to fix it.  It needs
  37 ;; documentation in the manual (also on my to-do list).
  38
  39 ;; Put this in your startup file (~/.gnus.el for instance)
  40
  41 ;; (setq gnus-registry-max-entries 2500
  42 ;;       gnus-registry-use-long-group-names t)
  43
  44 ;; (gnus-registry-initialize)
  45
  46 ;; Then use this in your fancy-split:
  47
  48 ;; (: gnus-registry-split-fancy-with-parent)
  49
  50 ;; TODO:
  51
  52 ;; - get the correct group on spool actions
  53
  54 ;; - articles that are spooled to a different backend should be handled
  55
  56 ;;; Code:
  57
  58 (eval-when-compile (require 'cl))
  59
  60 (require 'gnus)
  61 (require 'gnus-int)
  62 (require 'gnus-sum)
  63 (require 'gnus-util)
  64 (require 'nnmail)
  65
  66 (defvar gnus-adaptive-word-syntax-table)
  67
  68 (defvar gnus-registry-dirty t
  69  "Boolean set to t when the registry is modified")
  70
  71 (defgroup gnus-registry nil
  72   "The Gnus registry."
  73   :version "22.1"
  74   :group 'gnus)
  75
  76 (defvar gnus-registry-hashtb (make-hash-table
  77                               :size 256
  78                               :test 'equal)
  79   "*The article registry by Message ID.")
  80
  81 (defcustom gnus-registry-marks
  82   '(Important Work Personal To-Do Later)
  83   "List of marks that `gnus-registry-mark-article' will offer for completion."
  84   :group 'gnus-registry
  85   :type '(repeat symbol))
  86
  87 (defcustom gnus-registry-default-mark 'To-Do
  88   "The default mark."
  89   :group 'gnus-registry
  90   :type 'symbol)
  91
  92 (defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$")
  93   "List of groups that gnus-registry-split-fancy-with-parent won't return.
  94 The group names are matched, they don't have to be fully
  95 qualified.  This parameter tells the Registry 'never split a
  96 message into a group that matches one of these, regardless of
  97 references.'"
  98   :group 'gnus-registry
  99   :type '(repeat regexp))
 100
 101 (defcustom gnus-registry-install nil
 102   "Whether the registry should be installed."
 103   :group 'gnus-registry
 104   :type 'boolean)
 105
 106 (defcustom gnus-registry-clean-empty t
 107   "Whether the empty registry entries should be deleted.
 108 Registry entries are considered empty when they have no groups
 109 and no extra data."
 110   :group 'gnus-registry
 111   :type 'boolean)
 112
 113 (defcustom gnus-registry-use-long-group-names nil
 114   "Whether the registry should use long group names (BUGGY)."
 115   :group 'gnus-registry
 116   :type 'boolean)
 117
 118 (defcustom gnus-registry-track-extra nil
 119   "Whether the registry should track extra data about a message.
 120 The Subject and Sender (From:) headers are currently tracked this
 121 way."
 122   :group 'gnus-registry
 123   :type
 124   '(set :tag "Tracking choices"
 125     (const :tag "Track by subject (Subject: header)" subject)
 126     (const :tag "Track by sender (From: header)"  sender)))
 127
 128 (defcustom gnus-registry-entry-caching t
 129   "Whether the registry should cache extra information."
 130   :group 'gnus-registry
 131   :type 'boolean)
 132
 133 (defcustom gnus-registry-minimum-subject-length 5
 134   "The minimum length of a subject before it's considered trackable."
 135   :group 'gnus-registry
 136   :type 'integer)
 137
 138 (defcustom gnus-registry-trim-articles-without-groups t
 139   "Whether the registry should clean out message IDs without groups."
 140   :group 'gnus-registry
 141   :type 'boolean)
 142
 143 (defcustom gnus-registry-extra-entries-precious '(marks)
 144   "What extra entries are precious, meaning they won't get trimmed.
 145 When you save the Gnus registry, it's trimmed to be no longer
 146 than `gnus-registry-max-entries' (which is nil by default, so no
 147 trimming happens).  Any entries with extra data in this list (by
 148 default, marks are included, so articles with marks are
 149 considered precious) will not be trimmed."
 150   :group 'gnus-registry
 151   :type '(repeat symbol))
 152
 153 (defcustom gnus-registry-cache-file
 154   (nnheader-concat
 155    (or gnus-dribble-directory gnus-home-directory "~/")
 156    ".gnus.registry.eld")
 157   "File where the Gnus registry will be stored."
 158   :group 'gnus-registry
 159   :type 'file)
 160
 161 (defcustom gnus-registry-max-entries nil
 162   "Maximum number of entries in the registry, nil for unlimited."
 163   :group 'gnus-registry
 164   :type '(radio (const :format "Unlimited " nil)
 165                 (integer :format "Maximum number: %v")))
 166
 167 (defun gnus-registry-track-subject-p ()
 168   (memq 'subject gnus-registry-track-extra))
 169
 170 (defun gnus-registry-track-sender-p ()
 171   (memq 'sender gnus-registry-track-extra))
 172
 173 (defun gnus-registry-cache-read ()
 174   "Read the registry cache file."
 175   (interactive)
 176   (let ((file gnus-registry-cache-file))
 177     (when (file-exists-p file)
 178       (gnus-message 5 "Reading %s..." file)
 179       (gnus-load file)
 180       (gnus-message 5 "Reading %s...done" file))))
 181
 182 ;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in
 183 ;; `gnus-start.el'.  --rsteib
 184 (defun gnus-registry-cache-save ()
 185   "Save the registry cache file."
 186   (interactive)
 187   (let ((file gnus-registry-cache-file))
 188     (save-excursion
 189       (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
 190       (make-local-variable 'version-control)
 191     (setq version-control gnus-backup-startup-file)
 192     (setq buffer-file-name file)
 193     (setq default-directory (file-name-directory buffer-file-name))
 194     (buffer-disable-undo)
 195     (erase-buffer)
 196     (gnus-message 5 "Saving %s..." file)
 197     (if gnus-save-startup-file-via-temp-buffer
 198         (let ((coding-system-for-write gnus-ding-file-coding-system)
 199               (standard-output (current-buffer)))
 200           (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)
 201           (gnus-registry-cache-whitespace file)
 202           (save-buffer))
 203       (let ((coding-system-for-write gnus-ding-file-coding-system)
 204             (version-control gnus-backup-startup-file)
 205             (startup-file file)
 206             (working-dir (file-name-directory file))
 207             working-file
 208             (i -1))
 209         ;; Generate the name of a non-existent file.
 210         (while (progn (setq working-file
 211                             (format
 212                              (if (and (eq system-type 'ms-dos)
 213                                       (not (gnus-long-file-names)))
 214                                  "%s#%d.tm#" ; MSDOS limits files to 8+3
 215                                (if (memq system-type '(vax-vms axp-vms))
 216                                    "%s$tmp$%d"
 217                                  "%s#tmp#%d"))
 218                              working-dir (setq i (1+ i))))
 219                       (file-exists-p working-file)))
 220
 221         (unwind-protect
 222             (progn
 223               (gnus-with-output-to-file working-file
 224                 (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
 225
 226               ;; These bindings will mislead the current buffer
 227               ;; into thinking that it is visiting the startup
 228               ;; file.
 229               (let ((buffer-backed-up nil)
 230                     (buffer-file-name startup-file)
 231                     (file-precious-flag t)
 232                     (setmodes (file-modes startup-file)))
 233                 ;; Backup the current version of the startup file.
 234                 (backup-buffer)
 235
 236                 ;; Replace the existing startup file with the temp file.
 237                 (rename-file working-file startup-file t)
 238                 (gnus-set-file-modes startup-file setmodes)))
 239           (condition-case nil
 240               (delete-file working-file)
 241             (file-error nil)))))
 242
 243     (gnus-kill-buffer (current-buffer))
 244     (gnus-message 5 "Saving %s...done" file))))
 245
 246 ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
 247 ;; Save the gnus-registry file with extra line breaks.
 248 (defun gnus-registry-cache-whitespace (filename)
 249   (gnus-message 7 "Adding whitespace to %s" filename)
 250   (save-excursion
 251     (goto-char (point-min))
 252     (while (re-search-forward "^(\\|(\\\"" nil t)
 253       (replace-match "\n\\&" t))
 254     (goto-char (point-min))
 255     (while (re-search-forward " $" nil t)
 256       (replace-match "" t t))))
 257
 258 (defun gnus-registry-save (&optional force)
 259   (when (or gnus-registry-dirty force)
 260     (let ((caching gnus-registry-entry-caching))
 261       ;; turn off entry caching, so mtime doesn't get recorded
 262       (setq gnus-registry-entry-caching nil)
 263       ;; remove entry caches
 264       (maphash
 265        (lambda (key value)
 266          (if (hash-table-p value)
 267              (remhash key gnus-registry-hashtb)))
 268        gnus-registry-hashtb)
 269       ;; remove empty entries
 270       (when gnus-registry-clean-empty
 271         (gnus-registry-clean-empty-function))
 272       ;; now trim and clean text properties from the registry appropriately
 273       (setq gnus-registry-alist
 274             (gnus-registry-remove-alist-text-properties
 275              (gnus-registry-trim
 276               (gnus-hashtable-to-alist
 277                gnus-registry-hashtb))))
 278       ;; really save
 279       (gnus-registry-cache-save)
 280       (setq gnus-registry-entry-caching caching)
 281       (setq gnus-registry-dirty nil))))
 282
 283 (defun gnus-registry-clean-empty-function ()
 284   "Remove all empty entries from the registry.  Returns count thereof."
 285   (let ((count 0))
 286
 287     (maphash
 288      (lambda (key value)
 289        (when (stringp key)
 290          (dolist (group (gnus-registry-fetch-groups key))
 291            (when (gnus-parameter-registry-ignore group)
 292              (gnus-message
 293               10
 294               "gnus-registry: deleted ignored group %s from key %s"
 295               group key)
 296              (gnus-registry-delete-group key group)))
 297
 298          (unless (gnus-registry-group-count key)
 299            (gnus-registry-delete-id key))
 300
 301          (unless (or
 302                   (gnus-registry-fetch-group key)
 303                   ;; TODO: look for specific extra data here!
 304                   ;; in this example, we look for 'label
 305                   (gnus-registry-fetch-extra key 'label))
 306            (incf count)
 307            (gnus-registry-delete-id key))
 308
 309          (unless (stringp key)
 310            (gnus-message
 311             10
 312             "gnus-registry key %s was not a string, removing"
 313             key)
 314            (gnus-registry-delete-id key))))
 315
 316      gnus-registry-hashtb)
 317     count))
 318
 319 (defun gnus-registry-read ()
 320   (gnus-registry-cache-read)
 321   (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
 322   (setq gnus-registry-dirty nil))
 323
 324 (defun gnus-registry-remove-alist-text-properties (v)
 325   "Remove text properties from all strings in alist."
 326   (if (stringp v)
 327       (gnus-string-remove-all-properties v)
 328     (if (and (listp v) (listp (cdr v)))
 329         (mapcar 'gnus-registry-remove-alist-text-properties v)
 330       (if (and (listp v) (stringp (cdr v)))
 331           (cons (gnus-registry-remove-alist-text-properties (car v))
 332                 (gnus-registry-remove-alist-text-properties (cdr v)))
 333       v))))
 334
 335 (defun gnus-registry-trim (alist)
 336   "Trim alist to size, using gnus-registry-max-entries.
 337 Any entries with extra data (marks, currently) are left alone."
 338   (if (null gnus-registry-max-entries)
 339       alist                             ; just return the alist
 340     ;; else, when given max-entries, trim the alist
 341     (let* ((timehash (make-hash-table
 342                       :size 20000
 343                       :test 'equal))
 344            (precious (make-hash-table
 345                       :size 20000
 346                       :test 'equal))
 347            (trim-length (- (length alist) gnus-registry-max-entries))
 348            (trim-length (if (natnump trim-length) trim-length 0))
 349            precious-list junk-list)
 350       (maphash
 351        (lambda (key value)
 352          (let ((extra (gnus-registry-fetch-extra key)))
 353            (dolist (item gnus-registry-extra-entries-precious)
 354              (dolist (e extra)
 355                (when (equal (nth 0 e) item)
 356                  (puthash key t precious)
 357                  (return))))
 358            (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)))
 359        gnus-registry-hashtb)
 360
 361       (dolist (item alist)
 362         (let ((key (nth 0 item)))
 363           (if (gethash key precious)
 364               (push item precious-list)
 365             (push item junk-list))))
 366
 367       (sort
 368        junk-list
 369        (lambda (a b)
 370          (let ((t1 (or (cdr (gethash (car a) timehash))
 371                        '(0 0 0)))
 372                (t2 (or (cdr (gethash (car b) timehash))
 373                        '(0 0 0))))
 374            (time-less-p t1 t2))))
 375
 376       ;; we use the return value of this setq, which is the trimmed alist
 377       (setq alist (append precious-list
 378                           (nthcdr trim-length junk-list))))))
 379
 380 (defun gnus-registry-action (action data-header from &optional to method)
 381   (let* ((id (mail-header-id data-header))
 382          (subject (gnus-string-remove-all-properties
 383                    (gnus-registry-simplify-subject
 384                     (mail-header-subject data-header))))
 385          (sender (gnus-string-remove-all-properties (mail-header-from data-header)))
 386          (from (gnus-group-guess-full-name-from-command-method from))
 387          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
 388          (to-name (if to to "the Bit Bucket"))
 389          (old-entry (gethash id gnus-registry-hashtb)))
 390     (gnus-message 7 "Registry: article %s %s from %s to %s"
 391                   id
 392                   (if method "respooling" "going")
 393                   from
 394                   to)
 395
 396     ;; All except copy will need a delete
 397     (gnus-registry-delete-group id from)
 398
 399     (when (equal 'copy action)
 400       (gnus-registry-add-group id from subject sender)) ; undo the delete
 401
 402     (gnus-registry-add-group id to subject sender)))
 403
 404 (defun gnus-registry-spool-action (id group &optional subject sender)
 405   (let ((group (gnus-group-guess-full-name-from-command-method group)))
 406     (when (and (stringp id) (string-match "\r$" id))
 407       (setq id (substring id 0 -1)))
 408     (gnus-message 7 "Registry: article %s spooled to %s"
 409                   id
 410                   group)
 411     (gnus-registry-add-group id group subject sender)))
 412
 413 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 414 ;; the cache and if a match is found, return that group.
 415 (defun gnus-registry-split-fancy-with-parent ()
 416   "Split this message into the same group as its parent.  The parent
 417 is obtained from the registry.  This function can be used as an entry
 418 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 419 this: (: gnus-registry-split-fancy-with-parent)
 420
 421 This function tracks ALL backends, unlike
 422 `nnmail-split-fancy-with-parent' which tracks only nnmail
 423 messages.
 424
 425 For a message to be split, it looks for the parent message in the
 426 References or In-Reply-To header and then looks in the registry
 427 to see which group that message was put in.  This group is
 428 returned, unless `gnus-registry-follow-group-p' return nil for
 429 that group.
 430
 431 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 432   (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
 433          (reply-to (message-fetch-field "in-reply-to"))      ; may be nil
 434          ;; now, if reply-to is valid, append it to the References
 435          (refstr (if reply-to
 436                      (concat refstr " " reply-to)
 437                    refstr))
 438          ;; these may not be used, but the code is cleaner having them up here
 439          (sender (gnus-string-remove-all-properties
 440                   (message-fetch-field "from")))
 441          (subject (gnus-string-remove-all-properties
 442                    (gnus-registry-simplify-subject
 443                     (message-fetch-field "subject"))))
 444
 445          (nnmail-split-fancy-with-parent-ignore-groups
 446           (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 447               nnmail-split-fancy-with-parent-ignore-groups
 448             (list nnmail-split-fancy-with-parent-ignore-groups)))
 449          (log-agent "gnus-registry-split-fancy-with-parent")
 450          found)
 451
 452     ;; this is a big if-else statement.  it uses
 453     ;; gnus-registry-post-process-groups to filter the results after
 454     ;; every step.
 455     (cond
 456      ;; the references string must be valid and parse to valid references
 457      ((and refstr (gnus-extract-references refstr))
 458       (dolist (reference (nreverse (gnus-extract-references refstr)))
 459         (gnus-message
 460          9
 461          "%s is looking for matches for reference %s from [%s]"
 462          log-agent reference refstr)
 463         (dolist (group (gnus-registry-fetch-groups reference))
 464           (when (and group (gnus-registry-follow-group-p group))
 465             (gnus-message
 466              7
 467              "%s traced the reference %s from [%s] to group %s"
 468              log-agent reference refstr group)
 469             (push group found))))
 470       ;; filter the found groups and return them
 471       (setq found (gnus-registry-post-process-groups "references" refstr found)))
 472
 473      ;; else: there were no matches, now try the extra tracking by sender
 474      ((and (gnus-registry-track-sender-p)
 475            sender)
 476       (maphash
 477        (lambda (key value)
 478          (let ((this-sender (cdr
 479                              (gnus-registry-fetch-extra key 'sender)))
 480                matches)
 481            (when (and this-sender
 482                       (equal sender this-sender))
 483              (setq found (append (gnus-registry-fetch-groups key) found))
 484              (push key matches)
 485              (gnus-message
 486               ;; raise level of messaging if gnus-registry-track-extra
 487               (if gnus-registry-track-extra 7 9)
 488               "%s (extra tracking) traced sender %s to groups %s (keys %s)"
 489               log-agent sender found matches))))
 490        gnus-registry-hashtb)
 491       ;; filter the found groups and return them
 492       (setq found (gnus-registry-post-process-groups "sender" sender found)))
 493
 494      ;; else: there were no matches, now try the extra tracking by subject
 495      ((and (gnus-registry-track-subject-p)
 496            subject
 497            (< gnus-registry-minimum-subject-length (length subject)))
 498       (maphash
 499        (lambda (key value)
 500          (let ((this-subject (cdr
 501                               (gnus-registry-fetch-extra key 'subject)))
 502                matches)
 503            (when (and this-subject
 504                       (equal subject this-subject))
 505              (setq found (append (gnus-registry-fetch-groups key) found))
 506              (push key matches)
 507              (gnus-message
 508               ;; raise level of messaging if gnus-registry-track-extra
 509               (if gnus-registry-track-extra 7 9)
 510               "%s (extra tracking) traced subject %s to groups %s (keys %s)"
 511               log-agent subject found matches))))
 512        gnus-registry-hashtb)
 513       ;; filter the found groups and return them
 514       (setq found (gnus-registry-post-process-groups "subject" subject found))))))
 515
 516 (defun gnus-registry-post-process-groups (mode key groups)
 517   "Modifies GROUPS obtained by searching by MODE for KEY to determine which ones to follow.
 518
 519 MODE can be 'subject' or 'sender' for example.  The KEY is the
 520 value by which MODE was searched.
 521
 522 Transforms each group name to the equivalent short name.
 523
 524 Checks if the current Gnus method (from `gnus-command-method' or
 525 from `gnus-newsgroup-name') is the same as the group's method.
 526 This is not possible if gnus-registry-use-long-group-names is
 527 false.  Foreign methods are not supported so they are rejected.
 528
 529 Reduces the list to a single group, or complains if that's not
 530 possible."
 531   (let ((log-agent "gnus-registry-post-process-group")
 532         out)
 533     (if gnus-registry-use-long-group-names
 534         (dolist (group groups)
 535           (let ((m1 (gnus-find-method-for-group group))
 536                 (m2 (or gnus-command-method
 537                         (gnus-find-method-for-group gnus-newsgroup-name)))
 538                 (short-name (gnus-group-short-name group)))
 539             (if (gnus-methods-equal-p m1 m2)
 540                 (progn
 541                   ;; this is REALLY just for debugging
 542                   (gnus-message
 543                    10
 544                    "%s stripped group %s to %s"
 545                    log-agent group short-name)
 546                   (unless (member short-name out)
 547                     (push short-name out)))
 548               ;; else...
 549               (gnus-message
 550                7
 551                "%s ignored foreign group %s"
 552                log-agent group))))
 553       (setq out groups))
 554     (when (cdr-safe out)
 555         (gnus-message
 556          5
 557          "%s: too many extra matches (%s) for %s %s.  Returning none."
 558          log-agent out mode key)
 559         (setq out nil))
 560     out))
 561
 562 (defun gnus-registry-follow-group-p (group)
 563   "Determines if a group name should be followed.
 564 Consults `gnus-registry-unfollowed-groups' and
 565 `nnmail-split-fancy-with-parent-ignore-groups'."
 566   (not (or (gnus-registry-grep-in-list
 567             group
 568             gnus-registry-unfollowed-groups)
 569            (gnus-registry-grep-in-list
 570             group
 571             nnmail-split-fancy-with-parent-ignore-groups))))
 572
 573 (defun gnus-registry-wash-for-keywords (&optional force)
 574   (interactive)
 575   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
 576         word words)
 577     (if (or (not (gnus-registry-fetch-extra id 'keywords))
 578             force)
 579         (save-excursion
 580           (set-buffer gnus-article-buffer)
 581           (article-goto-body)
 582           (save-window-excursion
 583             (save-restriction
 584               (narrow-to-region (point) (point-max))
 585               (with-syntax-table gnus-adaptive-word-syntax-table
 586                 (while (re-search-forward "\\b\\w+\\b" nil t)
 587                   (setq word (gnus-registry-remove-alist-text-properties
 588                               (downcase (buffer-substring
 589                                          (match-beginning 0) (match-end 0)))))
 590                   (if (> (length word) 3)
 591                       (push word words))))))
 592           (gnus-registry-store-extra-entry id 'keywords words)))))
 593
 594 (defun gnus-registry-find-keywords (keyword)
 595   (interactive "skeyword: ")
 596   (let (articles)
 597     (maphash
 598      (lambda (key value)
 599        (when (gnus-registry-grep-in-list
 600               keyword
 601               (cdr (gnus-registry-fetch-extra key 'keywords)))
 602          (push key articles)))
 603      gnus-registry-hashtb)
 604     articles))
 605
 606 (defun gnus-registry-register-message-ids ()
 607   "Register the Message-ID of every article in the group"
 608   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 609     (dolist (article gnus-newsgroup-articles)
 610       (let ((id (gnus-registry-fetch-message-id-fast article)))
 611         (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id))
 612           (gnus-message 9 "Registry: Registering article %d with group %s"
 613                         article gnus-newsgroup-name)
 614           (gnus-registry-add-group
 615            id
 616            gnus-newsgroup-name
 617            (gnus-registry-fetch-simplified-message-subject-fast article)
 618            (gnus-registry-fetch-sender-fast article)))))))
 619
 620 (defun gnus-registry-fetch-message-id-fast (article)
 621   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 622   (if (and (numberp article)
 623            (assoc article (gnus-data-list nil)))
 624       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 625     nil))
 626
 627 (defun gnus-registry-simplify-subject (subject)
 628   (if (stringp subject)
 629       (gnus-simplify-subject subject)
 630     nil))
 631
 632 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 633   "Fetch the Subject quickly, using the internal gnus-data-list function"
 634   (if (and (numberp article)
 635            (assoc article (gnus-data-list nil)))
 636       (gnus-string-remove-all-properties
 637        (gnus-registry-simplify-subject
 638         (mail-header-subject (gnus-data-header
 639                               (assoc article (gnus-data-list nil))))))
 640     nil))
 641
 642 (defun gnus-registry-fetch-sender-fast (article)
 643   "Fetch the Sender quickly, using the internal gnus-data-list function"
 644   (if (and (numberp article)
 645            (assoc article (gnus-data-list nil)))
 646       (gnus-string-remove-all-properties
 647        (mail-header-from (gnus-data-header
 648                           (assoc article (gnus-data-list nil)))))
 649     nil))
 650
 651 ;;; this should be redone with catch/throw
 652 (defun gnus-registry-grep-in-list (word list)
 653   (when word
 654     (memq nil
 655           (mapcar 'not
 656                   (mapcar
 657                    (lambda (x)
 658                      (string-match word x))
 659                    list)))))
 660
 661
 662 (defun gnus-registry-read-mark ()
 663   "Read a mark name from the user with completion."
 664   (let ((mark (gnus-completing-read-with-default
 665                (symbol-name gnus-registry-default-mark)
 666                "Label"
 667                (mapcar (lambda (x)      ; completion list
 668                          (cons (symbol-name x) x))
 669                        gnus-registry-marks))))
 670     (when (stringp mark)
 671       (intern mark))))
 672
 673 (defun gnus-registry-set-article-mark (&rest articles)
 674   "Apply a mark to process-marked ARTICLES."
 675   (interactive (gnus-summary-work-articles current-prefix-arg))
 676   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t))
 677
 678 (defun gnus-registry-remove-article-mark (&rest articles)
 679   "Remove a mark from process-marked ARTICLES."
 680   (interactive (gnus-summary-work-articles current-prefix-arg))
 681   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t))
 682
 683 (defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message)
 684   "Apply a mark to a list of ARTICLES."
 685   (let ((article-id-list
 686          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
 687     (dolist (id article-id-list)
 688       (let* (
 689              ;; all the marks for this article without the mark of
 690              ;; interest
 691              (marks
 692               (delq mark (gnus-registry-fetch-extra-marks id)))
 693              ;; the new marks we want to use
 694              (new-marks (if remove
 695                             marks
 696                           (cons mark marks))))
 697         (when show-message
 698           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
 699                         (if remove "Removing" "Adding")
 700                         mark id new-marks))
 701
 702         (apply 'gnus-registry-store-extra-marks ; set the extra marks
 703                id                               ; for the message ID
 704                new-marks)))))
 705
 706 (defun gnus-registry-get-article-marks (&rest articles)
 707   "Get the Gnus registry marks for ARTICLES and show them if interactive.
 708 Uses process/prefix conventions.  For multiple articles,
 709 only the last one's marks are returned."
 710   (interactive (gnus-summary-work-articles 1))
 711   (let (marks)
 712     (dolist (article articles)
 713       (let ((article-id
 714              (gnus-registry-fetch-message-id-fast article)))
 715         (setq marks (gnus-registry-fetch-extra-marks article-id))))
 716     (when (interactive-p)
 717         (gnus-message 1 "Marks are %S" marks))
 718     marks))
 719
 720 ;;; if this extends to more than 'marks, it should be improved to be more generic.
 721 (defun gnus-registry-fetch-extra-marks (id)
 722   "Get the marks of a message, based on the message ID.
 723 Returns a list of symbol marks or nil."
 724   (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
 725
 726 (defun gnus-registry-has-extra-mark (id mark)
 727   "Checks if a message has `mark', based on the message ID `id'."
 728   (memq mark (gnus-registry-fetch-extra-marks id)))
 729
 730 (defun gnus-registry-store-extra-marks (id &rest mark-list)
 731   "Set the marks of a message, based on the message ID.
 732 The `mark-list' can be nil, in which case no marks are left."
 733   (gnus-registry-store-extra-entry id 'marks (list mark-list)))
 734
 735 (defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
 736   "Delete the message marks in `mark-delete-list', based on the message ID."
 737   (let ((marks (gnus-registry-fetch-extra-marks id)))
 738     (when marks
 739       (dolist (mark mark-delete-list)
 740         (setq marks (delq mark marks))))
 741     (gnus-registry-store-extra-marks id (car marks))))
 742
 743 (defun gnus-registry-delete-all-extra-marks (id)
 744   "Delete all the marks for a message ID."
 745   (gnus-registry-store-extra-marks id nil))
 746
 747 (defun gnus-registry-fetch-extra (id &optional entry)
 748   "Get the extra data of a message, based on the message ID.
 749 Returns the first place where the trail finds a nonstring."
 750   (let ((entry-cache (gethash entry gnus-registry-hashtb)))
 751     (if (and entry
 752              (hash-table-p entry-cache)
 753              (gethash id entry-cache))
 754         (gethash id entry-cache)
 755       ;; else, if there is no caching possible...
 756       (let ((trail (gethash id gnus-registry-hashtb)))
 757         (when (listp trail)
 758           (dolist (crumb trail)
 759             (unless (stringp crumb)
 760               (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
 761
 762 (defun gnus-registry-fetch-extra-entry (alist &optional entry id)
 763   "Get the extra data of a message, or a specific entry in it.
 764 Update the entry cache if needed."
 765   (if (and entry id)
 766       (let ((entry-cache (gethash entry gnus-registry-hashtb))
 767             entree)
 768         (when gnus-registry-entry-caching
 769           ;; create the hash table
 770           (unless (hash-table-p entry-cache)
 771             (setq entry-cache (make-hash-table
 772                                :size 4096
 773                                :test 'equal))
 774             (puthash entry entry-cache gnus-registry-hashtb))
 775
 776           ;; get the entree from the hash table or from the alist
 777           (setq entree (gethash id entry-cache)))
 778
 779         (unless entree
 780           (setq entree (assq entry alist))
 781           (when gnus-registry-entry-caching
 782             (puthash id entree entry-cache)))
 783         entree)
 784     alist))
 785
 786 (defun gnus-registry-store-extra (id extra)
 787   "Store the extra data of a message, based on the message ID.
 788 The message must have at least one group name."
 789   (when (gnus-registry-group-count id)
 790     ;; we now know the trail has at least 1 group name, so it's not empty
 791     (let ((trail (gethash id gnus-registry-hashtb))
 792           (old-extra (gnus-registry-fetch-extra id))
 793           entry-cache)
 794       (dolist (crumb trail)
 795         (unless (stringp crumb)
 796           (dolist (entry crumb)
 797             (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
 798           (when entry-cache
 799             (remhash id entry-cache))))
 800       (puthash id (cons extra (delete old-extra trail))
 801                gnus-registry-hashtb)
 802       (setq gnus-registry-dirty t)))))
 803
 804 (defun gnus-registry-delete-extra-entry (id key)
 805   "Delete a specific entry in the extras field of the registry entry for id."
 806   (gnus-registry-store-extra-entry id key nil))
 807
 808 (defun gnus-registry-store-extra-entry (id key value)
 809   "Put a specific entry in the extras field of the registry entry for id."
 810   (let* ((extra (gnus-registry-fetch-extra id))
 811          ;; all the entries except the one for `key'
 812          (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
 813          (alist (if value
 814                     (gnus-registry-remove-alist-text-properties
 815                      (cons (cons key value)
 816                            the-rest))
 817                   the-rest)))
 818     (gnus-registry-store-extra id alist)))
 819
 820 (defun gnus-registry-fetch-group (id)
 821   "Get the group of a message, based on the message ID.
 822 Returns the first place where the trail finds a group name."
 823   (when (gnus-registry-group-count id)
 824     ;; we now know the trail has at least 1 group name
 825     (let ((trail (gethash id gnus-registry-hashtb)))
 826       (dolist (crumb trail)
 827         (when (stringp crumb)
 828           (return (if gnus-registry-use-long-group-names
 829                        crumb
 830                      (gnus-group-short-name crumb))))))))
 831
 832 (defun gnus-registry-fetch-groups (id)
 833   "Get the groups of a message, based on the message ID."
 834   (let ((trail (gethash id gnus-registry-hashtb))
 835         groups)
 836     (dolist (crumb trail)
 837       (when (stringp crumb)
 838         ;; push the group name into the list
 839         (setq
 840          groups
 841          (cons
 842           (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
 843               crumb
 844             (gnus-group-short-name crumb))
 845          groups))))
 846     ;; return the list of groups
 847     groups))
 848
 849 (defun gnus-registry-group-count (id)
 850   "Get the number of groups of a message, based on the message ID."
 851   (let ((trail (gethash id gnus-registry-hashtb)))
 852     (if (and trail (listp trail))
 853         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 854       0)))
 855
 856 (defun gnus-registry-delete-group (id group)
 857   "Delete a group for a message, based on the message ID."
 858   (when (and group id)
 859       (let ((trail (gethash id gnus-registry-hashtb))
 860             (short-group (gnus-group-short-name group)))
 861         (puthash id (if trail
 862                         (delete short-group (delete group trail))
 863                       nil)
 864                  gnus-registry-hashtb))
 865       ;; now, clear the entry if there are no more groups
 866       (when gnus-registry-trim-articles-without-groups
 867         (unless (gnus-registry-group-count id)
 868           (gnus-registry-delete-id id)))
 869       ;; is this ID still in the registry?
 870       (when (gethash id gnus-registry-hashtb)
 871         (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 872
 873 (defun gnus-registry-delete-id (id)
 874   "Delete a message ID from the registry."
 875   (when (stringp id)
 876     (remhash id gnus-registry-hashtb)
 877     (maphash
 878      (lambda (key value)
 879        (when (hash-table-p value)
 880          (remhash id value)))
 881      gnus-registry-hashtb)))
 882
 883 (defun gnus-registry-add-group (id group &optional subject sender)
 884   "Add a group for a message, based on the message ID."
 885   (when group
 886     (when (and id
 887                (not (string-match "totally-fudged-out-message-id" id)))
 888       (let ((full-group group)
 889             (group (if gnus-registry-use-long-group-names
 890                        group
 891                      (gnus-group-short-name group))))
 892         (gnus-registry-delete-group id group)
 893
 894         (unless gnus-registry-use-long-group-names ;; unnecessary in this case
 895           (gnus-registry-delete-group id full-group))
 896
 897         (let ((trail (gethash id gnus-registry-hashtb)))
 898           (puthash id (if trail
 899                           (cons group trail)
 900                         (list group))
 901                    gnus-registry-hashtb)
 902
 903           (when (and (gnus-registry-track-subject-p)
 904                      subject)
 905             (gnus-registry-store-extra-entry
 906              id
 907              'subject
 908              (gnus-registry-simplify-subject subject)))
 909           (when (and (gnus-registry-track-sender-p)
 910                      sender)
 911             (gnus-registry-store-extra-entry
 912              id
 913              'sender
 914              sender))
 915
 916           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 917
 918 (defun gnus-registry-clear ()
 919   "Clear the Gnus registry."
 920   (interactive)
 921   (setq gnus-registry-alist nil)
 922   (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
 923   (setq gnus-registry-dirty t))
 924
 925 ;;;###autoload
 926 (defun gnus-registry-initialize ()
 927   (interactive)
 928   (setq gnus-registry-install t)
 929   (gnus-registry-install-hooks)
 930   (gnus-registry-read))
 931
 932 ;;;###autoload
 933 (defun gnus-registry-install-hooks ()
 934   "Install the registry hooks."
 935   (interactive)
 936   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 937   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 938   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 939   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 940
 941   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 942   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 943
 944   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 945
 946 (defun gnus-registry-unload-hook ()
 947   "Uninstall the registry hooks."
 948   (interactive)
 949   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 950   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 951   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 952   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 953
 954   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 955   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 956
 957   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 958
 959 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
 960
 961 (when gnus-registry-install
 962   (gnus-registry-install-hooks)
 963   (gnus-registry-read))
 964
 965 ;; TODO: a lot of things
 966
 967 (provide 'gnus-registry)
 968
 969 ;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
 970 ;;; gnus-registry.el ends here