X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/95754b9f0f21b64e83ea21f8efb9174b25cb1182..2d8a544976354b3787e4f28f2d97b3ab96f4a052:/lisp/mail/smtpmail.el diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 2dbfa18f33..84a6135014 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1,6 +1,7 @@ ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -;; Copyright (C) 1995, 1996, 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004 +;; Free Software Foundation, Inc. ;; Author: Tomoji Kagatani ;; Maintainer: Simon Josefsson @@ -44,6 +45,8 @@ ;; '(("YOUR SMTP HOST" 25 "username" "password"))) ;;(setq smtpmail-starttls-credentials ;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert"))) +;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an +;; integer or a string, just as long as they match (eq). ;; To queue mail, set smtpmail-queue-mail to t and use ;; smtpmail-send-queued-mail to send. @@ -212,7 +215,7 @@ This is relative to `smtpmail-queue-dir'.") ;;; (defvar smtpmail-mail-address nil - "Value of `user-mail-address' in ambient buffer.") + "Value to use for envelope-from address for mail from ambient buffer.") ;;;###autoload (defun smtpmail-send-it () @@ -223,7 +226,11 @@ This is relative to `smtpmail-queue-dir'.") (case-fold-search nil) delimline (mailbuf (current-buffer)) - (smtpmail-mail-address user-mail-address) + ;; Examine this variable now, so that + ;; local binding in the mail buffer will take effect. + (smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + user-mail-address)) (smtpmail-code-conv-from (if enable-multibyte-characters (let ((sendmail-coding-system smtpmail-code-conv-from)) @@ -354,6 +361,8 @@ This is relative to `smtpmail-queue-dir'.") (buffer-data (create-file-buffer file-data)) (buffer-elisp (create-file-buffer file-elisp)) (buffer-scratch "*queue-mail*")) + (unless (file-exists-p smtpmail-queue-dir) + (make-directory smtpmail-queue-dir t)) (with-current-buffer buffer-data (erase-buffer) (insert-buffer tembuf) @@ -397,11 +406,14 @@ This is relative to `smtpmail-queue-dir'.") (with-temp-buffer (let ((coding-system-for-read 'no-conversion)) (insert-file-contents file-msg)) - (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp smtpmail-recipient-address-list - (current-buffer))) - (error "Sending failed; SMTP protocol error")) - (error "Sending failed; no recipients"))) + (let ((smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + user-mail-address))) + (if (not (null smtpmail-recipient-address-list)) + (if (not (smtpmail-via-smtp smtpmail-recipient-address-list + (current-buffer))) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")))) (delete-file file-msg) (delete-file (concat file-msg ".el")) (delete-region (point-at-bol) (point-at-bol 2))) @@ -457,7 +469,9 @@ This is relative to `smtpmail-queue-dir'.") (let ((cred (smtpmail-find-credentials smtpmail-starttls-credentials host port))) (if (null (and cred (condition-case () - (call-process "starttls") + (progn + (require 'starttls) + (call-process starttls-program)) (error nil)))) ;; The normal case. (open-network-stream "SMTP" process-buffer host port) @@ -469,7 +483,14 @@ This is relative to `smtpmail-queue-dir'.") (setq cred-key (expand-file-name cred-key))) (file-regular-p (setq cred-cert (expand-file-name cred-cert)))) - (list "--key-file" cred-key "--cert-file" cred-cert)))) + (list "--key-file" cred-key "--cert-file" cred-cert))) + (starttls-extra-arguments + (when (and (stringp cred-key) (stringp cred-cert) + (file-regular-p + (setq cred-key (expand-file-name cred-key))) + (file-regular-p + (setq cred-cert (expand-file-name cred-cert)))) + (list "--x509keyfile" cred-key "--x509certfile" cred-cert)))) (starttls-open-stream "SMTP" process-buffer host port))))) (defun smtpmail-try-auth-methods (process supported-extensions host port) @@ -477,9 +498,9 @@ This is relative to `smtpmail-queue-dir'.") (mech (car (smtpmail-intersection smtpmail-auth-supported mechs))) (cred (if (stringp smtpmail-auth-credentials) (let* ((netrc (netrc-parse smtpmail-auth-credentials)) - (hostentry (netrc-machine - netrc host (format "%s" (or port "smtp")) - "smtp"))) + (port-name (format "%s" (or port "smtp"))) + (hostentry (netrc-machine netrc host port-name + port-name))) (when hostentry (list host port (netrc-get hostentry "login") @@ -493,7 +514,7 @@ This is relative to `smtpmail-queue-dir'.") (smtpmail-cred-server cred) (smtpmail-cred-port cred)))))) ret) - (when cred + (when (and cred mech) (cond ((eq mech 'cram-md5) (smtpmail-send-command process (format "AUTH %s" mech)) @@ -541,9 +562,12 @@ This is relative to `smtpmail-queue-dir'.") (host (or smtpmail-smtp-server (error "`smtpmail-smtp-server' not defined"))) (port smtpmail-smtp-service) - (envelope-from (or (mail-envelope-from) - smtpmail-mail-address - user-mail-address)) + ;; smtpmail-mail-address should be set to the appropriate + ;; buffer-local value by the caller, but in case not: + (envelope-from (or smtpmail-mail-address + (and mail-specify-envelope-from + (mail-envelope-from)) + user-mail-address)) response-code greeting process-buffer @@ -657,7 +681,7 @@ This is relative to `smtpmail-queue-dir'.") (>= (car response-code) 400)) (throw 'done nil)))) - ;; MAIL FROM: + ;; MAIL FROM: (let ((size-part (if (or (member 'size supported-extensions) (assoc 'size supported-extensions)) @@ -666,13 +690,8 @@ This is relative to `smtpmail-queue-dir'.") ;; size estimate: (+ (- (point-max) (point-min)) ;; Add one byte for each change-of-line - ;; because or CR-LF representation: - (count-lines (point-min) (point-max)) - ;; For some reason, an empty line is - ;; added to the message. Maybe this - ;; is a bug, but it can't hurt to add - ;; those two bytes anyway: - 2))) + ;; because of CR-LF representation: + (count-lines (point-min) (point-max))))) "")) (body-part (if (member '8bitmime supported-extensions) @@ -692,8 +711,8 @@ This is relative to `smtpmail-queue-dir'.") "") ""))) ; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) - (smtpmail-send-command process (format "MAIL FROM: <%s>%s%s" - envelope-from + (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" + envelope-from size-part body-part)) @@ -703,10 +722,10 @@ This is relative to `smtpmail-queue-dir'.") (throw 'done nil) )) - ;; RCPT TO: + ;; RCPT TO: (let ((n 0)) (while (not (null (nth n recipient))) - (smtpmail-send-command process (format "RCPT TO: <%s>" (smtpmail-maybe-append-domain (nth n recipient)))) + (smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient)))) (setq n (1+ n)) (setq response-code (smtpmail-read-response process)) @@ -769,49 +788,49 @@ This is relative to `smtpmail-queue-dir'.") (response-continue t) (return-value '(nil ())) match-end) - - (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)) - - (setq match-end (point)) - (setq response-strings - (cons (buffer-substring smtpmail-read-point (- match-end 2)) - response-strings)) - - (goto-char smtpmail-read-point) - (if (looking-at "[0-9]+ ") - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (if smtpmail-debug-info - (message "%s" (car response-strings))) - - (setq smtpmail-read-point match-end) - - ;; ignore lines that start with "0" - (if (looking-at "0[0-9]+ ") - nil + (catch 'done + (while response-continue + (goto-char smtpmail-read-point) + (while (not (search-forward "\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (throw 'done nil)) + (accept-process-output process) + (goto-char smtpmail-read-point)) + + (setq match-end (point)) + (setq response-strings + (cons (buffer-substring smtpmail-read-point (- match-end 2)) + response-strings)) + + (goto-char smtpmail-read-point) + (if (looking-at "[0-9]+ ") + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (if smtpmail-debug-info + (message "%s" (car response-strings))) + + (setq smtpmail-read-point match-end) + + ;; ignore lines that start with "0" + (if (looking-at "0[0-9]+ ") + nil + (setq response-continue nil) + (setq return-value + (cons (string-to-int + (buffer-substring begin end)) + (nreverse response-strings))))) + + (if (looking-at "[0-9]+-") + (progn (if smtpmail-debug-info + (message "%s" (car response-strings))) + (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 (string-to-int - (buffer-substring begin end)) - (nreverse response-strings))))) - - (if (looking-at "[0-9]+-") - (progn (if smtpmail-debug-info - (message "%s" (car response-strings))) - (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 (nreverse response-strings))) - ) - ))) - (setq smtpmail-read-point match-end) + (cons nil (nreverse response-strings))))))) + (setq smtpmail-read-point match-end)) return-value)) @@ -844,31 +863,15 @@ This is relative to `smtpmail-queue-dir'.") ) (defun smtpmail-send-data (process buffer) - (let - ((data-continue t) - (sending-data nil) - this-line - this-line-end) - + (let ((data-continue t) sending-data) (with-current-buffer buffer (goto-char (point-min))) - (while data-continue (with-current-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) - ) - ) - ) - + (setq sending-data (buffer-substring (point-at-bol) (point-at-eol))) + (end-of-line 2) + (setq data-continue (not (eobp)))) + (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:
." @@ -946,4 +949,5 @@ many continuation lines." (provide 'smtpmail) +;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 ;;; smtpmail.el ends here