| 1 | ;;; gnus-dup.el --- suppression of duplicate articles in Gnus |
| 2 | |
| 3 | ;; Copyright (C) 1996-2012 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 <http://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 | (eval-when-compile (require 'cl)) |
| 33 | |
| 34 | (require 'gnus) |
| 35 | (require 'gnus-art) |
| 36 | |
| 37 | (defgroup gnus-duplicate nil |
| 38 | "Suppression of duplicate articles." |
| 39 | :group 'gnus) |
| 40 | |
| 41 | (defcustom gnus-save-duplicate-list nil |
| 42 | "*If non-nil, save the duplicate list when shutting down Gnus. |
| 43 | If nil, duplicate suppression will only work on duplicates |
| 44 | seen in the same session." |
| 45 | :group 'gnus-duplicate |
| 46 | :type 'boolean) |
| 47 | |
| 48 | (defcustom gnus-duplicate-list-length 10000 |
| 49 | "*The number of Message-IDs to keep in the duplicate suppression list." |
| 50 | :group 'gnus-duplicate |
| 51 | :type 'integer) |
| 52 | |
| 53 | (defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression") |
| 54 | "*The name of the file to store the duplicate suppression list." |
| 55 | :group 'gnus-duplicate |
| 56 | :type 'file) |
| 57 | |
| 58 | ;;; Internal variables |
| 59 | |
| 60 | (defvar gnus-dup-list nil) |
| 61 | (defvar gnus-dup-hashtb nil) |
| 62 | |
| 63 | (defvar gnus-dup-list-dirty nil) |
| 64 | |
| 65 | ;;; |
| 66 | ;;; Starting and stopping |
| 67 | ;;; |
| 68 | |
| 69 | (gnus-add-shutdown 'gnus-dup-close 'gnus) |
| 70 | |
| 71 | (defun gnus-dup-close () |
| 72 | "Possibly save the duplicate suppression list and shut down the subsystem." |
| 73 | (gnus-dup-save) |
| 74 | (setq gnus-dup-list nil |
| 75 | gnus-dup-hashtb nil |
| 76 | gnus-dup-list-dirty nil)) |
| 77 | |
| 78 | (defun gnus-dup-open () |
| 79 | "Possibly read the duplicate suppression list and start the subsystem." |
| 80 | (if gnus-save-duplicate-list |
| 81 | (gnus-dup-read) |
| 82 | (setq gnus-dup-list nil)) |
| 83 | (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length)) |
| 84 | ;; Enter all Message-IDs into the hash table. |
| 85 | (let ((obarray gnus-dup-hashtb)) |
| 86 | (mapc 'intern gnus-dup-list))) |
| 87 | |
| 88 | (defun gnus-dup-read () |
| 89 | "Read the duplicate suppression list." |
| 90 | (setq gnus-dup-list nil) |
| 91 | (when (file-exists-p gnus-duplicate-file) |
| 92 | (load gnus-duplicate-file t t t))) |
| 93 | |
| 94 | (defun gnus-dup-save () |
| 95 | "Save the duplicate suppression list." |
| 96 | (when (and gnus-save-duplicate-list |
| 97 | gnus-dup-list-dirty) |
| 98 | (with-temp-file gnus-duplicate-file |
| 99 | (gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list)))) |
| 100 | (setq gnus-dup-list-dirty nil)) |
| 101 | |
| 102 | ;;; |
| 103 | ;;; Interface functions |
| 104 | ;;; |
| 105 | |
| 106 | (defun gnus-dup-enter-articles () |
| 107 | "Enter articles from the current group for future duplicate suppression." |
| 108 | (unless gnus-dup-list |
| 109 | (gnus-dup-open)) |
| 110 | (setq gnus-dup-list-dirty t) ; mark list for saving |
| 111 | (let (msgid) |
| 112 | ;; Enter the Message-IDs of all read articles into the list |
| 113 | ;; and hash table. |
| 114 | (dolist (datum gnus-newsgroup-data) |
| 115 | (when (and (not (gnus-data-pseudo-p datum)) |
| 116 | (> (gnus-data-number datum) 0) |
| 117 | (not (memq (gnus-data-number datum) gnus-newsgroup-unreads)) |
| 118 | (not (= (gnus-data-mark datum) gnus-canceled-mark)) |
| 119 | (setq msgid (mail-header-id (gnus-data-header datum))) |
| 120 | (not (nnheader-fake-message-id-p msgid)) |
| 121 | (not (intern-soft msgid gnus-dup-hashtb))) |
| 122 | (push msgid gnus-dup-list) |
| 123 | (intern msgid gnus-dup-hashtb)))) |
| 124 | ;; Chop off excess Message-IDs from the list. |
| 125 | (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) |
| 126 | (when end |
| 127 | (mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr end)) |
| 128 | (setcdr end nil)))) |
| 129 | |
| 130 | (defun gnus-dup-suppress-articles () |
| 131 | "Mark duplicate articles as read." |
| 132 | (unless gnus-dup-list |
| 133 | (gnus-dup-open)) |
| 134 | (gnus-message 8 "Suppressing duplicates...") |
| 135 | (let ((auto (and gnus-newsgroup-auto-expire |
| 136 | (memq gnus-duplicate-mark gnus-auto-expirable-marks))) |
| 137 | number) |
| 138 | (dolist (header gnus-newsgroup-headers) |
| 139 | (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb) |
| 140 | (gnus-summary-article-unread-p (mail-header-number header))) |
| 141 | (setq gnus-newsgroup-unreads |
| 142 | (delq (setq number (mail-header-number header)) |
| 143 | gnus-newsgroup-unreads)) |
| 144 | (if (not auto) |
| 145 | (push (cons number gnus-duplicate-mark) gnus-newsgroup-reads) |
| 146 | (push number gnus-newsgroup-expirable) |
| 147 | (push (cons number gnus-expirable-mark) gnus-newsgroup-reads))))) |
| 148 | (gnus-message 8 "Suppressing duplicates...done")) |
| 149 | |
| 150 | (defun gnus-dup-unsuppress-article (article) |
| 151 | "Stop suppression of ARTICLE." |
| 152 | (let* ((header (gnus-data-header (gnus-data-find article))) |
| 153 | (id (when header (mail-header-id header)))) |
| 154 | (when id |
| 155 | (setq gnus-dup-list-dirty t) |
| 156 | (setq gnus-dup-list (delete id gnus-dup-list)) |
| 157 | (unintern id gnus-dup-hashtb)))) |
| 158 | |
| 159 | (provide 'gnus-dup) |
| 160 | |
| 161 | ;;; gnus-dup.el ends here |