Mercurial > emacs
diff 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 diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/smtpmail.el Fri Jun 07 14:21:50 1996 +0000 @@ -0,0 +1,479 @@ +;; 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