Mercurial > emacs
view lisp/mail/uce.el @ 31384:f6cb7dfe5e7c
(vc-cvs-show-log-entry): New function.
(vc-cvs-stay-local): Allow it to be a hostname regexp
as well.
(vc-cvs-remote-p): Renamed to vc-cvs-stay-local-p. Handle
hostname regexps. Updated all callers.
(vc-cvs-responsible-p): Handle directories as well.
(vc-cvs-could-register): New function.
(vc-cvs-retrieve-snapshot): Parse "cvs update" output, keep file
properties up-to-date.
(vc-cvs-checkout): Do the right thing when the
workfile does not exist.
(vc-cvs-registered): Use new function
vc-cvs-parse-entry to do the actual work.
(vc-cvs-remote-p): Allow FILE to be a directory, too.
(vc-cvs-dir-state): New function.
(vc-cvs-dir-state-heuristic): New function, subroutine of the
above.
(vc-cvs-parse-entry): New function, also to be used in
vc-cvs-registered.
(vc-cvs-checkout): Slight restructuring to make the
control-flow more clear and to avoid running `cvs' twice.
(vc-cvs-workfile-version): Removed comment that this
is not reached. It is.
(vc-cvs-merge): Set state to 'edited after merge.
(vc-cvs-merge-news): Set workfile version to nil if not known.
(vc-cvs-latest-on-branch-p): Recommented. Candidate for removal.
(vc-cvs-checkin): Raise the max-correct status from 0
to 1. Make sure to switch to *vc* before looking for an error
message. Use vc-parse-buffer.
(vc-cvs-create-snapshot): Swap DIR and NAME.
(vc-cvs-retrieve-snapshot): New function (untested).
(vc-cvs-stay-local): Default to t.
(vc-cvs-remote-p): New function and property.
(vc-cvs-state): Stay local only if the above is t.
(vc-handle-cvs): Removed.
(vc-cvs-registered): Don't check vc-handle-cvs -- it should all be
done via vc-handled-backends now.
(vc-cvs-header): Escape Id.
(vc-cvs-state, vc-cvs-fetch-status): Use
with-temp-file. Use the new BUFFER=t argument to vc-do-command.
(vc-cvs-print-log, vc-cvs-diff): Insert in the current buffer.
(vc-cvs-state): Use vc-do-command instead of
vc-simple-command.
(vc-cvs-diff): Remove unused and unsupported argument CMP.
(vc-cvs-registered): Obey vc-handle-cvs.
(vc-cvs-registered): Use with-temp-buffer. Reorder
extraction of fields and call to file-attributes because of a
temporary bug in rcp.el.
(vc-cvs-fetch-status): Use with-current-buffer.
Merge in code
from vc-cvs-hooks.el.
(proto vc-cvs-registered): Require 'vc-cvs instead of
'vc-cvs-hooks. Don't require 'vc anymore.
(vc-cvs-responsible-p): Use expand-file-name instead of concat and
file-directory-p instead of file-exists-p.
(vc-cvs-create-snapshot): New function, replacing
vc-cvs-assign-name.
(vc-cvs-assign-name): Remove.
(vc-cvs-header): New var.
Update Copyright.
(vc-cvs-diff): Remove unused `backend' variable.
(vc-cvs-checkout): Only toggle read-only if the buffer is setup
right.
(tail): Provide vc-cvs.
(vc-cvs-merge-news, vc-cvs-checkout): Removed call to
vc-file-clear-masterprops.
(vc-cvs-state): Typo.
(vc-cvs-merge-news): Return the status code rather than the error
msg.
(vc-cvs-state): Don't overwrite a non-heuristic state
with a heuristic one.
(vc-cvs-merge-news): Just use 'edited for the case with conflicts.
(vc-cvs-checkin): Do a trivial parse to set the state in case of
error. That allows us to get to 'needs-merge even in the
stay-local case. There's still no way to detect 'needs-patch in
such a setup (or to force an update for that matter).
(vc-cvs-logentry-check): Remove, the default works as well.
(vc-cvs-print-log, vc-cvs-diff): Run cvs
asynchronously.
(vc-cvs-stay-local): Renamed from
vc-cvs-simple-toggle. Redocumented.
(vc-cvs-state): If locality is wanted, use vc-cvs-state-heuristic.
(vc-cvs-toggle-read-only): Removed.
(for compiler
warnings).
(vc-cvs-release, vc-cvs-system-release): Remove.
(vc-cvs-use-edit, vc-cvs-simple-toggle): New config variables.
(vc-cvs-dired-state-info): Use `cvs-state' and slightly different
status symbols.
(vc-cvs-parse-status, vc-cvs-state): Move from vc-cvs-hooks.el.
(vc-cvs-toggle-read-only): First cut at a function to allow a
cvs-status-free vc-toggle-read-only.
(vc-cvs-merge-news): Move from cvs-merge-news in vc.el.
(vc-cvs-checkin): Use vc-recompute-state+vc-state instead of
vc-cvs-status. Also set vc-state rather than vc-locking-user.
(vc-cvs-checkout): Modify access rights directly if the user
requested not to use `cvs edit'. And refresh the mode line.
(if
workfile' that got lost when the code was extracted from vc.el.
And merged the tail with the rest of the code (not possible in the
old vc.el where the tail was shared among all backends). And
explicitly set the state to 'edited if `writable' is set.
(vc-cvs-revert,vc-cvs-checkout): References to
`vc-checkout-model' updated to `vc-cvs-update-model'.
(vc-cvs-logentry-check): Function added.
(vc-cvs-revert,vc-cvs-checkout): Function calls to
`vc-checkout-required' updated to `vc-cvs-uses-locking'.
(vc-cvs-admin): Added the query-only option as
required by the vc.el file.
(vc-cvs-annotate-difference): Updated to handle
beginning of annotate buffers correctly.
Rename `vc-uses-locking' to
`vc-checkout-required'. Rename the `locked' state to `reserved'.
(vc-cvs-annotate-difference): Handle possible
millenium problem (merged from mainline).
Split the annotate feature into a BACKEND-specific
part and moved the non-BACKEND stuff to vc.el.
(vc-cvs-latest-on-branch-p): Function added.
(vc-cvs-revert): Merged and adapted "unedit" patch
from main line.
(vc-cvs-diff): Function added.
(vc-cvs-checkout): Function `vc-cvs-checkout' added.
Require vc when compiling.
(vc-cvs-register-switches): Doc fix.
(vc-annotate-color-map, vc-annotate-menu-elements): Fix custom type.
(vc-cvs-print-log, vc-cvs-assign-name, vc-cvs-merge)
(vc-cvs-check-headers, vc-cvs-steal, vc-cvs-revert, vc-cvs-checkin):
New functions (code from vc.el).
(vc-annotate-display-default): Fix interactive spec.
(vc-annotate-time-span): Doc fix.
Moved the annotate functionality from vc.el.
(vc-cvs-admin, vc-cvs-fetch-status): Added from vc.el.
(vc-cvs-system-release):
Renamed from vc-cvs-backend-release.
(vc-cvs-release): Moved from vc.el.
(vc-cvs-backend-release): New function.
(vc-cvs-dired-state-info, vc-cvs-fetch-status): Moved
from vc.el and renamed.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Mon, 04 Sep 2000 19:48:04 +0000 |
parents | fa7a79afcbf7 |
children | 64d8d90d180d |
line wrap: on
line source
;;; uce.el --- facilitate reply to unsolicited commercial email ;; Copyright (C) 1996, 1998, 2000 Free Software Foundation, Inc. ;; Author: stanislav shalunov <shalunov@mccme.ru> ;; Created: 10 Dec 1996 ;; Keywords: uce, unsolicited commercial email ;; This file is part of GNU Emacs. ;; This program 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. ;; This program 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 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. ;;; 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 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. ;; 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` ;; <F.Potorti@cnuce.cnr.it> pointed out that my use of defvar was ;; weird, suggested fix, and added let form. ;; 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:'. ;; Aug 16, 2000 -- changes from Detlev Zundel ;; <detlev.zundel@stud.uni-karlsruhe.de> 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: (require 'sendmail) ;; Those sections of code which are dependent upon ;; RMAIL are only evaluated if we have received a message with RMAIL... ;;(require 'rmail) (defgroup uce nil "Facilitate reply to unsolicited commercial email." :prefix "uce-" :group 'mail) (defcustom uce-mail-reader 'rmail "A symbol indicating which mail reader you are using. Choose from: `gnus', `rmail'." :type '(choice (const gnus) (const rmail)) :version "20.3" :group 'uce) (defcustom uce-setup-hook nil "Hook to run after UCE rant message is composed. This hook is run after `mail-setup-hook', which is run as well." :type 'hook :group 'uce) (defcustom uce-message-text "Recently, I have received an Unsolicited Commercial E-mail from you. I do not like UCE's and I would like to inform you that sending unsolicited messages to someone while he or she may have to pay for reading your message may be illegal. Anyway, it is highly annoying and not welcome by anyone. It is rude, after all. If you think that this is a good way to advertise your products or services you are mistaken. Spamming will only make people hate you, not buy from you. 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 has been sent to postmasters at the host that is 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." "This is the text that `uce-reply-to-uce' command will put in reply buffer. Some of spamming programs in use will be set up to read all incoming 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. Value nil means use no separator." :type '(choice (const nil) string) :group 'uce) (defcustom uce-signature mail-signature "Text to put as your signature after the note to UCE sender. Value nil means none, t means insert `~/.signature' file (if it happens to exist), if this variable is a string this string will be inserted as your signature." :type '(choice (const nil) (const t) string) :group '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) (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"))))) (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 (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) (copy-region-as-kill (point-min) (point-max))) ((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) (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) (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." (interactive "P") (insert uce-message-text)) (provide 'uce) ;;; uce.el ends here