diff options
| -rw-r--r-- | lisp/mail/uce.el | 338 |
1 files changed, 200 insertions, 138 deletions
diff --git a/lisp/mail/uce.el b/lisp/mail/uce.el index 1cec136da38..3b0956159dd 100644 --- a/lisp/mail/uce.el +++ b/lisp/mail/uce.el @@ -1,10 +1,9 @@ ;;; uce.el --- facilitate reply to unsolicited commercial email -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998 Free Software Foundation, Inc. -;; Author: stanislav shalunov <shalunov@math.wisc.edu> +;; Author: stanislav shalunov <shalunov@mccme.ru> ;; Created: 10 Dec 1996 -;; Version: 1.0 ;; Keywords: uce, unsolicited commercial email ;; This file is part of GNU Emacs. @@ -27,13 +26,11 @@ ;;; Commentary: ;; Code in this file provides semi-automatic means of replying to -;; UCE's you might get. It works currently only with Rmail. 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, would you -;; please grab the newest version from -;; http://math.wisc.edu/~shalunov/uce.el and let me know, if you would -;; like, about your changes so I can incorporate them. I'd appreciate -;; it. +;; 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 @@ -75,12 +72,23 @@ ;; Dec 17, 1996 -- made scanning for host names little bit more clever ;; (obviously bogus stuff like localhost is now ignored). +;; Nov 11, 1997 -- incorporated changes from Mikael Djurfeldt +;; <mdj@nada.kth.se> to make uce.el work with Gnus. Changed the text +;; of message that is sent. + +;; Dec 3, 1997 -- changes from Gareth Jones <gdj1@gdjones.demon.co.uk> +;; handling Received headers following some line like `From:'. + ;;; Setup: ;; put in your ~./emacs the following line: ;; (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: @@ -102,7 +110,13 @@ ;;; Code: (require 'sendmail) -(require 'rmail) +;; Those sections of code which are dependent upon +;; RMAIL are only evaluated if we have received a message with RMAIL... +;;(require 'rmail) + +(defvar uce-mail-reader 'rmail + "A symbol indicating which mail reader you are using. +Choose from: gnus, rmail.") (defgroup uce nil "Facilitate reply to unsolicited commercial email." @@ -130,15 +144,25 @@ If you have any list of people you send unsolicited commercial emails to, REMOVE me from such list immediately. I suggest that you make this list just empty. + ---------------------------------------------------- + +If you are not an administrator of any site and still have received +this message then your email address is being abused by some spammer. +They fake your address in From: or Reply-To: header. In this case, +you might want to show this message to your system administrator, and +ask him/her to investigate this matter. + Note to the postmaster(s): I append the text of UCE in question to -this message, I would like to hear from you about action(s) taken. +this message; I would like to hear from you about action(s) taken. This message has been sent to postmasters at the host that is -mentioned as original sender's host and to the postmaster whose host -was used as mail relay for this message. If message was sent not by -your user, could you please compare time when this message was sent -(use time in Received: field of the envelope rather than Date: field) -with your sendmail logs and see what host was using your sendmail at -this moment of time. +mentioned as original sender's host (I do realize that it may be +faked, but I think that if your domain name is being abused this way +you might want to learn about it, and take actions) and to the +postmaster whose host was used as mail relay for this message. If +message was sent not by your user, could you please compare time when +this message was sent (use time in Received: field of the envelope +rather than Date: field) with your sendmail logs and see what host was +using your sendmail at this moment of time. Thank you." @@ -185,127 +209,165 @@ These are mostly meant for headers that prevent delivery errors reporting." 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 "P") - (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 (and in many cases, really are). - (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) - sender-host (substring to first-at-sign end-of-hostname)) - (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) - ;; Begin of Rmail dependant section. - (or (get-buffer "RMAIL") - (error "No buffer RMAIL, cannot find UCE")) - (switch-to-buffer "RMAIL") - (save-excursion - (save-restriction - (widen) - (rmail-maybe-set-message-counters) - (copy-region-as-kill (rmail-msgbeg rmail-current-message) - (rmail-msgend rmail-current-message)))) - (switch-to-buffer "*mail*") - (erase-buffer) - (setq temp (point)) - (yank) - (goto-char temp) - (forward-line 2) - (while (looking-at "Summary-Line:\\|Mail-From:") - (forward-line 1)) - (delete-region temp (point)) - ;; Now find the mail hub that first accepted this message. - (while (or (looking-at "Received:") - (looking-at " ") - (looking-at "\t")) - (forward-line 1)) - (while (or (looking-at " ") - (looking-at "\t")) - (forward-line -1)) - ;; Is this always good? It's the only thing I saw when I checked - ;; a few messages. - (search-forward ": from ") - (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. - (search-forward "\nMessage-Id: ") - (search-forward "@") - (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))))) - (search-forward "\n*** EOOH ***\n") - (forward-line -1) - (setq temp (point)) - (search-forward "\n\n" nil t) - (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 + (interactive) + (let ((message-buffer + (cond ((eq uce-mail-reader 'gnus) "*Article*") + ((eq uce-mail-reader 'rmail) "RMAIL") + (t (error + "Variable uce-mail-reader set to unrecognized value"))))) + (or (get-buffer message-buffer) + (error (concat "No buffer " message-buffer ", cannot find UCE"))) + (switch-to-buffer message-buffer) + (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 - (let ((fill-prefix "\t") - (address-start (point))) - (insert to "\n") - (fill-region-as-paragraph address-start (point))) - (newline)) - (insert "Subject: " uce-subject-line "\n") - (if uce-default-headers - (insert uce-default-headers)) - (if mail-default-headers - (insert mail-default-headers)) - (if mail-default-reply-to - (insert "Reply-to: " mail-default-reply-to "\n\n")) - (mail-sendmail-delimit-header) - ;; Insert all our text. Then go back to the place where we started. - (if to (setq to (point))) - ;; Text of ranting. - (if uce-message-text - (insert uce-message-text)) - ;; Signature. - (cond ((eq uce-signature t) - (if (file-exists-p "~/.signature") - (progn - (insert "\n\n-- \n") - (insert-file "~/.signature") - ;; Function insert-file leaves point where it was, - ;; while we want to place signature in the ``middle'' - ;; of the message. - (exchange-point-and-mark)))) - (uce-signature - (insert "\n\n-- \n" uce-signature))) - ;; And text of the original message. - (if uce-uce-separator - (insert "\n\n" uce-uce-separator "\n")) - ;; If message doesn't end with a newline, insert it. - (goto-char (point-max)) - (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))) + (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) + sender-host (substring to first-at-sign end-of-hostname)) + (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) + (article-hide-headers -1) + (copy-region-as-kill (point-min) (point-max)) + (article-hide-headers)) + ((eq uce-mail-reader 'rmail) + (save-excursion + (save-restriction + (widen) + (rmail-maybe-set-message-counters) + (copy-region-as-kill (rmail-msgbeg rmail-current-message) + (rmail-msgend rmail-current-message)))))) + (switch-to-buffer "*mail*") + (erase-buffer) + (setq temp (point)) + (yank) + (goto-char temp) + (if (eq uce-mail-reader 'rmail) + (progn + (forward-line 2) + (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) + (beginning-of-buffer) + (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 + (if to + (let ((fill-prefix "\t") + (address-start (point))) + (insert to "\n") + (fill-region-as-paragraph address-start (point))) + (newline)) + (insert "Subject: " uce-subject-line "\n") + (if uce-default-headers + (insert uce-default-headers)) + (if mail-default-headers + (insert mail-default-headers)) + (if mail-default-reply-to + (insert "Reply-to: " mail-default-reply-to "\n")) + (insert mail-header-separator "\n") + ;; Insert all our text. Then go back to the place where we started. + (if to (setq to (point))) + ;; Text of ranting. + (if uce-message-text + (insert uce-message-text)) + ;; Signature. + (cond ((eq uce-signature t) + (if (file-exists-p "~/.signature") + (progn + (insert "\n\n-- \n") + (insert-file "~/.signature") + ;; Function insert-file leaves point where it was, + ;; while we want to place signature in the ``middle'' + ;; of the message. + (exchange-point-and-mark)))) + (uce-signature + (insert "\n\n-- \n" uce-signature))) + ;; And text of the original message. + (if uce-uce-separator + (insert "\n\n" uce-uce-separator "\n")) + ;; If message doesn't end with a newline, insert it. + (goto-char (point-max)) + (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." |