comparison lisp/mail/smtpmail.el @ 89909:68c22ea6027c

Sync to HEAD

89908:ee1402f7b568

;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail

;; Copyright (C) 1995, 1996, 2001, 2002, 2003 Free Software Foundation, Inc.

;; Author: Tomoji Kagatani <[e-mail]>
;; Maintainer: Simon Josefsson <[e-mail]>
;; w32 Maintainer: Brian D. Carlstrom <[e-mail]>
;; ESMTP support: Simon Leinen <[e-mail]>

;;(setq smtpmail-debug-info t) ; only to debug problems
;;(setq smtpmail-auth-credentials  ; or use ~/.authinfo
;;      '(("YOUR SMTP HOST" 25 "username" "password")))
;;(setq smtpmail-starttls-credentials
;;      '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert")))

;; To queue mail, set smtpmail-queue-mail to t and use
;; smtpmail-send-queued-mail to send.

;; Modified by Stephen Cranefield <[e-mail]>,

;;;
;;;
;;;

(defvar smtpmail-mail-address nil
  "Value of `user-mail-address' in ambient buffer.")

;;;###autoload
(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)
	delimline
	(mailbuf (current-buffer))
	(smtpmail-mail-address user-mail-address)
	(smtpmail-code-conv-from
	 (if enable-multibyte-characters
	     (let ((sendmail-coding-system smtpmail-code-conv-from))
	       (select-message-coding-system)))))
    (unwind-protect

	;; the MIME headers, and code conversions might guess the
	;; encoding wrongly.
	(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")))
	(delete-file file-msg)
	(delete-file (concat file-msg ".el"))
	(delete-region (point-at-bol) (point-at-bol 2)))
      (write-region (point-min) (point-max) smtpmail-queue-index))))

(defun smtpmail-try-auth-methods (process supported-extensions host port)
  (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
	 (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")))
                     (when hostentry
                       (list host port
                             (netrc-get hostentry "login")
                             (netrc-get hostentry "password"))))
		 (smtpmail-find-credentials

		       (read-passwd
			(format "SMTP password for %s:%s: "
				(smtpmail-cred-server cred)
				(smtpmail-cred-port cred))))))
	 ret)
    (when cred
      (cond
       ((eq mech 'cram-md5)
	(smtpmail-send-command process (format "AUTH %s" mech))
	(if (or (null (car (setq ret (smtpmail-read-response process))))
		(not (integerp (car ret)))

(defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
  (let ((process nil)
	(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))
	response-code
	greeting
	process-buffer
	(supported-extensions '()))
    (unwind-protect

		  (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>
	    (let ((size-part
		   (if (or (member 'size supported-extensions)
			   (assoc 'size supported-extensions))
		       (format " SIZE=%d"
			       (with-current-buffer smtpmail-text-buffer
				 ;; 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)))
		     ""))
		  (body-part
		   (if (member '8bitmime supported-extensions)
		       ;; FIXME:
		       ;; Code should be added here that transforms

		       (if nil
			   " BODY=8BITMIME"
			 "")
		     "")))
;	      (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
						     size-part
						     body-part))

	      (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>
	    (let ((n 0))
	      (while (not (null (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))
		(if (or (null (car response-code))
			(not (integerp (car response-code)))

  (let ((case-fold-search nil)
	(response-strings nil)
	(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
	      (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)
    return-value))


(defun smtpmail-send-command (process command)
  (goto-char (point-max))

  (process-send-string process data)
  (process-send-string process "\r\n")
  )

(defun smtpmail-send-data (process buffer)
  (let
      ((data-continue t)
       (sending-data nil)
       this-line
       this-line-end)

    (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)
      )
    )
  )


(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
  "Get address list suitable for smtp RCPT TO: <address>."
  (unwind-protect
      (with-current-buffer smtpmail-address-buffer

	  (replace-match ""))))))


(provide 'smtpmail)

;;; smtpmail.el ends here

89909:68c22ea6027c

;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail

;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004
;;   Free Software Foundation, Inc.

;; Author: Tomoji Kagatani <[e-mail]>
;; Maintainer: Simon Josefsson <[e-mail]>
;; w32 Maintainer: Brian D. Carlstrom <[e-mail]>
;; ESMTP support: Simon Leinen <[e-mail]>

;;(setq smtpmail-debug-info t) ; only to debug problems
;;(setq smtpmail-auth-credentials  ; or use ~/.authinfo
;;      '(("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.

;; Modified by Stephen Cranefield <[e-mail]>,

;;;
;;;
;;;

(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
		    (generate-new-buffer " smtpmail errors")
		  0))
	(tembuf (generate-new-buffer " smtpmail temp"))
	(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))
	       (select-message-coding-system)))))
    (unwind-protect

	;; the MIME headers, and code conversions might guess the
	;; encoding wrongly.
	(with-temp-buffer
	  (let ((coding-system-for-read 'no-conversion))
	    (insert-file-contents file-msg))
          (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)))
      (write-region (point-min) (point-max) smtpmail-queue-index))))

(defun smtpmail-try-auth-methods (process supported-extensions host port)
  (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
	 (mech (car (smtpmail-intersection smtpmail-auth-supported mechs)))
	 (cred (if (stringp smtpmail-auth-credentials)
		   (let* ((netrc (netrc-parse smtpmail-auth-credentials))
                          (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

		       (read-passwd
			(format "SMTP password for %s:%s: "
				(smtpmail-cred-server cred)
				(smtpmail-cred-port cred))))))
	 ret)
    (when (and cred mech)
      (cond
       ((eq mech 'cram-md5)
	(smtpmail-send-command process (format "AUTH %s" mech))
	(if (or (null (car (setq ret (smtpmail-read-response process))))
		(not (integerp (car ret)))

(defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
  (let ((process nil)
	(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
	(supported-extensions '()))
    (unwind-protect

		  (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>
	    (let ((size-part
		   (if (or (member 'size supported-extensions)
			   (assoc 'size supported-extensions))
		       (format " SIZE=%d"
			       (with-current-buffer smtpmail-text-buffer
				 ;; size estimate:
				 (+ (- (point-max) (point-min))
				    ;; Add one byte for each change-of-line
				    ;; because of CR-LF representation:
				    (count-lines (point-min) (point-max)))))
		     ""))
		  (body-part
		   (if (member '8bitmime supported-extensions)
		       ;; FIXME:
		       ;; Code should be added here that transforms

		       (if nil
			   " BODY=8BITMIME"
			 "")
		     "")))
;	      (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
						     size-part
						     body-part))

	      (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>
	    (let ((n 0))
	      (while (not (null (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))
		(if (or (null (car response-code))
			(not (integerp (car response-code)))

  (let ((case-fold-search nil)
	(response-strings nil)
	(response-continue t)
	(return-value '(nil ()))
	match-end)
    (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 nil (nreverse response-strings)))))))
      (setq smtpmail-read-point match-end))
    return-value))


(defun smtpmail-send-command (process command)
  (goto-char (point-max))

  (process-send-string process data)
  (process-send-string process "\r\n")
  )

(defun smtpmail-send-data (process buffer)
  (let ((data-continue t) sending-data)
    (with-current-buffer buffer
      (goto-char (point-min)))
    (while data-continue
      (with-current-buffer buffer
        (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: <address>."
  (unwind-protect
      (with-current-buffer smtpmail-address-buffer

	  (replace-match ""))))))


(provide 'smtpmail)

;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
;;; smtpmail.el ends here