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