git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-registry.el

   1 ;;; gnus-registry.el --- article registry for Gnus
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'gnus)
  32 (require 'gnus-int)
  33 (require 'gnus-sum)
  34 (require 'nnmail)
  35
  36 (defgroup gnus-registry nil
  37   "The Gnus registry."
  38   :group 'gnus)
  39
  40 (defvar gnus-registry-hashtb nil
  41   "*The article registry by Message ID.")
  42
  43 (defvar gnus-registry-headers-hashtb nil
  44   "*The article header registry by Message ID.  Unused for now.")
  45
  46 (defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
  47   "List of groups that gnus-registry-split-fancy-with-parent won't follow.
  48 The group names are matched, they don't have to be fully qualified."
  49   :group 'gnus-registry
  50   :type '(repeat string))
  51
  52 ;; Function(s) missing in Emacs 20
  53 (when (memq nil (mapcar 'fboundp '(puthash)))
  54   (require 'cl)
  55   (unless (fboundp 'puthash)
  56     ;; alias puthash is missing from Emacs 20 cl-extra.el
  57     (defalias 'puthash 'cl-puthash)))
  58
  59 (defun gnus-registry-translate-to-alist ()
  60   (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb)))
  61
  62 (defun gnus-registry-translate-from-alist ()
  63   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
  64
  65 (defun alist-to-hashtable (alist)
  66   "Build a hashtable from the values in ALIST."
  67   (let ((ht (make-hash-table
  68              :size 4096
  69              :test 'equal)))
  70     (mapc
  71      (lambda (kv-pair)
  72        (puthash (car kv-pair) (cdr kv-pair) ht))
  73      alist)
  74      ht))
  75
  76 (defun hashtable-to-alist (hash)
  77   "Build an alist from the values in HASH."
  78   (let ((list nil))
  79     (maphash
  80      (lambda (key value)
  81        (setq list (cons (cons key value) list)))
  82      hash)
  83     list))
  84
  85 (defun gnus-register-action (action data-header from &optional to method)
  86   (let* ((id (mail-header-id data-header))
  87         (from (gnus-group-guess-full-name from))
  88         (to (if to (gnus-group-guess-full-name to) nil))
  89         (to-name (if to to "the Bit Bucket"))
  90         (old-entry (gethash id gnus-registry-hashtb)))
  91     (gnus-message 5 "Registry: article %s %s from %s to %s"
  92                   id
  93                   (if method "respooling" "going")
  94                   from
  95                   to)
  96
  97     (cond
  98      ((equal 'delete action) (gnus-registry-delete-group id from))
  99      (t (gnus-registry-add-group id to)))))
 100
 101 (defun gnus-register-spool-action (id group)
 102   ;; do not process the draft IDs
 103 ;  (unless (string-match "totally-fudged-out-message-id" id)
 104 ;    (let ((group (gnus-group-guess-full-name group)))
 105   (when (string-match "\r$" id)
 106     (setq id (substring id 0 -1)))
 107   (gnus-message 5 "Registry: article %s spooled to %s"
 108                 id
 109                 group)
 110   (gnus-registry-add-group id group))
 111 ;)
 112
 113 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 114 ;; the cache and if a match is found, return that group.
 115 (defun gnus-registry-split-fancy-with-parent ()
 116   "Split this message into the same group as its parent.  The parent
 117 is obtained from the registry.  This function can be used as an entry
 118 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 119 this: (: gnus-registry-split-fancy-with-parent)
 120
 121 For a message to be split, it looks for the parent message in the
 122 References or In-Reply-To header and then looks in the registry to
 123 see which group that message was put in.  This group is returned.
 124
 125 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 126   (let ((refstr (or (message-fetch-field "references")
 127                     (message-fetch-field "in-reply-to")))
 128         (references nil)
 129         (res nil))
 130     (when refstr
 131       (setq references (nreverse (gnus-split-references refstr)))
 132       (mapcar (lambda (x)
 133                 (setq res (or (gnus-registry-fetch-group x) res))
 134                 (when (or (gnus-registry-grep-in-list
 135                            res
 136                            gnus-registry-unfollowed-groups)
 137                           (gnus-registry-grep-in-list
 138                            res
 139                            nnmail-split-fancy-with-parent-ignore-groups))
 140                   (setq res nil)))
 141               references)
 142       res)))
 143
 144 (defun gnus-registry-grep-in-list (word list)
 145   (memq nil
 146         (mapcar 'not
 147          (mapcar
 148           (lambda (x)
 149             (string-match x word))
 150           list))))
 151
 152 (defun gnus-registry-fetch-group (id)
 153   "Get the group of a message, based on the message ID.
 154 Returns the first place where the trail finds a spool action."
 155   (let ((trail (gethash id gnus-registry-hashtb)))
 156     (if trail
 157         (car trail)
 158       nil)))
 159
 160 (defun gnus-registry-delete-group (id group)
 161   "Get the group of a message, based on the message ID.
 162 Returns the first place where the trail finds a spool action."
 163   (let ((trail (gethash id gnus-registry-hashtb))
 164         (group (gnus-group-short-name group)))
 165     (puthash id (if trail
 166                     (delete group trail)
 167                   nil)
 168     gnus-registry-hashtb))
 169   ;; now, clear the entry if it's empty
 170   (unless (gethash id gnus-registry-hashtb)
 171     (remhash id gnus-registry-hashtb)))
 172
 173 (defun gnus-registry-add-group (id group)
 174   "Get the group of a message, based on the message ID.
 175 Returns the first place where the trail finds a spool action."
 176   ;; make sure there are no duplicate entries
 177   (let ((group (gnus-group-short-name group)))
 178     (gnus-registry-delete-group id group)
 179     (let ((trail (gethash id gnus-registry-hashtb)))
 180       (puthash id (if trail
 181                       (cons group trail)
 182                     (list group))
 183                gnus-registry-hashtb))))
 184
 185 (defun gnus-registry-clear ()
 186   "Clear the Gnus registry."
 187   (interactive)
 188   (setq gnus-registry-alist nil
 189         gnus-registry-headers-alist nil)
 190   (gnus-registry-translate-from-alist))
 191
 192 ; also does copy, respool, and crosspost
 193 (add-hook 'gnus-summary-article-move-hook 'gnus-register-action)
 194 (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 195 (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 196 (add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
 197
 198 (add-hook 'gnus-save-newsrc-hook 'gnus-registry-translate-to-alist)
 199 (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-translate-from-alist)
 200
 201 ;; TODO: a lot of things
 202
 203 (provide 'gnus-registry)
 204
 205 ;;; gnus-registry.el ends here