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

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