X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/60ed3fa5f057c13e7043796e994abea3e1e5734a..2d8a544976354b3787e4f28f2d97b3ab96f4a052:/lisp/mail/smtpmail.el diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index b23970d441..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 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004 +;; Free Software Foundation, Inc. ;; Author: Tomoji Kagatani ;; Maintainer: Simon Josefsson @@ -44,8 +45,10 @@ ;; '(("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 +;; To queue mail, set smtpmail-queue-mail to t and use ;; smtpmail-send-queued-mail to send. ;; Modified by Stephen Cranefield , @@ -66,7 +69,6 @@ ;;; Code: (require 'sendmail) -(require 'time-stamp) (autoload 'starttls-open-stream "starttls") (autoload 'starttls-negotiate "starttls") (autoload 'mail-strip-quoted-names "mail-utils") @@ -74,6 +76,8 @@ (autoload 'message-make-message-id "message") (autoload 'rfc2104-hash "rfc2104") (autoload 'netrc-parse "netrc") +(autoload 'netrc-machine "netrc") +(autoload 'netrc-get "netrc") ;;; (defgroup smtpmail nil @@ -82,11 +86,12 @@ (defcustom smtpmail-default-smtp-server nil - "*Specify default SMTP server." + "*Specify default SMTP server. +This only has effect if you specify it before loading the smtpmail library." :type '(choice (const nil) string) :group 'smtpmail) -(defcustom smtpmail-smtp-server +(defcustom smtpmail-smtp-server (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) "*The name of the host running SMTP server." :type '(choice (const nil) string) @@ -139,7 +144,7 @@ The commands enables verbose information from the SMTP server." :type 'boolean :group 'smtpmail) -(defcustom smtpmail-queue-mail nil +(defcustom smtpmail-queue-mail nil "*Specify if mail is queued (if t) or sent immediately (if nil). If queued, it is stored in the directory `smtpmail-queue-dir' and sent with `smtpmail-send-queued-mail'." @@ -165,7 +170,7 @@ looks like `user@realm'." (string :tag "Username") (choice (const :tag "Query when needed" nil) (string :tag "Password"))))) - :version "21.3" + :version "21.4" :group 'smtpmail) (defcustom smtpmail-starttls-credentials '(("" 25 "" "")) @@ -209,6 +214,9 @@ This is relative to `smtpmail-queue-dir'.") ;;; ;;; +(defvar smtpmail-mail-address nil + "Value to use for envelope-from address for mail from ambient buffer.") + ;;;###autoload (defun smtpmail-send-it () (let ((errbuf (if mail-interactive @@ -218,6 +226,11 @@ This is relative to `smtpmail-queue-dir'.") (case-fold-search nil) delimline (mailbuf (current-buffer)) + ;; 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)) @@ -258,7 +271,7 @@ This is relative to `smtpmail-queue-dir'.") ;; they put one in themselves. (goto-char (point-min)) (if (not (re-search-forward "^From:" delimline t)) - (let* ((login user-mail-address) + (let* ((login smtpmail-mail-address) (fullname (user-full-name))) (cond ((eq mail-from-style 'angles) (insert "From: " fullname) @@ -292,7 +305,7 @@ This is relative to `smtpmail-queue-dir'.") ;; ... then undo escaping of matching parentheses, ;; including matching nested parentheses. (goto-char fullname-start) - (while (re-search-forward + (while (re-search-forward "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" fullname-end 1) (replace-match "\\1(\\3)" t) @@ -327,26 +340,29 @@ This is relative to `smtpmail-queue-dir'.") (setq smtpmail-recipient-address-list (smtpmail-deduce-address-list tembuf (point-min) delimline)) (kill-buffer smtpmail-address-buffer) - + (smtpmail-do-bcc delimline) ; Send or queue (if (not smtpmail-queue-mail) (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp + (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf)) (error "Sending failed; SMTP protocol error")) (error "Sending failed; no recipients")) - (let* ((file-data (concat - smtpmail-queue-dir - (concat (time-stamp-yyyy-mm-dd) - "_" (time-stamp-hh:mm:ss) - "_" - (setq smtpmail-queue-counter - (1+ smtpmail-queue-counter))))) - (file-elisp (concat file-data ".el")) + (let* ((file-data + (expand-file-name + (format "%s_%i" + (format-time-string "%Y-%m-%d_%H:%M:%S") + (setq smtpmail-queue-counter + (1+ smtpmail-queue-counter))) + smtpmail-queue-dir)) + (file-data (convert-standard-filename file-data)) + (file-elisp (concat file-data ".el")) (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) @@ -356,12 +372,12 @@ This is relative to `smtpmail-queue-dir'.") (insert (concat "(setq smtpmail-recipient-address-list '" (prin1-to-string smtpmail-recipient-address-list) - ")\n")) + ")\n")) (write-file file-elisp) (set-buffer (generate-new-buffer buffer-scratch)) (insert (concat file-data "\n")) - (append-to-file (point-min) - (point-max) + (append-to-file (point-min) + (point-max) smtpmail-queue-index) ) (kill-buffer buffer-scratch) @@ -371,6 +387,7 @@ This is relative to `smtpmail-queue-dir'.") (if (bufferp errbuf) (kill-buffer errbuf))))) +;;;###autoload (defun smtpmail-send-queued-mail () "Send mail that was queued as a result of setting `smtpmail-queue-mail'." (interactive) @@ -389,14 +406,17 @@ 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")) - (kill-line 1)) + (delete-region (point-at-bol) (point-at-bol 2))) (write-region (point-min) (point-max) smtpmail-queue-index)))) ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) @@ -449,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) @@ -461,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) @@ -469,12 +498,13 @@ 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"))) - (list host port - (netrc-get hostentry "login") - (netrc-get hostentry "password"))) + (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") + (netrc-get hostentry "password")))) (smtpmail-find-credentials smtpmail-auth-credentials host port))) (passwd (when cred @@ -484,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)) @@ -521,7 +551,7 @@ This is relative to `smtpmail-queue-dir'.") (>= (car ret) 400)) (throw 'done nil))) (t - (error "Mechanism %s not implemented" mech))) + (error "Mechanism %s not implemented" mech))) ;; Remember the password. (when (and (not (stringp smtpmail-auth-credentials)) (null (smtpmail-cred-passwd cred))) @@ -532,6 +562,12 @@ This is relative to `smtpmail-queue-dir'.") (host (or smtpmail-smtp-server (error "`smtpmail-smtp-server' not defined"))) (port smtpmail-smtp-service) + ;; 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 @@ -558,7 +594,7 @@ This is relative to `smtpmail-queue-dir'.") (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)) @@ -605,7 +641,7 @@ This is relative to `smtpmail-queue-dir'.") (if (and do-starttls (smtpmail-find-credentials smtpmail-starttls-credentials host port) (member 'starttls supported-extensions) - (process-id process)) + (numberp (process-id process))) (progn (smtpmail-send-command process (format "STARTTLS")) (if (or (null (car (setq response-code (smtpmail-read-response process)))) @@ -615,7 +651,7 @@ This is relative to `smtpmail-queue-dir'.") (starttls-negotiate process) (setq do-starttls nil)) (setq do-ehlo nil)))) - + (smtpmail-try-auth-methods process supported-extensions host port) (if (or (member 'onex supported-extensions) @@ -645,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)) @@ -654,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) @@ -680,9 +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" - (or mail-envelope-from - user-mail-address) + (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" + envelope-from size-part body-part)) @@ -691,11 +721,11 @@ This is relative to `smtpmail-queue-dir'.") (>= (car response-code) 400)) (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)) @@ -705,7 +735,7 @@ This is relative to `smtpmail-queue-dir'.") (throw 'done nil) ) )) - + ;; DATA (smtpmail-send-command process "DATA") @@ -742,7 +772,9 @@ This is relative to `smtpmail-queue-dir'.") ; (>= (car response-code) 400)) ; (throw 'done nil) ; ) - (delete-process process)))))) + (delete-process process) + (unless smtpmail-debug-info + (kill-buffer process-buffer))))))) (defun smtpmail-process-filter (process output) @@ -756,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)) @@ -818,7 +850,7 @@ This is relative to `smtpmail-queue-dir'.") smtpmail-code-conv-from) (setq data (string-as-multibyte (encode-coding-string data smtpmail-code-conv-from)))) - + (if smtpmail-debug-info (insert data "\r\n")) @@ -831,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:
." @@ -933,4 +949,5 @@ many continuation lines." (provide 'smtpmail) +;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 ;;; smtpmail.el ends here