X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-dup.el;h=be909ccd798301c87636c86e28b9fffc9212a30e;hp=c2cc879804217da8e6d9c7aacf8a3117d402d533;hb=ca3685c9e20ae1fe87c3147c6b6eb9b4d18f9ccb;hpb=11bbb9dc78aaca5a11345d65515910054e2b2bd1 diff --git a/lisp/gnus-dup.el b/lisp/gnus-dup.el index c2cc87980..be909ccd7 100644 --- a/lisp/gnus-dup.el +++ b/lisp/gnus-dup.el @@ -1,25 +1,25 @@ ;;; gnus-dup.el --- suppression of duplicate articles in Gnus -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -30,26 +30,39 @@ ;;; Code: -(require 'gnus-load) -(require 'gnus-art) +(eval-when-compile (require 'cl)) + (require 'gnus) +(require 'gnus-art) + +(defgroup gnus-duplicate nil + "Suppression of duplicate articles." + :group 'gnus) -(defvar gnus-save-duplicate-list nil +(defcustom gnus-save-duplicate-list nil "*If non-nil, save the duplicate list when shutting down Gnus. If nil, duplicate suppression will only work on duplicates -seen in the same session.") +seen in the same session." + :group 'gnus-duplicate + :type 'boolean) -(defvar gnus-duplicate-list-length 10000 - "*The number of Message-IDs to keep in the duplicate suppression list.") +(defcustom gnus-duplicate-list-length 10000 + "*The number of Message-IDs to keep in the duplicate suppression list." + :group 'gnus-duplicate + :type 'integer) -(defvar gnus-duplicate-file (nnheader-concat gnus-directory "suppression") - "*The name of the file to store the duplicate suppression list.") +(defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression") + "*The name of the file to store the duplicate suppression list." + :group 'gnus-duplicate + :type 'file) ;;; Internal variables (defvar gnus-dup-list nil) (defvar gnus-dup-hashtb nil) +(defvar gnus-dup-list-dirty nil) + ;;; ;;; Starting and stopping ;;; @@ -58,10 +71,10 @@ seen in the same session.") (defun gnus-dup-close () "Possibly save the duplicate suppression list and shut down the subsystem." - (when gnus-save-duplicate-list - (gnus-dup-save)) + (gnus-dup-save) (setq gnus-dup-list nil - gnus-dup-hashtb nil)) + gnus-dup-hashtb nil + gnus-dup-list-dirty nil)) (defun gnus-dup-open () "Possibly read the duplicate suppression list and start the subsystem." @@ -70,10 +83,8 @@ seen in the same session.") (setq gnus-dup-list nil)) (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length)) ;; Enter all Message-IDs into the hash table. - (let ((list gnus-dup-list) - (obarray gnus-dup-hashtb)) - (while list - (intern (pop list))))) + (let ((obarray gnus-dup-hashtb)) + (mapc 'intern gnus-dup-list))) (defun gnus-dup-read () "Read the duplicate suppression list." @@ -83,9 +94,11 @@ seen in the same session.") (defun gnus-dup-save () "Save the duplicate suppression list." - (nnheader-temp-write gnus-duplicate-file - (prin1 `(setq gnus-duplicate-file ',gnus-duplicate-file) - (current-buffer)))) + (when (and gnus-save-duplicate-list + gnus-dup-list-dirty) + (with-temp-file gnus-duplicate-file + (gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list)))) + (setq gnus-dup-list-dirty nil)) ;;; ;;; Interface functions @@ -95,42 +108,52 @@ seen in the same session.") "Enter articles from the current group for future duplicate suppression." (unless gnus-dup-list (gnus-dup-open)) - (let ((data gnus-newsgroup-data) - id) + (setq gnus-dup-list-dirty t) ; mark list for saving + (let (msgid) ;; Enter the Message-IDs of all read articles into the list ;; and hash table. - (while data - (when (gnus-data-read-p (car data)) - (intern (car (push (mail-header-id (gnus-data-header (car data))) - gnus-dup-list)) - gnus-dup-hashtb)) - (pop data)) - ;; Chop off excess Message-IDs from the list. - (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) - (when end - (setcdr end nil))))) + (dolist (datum gnus-newsgroup-data) + (when (and (not (gnus-data-pseudo-p datum)) + (> (gnus-data-number datum) 0) + (not (memq (gnus-data-number datum) gnus-newsgroup-unreads)) + (not (= (gnus-data-mark datum) gnus-canceled-mark)) + (setq msgid (mail-header-id (gnus-data-header datum))) + (not (nnheader-fake-message-id-p msgid)) + (not (intern-soft msgid gnus-dup-hashtb))) + (push msgid gnus-dup-list) + (intern msgid gnus-dup-hashtb)))) + ;; Chop off excess Message-IDs from the list. + (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) + (when end + (mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr end)) + (setcdr end nil)))) (defun gnus-dup-suppress-articles () "Mark duplicate articles as read." (unless gnus-dup-list (gnus-dup-open)) (gnus-message 6 "Suppressing duplicates...") - (let ((headers gnus-newsgroup-headers) + (let ((auto (and gnus-newsgroup-auto-expire + (memq gnus-duplicate-mark gnus-auto-expirable-marks))) number) - (while headers - (when (intern-soft (mail-header-id (car headers)) gnus-dup-hashtb) - (setq gnus-newsgroup-unreads - (delq (setq number (mail-header-number (car headers))) + (dolist (header gnus-newsgroup-headers) + (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb) + (gnus-summary-article-unread-p (mail-header-number header))) + (setq gnus-newsgroup-unreads + (delq (setq number (mail-header-number header)) gnus-newsgroup-unreads)) - (push (cons number gnus-duplicate-mark) - gnus-newsgroup-reads)) - (pop headers))) + (if (not auto) + (push (cons number gnus-duplicate-mark) gnus-newsgroup-reads) + (push number gnus-newsgroup-expirable) + (push (cons number gnus-expirable-mark) gnus-newsgroup-reads))))) (gnus-message 6 "Suppressing duplicates...done")) (defun gnus-dup-unsuppress-article (article) "Stop suppression of ARTICLE." - (let ((id (mail-header-id (gnus-data-header (gnus-data-find article))))) + (let* ((header (gnus-data-header (gnus-data-find article))) + (id (when header (mail-header-id header)))) (when id + (setq gnus-dup-list-dirty t) (setq gnus-dup-list (delete id gnus-dup-list)) (unintern id gnus-dup-hashtb))))