;;; wl-spam.el

;; Copyright (C) 2001 Kenichi OKADA <okada@opaopa.org>

;; Author: Kenichi OKADA <okada@opaopa.org>

;; 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 this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; usage:
;;
;; Do not use this if you do not know how to use it.
;;
;; (setq wl-draft-send-mail-function 'wl-draft-send-mail-with-spam)
;;
;; To: real-recipient
;; Sto: fake-recipient
;;
;; Field "Sto:" is override field "To:".
;; You can use Scc: ,too.
;;
;; Sfrom: envelope-from
;; sfrom overrides your 'wl-envelope-from

;;; Code:

(defun wl-draft-send-mail-with-spam ()
  "Send the prepared message buffer with SMTP."
  (require 'smtp)
  (let* ((errbuf (if mail-interactive
		     (generate-new-buffer " smtp errors")
		   0))
	 (case-fold-search t)
	 (default-case-fold-search t)
	 (sender (or wl-envelope-from
		     (wl-address-header-extract-address wl-from)))
	 (delimline (save-excursion
		      (goto-char (point-min))
		      (re-search-forward
		       (concat "^" (regexp-quote mail-header-separator)
			       "$\\|^$") nil t)
		      (point-marker)))
	 (smtp-server
	  (or wl-smtp-posting-server
	      ;; Compatibility stuff for FLIM 1.12.5 or earlier.
	      ;; They don't accept a function as the value of `smtp-server'.
	      (if (functionp smtp-server)
		  (funcall
		   smtp-server
		   sender
		   ;; no harm..
		   (let (wl-draft-remove-group-list-contents)
		     (wl-draft-deduce-address-list
		      (current-buffer) (point-min) delimline)))
		(or smtp-server "localhost"))))
	 (smtp-service (or wl-smtp-posting-port smtp-service))
	 (smtp-local-domain (or smtp-local-domain wl-local-domain))
	 (id (std11-field-body "message-id"))
	 recipients sto scc sfrom)
    (if (not (elmo-plugged-p smtp-server smtp-service))
	(wl-draft-set-sent-message 'mail 'unplugged
				   (cons smtp-server smtp-service))
      (unwind-protect
	  (save-excursion
	    ;; Instead of `smtp-deduce-address-list'.
	    (setq recipients (wl-draft-deduce-address-list
			      (current-buffer) (point-min) delimline))
	    (unless recipients (error "No recipients"))
	    ;; Insert an extra newline if we need it to work around
	    ;; Sun's bug that swallows newlines.
	    (goto-char (1+ delimline))
	    (if (eval mail-mailer-swallows-blank-line)
		(newline))
;;;	    (run-hooks 'wl-mail-send-pre-hook)
	    (if mail-interactive
		(save-excursion
		  (set-buffer errbuf)
		  (erase-buffer)))
;; for spaming
	    (if (setq sto (std11-field-body "sto"))
		(progn
		  (wl-spam-replace-field "To" sto delimline)
		  (wl-draft-delete-field "sto" delimline)))
	    (if (setq scc (std11-field-body "scc"))
		(progn
		  (wl-spam-replace-field "Cc" scc delimline)
		  (wl-draft-delete-field "scc" delimline)))
	    (if (setq sfrom (std11-field-body "sfrom"))
		(progn
		  (setq sender
			(wl-address-header-extract-address sfrom))
		  (wl-draft-delete-field "sfrom" delimline)))
	    (if (or sto scc sfrom)
		(save-excursion
		  (goto-char delimline)
		  (insert "X-Spam: I'm spaming now!")))
;; ends here
	    (wl-draft-delete-field "bcc" delimline)
	    (wl-draft-delete-field "resent-bcc" delimline)
	    (let (process-connection-type)
	      (as-binary-process
	       (when recipients
		 (wl-smtp-extension-bind
		  (condition-case err
		      (smtp-send-buffer sender recipients (current-buffer))
		    (error
		     (wl-draft-write-sendlog 'failed 'smtp smtp-server
					     recipients id)
		     (if (/= (nth 1 err) 334)
			 (elmo-remove-passwd
			  (wl-smtp-password-key
			   smtp-sasl-user-name
			   (car smtp-sasl-mechanisms)
			   smtp-server)))
		     (signal (car err) (cdr err)))))
		 (wl-draft-set-sent-message 'mail 'sent)
		 (wl-draft-write-sendlog
		  'ok 'smtp smtp-server recipients id)))))
	(if (bufferp errbuf)
	    (kill-buffer errbuf))))))

(defun wl-spam-replace-field (field value &optional delimline)
  (save-restriction
    (unless delimline
      (if (search-forward "\n\n" nil t)
	  (setq delimline (point))
	(setq delimline (point-max))))
    (narrow-to-region (point-min) delimline)
    (goto-char (point-min))
    (let ((regexp (concat "^" (regexp-quote field) ":"))
	  (case-fold-search t))
      (while (not (eobp))
	(if (looking-at regexp)
	    (progn
	      (delete-region
	       (point)
	       (progn
		 (forward-line 1)
		 (if (re-search-forward "^[^ \t]" nil t)
		     (goto-char (match-beginning 0))
		   (point-max))))
	      (unless (string= value "")
		(insert (concat field ": " value "\n"))))
	  (forward-line 1)
	  (if (re-search-forward "^[^ \t]" nil t)
	      (goto-char (match-beginning 0))
	    (point-max)))))))

(provide 'wl-spam)

;;; wl-spam.el ends here