lisp/gnus/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 ((obarray gnus-dup-hashtb))
  89     (mapc 'intern gnus-dup-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     (with-temp-file 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 (msgid)
 115     ;; Enter the Message-IDs of all read articles into the list
 116     ;; and hash table.
 117     (dolist (datum gnus-newsgroup-data)
 118       (when (and (not (gnus-data-pseudo-p datum))
 119                  (> (gnus-data-number datum) 0)
 120                  (not (memq (gnus-data-number datum) gnus-newsgroup-unreads))
 121                  (not (= (gnus-data-mark datum) gnus-canceled-mark))
 122                  (setq msgid (mail-header-id (gnus-data-header datum)))
 123                  (not (nnheader-fake-message-id-p msgid))
 124                  (not (intern-soft msgid gnus-dup-hashtb)))
 125         (push msgid gnus-dup-list)
 126         (intern msgid gnus-dup-hashtb))))
 127   ;; Chop off excess Message-IDs from the list.
 128   (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
 129     (when end
 130       (mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr 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 ((auto (and gnus-newsgroup-auto-expire
 139                    (memq gnus-duplicate-mark gnus-auto-expirable-marks)))
 140         number)
 141     (dolist (header gnus-newsgroup-headers)
 142       (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb)
 143                  (gnus-summary-article-unread-p (mail-header-number header)))
 144         (setq gnus-newsgroup-unreads
 145               (delq (setq number (mail-header-number header))
 146                     gnus-newsgroup-unreads))
 147         (if (not auto)
 148             (push (cons number gnus-duplicate-mark) gnus-newsgroup-reads)
 149           (push number gnus-newsgroup-expirable)
 150           (push (cons number gnus-expirable-mark) gnus-newsgroup-reads)))))
 151   (gnus-message 6 "Suppressing duplicates...done"))
 152
 153 (defun gnus-dup-unsuppress-article (article)
 154   "Stop suppression of ARTICLE."
 155   (let* ((header (gnus-data-header (gnus-data-find article)))
 156          (id     (when header (mail-header-id header))))
 157     (when id
 158       (setq gnus-dup-list-dirty t)
 159       (setq gnus-dup-list (delete id gnus-dup-list))
 160       (unintern id gnus-dup-hashtb))))
 161
 162 (provide 'gnus-dup)
 163
 164 ;; arch-tag: 903e94db-7b00-4d19-83ee-cf34a81fa5fb
 165 ;;; gnus-dup.el ends here