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 (defvar gnus-registry-hashtb nil
  37   "*The article registry by Message ID.")
  38 (setq gnus-registry-hashtb (make-hash-table
  39                             :size 4096
  40                             :test 'equal)) ; we test message ID strings equality
  41
  42 ;; sample data-header
  43 ;; (defvar tzz-header '(49 "Re[2]: good news" "\"Jonathan Pryor\" <offerlm@aol.com>" "Mon, 17 Feb 2003 10:41:46 +-0800" "<88288020@dytqq>" "" 896 18 "lockgroove.bwh.harvard.edu spam.asian:49" nil))
  44
  45 ;; (maphash (lambda (key value) (message "key: %s value: %s" key value)) gnus-registry-hashtb)
  46 ;; (clrhash gnus-registry-hashtb)
  47
  48 ;; Function(s) missing in Emacs 20
  49 (when (memq nil (mapcar 'fboundp '(puthash)))
  50   (require 'cl)
  51   (unless (fboundp 'puthash)
  52     ;; alias puthash is missing from Emacs 20 cl-extra.el
  53     (defalias 'puthash 'cl-puthash)))
  54
  55 (defun gnus-registry-translate-to-alist ()
  56   (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb)))
  57
  58 (defun gnus-registry-translate-from-alist ()
  59   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
  60
  61 (defun alist-to-hashtable (alist)
  62   "Build a hashtable from the values in ALIST."
  63   (let ((ht (make-hash-table
  64              :size 4096
  65              :test 'equal)))
  66     (mapc
  67      (lambda (kv-pair)
  68        (puthash (car kv-pair) (cdr kv-pair) ht))
  69      alist)
  70      ht))
  71
  72 (defun hashtable-to-alist (hash)
  73   "Build an alist from the values in HASH."
  74   (let ((list nil))
  75     (maphash
  76      (lambda (key value)
  77        (setq list (cons (cons key value) list)))
  78      hash)))
  79
  80 (defun gnus-register-action (action data-header from &optional to method)
  81   (let* ((id (mail-header-id data-header))
  82         (hash-entry (gethash id gnus-registry-hashtb)))
  83     (gnus-message 5 "Registry: article %s %s from %s to %s"
  84              id
  85              (if method "respooling" "going")
  86              (gnus-group-guess-full-name from)
  87              (if to (gnus-group-guess-full-name to) "the Bit Bucket"))
  88     (unless hash-entry
  89       (setq hash-entry (puthash id (list data-header) gnus-registry-hashtb)))
  90     (puthash id (cons (list action from to method)
  91                       (gethash id gnus-registry-hashtb)) gnus-registry-hashtb)))
  92
  93 (defun gnus-register-spool-action (id group)
  94   (gnus-message 5 "Registry: article %s spooled to %s"
  95            id
  96            (gnus-group-prefixed-name
  97             group
  98             gnus-internal-registry-spool-current-method
  99             t))
 100   (puthash id (cons (list 'spool nil group nil)
 101                     (gethash id gnus-registry-hashtb)) gnus-registry-hashtb))
 102
 103 (add-hook 'gnus-summary-article-move-hook 'gnus-register-action) ; also does copy, respool, and crosspost
 104 (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 105 (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 106 (add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
 107
 108 (add-hook 'gnus-save-newsrc-hook 'gnus-registry-translate-to-alist)
 109 (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-translate-from-alist)
 110
 111 ;; TODO: a lot of things
 112
 113 (provide 'gnus-registry)
 114
 115 ;;; gnus-registry.el ends here