X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-nocem.el;h=0364c963a2706011f60c1efee325d7f5b14645fa;hb=74a489ff1213794152d6e13f7a11e16c89f62602;hp=80f04b0046fc95094a723b593756b7db62188006;hpb=28873a222f49d38b3e8610d0b55111fb46afe414;p=gnus diff --git a/lisp/gnus-nocem.el b/lisp/gnus-nocem.el index 80f04b004..0364c963a 100644 --- a/lisp/gnus-nocem.el +++ b/lisp/gnus-nocem.el @@ -1,15 +1,17 @@ ;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen +;; Copyright (C) 1995, 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 @@ -17,9 +19,7 @@ ;; 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: @@ -34,29 +34,61 @@ (require 'gnus-range) (defgroup gnus-nocem nil - "NoCeM pseudo-cancellation treatment" + "NoCeM pseudo-cancellation treatment." :group 'gnus-score) (defcustom gnus-nocem-groups - '("news.lists.filters" "news.admin.net-abuse.bulletins" - "alt.nocem.misc" "news.admin.net-abuse.announce") - "List of groups that will be searched for NoCeM messages." + '("news.lists.filters" "alt.nocem.misc") + "*List of groups that will be searched for NoCeM messages." :group 'gnus-nocem + :version "23.1" :type '(repeat (string :tag "Group"))) (defcustom gnus-nocem-issuers - '("AutoMoose-1" "Automoose-1" ; CancelMoose[tm] - "rbraver@ohww.norman.ok.us" ; Robert Braver - "clewis@ferret.ocunix.on.ca" ; Chris Lewis - "jem@xpat.com" ; Despammer from Korea - "snowhare@xmission.com" ; Benjamin "Snowhare" Franz - "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM! - ) - "List of NoCeM issuers to pay attention to. - -This can also be a list of `(ISSUER CONDITIONS)' elements." + '("Adri Verhoef" + "alba-nocem@albasani.net" + "bleachbot@httrack.com" + "news@arcor-online.net" + "news@uni-berlin.de" + "nocem@arcor.de" + "pgpmoose@killfile.org" + "xjsppl@gmx.de") + "*List of NoCeM issuers to pay attention to. + +This can also be a list of `(ISSUER CONDITION ...)' elements. + +See for an +issuer registry." :group 'gnus-nocem - :type '(repeat string)) + :link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html") + :version "23.1" + :type '(repeat (cons :format "%v" (string :tag "Issuer") + (repeat :tag "Condition" + (group (checklist :inline t (const not)) + (regexp :tag "Type" :value ".*"))))) + :get (lambda (symbol) + (mapcar (lambda (elem) + (if (consp elem) + (cons (car elem) + (mapcar (lambda (elt) + (if (consp elt) elt (list elt))) + (cdr elem))) + (list elem))) + (default-value symbol))) + :set (lambda (symbol value) + (custom-set-default + symbol + (mapcar (lambda (elem) + (if (consp elem) + (if (cdr elem) + (mapcar (lambda (elt) + (if (consp elt) + (if (cdr elt) elt (car elt)) + elt)) + elem) + (car elem)) + elem)) + value)))) (defcustom gnus-nocem-directory (nnheader-concat gnus-article-save-directory "NoCeM/") @@ -69,19 +101,45 @@ This can also be a list of `(ISSUER CONDITIONS)' elements." :group 'gnus-nocem :type 'integer) -(defcustom gnus-nocem-verifyer 'mc-verify +(defcustom gnus-nocem-verifyer (if (locate-library "epg") + 'gnus-nocem-epg-verify + 'pgg-verify) "*Function called to verify that the NoCeM message is valid. -One likely value is `mc-verify'. If the function in this variable -isn't bound, the message will be used unconditionally." +If the function in this variable isn't bound, the message will be used +unconditionally." :group 'gnus-nocem - :type '(radio (function-item mc-verify) - (function :tag "other"))) + :version "23.1" + :type '(radio (function-item gnus-nocem-epg-verify) + (function-item pgg-verify) + (function-item mc-verify) + (function :tag "other")) + :set (lambda (symbol value) + (custom-set-default symbol + (if (and (eq value 'gnus-nocem-epg-verify) + (not (locate-library "epg"))) + 'pgg-verify + value)))) (defcustom gnus-nocem-liberal-fetch nil "*If t try to fetch all messages which have @@NCM in the subject. Otherwise don't fetch messages which have references or whose message-id -matches an previously scanned and verified nocem message." +matches a previously scanned and verified nocem message." + :group 'gnus-nocem + :type 'boolean) + +(defcustom gnus-nocem-check-article-limit 500 + "*If non-nil, the maximum number of articles to check in any NoCeM group." + :group 'gnus-nocem + :version "21.1" + :type '(choice (const :tag "unlimited" nil) + (integer 1000))) + +(defcustom gnus-nocem-check-from t + "Non-nil means check for valid issuers in message bodies. +Otherwise don't bother fetching articles unless their author matches a +valid issuer, which is much faster if you are selective about the issuers." :group 'gnus-nocem + :version "21.1" :type 'boolean) ;;; Internal variables @@ -108,21 +166,22 @@ matches an previously scanned and verified nocem message." "Real-name mappings of subscribed groups.") (defun gnus-fill-real-hashtb () - "Fill up a hash table with the real-name mappings from the user's -active file." - (setq gnus-nocem-real-group-hashtb (gnus-make-hashtable - (length gnus-newsrc-alist))) + "Fill up a hash table with the real-name mappings from the user's active file." + (if (hash-table-p gnus-nocem-real-group-hashtb) + (clrhash gnus-nocem-real-group-hashtb) + (setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal))) (mapcar (lambda (group) (setq group (gnus-group-real-name (car group))) - (gnus-sethash group t gnus-nocem-real-group-hashtb)) + (puthash group t gnus-nocem-real-group-hashtb)) gnus-newsrc-alist)) +;;;###autoload (defun gnus-nocem-scan-groups () "Scan all NoCeM groups for new NoCeM messages." (interactive) (let ((groups gnus-nocem-groups) (gnus-inhibit-demon t) - group active gactive articles) + group active gactive articles check-headers) (gnus-make-directory gnus-nocem-directory) ;; Load any previous NoCeM headers. (gnus-nocem-load-cache) @@ -147,7 +206,7 @@ active file." (save-excursion (let ((dependencies (make-vector 10 nil)) headers header) - (nnheader-temp-write nil + (with-temp-buffer (setq headers (if (eq 'nov (gnus-retrieve-headers @@ -168,13 +227,34 @@ active file." ;; are not allowed to have references, so we can ;; ignore scanning followups. (and (string-match "@@NCM" (mail-header-subject header)) + (and gnus-nocem-check-from + (let ((case-fold-search t)) + (catch 'ok + (mapc + (lambda (author) + (if (consp author) + (setq author (car author))) + (if (string-match + author (mail-header-from header)) + (throw 'ok t))) + gnus-nocem-issuers) + nil))) (or gnus-nocem-liberal-fetch (and (or (string= "" (mail-header-references header)) (null (mail-header-references header))) (not (member (mail-header-message-id header) gnus-nocem-seen-message-ids)))) - (gnus-nocem-check-article group header))))))) + (push header check-headers))) + (setq check-headers (last (nreverse check-headers) + gnus-nocem-check-article-limit)) + (let ((i 0) + (len (length check-headers))) + (dolist (h check-headers) + (gnus-message + 7 "Checking article %d in %s for NoCeM (%d of %d)..." + (mail-header-number h) group (incf i) len) + (gnus-nocem-check-article group h))))))) (setq gnus-nocem-active (cons (list group gactive) (delq (assoc group gnus-nocem-active) @@ -186,19 +266,22 @@ active file." (defun gnus-nocem-check-article (group header) "Check whether the current article is an NCM article and that we want it." ;; Get the article. - (gnus-message 7 "Checking article %d in %s for NoCeM..." - (mail-header-number header) group) (let ((date (mail-header-date header)) + (gnus-newsgroup-name group) issuer b e type) (when (or (not date) - (nnmail-time-less - (nnmail-time-since (nnmail-date-to-time date)) - (nnmail-days-to-time gnus-nocem-expiry-wait))) + (time-less-p + (time-since (date-to-time date)) + (days-to-time gnus-nocem-expiry-wait))) (gnus-request-article-this-buffer (mail-header-number header) group) (goto-char (point-min)) - (when (re-search-forward "-----BEGIN PGP MESSAGE-----" nil t) + (when (re-search-forward + "-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----" + nil t) (delete-region (point-min) (match-beginning 0))) - (when (re-search-forward "-----END PGP MESSAGE-----\n?" nil t) + (when (re-search-forward + "-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?" + nil t) (delete-region (match-end 0) (point-max))) (goto-char (point-min)) ;; The article has to have proper NoCeM headers. @@ -207,7 +290,7 @@ active file." ;; We get the name of the issuer. (narrow-to-region b e) (setq issuer (mail-fetch-field "issuer") - type (mail-fetch-field "issuer")) + type (mail-fetch-field "type")) (widen) (if (not (gnus-nocem-message-wanted-p issuer type)) (message "invalid NoCeM issuer: %s" issuer) @@ -228,18 +311,20 @@ active file." (while (setq condition (pop conditions)) (cond ((stringp condition) - (setq wanted (string-match condition) type)) + (when (string-match condition type) + (setq wanted t))) ((and (consp condition) (eq (car condition) 'not) (stringp (cadr condition))) - (setq wanted (not (string-match (cadr condition) type)))) + (when (string-match (cadr condition) type) + (setq wanted nil))) (t (error "Invalid NoCeM condition: %S" condition)))) wanted)))) (defun gnus-nocem-verify-issuer (person) "Verify using PGP that the canceler is who she says she is." - (if (fboundp gnus-nocem-verifyer) + (if (functionp gnus-nocem-verifyer) (ignore-errors (funcall gnus-nocem-verifyer)) ;; If we don't have Mailcrypt, then we use the message anyway. @@ -258,30 +343,26 @@ active file." (while (search-forward "\t" nil t) (cond ((not (ignore-errors - (setq group (let ((obarray gnus-active-hashtb)) (read buf))))) + (setq group (gnus-group-real-name (symbol-name (read buf)))) + (gethash group gnus-nocem-real-group-hashtb))) ;; An error. ) - ((not (symbolp group)) - ;; Ignore invalid entries. - ) - ((not (boundp group)) - ;; Make sure all entries in the hashtb are bound. - (set group nil)) (t - (when (gnus-gethash (gnus-group-real-name (symbol-name group)) - gnus-nocem-real-group-hashtb) - ;; Valid group. - (beginning-of-line) - (while (= (following-char) ?\t) - (forward-line -1)) - (setq id (buffer-substring (point) (1- (search-forward "\t")))) - (unless (gnus-gethash id gnus-nocem-hashtb) - ;; only store if not already present - (gnus-sethash id t gnus-nocem-hashtb) - (push id ncm)) - (forward-line 1) - (while (= (following-char) ?\t) - (forward-line 1)))))) + ;; Valid group. + (beginning-of-line) + (while (eq (char-after) ?\t) + (forward-line -1)) + (setq id (buffer-substring (point) (1- (search-forward "\t")))) + (unless (if (hash-table-p gnus-nocem-hashtb) + (gethash id gnus-nocem-hashtb) + (setq gnus-nocem-hashtb (make-hash-table :test 'equal)) + nil) + ;; only store if not already present + (puthash id t gnus-nocem-hashtb) + (push id ncm)) + (forward-line 1) + (while (eq (char-after) ?\t) + (forward-line 1))))) (when ncm (setq gnus-nocem-touched-alist t) (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time) @@ -289,6 +370,7 @@ active file." gnus-nocem-alist)) t))) +;;;###autoload (defun gnus-nocem-load-cache () "Load the NoCeM cache." (interactive) @@ -303,13 +385,13 @@ active file." "Save the NoCeM cache." (when (and gnus-nocem-alist gnus-nocem-touched-alist) - (nnheader-temp-write (gnus-nocem-cache-file) + (with-temp-file (gnus-nocem-cache-file) (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist))) (setq gnus-nocem-touched-alist nil))) (defun gnus-nocem-save-active () "Save the NoCeM active file." - (nnheader-temp-write (gnus-nocem-active-file) + (with-temp-file (gnus-nocem-active-file) (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active)))) (defun gnus-nocem-alist-to-hashtb () @@ -317,18 +399,20 @@ active file." (let* ((alist gnus-nocem-alist) (pprev (cons nil alist)) (prev pprev) - (expiry (nnmail-days-to-time gnus-nocem-expiry-wait)) + (expiry (days-to-time gnus-nocem-expiry-wait)) entry) - (setq gnus-nocem-hashtb (gnus-make-hashtable (* (length alist) 51))) + (if (hash-table-p gnus-nocem-hashtb) + (clrhash gnus-nocem-hashtb) + (setq gnus-nocem-hashtb (make-hash-table :test 'equal))) (while (setq entry (car alist)) - (if (not (nnmail-time-less (nnmail-time-since (car entry)) expiry)) + (if (not (time-less-p (time-since (car entry)) expiry)) ;; This entry has expired, so we remove it. (setcdr prev (cdr alist)) (setq prev alist) ;; This is ok, so we enter it into the hashtable. (setq entry (cdr entry)) (while entry - (gnus-sethash (car entry) t gnus-nocem-hashtb) + (puthash (car entry) t gnus-nocem-hashtb) (setq entry (cdr entry)))) (setq alist (cdr alist))))) @@ -345,7 +429,23 @@ active file." (defun gnus-nocem-unwanted-article-p (id) "Say whether article ID in the current group is wanted." - (gnus-gethash id gnus-nocem-hashtb)) + (and gnus-nocem-hashtb + (gethash id gnus-nocem-hashtb))) + +(autoload 'epg-make-context "epg") +(eval-when-compile + (autoload 'epg-verify-string "epg") + (autoload 'epg-context-result-for "epg") + (autoload 'epg-signature-status "epg")) + +(defun gnus-nocem-epg-verify () + "Return t if EasyPG verifies a signed message in the current buffer." + (let ((context (epg-make-context 'OpenPGP)) + result) + (epg-verify-string context (buffer-string)) + (and (setq result (epg-context-result-for context 'verify)) + (not (cdr result)) + (eq (epg-signature-status (car result)) 'good)))) (provide 'gnus-nocem)