comparison lisp/mail/uce.el @ 101694:977623d6c580

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.

101693:d8e498f22523

;;; 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.

;; Author: stanislav shalunov <[e-mail]>
;; Created: 10 Dec 1996
;; Keywords: uce, unsolicited commercial email

;; This file is part of GNU Emacs.

;; 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

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; 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.

;; 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 [e-mail] 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.

;; Then, we add "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
;; original message with full headers and envelope for postmasters.
;; Then buffer is left for editing.

;; 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.

;;; Change log:

;; Dec 10, 1996 -- posted draft version to gnu.sources.emacs

;; Dec 11, 1996 -- fixed some typos, and Francesco Potorti`
;; <[e-mail]> pointed out that my use of defvar was

;; Aug 16, 2000 -- changes from Detlev Zundel
;; <[e-mail]> to make uce.el work with the
;; 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
;; RMAIL are only evaluated if we have received a message with RMAIL...
;;(require 'rmail)

to spam address email, and will remove people who put the word `remove'
on beginning of some line from the spamming list.  So, when you set it
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
  :group 'uce)

(defcustom uce-uce-separator
  "----- original unsolicited commercial email follows -----"
  "Line that will begin quoting of the UCE.

(defcustom uce-default-headers
  "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
  :group 'uce)

(defcustom uce-subject-line
  "Spam alert: unsolicited commercial e-mail"
  "Subject of the message that will be sent in response to a UCE."
  :type 'string
  :group 'uce)

(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))


(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."
  (interactive)
  (let ((message-buffer
	 (cond ((eq uce-mail-reader 'gnus) gnus-original-article-buffer)
	       ((eq uce-mail-reader 'rmail) "RMAIL")
	       (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))
    (switch-to-buffer message-buffer)
    ;; We need the message with headers pruned.
    (if full-header-p
	(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 ""))
      (if reply-to
	  (setq to (format "%s, %s" to (mail-strip-quoted-names reply-to))))
      (let (first-at-sign end-of-hostname sender-host)
	(setq first-at-sign (string-match "@" to)
	      end-of-hostname (string-match "[ ,>]" to first-at-sign)

	(if (string-match "\\." sender-host)
	    (setq to (format "%s, postmaster%s, abuse%s"
			     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))
      (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))))
      ;; 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.
      (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)
	     (goto-char (point-min))
	     (search-forward "*** EOOH ***\n")
	     (beginning-of-line)
	     (forward-line -1)))
      (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")))))
      (setq temp (point))
      (search-forward " ")
      (forward-char -1)
      ;; And add its postmaster to the list of addresses.
      (if (string-match "\\." (buffer-substring temp (point)))
	  (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.
      (auto-save-mode auto-save-default)
      (mail-mode)
      (goto-char (point-min))
      (insert "To: ")
      (save-excursion

	(or (bolp) (newline)))
      ;; And go back to the beginning of text.
      (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
      ;; functions in mail-mode, etc.
      (run-hooks 'mail-setup-hook 'uce-setup-hook))))

(defun uce-insert-ranting (&optional ignored)
  "Insert text of the usual reply to UCE into current buffer."

101694:977623d6c580

;;; 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.

;; Author: stanislav shalunov <[e-mail]>
;; Created: 10 Dec 1996
;; Keywords: mail, uce, unsolicited commercial email

;; This file is part of GNU Emacs.

;; 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

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; 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.

;; 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 [e-mail]; 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 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 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 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:

;; 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.

;; 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

;; Dec 11, 1996 -- fixed some typos, and Francesco Potorti`
;; <[e-mail]> pointed out that my use of defvar was

;; Aug 16, 2000 -- changes from Detlev Zundel
;; <[e-mail]> to make uce.el work with the
;; latest Gnus.  Lars told him it should work for all versions of Gnus
;; younger than three years.


;;; Code:

(defvar gnus-original-article-buffer)
(defvar mail-reply-buffer)

(require 'sendmail)
;; Those sections of code which are dependent upon
;; RMAIL are only evaluated if we have received a message with RMAIL...
;;(require 'rmail)

to spam address email, and will remove people who put the word `remove'
on beginning of some line from the spamming list.  So, when you set it
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 '(choice (const nil) string)
  :group 'uce)

(defcustom uce-uce-separator
  "----- original unsolicited commercial email follows -----"
  "Line that will begin quoting of the UCE.

(defcustom uce-default-headers
  "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 '(choice (const nil) string)
  :group 'uce)

(defcustom uce-subject-line
  "Spam alert: unsolicited commercial e-mail"
  "Subject of the message that will be sent in response to a UCE."
  :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)
  "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) (bound-and-true-p rmail-buffer))
	       (t (error
		   "Variable uce-mail-reader set to unrecognized value"))))
	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.
    ;; 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.
      (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)
	(setq first-at-sign (string-match "@" to)
	      end-of-hostname (string-match "[ ,>]" to first-at-sign)

	(if (string-match "\\." sender-host)
	    (setq to (format "%s, postmaster%s, abuse%s"
			     to sender-host sender-host))))
      (setq mail-send-actions nil)
      (setq mail-reply-buffer nil)
      (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)
      (yank)
      (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.
      (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\n")))
      (re-search-backward "^Received:")
      ;; Is this always good?  It's the only thing I saw when I checked
      ;; a few messages.
      ;;(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)
      ;; And add its postmaster to the list of addresses.
      (if (string-match "\\." (buffer-substring temp (point)))
	  (setq to (format "%s, postmaster@%s"
			   to (buffer-substring temp (point)))))
      ;; Also look at the message-id, it helps *very* often.
      (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))
      (insert "To: ")
      (save-excursion

	(or (bolp) (newline)))
      ;; And go back to the beginning of text.
      (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 standard
      ;; functions in mail-mode, etc.
      (run-hooks 'mail-setup-hook 'uce-setup-hook))))

(defun uce-insert-ranting (&optional ignored)
  "Insert text of the usual reply to UCE into current buffer."