lisp/gnus/gnus-dup.el

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