Mercurial > emacs
view lisp/mail/smtpmail.el @ 15345:4eef6c1687f8
Initial revision
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Fri, 07 Jun 1996 14:21:50 +0000 |
parents | |
children | 4cd6ff2384dc |
line wrap: on
line source
;; Simple SMTP protocol (RFC 821) for sending mail ;; Copyright (C) 1995 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> ;; Keywords: mail ;; 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 ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs 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: ;; Send Mail to smtp host from smtpmail temp buffer. ;; alfa release ;; Please add these lines in your .emacs(_emacs). ;; ;;(setq send-mail-function 'smtpmail-send-it) ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") ;;(setq smtpmail-smtp-service "smtp") ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") ;;(setq smtpmail-debug-info t) ;;(load-library "smtpmail") ;;(setq smtpmail-code-conv-from nil) ;;; Code: (require 'sendmail) ;;; (defvar smtpmail-default-smtp-server nil "*Specify default SMTP server.") (defvar smtpmail-smtp-server (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) "*The name of the host running SMTP server.") (defvar smtpmail-smtp-service "smtp" "*SMTP service port number. smtp or 25 .") (defvar smtpmail-local-domain nil "*Local domain name without a host name. If the function (system-name) returns the full internet address, don't define this value.") (defvar smtpmail-debug-info nil "*smtpmail debug info printout. messages and process buffer.") (defvar smtpmail-code-conv-from nil ;; *junet* "*smtpmail code convert from this code to *internal*..for tiny-mime..") ;;; ;;; ;;; (defun smtpmail-send-it () (let ((errbuf (if mail-interactive (generate-new-buffer " smtpmail errors") 0)) (tembuf (generate-new-buffer " smtpmail temp")) (case-fold-search nil) resend-to-addresses delimline (mailbuf (current-buffer))) (unwind-protect (save-excursion (set-buffer tembuf) (erase-buffer) (insert-buffer-substring mailbuf) (goto-char (point-max)) ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) ;; Change header-delimiter to be what sendmail expects. (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (backward-char 1) (setq delimline (point-marker)) (if mail-aliases (expand-mail-aliases (point-min) delimline)) (goto-char (point-min)) ;; ignore any blank lines in the header (while (and (re-search-forward "\n\n\n*" delimline t) (< (point) delimline)) (replace-match "\n")) (let ((case-fold-search t)) (goto-char (point-min)) ;; Find and handle any FCC fields. (goto-char (point-min)) (if (re-search-forward "^FCC:" delimline t) (mail-do-fcc delimline)) (goto-char (point-min)) (require 'mail-utils) (while (re-search-forward "^Resent-to:" delimline t) (setq resend-to-addresses (save-restriction (narrow-to-region (point) (save-excursion (end-of-line) (point))) (append (mail-parse-comma-list) resend-to-addresses)))) ;;; Apparently this causes a duplicate Sender. ;;; ;; If the From is different than current user, insert Sender. ;;; (goto-char (point-min)) ;;; (and (re-search-forward "^From:" delimline t) ;;; (progn ;;; (require 'mail-utils) ;;; (not (string-equal ;;; (mail-strip-quoted-names ;;; (save-restriction ;;; (narrow-to-region (point-min) delimline) ;;; (mail-fetch-field "From"))) ;;; (user-login-name)))) ;;; (progn ;;; (forward-line 1) ;;; (insert "Sender: " (user-login-name) "\n"))) ;; "S:" is an abbreviation for "Subject:". (goto-char (point-min)) (if (re-search-forward "^S:" delimline t) (replace-match "Subject:")) ;; Don't send out a blank subject line (goto-char (point-min)) (if (re-search-forward "^Subject:[ \t]*\n" delimline t) (replace-match "")) ;; 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)) (if mail-interactive (save-excursion (set-buffer errbuf) (erase-buffer)))) ;; ;; ;; (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) (setq smtpmail-recipient-address-list (smtpmail-deduce-address-list tembuf (point-min) delimline)) (kill-buffer smtpmail-address-buffer) (smtpmail-do-bcc delimline) (if (not (null smtpmail-recipient-address-list)) (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf)) (error "Sending... Failed. SMTP Protocol Error.")) (error "Sending... failed. No recipients.")) ) (kill-buffer tembuf) (if (bufferp errbuf) (kill-buffer errbuf))))) ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) (defun smtpmail-fqdn () (if smtpmail-local-domain (concat (system-name) "." smtpmail-local-domain) (system-name))) (defun smtpmail-via-smtp (recipient smtpmail-text-buffer) (let ((process nil) host port response-code ) (setq host smtpmail-smtp-server) (setq port smtpmail-smtp-service) (unwind-protect (catch 'done ;; get or create the trace buffer (setq process-buffer (get-buffer-create (format "*trace of SMTP session to %s*" host))) ;; clear the trace buffer of old output (save-excursion (set-buffer process-buffer) (erase-buffer)) ;; open the connection to the server (setq process (open-network-stream "SMTP" process-buffer host port)) (and (null process) (throw 'done nil)) ;; set the send-filter (set-process-filter process 'smtpmail-process-filter) (save-excursion (set-buffer process-buffer) (make-local-variable 'smtpmail-read-point) (setq smtpmail-read-point (point-min)) (if (or (null (car (setq greeting (smtpmail-read-response process)))) (not (integerp (car greeting))) (>= (car greeting) 400)) (throw 'done nil) ) ;; HELO (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn))) (if (or (null (car (setq response-code (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) (throw 'done nil) ) ;; MAIL FROM: <sender> ; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) (smtpmail-send-command process (format "MAIL FROM:%s" user-mail-address)) (if (or (null (car (setq response-code (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) (throw 'done nil) ) ;; RCPT TO: <recipient> (setq n 0) (while (not (null (nth n recipient))) (smtpmail-send-command process (format "RCPT TO: %s" (nth n recipient))) (setq n (1+ n)) (if (or (null (car (setq response-code (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) (throw 'done nil) ) ) ;; DATA (smtpmail-send-command process "DATA") (if (or (null (car (setq response-code (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) (throw 'done nil) ) ;; Mail contents (smtpmail-send-data process smtpmail-text-buffer) ;;DATA end "." (smtpmail-send-command process ".") (if (or (null (car (setq response-code (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) (throw 'done nil) ) ;;QUIT ; (smtpmail-send-command process "QUIT") ; (and (null (car (smtpmail-read-response process))) ; (throw 'done nil)) t )) (if process (save-excursion (set-buffer (process-buffer process)) (smtpmail-send-command process "QUIT") (smtpmail-read-response process) ; (if (or (null (car (setq response-code (smtpmail-read-response process)))) ; (not (integerp (car response-code))) ; (>= (car response-code) 400)) ; (throw 'done nil) ; ) (delete-process process)))))) ;; check completely by T.Kagatani (defun smtpmail-process-filter (process output) (save-excursion (set-buffer (process-buffer process)) (goto-char (point-max)) (insert output))) ;; check completely by T.Kagatani (defun smtpmail-read-response (process) (let ((case-fold-search nil) (response-string nil) (response-continue t) (return-value '(nil "")) match-end) ; (setq response-string nil) ; (setq response-continue t) ; (setq return-value '(nil "")) (goto-char smtpmail-read-point) (while response-continue (while (not (search-forward "\r\n" nil t)) (accept-process-output process) (goto-char smtpmail-read-point)) (setq match-end (point)) (if (null response-string) (setq response-string (buffer-substring smtpmail-read-point (- match-end 2)))) (goto-char smtpmail-read-point) (if (looking-at "[0-9]+ ") (progn (setq response-continue nil) ; (setq return-value response-string) (if smtpmail-debug-info (message response-string)) (setq smtpmail-read-point match-end) (setq return-value (cons (string-to-int (buffer-substring (match-beginning 0) (match-end 0))) response-string))) (if (looking-at "[0-9]+-") (progn (setq smtpmail-read-point match-end) (setq response-continue t)) (progn (setq smtpmail-read-point match-end) (setq response-continue nil) (setq return-value (cons nil response-string)) ) ))) (setq smtpmail-read-point match-end) return-value)) ;; check completely by T.Kagatani (defun smtpmail-send-command (process command) (goto-char (point-max)) (if (= (aref command 0) ?P) (insert "PASS <omitted>\r\n") (insert command "\r\n")) (setq smtpmail-read-point (point)) (process-send-string process command) (process-send-string process "\r\n")) ;; check completely by T.Kagatani (defun smtpmail-send-data-1 (process data) (goto-char (point-max)) (if (not (null smtpmail-code-conv-from)) (setq data (code-convert-string data smtpmail-code-conv-from *internal*))) (if smtpmail-debug-info (insert data "\r\n")) (setq smtpmail-read-point (point)) (process-send-string process data) ;; . -> .. (if (string-equal data ".") (process-send-string process ".")) (process-send-string process "\r\n") ) (defun smtpmail-send-data (process buffer) (let ((data-continue t) (sending-data nil) this-line this-line-end) (save-excursion (set-buffer buffer) (goto-char (point-min))) (while data-continue (save-excursion (set-buffer buffer) (beginning-of-line) (setq this-line (point)) (end-of-line) (setq this-line-end (point)) (setq sending-data nil) (setq sending-data (buffer-substring this-line this-line-end)) (if (/= (forward-line 1) 0) (setq data-continue nil))) (smtpmail-send-data-1 process sending-data) ) ) ) (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO: <address>." (require 'mail-utils) ;; pick up mail-strip-quoted-names (let ((case-fold-search t) (simple-address-list "") this-line this-line-end) (unwind-protect (save-excursion ;; (set-buffer smtpmail-address-buffer) (erase-buffer) (insert-buffer-substring smtpmail-text-buffer header-start header-end) (goto-char (point-min)) (while (re-search-forward "^\\(TO:\\|CC:\\|BCC:\\)" header-end t) (replace-match "") (setq this-line (match-beginning 0)) (forward-line 1) ;; get any continuation lines (while (and (looking-at "^[ \t]+") (< (point) header-end)) (forward-line 1)) (setq this-line-end (point-marker)) (setq simple-address-list (concat simple-address-list " " (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) ) (erase-buffer) (insert-string " ") (insert-string simple-address-list) (insert-string "\n") (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank (goto-char (point-min)) ;; tidyness in case hook is not robust when it looks at this (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) (goto-char (point-min)) (setq recipient-address-list nil) (while (re-search-forward " [^ ]+ " (point-max) t) (backward-char 1) (setq recipient-address-list(cons (buffer-substring (match-beginning 0) (match-end 0)) recipient-address-list)) ) (setq smtpmail-recipient-address-list recipient-address-list) ) ) ) ) (defun smtpmail-do-bcc (header-end) "Delete BCC: and their continuation lines from the header area. There may be multiple BCC: lines, and each may have arbitrarily many continuation lines." (let ((case-fold-search t)) (save-excursion (goto-char (point-min)) ;; iterate over all BCC: lines (while (re-search-forward "^BCC:" header-end t) (delete-region (match-beginning 0) (progn (forward-line 1) (point))) ;; get rid of any continuation lines (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) (replace-match "")) ) ) ;; save-excursion ) ;; let ) (provide 'smtpmail) ;; smtpmail.el ends here