cgit.sxemacs.org Git - gnus/blob - lisp/gnus-dup.el

   1 ;;; gnus-dup.el --- suppression of duplicate articles in Gnus
   2 ;; Copyright (C) 1996 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 (require 'gnus-load)
  34 (require 'gnus-art)
  35 (require 'gnus)
  36
  37 (defvar gnus-save-duplicate-list nil
  38   "*If non-nil, save the duplicate list when shutting down Gnus.
  39 If nil, duplicate suppression will only work on duplicates
  40 seen in the same session.")
  41
  42 (defvar gnus-duplicate-list-length 10000
  43   "*The number of Message-IDs to keep in the duplicate suppression list.")
  44
  45 (defvar gnus-duplicate-file (nnheader-concat gnus-directory "suppression")
  46   "*The name of the file to store the duplicate suppression list.")
  47
  48 ;;; Internal variables
  49
  50 (defvar gnus-dup-list nil)
  51 (defvar gnus-dup-hashtb nil)
  52
  53 ;;;
  54 ;;; Starting and stopping
  55 ;;;
  56
  57 (gnus-add-shutdown 'gnus-dup-close 'gnus)
  58
  59 (defun gnus-dup-close ()
  60   "Possibly save the duplicate suppression list and shut down the subsystem."
  61   (when gnus-save-duplicate-list
  62     (gnus-dup-save))
  63   (setq gnus-dup-list nil
  64         gnus-dup-hashtb nil))
  65
  66 (defun gnus-dup-open ()
  67   "Possibly read the duplicate suppression list and start the subsystem."
  68   (if gnus-save-duplicate-list
  69       (gnus-dup-read)
  70     (setq gnus-dup-list nil))
  71   (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
  72   ;; Enter all Message-IDs into the hash table.
  73   (let ((list gnus-dup-list)
  74         (obarray gnus-dup-hashtb))
  75     (while list
  76       (intern (pop list)))))
  77
  78 (defun gnus-dup-read ()
  79   "Read the duplicate suppression list."
  80   (setq gnus-dup-list nil)
  81   (when (file-exists-p gnus-duplicate-file)
  82     (load gnus-duplicate-file t t t)))
  83
  84 (defun gnus-dup-save ()
  85   "Save the duplicate suppression list."
  86   (nnheader-temp-write gnus-duplicate-file
  87     (gnus-prin1 `(setq gnus-duplicate-file ',gnus-duplicate-file))))
  88
  89 ;;;
  90 ;;; Interface functions
  91 ;;;
  92
  93 (defun gnus-dup-enter-articles ()
  94   "Enter articles from the current group for future duplicate suppression."
  95   (unless gnus-dup-list
  96     (gnus-dup-open))
  97   (let ((data gnus-newsgroup-data)
  98         id)
  99     ;; Enter the Message-IDs of all read articles into the list
 100     ;; and hash table.
 101     (while data
 102       (when (gnus-data-read-p (car data))
 103         (intern (car (push (mail-header-id (gnus-data-header (car data)))
 104                            gnus-dup-list))
 105                 gnus-dup-hashtb))
 106       (pop data))
 107     ;; Chop off excess Message-IDs from the list.
 108     (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
 109       (when end
 110         (setcdr end nil)))))
 111
 112 (defun gnus-dup-suppress-articles ()
 113   "Mark duplicate articles as read."
 114   (unless gnus-dup-list
 115     (gnus-dup-open))
 116   (gnus-message 6 "Suppressing duplicates...")
 117   (let ((headers gnus-newsgroup-headers)
 118         number)
 119     (while headers
 120       (when (intern-soft (mail-header-id (car headers)) gnus-dup-hashtb)
 121         (setq gnus-newsgroup-unreads
 122               (delq (setq number (mail-header-number (car headers)))
 123                     gnus-newsgroup-unreads))
 124         (push (cons number gnus-duplicate-mark)
 125               gnus-newsgroup-reads))
 126       (pop headers)))
 127   (gnus-message 6 "Suppressing duplicates...done"))
 128
 129 (defun gnus-dup-unsuppress-article (article)
 130   "Stop suppression of ARTICLE."
 131   (let ((id (mail-header-id (gnus-data-header (gnus-data-find article)))))
 132     (when id
 133       (setq gnus-dup-list (delete id gnus-dup-list))
 134       (unintern id gnus-dup-hashtb))))
 135
 136 (provide 'gnus-dup)
 137
 138 ;;; gnus-dup.el ends here