X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/24975917d00d2a1f884a155e46be87eaa057f4c1..16f45d1b8d556362a0668f192e4453f126946b1c:/lisp/mail/smtpmail.el diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 5a9fff1b6d..925a6ec2e8 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1,8 +1,9 @@ ;; Simple SMTP protocol (RFC 821) for sending mail -;; Copyright (C) 1995 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani +;; Maintainer: Brian D. Carlstrom ;; Keywords: mail ;; This file is part of GNU Emacs. @@ -25,7 +26,6 @@ ;;; Commentary: ;; Send Mail to smtp host from smtpmail temp buffer. -;; alfa release ;; Please add these lines in your .emacs(_emacs). ;; @@ -36,6 +36,7 @@ ;;(setq smtpmail-debug-info t) ;;(load-library "smtpmail") ;;(setq smtpmail-code-conv-from nil) +;;(setq user-full-name "YOUR NAME HERE") ;;; Code: @@ -45,11 +46,11 @@ (defvar smtpmail-default-smtp-server nil "*Specify default SMTP server.") -(defvar smtpmail-smtp-server (or (getenv "SMTPSERVER") - smtpmail-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" +(defvar smtpmail-smtp-service 25 "*SMTP service port number. smtp or 25 .") (defvar smtpmail-local-domain nil @@ -68,6 +69,7 @@ don't define this value.") ;;; (defun smtpmail-send-it () + (require 'mail-utils) (let ((errbuf (if mail-interactive (generate-new-buffer " smtpmail errors") 0)) @@ -92,6 +94,7 @@ don't define this value.") (replace-match "\n") (backward-char 1) (setq delimline (point-marker)) +;; (sendmail-synch-aliases) (if mail-aliases (expand-mail-aliases (point-min) delimline)) (goto-char (point-min)) @@ -101,12 +104,7 @@ don't define this value.") (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 @@ -131,19 +129,65 @@ don't define this value.") ;;; (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 "")) + ;; Put the "From:" field in unless for some odd reason + ;; they put one in themselves. + (goto-char (point-min)) + (if (not (re-search-forward "^From:" delimline t)) + (let* ((login user-mail-address) + (fullname (user-full-name))) + (cond ((eq mail-from-style 'angles) + (insert "From: " fullname) + (let ((fullname-start (+ (point-min) 6)) + (fullname-end (point-marker))) + (goto-char fullname-start) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" + fullname-end 1) + (progn + ;; Quote fullname, escaping specials. + (goto-char fullname-start) + (insert "\"") + (while (re-search-forward "[\"\\]" + fullname-end 1) + (replace-match "\\\\\\&" t)) + (insert "\"")))) + (insert " <" login ">\n")) + ((eq mail-from-style 'parens) + (insert "From: " login " (") + (let ((fullname-start (point))) + (insert fullname) + (let ((fullname-end (point-marker))) + (goto-char fullname-start) + ;; RFC 822 says \ and nonmatching parentheses + ;; must be escaped in comments. + ;; Escape every instance of ()\ ... + (while (re-search-forward "[()\\]" fullname-end 1) + (replace-match "\\\\\\&" t)) + ;; ... then undo escaping of matching parentheses, + ;; including matching nested parentheses. + (goto-char fullname-start) + (while (re-search-forward + "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" + fullname-end 1) + (replace-match "\\1(\\3)" t) + (goto-char fullname-start)))) + (insert ")\n")) + ((null mail-from-style) + (insert "From: " login "\n"))))) ;; 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)) + ;; Find and handle any FCC fields. + (goto-char (point-min)) + (if (re-search-forward "^FCC:" delimline t) + (mail-do-fcc delimline)) (if mail-interactive (save-excursion (set-buffer errbuf) @@ -153,15 +197,16 @@ don't define this value.") ;; (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) (setq smtpmail-recipient-address-list - (smtpmail-deduce-address-list tembuf (point-min) delimline)) + (or resend-to-addresses + (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.")) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")) ) (kill-buffer tembuf) (if (bufferp errbuf) @@ -177,13 +222,11 @@ don't define this value.") (defun smtpmail-via-smtp (recipient smtpmail-text-buffer) (let ((process nil) - host - port + (host smtpmail-smtp-server) + (port smtpmail-smtp-service) response-code - ) - (setq host smtpmail-smtp-server) - (setq port smtpmail-smtp-service) - + greeting + process-buffer) (unwind-protect (catch 'done ;; get or create the trace buffer @@ -225,7 +268,7 @@ don't define this value.") ;; MAIL FROM: ; (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)) + (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))) @@ -234,17 +277,17 @@ don't define this value.") ) ;; RCPT TO: - (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) - ) - ) + (let ((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") @@ -286,14 +329,12 @@ don't define this value.") (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) @@ -305,8 +346,8 @@ don't define this value.") ; (setq response-continue t) ; (setq return-value '(nil "")) - (goto-char smtpmail-read-point) (while response-continue + (goto-char smtpmail-read-point) (while (not (search-forward "\r\n" nil t)) (accept-process-output process) (goto-char smtpmail-read-point)) @@ -344,7 +385,6 @@ don't define this value.") return-value)) -;; check completely by T.Kagatani (defun smtpmail-send-command (process command) (goto-char (point-max)) (if (= (aref command 0) ?P) @@ -354,7 +394,6 @@ don't define this value.") (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)) @@ -365,10 +404,10 @@ don't define this value.") (insert data "\r\n")) (setq smtpmail-read-point (point)) - (process-send-string process data) - ;; . -> .. - (if (string-equal data ".") + ;; Escape "." at start of a line + (if (eq (string-to-char data) ?.) (process-send-string process ".")) + (process-send-string process data) (process-send-string process "\r\n") ) @@ -408,7 +447,8 @@ don't define this value.") ((case-fold-search t) (simple-address-list "") this-line - this-line-end) + this-line-end + addr-regexp) (unwind-protect (save-excursion @@ -416,7 +456,13 @@ don't define this value.") (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) + ;; RESENT-* fields should stop processing of regular fields. + (save-excursion + (if (re-search-forward "^RESENT-TO:" header-end t) + (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)") + (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)"))) + + (while (re-search-forward addr-regexp header-end t) (replace-match "") (setq this-line (match-beginning 0)) (forward-line 1) @@ -441,13 +487,13 @@ don't define this value.") (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) + (let (recipient-address-list) + (while (re-search-forward " \\([^ ]+\\) " (point-max) t) + (backward-char 1) + (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) + recipient-address-list)) + ) + (setq smtpmail-recipient-address-list recipient-address-list)) ) )