lisp/gnus/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 it matches one of the entries in
 429 gnus-registry-unfollowed-groups or
 430 nnmail-split-fancy-with-parent-ignore-groups.
 431
 432 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 433   (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string
 434          (reply-to (message-fetch-field "in-reply-to"))      ; grab reply-to
 435          ;; now, if reply-to is valid, append it to the References
 436          (refstr (if reply-to
 437                      (concat refstr " " reply-to)
 438                    refstr))
 439         (nnmail-split-fancy-with-parent-ignore-groups
 440          (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 441              nnmail-split-fancy-with-parent-ignore-groups
 442            (list nnmail-split-fancy-with-parent-ignore-groups)))
 443         res)
 444     ;; the references string must be valid and parse to valid references
 445     (if (and refstr (gnus-extract-references refstr))
 446         (dolist (reference (nreverse (gnus-extract-references refstr)))
 447           (setq res (or (gnus-registry-fetch-group reference) res))
 448           (when (or (gnus-registry-grep-in-list
 449                      res
 450                      gnus-registry-unfollowed-groups)
 451                     (gnus-registry-grep-in-list
 452                      res
 453                      nnmail-split-fancy-with-parent-ignore-groups))
 454             (setq res nil)))
 455
 456       ;; else: there were no references, now try the extra tracking
 457       (let ((sender (gnus-string-remove-all-properties(message-fetch-field "from")))
 458             (subject (gnus-string-remove-all-properties
 459                       (gnus-registry-simplify-subject
 460                        (message-fetch-field "subject"))))
 461             (single-match t))
 462         (when (and single-match
 463                    (gnus-registry-track-sender-p)
 464                    sender)
 465           (maphash
 466            (lambda (key value)
 467              (let ((this-sender (cdr
 468                                  (gnus-registry-fetch-extra key 'sender))))
 469                (when (and single-match
 470                           this-sender
 471                           (equal sender this-sender))
 472                  ;; too many matches, bail
 473                  (unless (equal res (gnus-registry-fetch-group key))
 474                    (setq single-match nil))
 475                  (setq res (gnus-registry-fetch-group key))
 476                  (when (and sender res)
 477                    (gnus-message
 478                     ;; raise level of messaging if gnus-registry-track-extra
 479                     (if gnus-registry-track-extra 7 9)
 480                     "%s (extra tracking) traced sender %s to group %s"
 481                     "gnus-registry-split-fancy-with-parent"
 482                     sender
 483                     res)))))
 484            gnus-registry-hashtb))
 485         (when (and single-match
 486                    (gnus-registry-track-subject-p)
 487                    subject
 488                    (< gnus-registry-minimum-subject-length (length subject)))
 489           (maphash
 490            (lambda (key value)
 491              (let ((this-subject (cdr
 492                                   (gnus-registry-fetch-extra key 'subject))))
 493                (when (and single-match
 494                           this-subject
 495                           (equal subject this-subject))
 496                  ;; too many matches, bail
 497                  (unless (equal res (gnus-registry-fetch-group key))
 498                    (setq single-match nil))
 499                  (setq res (gnus-registry-fetch-group key))
 500                  (when (and subject res)
 501                    (gnus-message
 502                     ;; raise level of messaging if gnus-registry-track-extra
 503                     (if gnus-registry-track-extra 7 9)
 504                     "%s (extra tracking) traced subject %s to group %s"
 505                     "gnus-registry-split-fancy-with-parent"
 506                     subject
 507                     res)))))
 508            gnus-registry-hashtb))
 509         (unless single-match
 510           (gnus-message
 511            3
 512            "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
 513            refstr)
 514           (setq res nil))))
 515     (when (and refstr res)
 516       (gnus-message
 517        5
 518        "gnus-registry-split-fancy-with-parent traced %s to group %s"
 519        refstr res))
 520
 521     (when (and res gnus-registry-use-long-group-names)
 522       (let ((m1 (gnus-find-method-for-group res))
 523             (m2 (or gnus-command-method
 524                     (gnus-find-method-for-group gnus-newsgroup-name)))
 525             (short-res (gnus-group-short-name res)))
 526       (if (gnus-methods-equal-p m1 m2)
 527           (progn
 528             (gnus-message
 529              9
 530              "gnus-registry-split-fancy-with-parent stripped group %s to %s"
 531              res
 532              short-res)
 533             (setq res short-res))
 534         ;; else...
 535         (gnus-message
 536          7
 537          "gnus-registry-split-fancy-with-parent ignored foreign group %s"
 538          res)
 539         (setq res nil))))
 540     res))
 541
 542 (defun gnus-registry-wash-for-keywords (&optional force)
 543   (interactive)
 544   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
 545         word words)
 546     (if (or (not (gnus-registry-fetch-extra id 'keywords))
 547             force)
 548         (save-excursion
 549           (set-buffer gnus-article-buffer)
 550           (article-goto-body)
 551           (save-window-excursion
 552             (save-restriction
 553               (narrow-to-region (point) (point-max))
 554               (with-syntax-table gnus-adaptive-word-syntax-table
 555                 (while (re-search-forward "\\b\\w+\\b" nil t)
 556                   (setq word (gnus-registry-remove-alist-text-properties
 557                               (downcase (buffer-substring
 558                                          (match-beginning 0) (match-end 0)))))
 559                   (if (> (length word) 3)
 560                       (push word words))))))
 561           (gnus-registry-store-extra-entry id 'keywords words)))))
 562
 563 (defun gnus-registry-find-keywords (keyword)
 564   (interactive "skeyword: ")
 565   (let (articles)
 566     (maphash
 567      (lambda (key value)
 568        (when (gnus-registry-grep-in-list
 569               keyword
 570               (cdr (gnus-registry-fetch-extra key 'keywords)))
 571          (push key articles)))
 572      gnus-registry-hashtb)
 573     articles))
 574
 575 (defun gnus-registry-register-message-ids ()
 576   "Register the Message-ID of every article in the group"
 577   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 578     (dolist (article gnus-newsgroup-articles)
 579       (let ((id (gnus-registry-fetch-message-id-fast article)))
 580         (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id))
 581           (gnus-message 9 "Registry: Registering article %d with group %s"
 582                         article gnus-newsgroup-name)
 583           (gnus-registry-add-group
 584            id
 585            gnus-newsgroup-name
 586            (gnus-registry-fetch-simplified-message-subject-fast article)
 587            (gnus-registry-fetch-sender-fast article)))))))
 588
 589 (defun gnus-registry-fetch-message-id-fast (article)
 590   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 591   (if (and (numberp article)
 592            (assoc article (gnus-data-list nil)))
 593       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 594     nil))
 595
 596 (defun gnus-registry-simplify-subject (subject)
 597   (if (stringp subject)
 598       (gnus-simplify-subject subject)
 599     nil))
 600
 601 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 602   "Fetch the Subject quickly, using the internal gnus-data-list function"
 603   (if (and (numberp article)
 604            (assoc article (gnus-data-list nil)))
 605       (gnus-string-remove-all-properties
 606        (gnus-registry-simplify-subject
 607         (mail-header-subject (gnus-data-header
 608                               (assoc article (gnus-data-list nil))))))
 609     nil))
 610
 611 (defun gnus-registry-fetch-sender-fast (article)
 612   "Fetch the Sender quickly, using the internal gnus-data-list function"
 613   (if (and (numberp article)
 614            (assoc article (gnus-data-list nil)))
 615       (gnus-string-remove-all-properties
 616        (mail-header-from (gnus-data-header
 617                           (assoc article (gnus-data-list nil)))))
 618     nil))
 619
 620 ;;; this should be redone with catch/throw
 621 (defun gnus-registry-grep-in-list (word list)
 622   (when word
 623     (memq nil
 624           (mapcar 'not
 625                   (mapcar
 626                    (lambda (x)
 627                      (string-match word x))
 628                    list)))))
 629
 630
 631 (defun gnus-registry-read-mark ()
 632   "Read a mark name from the user with completion."
 633   (let ((mark (gnus-completing-read-with-default
 634                (symbol-name gnus-registry-default-mark)
 635                "Label"
 636                (mapcar (lambda (x)      ; completion list
 637                          (cons (symbol-name x) x))
 638                        gnus-registry-marks))))
 639     (when (stringp mark)
 640       (intern mark))))
 641
 642 (defun gnus-registry-set-article-mark (&rest articles)
 643   "Apply a mark to process-marked ARTICLES."
 644   (interactive (gnus-summary-work-articles current-prefix-arg))
 645   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t))
 646
 647 (defun gnus-registry-remove-article-mark (&rest articles)
 648   "Remove a mark from process-marked ARTICLES."
 649   (interactive (gnus-summary-work-articles current-prefix-arg))
 650   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t))
 651
 652 (defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message)
 653   "Apply a mark to a list of ARTICLES."
 654   (let ((article-id-list
 655          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
 656     (dolist (id article-id-list)
 657       (let* (
 658              ;; all the marks for this article without the mark of
 659              ;; interest
 660              (marks
 661               (delq mark (gnus-registry-fetch-extra-marks id)))
 662              ;; the new marks we want to use
 663              (new-marks (if remove
 664                             marks
 665                           (cons mark marks))))
 666         (when show-message
 667           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
 668                         (if remove "Removing" "Adding")
 669                         mark id new-marks))
 670
 671         (apply 'gnus-registry-store-extra-marks ; set the extra marks
 672                id                               ; for the message ID
 673                new-marks)))))
 674
 675 (defun gnus-registry-get-article-marks (&rest articles)
 676   "Get the Gnus registry marks for ARTICLES and show them if interactive.
 677 Uses process/prefix conventions.  For multiple articles,
 678 only the last one's marks are returned."
 679   (interactive (gnus-summary-work-articles 1))
 680   (let (marks)
 681     (dolist (article articles)
 682       (let ((article-id
 683              (gnus-registry-fetch-message-id-fast article)))
 684         (setq marks (gnus-registry-fetch-extra-marks article-id))))
 685     (when (interactive-p)
 686         (gnus-message 1 "Marks are %S" marks))
 687     marks))
 688
 689 ;;; if this extends to more than 'marks, it should be improved to be more generic.
 690 (defun gnus-registry-fetch-extra-marks (id)
 691   "Get the marks of a message, based on the message ID.
 692 Returns a list of symbol marks or nil."
 693   (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
 694
 695 (defun gnus-registry-has-extra-mark (id mark)
 696   "Checks if a message has `mark', based on the message ID `id'."
 697   (memq mark (gnus-registry-fetch-extra-marks id)))
 698
 699 (defun gnus-registry-store-extra-marks (id &rest mark-list)
 700   "Set the marks of a message, based on the message ID.
 701 The `mark-list' can be nil, in which case no marks are left."
 702   (gnus-registry-store-extra-entry id 'marks (list mark-list)))
 703
 704 (defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
 705   "Delete the message marks in `mark-delete-list', based on the message ID."
 706   (let ((marks (gnus-registry-fetch-extra-marks id)))
 707     (when marks
 708       (dolist (mark mark-delete-list)
 709         (setq marks (delq mark marks))))
 710     (gnus-registry-store-extra-marks id (car marks))))
 711
 712 (defun gnus-registry-delete-all-extra-marks (id)
 713   "Delete all the marks for a message ID."
 714   (gnus-registry-store-extra-marks id nil))
 715
 716 (defun gnus-registry-fetch-extra (id &optional entry)
 717   "Get the extra data of a message, based on the message ID.
 718 Returns the first place where the trail finds a nonstring."
 719   (let ((entry-cache (gethash entry gnus-registry-hashtb)))
 720     (if (and entry
 721              (hash-table-p entry-cache)
 722              (gethash id entry-cache))
 723         (gethash id entry-cache)
 724       ;; else, if there is no caching possible...
 725       (let ((trail (gethash id gnus-registry-hashtb)))
 726         (when (listp trail)
 727           (dolist (crumb trail)
 728             (unless (stringp crumb)
 729               (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
 730
 731 (defun gnus-registry-fetch-extra-entry (alist &optional entry id)
 732   "Get the extra data of a message, or a specific entry in it.
 733 Update the entry cache if needed."
 734   (if (and entry id)
 735       (let ((entry-cache (gethash entry gnus-registry-hashtb))
 736             entree)
 737         (when gnus-registry-entry-caching
 738           ;; create the hash table
 739           (unless (hash-table-p entry-cache)
 740             (setq entry-cache (make-hash-table
 741                                :size 4096
 742                                :test 'equal))
 743             (puthash entry entry-cache gnus-registry-hashtb))
 744
 745           ;; get the entree from the hash table or from the alist
 746           (setq entree (gethash id entry-cache)))
 747
 748         (unless entree
 749           (setq entree (assq entry alist))
 750           (when gnus-registry-entry-caching
 751             (puthash id entree entry-cache)))
 752         entree)
 753     alist))
 754
 755 (defun gnus-registry-store-extra (id extra)
 756   "Store the extra data of a message, based on the message ID.
 757 The message must have at least one group name."
 758   (when (gnus-registry-group-count id)
 759     ;; we now know the trail has at least 1 group name, so it's not empty
 760     (let ((trail (gethash id gnus-registry-hashtb))
 761           (old-extra (gnus-registry-fetch-extra id))
 762           entry-cache)
 763       (dolist (crumb trail)
 764         (unless (stringp crumb)
 765           (dolist (entry crumb)
 766             (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
 767           (when entry-cache
 768             (remhash id entry-cache))))
 769       (puthash id (cons extra (delete old-extra trail))
 770                gnus-registry-hashtb)
 771       (setq gnus-registry-dirty t)))))
 772
 773 (defun gnus-registry-delete-extra-entry (id key)
 774   "Delete a specific entry in the extras field of the registry entry for id."
 775   (gnus-registry-store-extra-entry id key nil))
 776
 777 (defun gnus-registry-store-extra-entry (id key value)
 778   "Put a specific entry in the extras field of the registry entry for id."
 779   (let* ((extra (gnus-registry-fetch-extra id))
 780          ;; all the entries except the one for `key'
 781          (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
 782          (alist (if value
 783                     (gnus-registry-remove-alist-text-properties
 784                      (cons (cons key value)
 785                            the-rest))
 786                   the-rest)))
 787     (gnus-registry-store-extra id alist)))
 788
 789 (defun gnus-registry-fetch-group (id)
 790   "Get the group of a message, based on the message ID.
 791 Returns the first place where the trail finds a group name."
 792   (when (gnus-registry-group-count id)
 793     ;; we now know the trail has at least 1 group name
 794     (let ((trail (gethash id gnus-registry-hashtb)))
 795       (dolist (crumb trail)
 796         (when (stringp crumb)
 797           (return (if gnus-registry-use-long-group-names
 798                        crumb
 799                      (gnus-group-short-name crumb))))))))
 800
 801 (defun gnus-registry-fetch-groups (id)
 802   "Get the groups of a message, based on the message ID."
 803   (let ((trail (gethash id gnus-registry-hashtb))
 804         groups)
 805     (dolist (crumb trail)
 806       (when (stringp crumb)
 807         ;; push the group name into the list
 808         (setq
 809          groups
 810          (cons
 811           (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
 812               crumb
 813             (gnus-group-short-name crumb))
 814          groups))))
 815     ;; return the list of groups
 816     groups))
 817
 818 (defun gnus-registry-group-count (id)
 819   "Get the number of groups of a message, based on the message ID."
 820   (let ((trail (gethash id gnus-registry-hashtb)))
 821     (if (and trail (listp trail))
 822         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 823       0)))
 824
 825 (defun gnus-registry-delete-group (id group)
 826   "Delete a group for a message, based on the message ID."
 827   (when (and group id)
 828       (let ((trail (gethash id gnus-registry-hashtb))
 829             (short-group (gnus-group-short-name group)))
 830         (puthash id (if trail
 831                         (delete short-group (delete group trail))
 832                       nil)
 833                  gnus-registry-hashtb))
 834       ;; now, clear the entry if there are no more groups
 835       (when gnus-registry-trim-articles-without-groups
 836         (unless (gnus-registry-group-count id)
 837           (gnus-registry-delete-id id)))
 838       ;; is this ID still in the registry?
 839       (when (gethash id gnus-registry-hashtb)
 840         (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 841
 842 (defun gnus-registry-delete-id (id)
 843   "Delete a message ID from the registry."
 844   (when (stringp id)
 845     (remhash id gnus-registry-hashtb)
 846     (maphash
 847      (lambda (key value)
 848        (when (hash-table-p value)
 849          (remhash id value)))
 850      gnus-registry-hashtb)))
 851
 852 (defun gnus-registry-add-group (id group &optional subject sender)
 853   "Add a group for a message, based on the message ID."
 854   (when group
 855     (when (and id
 856                (not (string-match "totally-fudged-out-message-id" id)))
 857       (let ((full-group group)
 858             (group (if gnus-registry-use-long-group-names
 859                        group
 860                      (gnus-group-short-name group))))
 861         (gnus-registry-delete-group id group)
 862
 863         (unless gnus-registry-use-long-group-names ;; unnecessary in this case
 864           (gnus-registry-delete-group id full-group))
 865
 866         (let ((trail (gethash id gnus-registry-hashtb)))
 867           (puthash id (if trail
 868                           (cons group trail)
 869                         (list group))
 870                    gnus-registry-hashtb)
 871
 872           (when (and (gnus-registry-track-subject-p)
 873                      subject)
 874             (gnus-registry-store-extra-entry
 875              id
 876              'subject
 877              (gnus-registry-simplify-subject subject)))
 878           (when (and (gnus-registry-track-sender-p)
 879                      sender)
 880             (gnus-registry-store-extra-entry
 881              id
 882              'sender
 883              sender))
 884
 885           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 886
 887 (defun gnus-registry-clear ()
 888   "Clear the Gnus registry."
 889   (interactive)
 890   (setq gnus-registry-alist nil)
 891   (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
 892   (setq gnus-registry-dirty t))
 893
 894 ;;;###autoload
 895 (defun gnus-registry-initialize ()
 896   (interactive)
 897   (setq gnus-registry-install t)
 898   (gnus-registry-install-hooks)
 899   (gnus-registry-read))
 900
 901 ;;;###autoload
 902 (defun gnus-registry-install-hooks ()
 903   "Install the registry hooks."
 904   (interactive)
 905   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 906   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 907   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 908   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 909
 910   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 911   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 912
 913   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 914
 915 (defun gnus-registry-unload-hook ()
 916   "Uninstall the registry hooks."
 917   (interactive)
 918   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
 919   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
 920   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
 921   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
 922
 923   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 924   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 925
 926   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 927
 928 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
 929
 930 (when gnus-registry-install
 931   (gnus-registry-install-hooks)
 932   (gnus-registry-read))
 933
 934 ;; TODO: a lot of things
 935
 936 (provide 'gnus-registry)
 937
 938 ;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
 939 ;;; gnus-registry.el ends here