lisp/gnus/gnus-dup.el

   1 ;;; gnus-dup.el --- suppression of duplicate articles in Gnus
   2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; This package tries to mark articles as read the second time the
  27 ;; user reads a copy.  This is useful if the server doesn't support
  28 ;; Xref properly, or if the user reads the same group from several
  29 ;; servers.
  30
  31 ;;; Code:
  32
  33 (eval-when-compile (require 'cl))
  34
  35 (require 'gnus)
  36 (require 'gnus-art)
  37
  38 (defgroup gnus-duplicate nil
  39   "Suppression of duplicate articles."
  40   :group 'gnus)
  41
  42 (defcustom gnus-save-duplicate-list nil
  43   "*If non-nil, save the duplicate list when shutting down Gnus.
  44 If nil, duplicate suppression will only work on duplicates
  45 seen in the same session."
  46   :group 'gnus-duplicate
  47   :type 'boolean)
  48
  49 (defcustom gnus-duplicate-list-length 10000
  50   "*The number of Message-IDs to keep in the duplicate suppression list."
  51   :group 'gnus-duplicate
  52   :type 'integer)
  53
  54 (defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression")
  55   "*The name of the file to store the duplicate suppression list."
  56   :group 'gnus-duplicate
  57   :type 'file)
  58
  59 ;;; Internal variables
  60
  61 (defvar gnus-dup-list nil)
  62 (defvar gnus-dup-hashtb nil)
  63
  64 (defvar gnus-dup-list-dirty nil)
  65
  66 ;;;
  67 ;;; Starting and stopping
  68 ;;;
  69
  70 (gnus-add-shutdown 'gnus-dup-close 'gnus)
  71
  72 (defun gnus-dup-close ()
  73   "Possibly save the duplicate suppression list and shut down the subsystem."
  74   (gnus-dup-save)
  75   (setq gnus-dup-list nil
  76         gnus-dup-hashtb nil
  77         gnus-dup-list-dirty nil))
  78
  79 (defun gnus-dup-open ()
  80   "Possibly read the duplicate suppression list and start the subsystem."
  81   (if gnus-save-duplicate-list
  82       (gnus-dup-read)
  83     (setq gnus-dup-list nil))
  84   (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
  85   ;; Enter all Message-IDs into the hash table.
  86   (let ((list gnus-dup-list)
  87         (obarray gnus-dup-hashtb))
  88     (while list
  89       (intern (pop list)))))
  90
  91 (defun gnus-dup-read ()
  92   "Read the duplicate suppression list."
  93   (setq gnus-dup-list nil)
  94   (when (file-exists-p gnus-duplicate-file)
  95     (load gnus-duplicate-file t t t)))
  96
  97 (defun gnus-dup-save ()
  98   "Save the duplicate suppression list."
  99   (when (and gnus-save-duplicate-list
 100              gnus-dup-list-dirty)
 101     (nnheader-temp-write gnus-duplicate-file
 102       (gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list))))
 103   (setq gnus-dup-list-dirty nil))
 104
 105 ;;;
 106 ;;; Interface functions
 107 ;;;
 108
 109 (defun gnus-dup-enter-articles ()
 110   "Enter articles from the current group for future duplicate suppression."
 111   (unless gnus-dup-list
 112     (gnus-dup-open))
 113   (setq gnus-dup-list-dirty t)          ; mark list for saving
 114   (let ((data gnus-newsgroup-data)
 115         datum msgid)
 116     ;; Enter the Message-IDs of all read articles into the list
 117     ;; and hash table.
 118     (while (setq datum (pop data))
 119       (when (and (not (gnus-data-pseudo-p datum))
 120                  (> (gnus-data-number datum) 0)
 121                  (gnus-data-read-p datum)
 122                  (not (= (gnus-data-mark datum) gnus-canceled-mark))
 123                  (setq msgid (mail-header-id (gnus-data-header datum)))
 124                  (not (nnheader-fake-message-id-p msgid))
 125                  (not (intern-soft msgid gnus-dup-hashtb)))
 126         (push msgid gnus-dup-list)
 127         (intern msgid gnus-dup-hashtb))))
 128   ;; Chop off excess Message-IDs from the list.
 129   (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
 130     (when end
 131       (setcdr end nil))))
 132
 133 (defun gnus-dup-suppress-articles ()
 134   "Mark duplicate articles as read."
 135   (unless gnus-dup-list
 136     (gnus-dup-open))
 137   (gnus-message 6 "Suppressing duplicates...")
 138   (let ((headers gnus-newsgroup-headers)
 139         number header)
 140     (while (setq header (pop headers))
 141       (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb)
 142                  (gnus-summary-article-unread-p (mail-header-number header)))
 143         (setq gnus-newsgroup-unreads
 144               (delq (setq number (mail-header-number header))
 145                     gnus-newsgroup-unreads))
 146         (push (cons number gnus-duplicate-mark)
 147               gnus-newsgroup-reads))))
 148   (gnus-message 6 "Suppressing duplicates...done"))
 149
 150 (defun gnus-dup-unsuppress-article (article)
 151   "Stop suppression of ARTICLE."
 152   (let ((id (mail-header-id (gnus-data-header (gnus-data-find article)))))
 153     (when id
 154       (setq gnus-dup-list-dirty t)
 155       (setq gnus-dup-list (delete id gnus-dup-list))
 156       (unintern id gnus-dup-hashtb))))
 157
 158 (provide 'gnus-dup)
 159
 160 ;;; gnus-dup.el ends here