# HG changeset patch # User Glenn Morris # Date 1233370228 0 # Node ID 977623d6c580c5d6fdd766288d8fb9a3394ef087 # Parent d8e498f2252370c1e01797666b27e27c8acc5dbf Tidy up commentary. (rmail-current-message): Remove unneeded declaration. (uce-message-text, uce-default-headers): Fix custom type. (rmail-buffer, rmail-msg-is-pruned): Declare. (uce-reply-to-uce): Add autoload cookie. Doc fix. Update for mbox Rmail. diff -r d8e498f22523 -r 977623d6c580 lisp/mail/uce.el --- a/lisp/mail/uce.el Sat Jan 31 02:47:50 2009 +0000 +++ b/lisp/mail/uce.el Sat Jan 31 02:50:28 2009 +0000 @@ -1,11 +1,11 @@ ;;; uce.el --- facilitate reply to unsolicited commercial email -;; Copyright (C) 1996, 1998, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009 Free Software Foundation, Inc. ;; Author: stanislav shalunov ;; Created: 10 Dec 1996 -;; Keywords: uce, unsolicited commercial email +;; Keywords: mail, uce, unsolicited commercial email ;; This file is part of GNU Emacs. @@ -24,43 +24,68 @@ ;;; Commentary: -;; Code in this file provides semi-automatic means of replying to -;; UCE's you might get. It works currently only with Rmail and Gnus. -;; If you would like to make it work with other mail readers, -;; Rmail-specific section is marked below. If you want to play with -;; code, please let me know about your changes so I can incorporate -;; them. I'd appreciate it. +;; The code in this file provides a semi-automatic means of replying +;; to unsolicited commercial email (UCE) you might get. Currently, it +;; only works with Rmail and Gnus. If you would like to make it work +;; with other mail readers, see the mail-client dependent section of +;; uce-reply-to-uce. Please let me know about your changes so I can +;; incorporate them. I'd appreciate it. -;; Function uce-reply-to-uce, if called when current message in RMAIL -;; buffer is a UCE, will setup *mail* buffer in the following way: it -;; scans full headers of message for 1) normal return address of -;; sender (From, Reply-To lines); and puts these addresses into To: -;; header, it also puts abuse@offenders.host address there 2) mailhub -;; that first saw this message; and puts address of its postmaster -;; into To: header 3) finally, it looks at Message-Id and adds -;; posmaster of that host to the list of addresses. +;; The command uce-reply-to-uce, if called when the current message +;; buffer is a UCE, will setup a reply *mail* buffer as follows. It +;; scans the full headers of the message for: 1) the normal return +;; address of the sender (From, Reply-To lines), and puts these +;; addresses into the To: header, along with abuse@offenders.host; 2) +;; the mailhub that first saw this message, and adds the address of +;; its postmaster into the To: header; and 3), finally, it looks at +;; the Message-Id and adds the postmaster of that host to the list of +;; addresses. -;; Then, we add "Errors-To: nobody@localhost" header, so that if some -;; of these addresses are not actually correct, we will never see +;; Then, we add an "Errors-To: nobody@localhost" header, so that if +;; some of these addresses are not actually correct, we will never see ;; bounced mail. Also, mail-self-blind and mail-archive-file-name ;; take no effect: the ideology is that we don't want to save junk or ;; replies to junk. -;; Then we put template into buffer (customizable message that -;; explains what has happened), customizable signature, and the +;; Then we insert a template into the buffer (a customizable message +;; that explains what has happened), customizable signature, and the ;; original message with full headers and envelope for postmasters. -;; Then buffer is left for editing. +;; Then the buffer is left for editing. + +;; The reason that the function uce-reply-to-uce is mail-client +;; dependent is that we want the full headers of the original message, +;; nothing stripped. If we use the normal means of inserting the +;; original message into the *mail* buffer, headers like Received: +;; (not really headers, but envelope lines) will be stripped, while +;; they bear valuable information for us and postmasters. I do wish +;; that there would be some portable way to write this function, but I +;; am not aware of any. + +;; Usage: -;; The reason that function uce-reply-to-uce is Rmail dependant is -;; that we want full headers of the original message, nothing -;; stripped. If we use normal means of inserting of the original -;; message into *mail* buffer headers like Received: (not really -;; headers, but envelope lines) will be stripped while they bear -;; valuable for us and postmasters information. I do wish that there -;; would be some way to write this function in some portable way, but -;; I am not aware of any. +;; Place uce.el in your load-path (and optionally byte-compile it). +;; Add the following line to your ~/.emacs: +;; (autoload 'uce-reply-to-uce "uce" "Reply to UCEs" t nil) +;; If you want to use it with Gnus rather than Rmail: +;; (setq uce-mail-reader 'gnus) + +;; Options: + +;; uce-message-text is a template that will be inserted into buffer. +;; It has a reasonable default. If you want to write some scarier +;; one, please do so and send it to me. Please keep it polite. -;;; Change log: +;; uce-signature behaves just like mail-signature. If nil, nothing is +;; inserted, if t, file ~/.signature is used, if a string, its +;; contents are inserted into buffer. + +;; uce-uce-separator is a line that separates your message from the +;; UCE that you enclose. + +;; uce-subject-line will be used as the subject of the outgoing message. + + +;;; Change Log: ;; Dec 10, 1996 -- posted draft version to gnu.sources.emacs @@ -83,39 +108,11 @@ ;; latest Gnus. Lars told him it should work for all versions of Gnus ;; younger than three years. -;; Setup: - -;; Add the following line to your ~/.emacs: - -;; (autoload 'uce-reply-to-uce "uce" "Reply to UCEs" t nil) - -;; If you want to use it with Gnus also use - -;; (setq uce-mail-reader 'gnus) - -;; store this file (uce.el) somewhere in load-path and byte-compile it. - -;;; Variables: - -;; uce-message-text is template that will be inserted into buffer. It -;; has reasonable default. If you want to write some scarier one, -;; please do so and send it to me. Please keep it polite. - -;; uce-signature behaves just like mail-signature. If nil, nothing is -;; inserted, if t, file ~/.signature is used, if a string, its -;; contents are inserted into buffer. - -;; uce-uce-separator is line that separates your message from the UCE -;; that you enclose. - -;; uce-subject-line will be used as subject of outgoing message. If -;; nil, left blank. ;;; Code: (defvar gnus-original-article-buffer) (defvar mail-reply-buffer) -(defvar rmail-current-message) (require 'sendmail) ;; Those sections of code which are dependent upon @@ -184,7 +181,7 @@ up, it might be a good idea to actually use this feature. Value nil means insert no text by default, lets you type it in." - :type 'string + :type '(choice (const nil) string) :group 'uce) (defcustom uce-uce-separator @@ -206,7 +203,7 @@ "Errors-To: nobody@localhost\nPrecedence: bulk\n" "Additional headers to use when responding to a UCE with \\[uce-reply-to-uce]. These are mostly meant for headers that prevent delivery errors reporting." - :type 'string + :type '(choice (const nil) string) :group 'uce) (defcustom uce-subject-line @@ -215,40 +212,47 @@ :type 'string :group 'uce) +;; End of user options. + + +(defvar rmail-buffer) +(declare-function rmail-msg-is-pruned "rmail" ()) (declare-function mail-strip-quoted-names "mail-utils" (address)) (declare-function rmail-maybe-set-message-counters "rmail" ()) (declare-function rmail-msgbeg "rmail" (n)) (declare-function rmail-msgend "rmail" (n)) (declare-function rmail-toggle-header "rmail" (&optional arg)) - +;;;###autoload (defun uce-reply-to-uce (&optional ignored) - "Send reply to UCE in Rmail. -UCE stands for unsolicited commercial email. Function will set up reply -buffer with default To: to the sender, his postmaster, his abuse@ -address, and postmaster of the mail relay used." + "Compose a reply to unsolicited commercial email (UCE). +Sets up a reply buffer addressed to: the sender, his postmaster, +his abuse@ address, and the postmaster of the mail relay used. +You might need to set `uce-mail-reader' before using this." (interactive) + ;; Start of mail-client dependent section. (let ((message-buffer (cond ((eq uce-mail-reader 'gnus) gnus-original-article-buffer) - ((eq uce-mail-reader 'rmail) "RMAIL") + ((eq uce-mail-reader 'rmail) (bound-and-true-p rmail-buffer)) (t (error "Variable uce-mail-reader set to unrecognized value")))) - (full-header-p (and (eq uce-mail-reader 'rmail) - (not (rmail-msg-is-pruned))))) - (or (get-buffer message-buffer) - (error "No buffer %s, cannot find UCE" message-buffer)) + pruned) + (or (and message-buffer (get-buffer message-buffer)) + (error "No mail buffer, cannot find UCE")) (switch-to-buffer message-buffer) ;; We need the message with headers pruned. - (if full-header-p - (rmail-toggle-header 1)) + ;; Why? All we do is get the from and reply-to headers. ? + (and (eq uce-mail-reader 'rmail) + (not (setq pruned (rmail-msg-is-pruned))) + (rmail-toggle-header 1)) (let ((to (mail-strip-quoted-names (mail-fetch-field "from" t))) (reply-to (mail-fetch-field "reply-to")) temp) ;; Initial setting of the list of recipients of our message; that's ;; what they are pretending to be. - (if to - (setq to (format "%s" (mail-strip-quoted-names to))) - (setq to "")) + (setq to (if to + (format "%s" (mail-strip-quoted-names to)) + "")) (if reply-to (setq to (format "%s, %s" to (mail-strip-quoted-names reply-to)))) (let (first-at-sign end-of-hostname sender-host) @@ -260,31 +264,22 @@ to sender-host sender-host)))) (setq mail-send-actions nil) (setq mail-reply-buffer nil) - (cond ((eq uce-mail-reader 'gnus) - (copy-region-as-kill (point-min) (point-max))) - ((eq uce-mail-reader 'rmail) - (save-excursion - (save-restriction - (rmail-toggle-header 1) - (widen) - (rmail-maybe-set-message-counters) - (copy-region-as-kill (rmail-msgbeg rmail-current-message) - (rmail-msgend rmail-current-message)))))) - ;; Restore the pruned header state we found. - (if full-header-p - (rmail-toggle-header 0)) + (when (eq uce-mail-reader 'rmail) + (rmail-toggle-header 0) + (rmail-maybe-set-message-counters)) ; why? + (copy-region-as-kill (point-min) (point-max)) + ;; Restore the initial header state we found. + (and pruned (rmail-toggle-header 1)) (switch-to-buffer "*mail*") (erase-buffer) - (setq temp (point)) (yank) - (goto-char temp) - (if (eq uce-mail-reader 'rmail) - (progn - (forward-line 2) - (let ((case-fold-search t)) - (while (looking-at "Summary-Line:\\|Mail-From:") - (forward-line 1))) - (delete-region temp (point)))) + (goto-char (point-min)) + ;; Delete any internal Rmail headers. + (when (eq uce-mail-reader 'rmail) + (search-forward "\n\n") + (while (re-search-backward "^X-RMAIL" nil t) + (delete-region (point) (line-beginning-position 2))) + (goto-char (point-min))) ;; Now find the mail hub that first accepted this message. ;; This should try to find the last Received: header. ;; Sometimes there may be other headers inbetween Received: headers. @@ -293,22 +288,15 @@ (re-search-forward "^Lines:") (beginning-of-line)) ((eq uce-mail-reader 'rmail) - (goto-char (point-min)) - (search-forward "*** EOOH ***\n") - (beginning-of-line) - (forward-line -1))) + (search-forward "\n\n"))) (re-search-backward "^Received:") - (beginning-of-line) ;; Is this always good? It's the only thing I saw when I checked ;; a few messages. - (let ((eol (save-excursion (end-of-line) (point)))) - ;;(if (not (re-search-forward ": \\(from\\|by\\) " eol t)) - (if (not (re-search-forward "\\(from\\|by\\) " eol t)) - (progn - (goto-char eol) - (if (looking-at "[ \t\n]+\\(from\\|by\\) ") - (goto-char (match-end 0)) - (error "Failed to extract hub address"))))) + ;;(if (not (re-search-forward ": \\(from\\|by\\) " eol t)) + (unless (re-search-forward "\\(from\\|by\\) " (line-end-position) 'move) + (if (looking-at "[ \t\n]+\\(from\\|by\\) ") + (goto-char (match-end 0)) + (error "Failed to extract hub address"))) (setq temp (point)) (search-forward " ") (forward-char -1) @@ -317,34 +305,25 @@ (setq to (format "%s, postmaster@%s" to (buffer-substring temp (point))))) ;; Also look at the message-id, it helps *very* often. - (if (and (search-forward "\nMessage-Id: " nil t) - ;; Not all Message-Id:'s have an `@' sign. - (let ((bol (point)) - eol) - (end-of-line) - (setq eol (point)) - (goto-char bol) - (search-forward "@" eol t))) - (progn - (setq temp (point)) - (search-forward ">") - (forward-char -1) - (if (string-match "\\." (buffer-substring temp (point))) - (setq to (format "%s, postmaster@%s" - to (buffer-substring temp (point))))))) - (cond ((eq uce-mail-reader 'gnus) - ;; Does Gnus always have Lines: in the end? - (re-search-forward "^Lines:") - (beginning-of-line)) - ((eq uce-mail-reader 'rmail) - (search-forward "\n*** EOOH ***\n") - (forward-line -1))) - (setq temp (point)) - (search-forward "\n\n" nil t) - (if (eq uce-mail-reader 'gnus) - (forward-line -1)) - (delete-region temp (point)) - ;; End of Rmail dependent section. + (and (search-forward "\nMessage-Id: " nil t) + ;; Not all Message-Id:'s have an `@' sign. + (search-forward "@" (line-end-position) t) + (progn + (setq temp (point)) + (search-forward ">") + (forward-char -1) + (if (string-match "\\." (buffer-substring temp (point))) + (setq to (format "%s, postmaster@%s" + to (buffer-substring temp (point))))))) + (when (eq uce-mail-reader 'gnus) + ;; Does Gnus always have Lines: in the end? + (re-search-forward "^Lines:") + (beginning-of-line) + (setq temp (point)) + (search-forward "\n\n" nil t) + (forward-line -1) + (delete-region temp (point))) + ;; End of mail-client dependent section. (auto-save-mode auto-save-default) (mail-mode) (goto-char (point-min)) @@ -387,7 +366,7 @@ (if to (goto-char to)) (or to (set-buffer-modified-p nil)) ;; Run hooks before we leave buffer for editing. Reasonable usage - ;; might be to set up special key bindings, replace standart + ;; might be to set up special key bindings, replace standard ;; functions in mail-mode, etc. (run-hooks 'mail-setup-hook 'uce-setup-hook))))