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 (defvar gnus-dup-list-dirty nil)
  54
  55 ;;;
  56 ;;; Starting and stopping
  57 ;;;
  58
  59 (gnus-add-shutdown 'gnus-dup-close 'gnus)
  60
  61 (defun gnus-dup-close ()
  62   "Possibly save the duplicate suppression list and shut down the subsystem."
  63   (gnus-dup-save)
  64   (setq gnus-dup-list nil
  65         gnus-dup-hashtb nil
  66         gnus-dup-list-dirty nil))
  67
  68 (defun gnus-dup-open ()
  69   "Possibly read the duplicate suppression list and start the subsystem."
  70   (if gnus-save-duplicate-list
  71       (gnus-dup-read)
  72     (setq gnus-dup-list nil))
  73   (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
  74   ;; Enter all Message-IDs into the hash table.
  75   (let ((list gnus-dup-list)
  76         (obarray gnus-dup-hashtb))
  77     (while list
  78       (intern (pop list)))))
  79
  80 (defun gnus-dup-read ()
  81   "Read the duplicate suppression list."
  82   (setq gnus-dup-list nil)
  83   (when (file-exists-p gnus-duplicate-file)
  84     (load gnus-duplicate-file t t t)))
  85
  86 (defun gnus-dup-save ()
  87   "Save the duplicate suppression list."
  88   (when (and gnus-save-duplicate-list
  89              gnus-dup-list-dirty)
  90     (nnheader-temp-write gnus-duplicate-file
  91       (gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list))))
  92   (setq gnus-dup-list-dirty nil))
  93
  94 ;;;
  95 ;;; Interface functions
  96 ;;;
  97
  98 (defun gnus-dup-enter-articles ()
  99   "Enter articles from the current group for future duplicate suppression."
 100   (unless gnus-dup-list
 101     (gnus-dup-open))
 102   (setq gnus-dup-list-dirty t)          ; mark list for saving
 103   (let ((data gnus-newsgroup-data)
 104         datum)
 105     ;; Enter the Message-IDs of all read articles into the list
 106     ;; and hash table.
 107     (while (setq datum (pop data))
 108       (when (and (not (gnus-data-pseudo-p datum))
 109                  (gnus-data-read-p datum))
 110         (intern (car (push (mail-header-id (gnus-data-header datum))
 111                            gnus-dup-list))
 112                 gnus-dup-hashtb))))
 113   ;; Chop off excess Message-IDs from the list.
 114   (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
 115     (when end
 116       (setcdr end nil))))
 117
 118 (defun gnus-dup-suppress-articles ()
 119   "Mark duplicate articles as read."
 120   (unless gnus-dup-list
 121     (gnus-dup-open))
 122   (gnus-message 6 "Suppressing duplicates...")
 123   (let ((headers gnus-newsgroup-headers)
 124         number header)
 125     (while (setq header (pop headers))
 126       (when (intern-soft (mail-header-id header) gnus-dup-hashtb)
 127         (setq gnus-newsgroup-unreads
 128               (delq (setq number (mail-header-number header))
 129                     gnus-newsgroup-unreads))
 130         (push (cons number gnus-duplicate-mark)
 131               gnus-newsgroup-reads))))
 132   (gnus-message 6 "Suppressing duplicates...done"))
 133
 134 (defun gnus-dup-unsuppress-article (article)
 135   "Stop suppression of ARTICLE."
 136   (let ((id (mail-header-id (gnus-data-header (gnus-data-find article)))))
 137     (when id
 138       (setq gnus-dup-list-dirty t)
 139       (setq gnus-dup-list (delete id gnus-dup-list))
 140       (unintern id gnus-dup-hashtb))))
 141
 142 (provide 'gnus-dup)
 143
 144 ;;; gnus-dup.el ends here