1;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail 2 3;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 4;; 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> 7;; Maintainer: Simon Josefsson <simon@josefsson.org> 8;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu> 9;; ESMTP support: Simon Leinen <simon@switch.ch> 10;; Hacked by Mike Taylor, 11th October 1999 to add support for 11;; automatically appending a domain to RCPT TO: addresses. 12;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz> 13;; Keywords: mail 14 15;; This file is part of GNU Emacs. 16 17;; GNU Emacs is free software; you can redistribute it and/or modify 18;; it under the terms of the GNU General Public License as published by 19;; the Free Software Foundation; either version 2, or (at your option) 20;; any later version. 21 22;; GNU Emacs is distributed in the hope that it will be useful, 23;; but WITHOUT ANY WARRANTY; without even the implied warranty of 24;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 25;; GNU General Public License for more details. 26 27;; You should have received a copy of the GNU General Public License 28;; along with GNU Emacs; see the file COPYING. If not, write to the 29;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 30;; Boston, MA 02110-1301, USA. 31 32;;; Commentary: 33 34;; Send Mail to smtp host from smtpmail temp buffer. 35 36;; Please add these lines in your .emacs(_emacs) or use customize. 37;; 38;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail' 39;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus 40;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") 41;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") 42;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME") 43;;(setq smtpmail-debug-info t) ; only to debug problems 44;;(setq smtpmail-auth-credentials ; or use ~/.authinfo 45;; '(("YOUR SMTP HOST" 25 "username" "password"))) 46;;(setq smtpmail-starttls-credentials 47;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert"))) 48;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an 49;; integer or a string, just as long as they match (eq). 50 51;; To queue mail, set smtpmail-queue-mail to t and use 52;; smtpmail-send-queued-mail to send. 53 54;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>, 55;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism. 56;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html 57;; Rewritten by Simon Josefsson to use same credential variable as AUTH 58;; support below. 59 60;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP 61;; Authentication by the AUTH mechanism. 62;; See http://www.ietf.org/rfc/rfc2554.txt 63 64;; Modified by Simon Josefsson <simon@josefsson.org>, 2000-10-07, to support 65;; STARTTLS. Requires external program 66;; ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz. 67;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2487.txt 68 69;;; Code: 70 71(require 'sendmail) 72(autoload 'starttls-open-stream "starttls") 73(autoload 'starttls-negotiate "starttls") 74(autoload 'mail-strip-quoted-names "mail-utils") 75(autoload 'message-make-date "message") 76(autoload 'message-make-message-id "message") 77(autoload 'rfc2104-hash "rfc2104") 78(autoload 'netrc-parse "netrc") 79(autoload 'netrc-machine "netrc") 80(autoload 'netrc-get "netrc") 81 82;;; 83(defgroup smtpmail nil 84 "SMTP protocol for sending mail." 85 :group 'mail) 86 87 88(defcustom smtpmail-default-smtp-server nil 89 "*Specify default SMTP server. 90This only has effect if you specify it before loading the smtpmail library." 91 :type '(choice (const nil) string) 92 :group 'smtpmail) 93 94(defcustom smtpmail-smtp-server 95 (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) 96 "*The name of the host running SMTP server." 97 :type '(choice (const nil) string) 98 :group 'smtpmail) 99 100(defcustom smtpmail-smtp-service 25 101 "*SMTP service port number. 102The default value would be \"smtp\" or 25." 103 :type '(choice (integer :tag "Port") (string :tag "Service")) 104 :group 'smtpmail) 105 106(defcustom smtpmail-local-domain nil 107 "*Local domain name without a host name. 108If the function `system-name' returns the full internet address, 109don't define this value." 110 :type '(choice (const nil) string) 111 :group 'smtpmail) 112 113(defcustom smtpmail-sendto-domain nil 114 "*Local domain name without a host name. 115This is appended (with an @-sign) to any specified recipients which do 116not include an @-sign, so that each RCPT TO address is fully qualified. 117\(Some configurations of sendmail require this.) 118 119Don't bother to set this unless you have get an error like: 120 Sending failed; SMTP protocol error 121when sending mail, and the *trace of SMTP session to <somewhere>* 122buffer includes an exchange like: 123 RCPT TO: <someone> 124 501 <someone>: recipient address must contain a domain 125" 126 :type '(choice (const nil) string) 127 :group 'smtpmail) 128 129(defcustom smtpmail-debug-info nil 130 "Whether to print info in buffer *trace of SMTP session to <somewhere>*. 131See also `smtpmail-debug-verb' which determines if the SMTP protocol should 132be verbose as well." 133 :type 'boolean 134 :group 'smtpmail) 135 136(defcustom smtpmail-debug-verb nil 137 "Whether this library sends the SMTP VERB command or not. 138The commands enables verbose information from the SMTP server." 139 :type 'boolean 140 :group 'smtpmail) 141 142(defcustom smtpmail-code-conv-from nil ;; *junet* 143 "*smtpmail code convert from this code to *internal*..for tiny-mime.." 144 :type 'boolean 145 :group 'smtpmail) 146 147(defcustom smtpmail-queue-mail nil 148 "*If set, mail is queued; otherwise it is sent immediately. 149If queued, it is stored in the directory `smtpmail-queue-dir' 150and sent with `smtpmail-send-queued-mail'." 151 :type 'boolean 152 :group 'smtpmail) 153 154(defcustom smtpmail-queue-dir "~/Mail/queued-mail/" 155 "*Directory where `smtpmail.el' stores queued mail." 156 :type 'directory 157 :group 'smtpmail) 158 159(defcustom smtpmail-auth-credentials "~/.authinfo" 160 "Specify username and password for servers, directly or via .netrc file. 161This variable can either be a filename pointing to a file in netrc(5) 162format, or list of four-element lists that contain, in order, 163`servername' (a string), `port' (an integer), `user' (a string) and 164`password' (a string, or nil to query the user when needed). If you 165need to enter a `realm' too, add it to the user string, so that it 166looks like `user@realm'." 167 :type '(choice file 168 (repeat (list (string :tag "Server") 169 (integer :tag "Port") 170 (string :tag "Username") 171 (choice (const :tag "Query when needed" nil) 172 (string :tag "Password"))))) 173 :version "22.1" 174 :group 'smtpmail) 175 176(defcustom smtpmail-starttls-credentials '(("" 25 "" "")) 177 "Specify STARTTLS keys and certificates for servers. 178This is a list of four-element list with `servername' (a string), 179`port' (an integer), `key' (a filename) and `certificate' (a 180filename). 181If you do not have a certificate/key pair, leave the `key' and 182`certificate' fields as `nil'. A key/certificate pair is only 183needed if you want to use X.509 client authenticated 184connections." 185 :type '(repeat (list (string :tag "Server") 186 (integer :tag "Port") 187 (file :tag "Key") 188 (file :tag "Certificate"))) 189 :version "21.1" 190 :group 'smtpmail) 191 192(defcustom smtpmail-warn-about-unknown-extensions nil 193 "*If set, print warnings about unknown SMTP extensions. 194This is mainly useful for development purposes, to learn about 195new SMTP extensions that might be useful to support." 196 :type 'boolean 197 :version "21.1" 198 :group 'smtpmail) 199 200(defvar smtpmail-queue-index-file "index" 201 "File name of queued mail index. 202This is relative to `smtpmail-queue-dir'.") 203 204(defvar smtpmail-address-buffer) 205(defvar smtpmail-recipient-address-list) 206 207(defvar smtpmail-queue-counter 0) 208 209;; Buffer-local variable. 210(defvar smtpmail-read-point) 211 212(defvar smtpmail-queue-index (concat smtpmail-queue-dir 213 smtpmail-queue-index-file)) 214 215(defconst smtpmail-auth-supported '(cram-md5 plain login) 216 "List of supported SMTP AUTH mechanisms.") 217 218;;; 219;;; 220;;; 221 222(defvar smtpmail-mail-address nil 223 "Value to use for envelope-from address for mail from ambient buffer.") 224 225;;;###autoload 226(defun smtpmail-send-it () 227 (let ((errbuf (if mail-interactive 228 (generate-new-buffer " smtpmail errors") 229 0)) 230 (tembuf (generate-new-buffer " smtpmail temp")) 231 (case-fold-search nil) 232 delimline 233 (mailbuf (current-buffer)) 234 ;; Examine this variable now, so that 235 ;; local binding in the mail buffer will take effect. 236 (smtpmail-mail-address 237 (or (and mail-specify-envelope-from (mail-envelope-from)) 238 user-mail-address)) 239 (smtpmail-code-conv-from 240 (if enable-multibyte-characters 241 (let ((sendmail-coding-system smtpmail-code-conv-from)) 242 (select-message-coding-system))))) 243 (unwind-protect 244 (save-excursion 245 (set-buffer tembuf) 246 (erase-buffer) 247 ;; Use the same buffer-file-coding-system as in the mail 248 ;; buffer, otherwise any write-region invocations (e.g., in 249 ;; mail-do-fcc below) will annoy with asking for a suitable 250 ;; encoding. 251 (set-buffer-file-coding-system smtpmail-code-conv-from nil t) 252 (insert-buffer-substring mailbuf) 253 (goto-char (point-max)) 254 ;; require one newline at the end. 255 (or (= (preceding-char) ?\n) 256 (insert ?\n)) 257 ;; Change header-delimiter to be what sendmail expects. 258 (mail-sendmail-undelimit-header) 259 (setq delimline (point-marker)) 260;; (sendmail-synch-aliases) 261 (if mail-aliases 262 (expand-mail-aliases (point-min) delimline)) 263 (goto-char (point-min)) 264 ;; ignore any blank lines in the header 265 (while (and (re-search-forward "\n\n\n*" delimline t) 266 (< (point) delimline)) 267 (replace-match "\n")) 268 (let ((case-fold-search t)) 269 ;; We used to process Resent-... headers here, 270 ;; but it was not done properly, and the job 271 ;; is done correctly in smtpmail-deduce-address-list. 272 ;; Don't send out a blank subject line 273 (goto-char (point-min)) 274 (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t) 275 (replace-match "") 276 ;; This one matches a Subject just before the header delimiter. 277 (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t) 278 (= (match-end 0) delimline)) 279 (replace-match ""))) 280 ;; Put the "From:" field in unless for some odd reason 281 ;; they put one in themselves. 282 (goto-char (point-min)) 283 (if (not (re-search-forward "^From:" delimline t)) 284 (let* ((login smtpmail-mail-address) 285 (fullname (user-full-name))) 286 (cond ((eq mail-from-style 'angles) 287 (insert "From: " fullname) 288 (let ((fullname-start (+ (point-min) 6)) 289 (fullname-end (point-marker))) 290 (goto-char fullname-start) 291 ;; Look for a character that cannot appear unquoted 292 ;; according to RFC 822. 293 (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" 294 fullname-end 1) 295 (progn 296 ;; Quote fullname, escaping specials. 297 (goto-char fullname-start) 298 (insert "\"") 299 (while (re-search-forward "[\"\\]" 300 fullname-end 1) 301 (replace-match "\\\\\\&" t)) 302 (insert "\"")))) 303 (insert " <" login ">\n")) 304 ((eq mail-from-style 'parens) 305 (insert "From: " login " (") 306 (let ((fullname-start (point))) 307 (insert fullname) 308 (let ((fullname-end (point-marker))) 309 (goto-char fullname-start) 310 ;; RFC 822 says \ and nonmatching parentheses 311 ;; must be escaped in comments. 312 ;; Escape every instance of ()\ ... 313 (while (re-search-forward "[()\\]" fullname-end 1) 314 (replace-match "\\\\\\&" t)) 315 ;; ... then undo escaping of matching parentheses, 316 ;; including matching nested parentheses. 317 (goto-char fullname-start) 318 (while (re-search-forward 319 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" 320 fullname-end 1) 321 (replace-match "\\1(\\3)" t) 322 (goto-char fullname-start)))) 323 (insert ")\n")) 324 ((null mail-from-style) 325 (insert "From: " login "\n"))))) 326 ;; Insert a `Message-Id:' field if there isn't one yet. 327 (goto-char (point-min)) 328 (unless (re-search-forward "^Message-Id:" delimline t) 329 (insert "Message-Id: " (message-make-message-id) "\n")) 330 ;; Insert a `Date:' field if there isn't one yet. 331 (goto-char (point-min)) 332 (unless (re-search-forward "^Date:" delimline t) 333 (insert "Date: " (message-make-date) "\n")) 334 ;; Possibly add a MIME header for the current coding system 335 (let (charset) 336 (goto-char (point-min)) 337 (and (eq mail-send-nonascii 'mime) 338 (not (re-search-forward "^MIME-version:" delimline t)) 339 (progn (skip-chars-forward "\0-\177") 340 (/= (point) (point-max))) 341 smtpmail-code-conv-from 342 (setq charset 343 (coding-system-get smtpmail-code-conv-from 344 'mime-charset)) 345 (goto-char delimline) 346 (insert "MIME-version: 1.0\n" 347 "Content-type: text/plain; charset=" 348 (symbol-name charset) 349 "\nContent-Transfer-Encoding: 8bit\n"))) 350 ;; Insert an extra newline if we need it to work around 351 ;; Sun's bug that swallows newlines. 352 (goto-char (1+ delimline)) 353 (if (eval mail-mailer-swallows-blank-line) 354 (newline)) 355 ;; Find and handle any FCC fields. 356 (goto-char (point-min)) 357 (if (re-search-forward "^FCC:" delimline t) 358 ;; Force mail-do-fcc to use the encoding of the mail 359 ;; buffer to encode outgoing messages on FCC files. 360 (let ((coding-system-for-write smtpmail-code-conv-from)) 361 (mail-do-fcc delimline))) 362 (if mail-interactive 363 (with-current-buffer errbuf 364 (erase-buffer)))) 365 ;; 366 ;; 367 ;; 368 (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) 369 (setq smtpmail-recipient-address-list 370 (smtpmail-deduce-address-list tembuf (point-min) delimline)) 371 (kill-buffer smtpmail-address-buffer) 372 373 (smtpmail-do-bcc delimline) 374 ; Send or queue 375 (if (not smtpmail-queue-mail) 376 (if (not (null smtpmail-recipient-address-list)) 377 (if (not (smtpmail-via-smtp 378 smtpmail-recipient-address-list tembuf)) 379 (error "Sending failed; SMTP protocol error")) 380 (error "Sending failed; no recipients")) 381 (let* ((file-data 382 (expand-file-name 383 (format "%s_%i" 384 (format-time-string "%Y-%m-%d_%H:%M:%S") 385 (setq smtpmail-queue-counter 386 (1+ smtpmail-queue-counter))) 387 smtpmail-queue-dir)) 388 (file-data (convert-standard-filename file-data)) 389 (file-elisp (concat file-data ".el")) 390 (buffer-data (create-file-buffer file-data)) 391 (buffer-elisp (create-file-buffer file-elisp)) 392 (buffer-scratch "*queue-mail*")) 393 (unless (file-exists-p smtpmail-queue-dir) 394 (make-directory smtpmail-queue-dir t)) 395 (with-current-buffer buffer-data 396 (erase-buffer) 397 (set-buffer-file-coding-system smtpmail-code-conv-from nil t) 398 (insert-buffer-substring tembuf) 399 (write-file file-data) 400 (set-buffer buffer-elisp) 401 (erase-buffer) 402 (insert (concat 403 "(setq smtpmail-recipient-address-list '" 404 (prin1-to-string smtpmail-recipient-address-list) 405 ")\n")) 406 (write-file file-elisp) 407 (set-buffer (generate-new-buffer buffer-scratch)) 408 (insert (concat file-data "\n")) 409 (append-to-file (point-min) 410 (point-max) 411 smtpmail-queue-index) 412 ) 413 (kill-buffer buffer-scratch) 414 (kill-buffer buffer-data) 415 (kill-buffer buffer-elisp)))) 416 (kill-buffer tembuf) 417 (if (bufferp errbuf) 418 (kill-buffer errbuf))))) 419 420;;;###autoload 421(defun smtpmail-send-queued-mail () 422 "Send mail that was queued as a result of setting `smtpmail-queue-mail'." 423 (interactive) 424 (with-temp-buffer 425 ;;; Get index, get first mail, send it, update index, get second 426 ;;; mail, send it, etc... 427 (let ((file-msg "")) 428 (insert-file-contents smtpmail-queue-index) 429 (goto-char (point-min)) 430 (while (not (eobp)) 431 (setq file-msg (buffer-substring (point) (line-end-position))) 432 (load file-msg) 433 ;; Insert the message literally: it is already encoded as per 434 ;; the MIME headers, and code conversions might guess the 435 ;; encoding wrongly. 436 (with-temp-buffer 437 (let ((coding-system-for-read 'no-conversion)) 438 (insert-file-contents file-msg)) 439 (let ((smtpmail-mail-address 440 (or (and mail-specify-envelope-from (mail-envelope-from)) 441 user-mail-address))) 442 (if (not (null smtpmail-recipient-address-list)) 443 (if (not (smtpmail-via-smtp smtpmail-recipient-address-list 444 (current-buffer))) 445 (error "Sending failed; SMTP protocol error")) 446 (error "Sending failed; no recipients")))) 447 (delete-file file-msg) 448 (delete-file (concat file-msg ".el")) 449 (delete-region (point-at-bol) (point-at-bol 2))) 450 (write-region (point-min) (point-max) smtpmail-queue-index)))) 451 452;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) 453 454(defun smtpmail-fqdn () 455 (if smtpmail-local-domain 456 (concat (system-name) "." smtpmail-local-domain) 457 (system-name))) 458 459(defsubst smtpmail-cred-server (cred) 460 (nth 0 cred)) 461 462(defsubst smtpmail-cred-port (cred) 463 (nth 1 cred)) 464 465(defsubst smtpmail-cred-key (cred) 466 (nth 2 cred)) 467 468(defsubst smtpmail-cred-user (cred) 469 (nth 2 cred)) 470 471(defsubst smtpmail-cred-cert (cred) 472 (nth 3 cred)) 473 474(defsubst smtpmail-cred-passwd (cred) 475 (nth 3 cred)) 476 477(defun smtpmail-find-credentials (cred server port) 478 (catch 'done 479 (let ((l cred) el) 480 (while (setq el (pop l)) 481 (when (and (equal server (smtpmail-cred-server el)) 482 (equal port (smtpmail-cred-port el))) 483 (throw 'done el)))))) 484 485(defun smtpmail-maybe-append-domain (recipient) 486 (if (or (not smtpmail-sendto-domain) 487 (string-match "@" recipient)) 488 recipient 489 (concat recipient "@" smtpmail-sendto-domain))) 490 491(defun smtpmail-intersection (list1 list2) 492 (let ((result nil)) 493 (dolist (el2 list2) 494 (when (memq el2 list1) 495 (push el2 result))) 496 (nreverse result))) 497 498(defvar starttls-extra-args) 499(defvar starttls-extra-arguments) 500 501(defun smtpmail-open-stream (process-buffer host port) 502 (let ((cred (smtpmail-find-credentials 503 smtpmail-starttls-credentials host port))) 504 (if (null (and cred (condition-case () 505 (with-no-warnings 506 (require 'starttls) 507 (call-process (if starttls-use-gnutls 508 starttls-gnutls-program 509 starttls-program))) 510 (error nil)))) 511 ;; The normal case. 512 (open-network-stream "SMTP" process-buffer host port) 513 (let* ((cred-key (smtpmail-cred-key cred)) 514 (cred-cert (smtpmail-cred-cert cred)) 515 (starttls-extra-args 516 (append 517 starttls-extra-args 518 (when (and (stringp cred-key) (stringp cred-cert) 519 (file-regular-p 520 (setq cred-key (expand-file-name cred-key))) 521 (file-regular-p 522 (setq cred-cert (expand-file-name cred-cert)))) 523 (list "--key-file" cred-key "--cert-file" cred-cert)))) 524 (starttls-extra-arguments 525 (append 526 starttls-extra-arguments 527 (when (and (stringp cred-key) (stringp cred-cert) 528 (file-regular-p 529 (setq cred-key (expand-file-name cred-key))) 530 (file-regular-p 531 (setq cred-cert (expand-file-name cred-cert)))) 532 (list "--x509keyfile" cred-key "--x509certfile" cred-cert))))) 533 (starttls-open-stream "SMTP" process-buffer host port))))) 534 535(defun smtpmail-try-auth-methods (process supported-extensions host port) 536 (let* ((mechs (cdr-safe (assoc 'auth supported-extensions))) 537 (mech (car (smtpmail-intersection smtpmail-auth-supported mechs))) 538 (cred (if (stringp smtpmail-auth-credentials) 539 (let* ((netrc (netrc-parse smtpmail-auth-credentials)) 540 (port-name (format "%s" (or port "smtp"))) 541 (hostentry (netrc-machine netrc host port-name 542 port-name))) 543 (when hostentry 544 (list host port 545 (netrc-get hostentry "login") 546 (netrc-get hostentry "password")))) 547 (smtpmail-find-credentials 548 smtpmail-auth-credentials host port))) 549 (passwd (when cred 550 (or (smtpmail-cred-passwd cred) 551 (read-passwd 552 (format "SMTP password for %s:%s: " 553 (smtpmail-cred-server cred) 554 (smtpmail-cred-port cred)))))) 555 ret) 556 (when (and cred mech) 557 (cond 558 ((eq mech 'cram-md5) 559 (smtpmail-send-command process (upcase (format "AUTH %s" mech))) 560 (if (or (null (car (setq ret (smtpmail-read-response process)))) 561 (not (integerp (car ret))) 562 (>= (car ret) 400)) 563 (throw 'done nil)) 564 (when (eq (car ret) 334) 565 (let* ((challenge (substring (cadr ret) 4)) 566 (decoded (base64-decode-string challenge)) 567 (hash (rfc2104-hash 'md5 64 16 passwd decoded)) 568 (response (concat (smtpmail-cred-user cred) " " hash)) 569 ;; Osamu Yamane <yamane@green.ocn.ne.jp>: 570 ;; SMTP auth fails because the SMTP server identifies 571 ;; only the first part of the string (delimited by 572 ;; new line characters) as a response from the 573 ;; client, and the rest as distinct commands. 574 575 ;; In my case, the response string is 80 characters 576 ;; long. Without the no-line-break option for 577 ;; base64-encode-sting, only the first 76 characters 578 ;; are taken as a response to the server, and the 579 ;; authentication fails. 580 (encoded (base64-encode-string response t))) 581 (smtpmail-send-command process (format "%s" encoded)) 582 (if (or (null (car (setq ret (smtpmail-read-response process)))) 583 (not (integerp (car ret))) 584 (>= (car ret) 400)) 585 (throw 'done nil))))) 586 ((eq mech 'login) 587 (smtpmail-send-command process "AUTH LOGIN") 588 (if (or (null (car (setq ret (smtpmail-read-response process)))) 589 (not (integerp (car ret))) 590 (>= (car ret) 400)) 591 (throw 'done nil)) 592 (smtpmail-send-command 593 process (base64-encode-string (smtpmail-cred-user cred) t)) 594 (if (or (null (car (setq ret (smtpmail-read-response process)))) 595 (not (integerp (car ret))) 596 (>= (car ret) 400)) 597 (throw 'done nil)) 598 (smtpmail-send-command process (base64-encode-string passwd t)) 599 (if (or (null (car (setq ret (smtpmail-read-response process)))) 600 (not (integerp (car ret))) 601 (>= (car ret) 400)) 602 (throw 'done nil))) 603 ((eq mech 'plain) 604 ;; We used to send an empty initial request, and wait for an 605 ;; empty response, and then send the password, but this 606 ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this 607 ;; is not sent if the server did not advertise AUTH PLAIN in 608 ;; the EHLO response. See RFC 2554 for more info. 609 (smtpmail-send-command process 610 (concat "AUTH PLAIN " 611 (base64-encode-string 612 (concat "\0" 613 (smtpmail-cred-user cred) 614 "\0" 615 passwd) t))) 616 (if (or (null (car (setq ret (smtpmail-read-response process)))) 617 (not (integerp (car ret))) 618 (not (equal (car ret) 235))) 619 (throw 'done nil))) 620 621 (t 622 (error "Mechanism %s not implemented" mech))) 623 ;; Remember the password. 624 (when (and (not (stringp smtpmail-auth-credentials)) 625 (null (smtpmail-cred-passwd cred))) 626 (setcar (cdr (cdr (cdr cred))) passwd))))) 627 628(defun smtpmail-via-smtp (recipient smtpmail-text-buffer) 629 (let ((process nil) 630 (host (or smtpmail-smtp-server 631 (error "`smtpmail-smtp-server' not defined"))) 632 (port smtpmail-smtp-service) 633 ;; smtpmail-mail-address should be set to the appropriate 634 ;; buffer-local value by the caller, but in case not: 635 (envelope-from (or smtpmail-mail-address 636 (and mail-specify-envelope-from 637 (mail-envelope-from)) 638 user-mail-address)) 639 response-code 640 greeting 641 process-buffer 642 (supported-extensions '())) 643 (unwind-protect 644 (catch 'done 645 ;; get or create the trace buffer 646 (setq process-buffer 647 (get-buffer-create (format "*trace of SMTP session to %s*" host))) 648 649 ;; clear the trace buffer of old output 650 (with-current-buffer process-buffer 651 (setq buffer-undo-list t) 652 (erase-buffer)) 653 654 ;; open the connection to the server 655 (setq process (smtpmail-open-stream process-buffer host port)) 656 (and (null process) (throw 'done nil)) 657 658 ;; set the send-filter 659 (set-process-filter process 'smtpmail-process-filter) 660 661 (with-current-buffer process-buffer 662 (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) 663 (make-local-variable 'smtpmail-read-point) 664 (setq smtpmail-read-point (point-min)) 665 666 667 (if (or (null (car (setq greeting (smtpmail-read-response process)))) 668 (not (integerp (car greeting))) 669 (>= (car greeting) 400)) 670 (throw 'done nil) 671 ) 672 673 (let ((do-ehlo t) 674 (do-starttls t)) 675 (while do-ehlo 676 ;; EHLO 677 (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) 678 679 (if (or (null (car (setq response-code 680 (smtpmail-read-response process)))) 681 (not (integerp (car response-code))) 682 (>= (car response-code) 400)) 683 (progn 684 ;; HELO 685 (smtpmail-send-command 686 process (format "HELO %s" (smtpmail-fqdn))) 687 688 (if (or (null (car (setq response-code 689 (smtpmail-read-response process)))) 690 (not (integerp (car response-code))) 691 (>= (car response-code) 400)) 692 (throw 'done nil))) 693 (dolist (line (cdr (cdr response-code))) 694 (let ((name 695 (with-case-table ascii-case-table 696 (mapcar (lambda (s) (intern (downcase s))) 697 (split-string (substring line 4) "[ ]"))))) 698 (and (eq (length name) 1) 699 (setq name (car name))) 700 (and name 701 (cond ((memq (if (consp name) (car name) name) 702 '(verb xvrb 8bitmime onex xone 703 expn size dsn etrn 704 enhancedstatuscodes 705 help xusr 706 auth=login auth starttls)) 707 (setq supported-extensions 708 (cons name supported-extensions))) 709 (smtpmail-warn-about-unknown-extensions 710 (message "Unknown extension %s" name))))))) 711 712 (if (and do-starttls 713 (smtpmail-find-credentials smtpmail-starttls-credentials host port) 714 (member 'starttls supported-extensions) 715 (numberp (process-id process))) 716 (progn 717 (smtpmail-send-command process (format "STARTTLS")) 718 (if (or (null (car (setq response-code (smtpmail-read-response process)))) 719 (not (integerp (car response-code))) 720 (>= (car response-code) 400)) 721 (throw 'done nil)) 722 (starttls-negotiate process) 723 (setq do-starttls nil)) 724 (setq do-ehlo nil)))) 725 726 (smtpmail-try-auth-methods process supported-extensions host port) 727 728 (if (or (member 'onex supported-extensions) 729 (member 'xone supported-extensions)) 730 (progn 731 (smtpmail-send-command process (format "ONEX")) 732 (if (or (null (car (setq response-code (smtpmail-read-response process)))) 733 (not (integerp (car response-code))) 734 (>= (car response-code) 400)) 735 (throw 'done nil)))) 736 737 (if (and smtpmail-debug-verb 738 (or (member 'verb supported-extensions) 739 (member 'xvrb supported-extensions))) 740 (progn 741 (smtpmail-send-command process (format "VERB")) 742 (if (or (null (car (setq response-code (smtpmail-read-response process)))) 743 (not (integerp (car response-code))) 744 (>= (car response-code) 400)) 745 (throw 'done nil)))) 746 747 (if (member 'xusr supported-extensions) 748 (progn 749 (smtpmail-send-command process (format "XUSR")) 750 (if (or (null (car (setq response-code (smtpmail-read-response process)))) 751 (not (integerp (car response-code))) 752 (>= (car response-code) 400)) 753 (throw 'done nil)))) 754 755 ;; MAIL FROM:<sender> 756 (let ((size-part 757 (if (or (member 'size supported-extensions) 758 (assoc 'size supported-extensions)) 759 (format " SIZE=%d" 760 (with-current-buffer smtpmail-text-buffer 761 ;; size estimate: 762 (+ (- (point-max) (point-min)) 763 ;; Add one byte for each change-of-line 764 ;; because of CR-LF representation: 765 (count-lines (point-min) (point-max))))) 766 "")) 767 (body-part 768 (if (member '8bitmime supported-extensions) 769 ;; FIXME: 770 ;; Code should be added here that transforms 771 ;; the contents of the message buffer into 772 ;; something the receiving SMTP can handle. 773 ;; For a receiver that supports 8BITMIME, this 774 ;; may mean converting BINARY to BASE64, or 775 ;; adding Content-Transfer-Encoding and the 776 ;; other MIME headers. The code should also 777 ;; return an indication of what encoding the 778 ;; message buffer is now, i.e. ASCII or 779 ;; 8BITMIME. 780 (if nil 781 " BODY=8BITMIME" 782 "") 783 ""))) 784; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) 785 (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" 786 envelope-from 787 size-part 788 body-part)) 789 790 (if (or (null (car (setq response-code (smtpmail-read-response process)))) 791 (not (integerp (car response-code))) 792 (>= (car response-code) 400)) 793 (throw 'done nil) 794 )) 795 796 ;; RCPT TO:<recipient> 797 (let ((n 0)) 798 (while (not (null (nth n recipient))) 799 (smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient)))) 800 (setq n (1+ n)) 801 802 (setq response-code (smtpmail-read-response process)) 803 (if (or (null (car response-code)) 804 (not (integerp (car response-code))) 805 (>= (car response-code) 400)) 806 (throw 'done nil) 807 ) 808 )) 809 810 ;; DATA 811 (smtpmail-send-command process "DATA") 812 813 (if (or (null (car (setq response-code (smtpmail-read-response process)))) 814 (not (integerp (car response-code))) 815 (>= (car response-code) 400)) 816 (throw 'done nil) 817 ) 818 819 ;; Mail contents 820 (smtpmail-send-data process smtpmail-text-buffer) 821 822 ;;DATA end "." 823 (smtpmail-send-command process ".") 824 825 (if (or (null (car (setq response-code (smtpmail-read-response process)))) 826 (not (integerp (car response-code))) 827 (>= (car response-code) 400)) 828 (throw 'done nil) 829 ) 830 831 ;;QUIT 832; (smtpmail-send-command process "QUIT") 833; (and (null (car (smtpmail-read-response process))) 834; (throw 'done nil)) 835 t )) 836 (if process 837 (with-current-buffer (process-buffer process) 838 (smtpmail-send-command process "QUIT") 839 (smtpmail-read-response process) 840 841; (if (or (null (car (setq response-code (smtpmail-read-response process)))) 842; (not (integerp (car response-code))) 843; (>= (car response-code) 400)) 844; (throw 'done nil) 845; ) 846 (delete-process process) 847 (unless smtpmail-debug-info 848 (kill-buffer process-buffer))))))) 849 850 851(defun smtpmail-process-filter (process output) 852 (with-current-buffer (process-buffer process) 853 (goto-char (point-max)) 854 (insert output))) 855 856(defun smtpmail-read-response (process) 857 (let ((case-fold-search nil) 858 (response-strings nil) 859 (response-continue t) 860 (return-value '(nil ())) 861 match-end) 862 (catch 'done 863 (while response-continue 864 (goto-char smtpmail-read-point) 865 (while (not (search-forward "\r\n" nil t)) 866 (unless (memq (process-status process) '(open run)) 867 (throw 'done nil)) 868 (accept-process-output process) 869 (goto-char smtpmail-read-point)) 870 871 (setq match-end (point)) 872 (setq response-strings 873 (cons (buffer-substring smtpmail-read-point (- match-end 2)) 874 response-strings)) 875 876 (goto-char smtpmail-read-point) 877 (if (looking-at "[0-9]+ ") 878 (let ((begin (match-beginning 0)) 879 (end (match-end 0))) 880 (if smtpmail-debug-info 881 (message "%s" (car response-strings))) 882 883 (setq smtpmail-read-point match-end) 884 885 ;; ignore lines that start with "0" 886 (if (looking-at "0[0-9]+ ") 887 nil 888 (setq response-continue nil) 889 (setq return-value 890 (cons (string-to-number 891 (buffer-substring begin end)) 892 (nreverse response-strings))))) 893 894 (if (looking-at "[0-9]+-") 895 (progn (if smtpmail-debug-info 896 (message "%s" (car response-strings))) 897 (setq smtpmail-read-point match-end) 898 (setq response-continue t)) 899 (progn 900 (setq smtpmail-read-point match-end) 901 (setq response-continue nil) 902 (setq return-value 903 (cons nil (nreverse response-strings))))))) 904 (setq smtpmail-read-point match-end)) 905 return-value)) 906 907 908(defun smtpmail-send-command (process command) 909 (goto-char (point-max)) 910 (if (= (aref command 0) ?P) 911 (insert "PASS <omitted>\r\n") 912 (insert command "\r\n")) 913 (setq smtpmail-read-point (point)) 914 (process-send-string process command) 915 (process-send-string process "\r\n")) 916 917(defun smtpmail-send-data-1 (process data) 918 (goto-char (point-max)) 919 920 (if (and (multibyte-string-p data) 921 smtpmail-code-conv-from) 922 (setq data (string-as-multibyte 923 (encode-coding-string data smtpmail-code-conv-from)))) 924 925 (if smtpmail-debug-info 926 (insert data "\r\n")) 927 928 (setq smtpmail-read-point (point)) 929 ;; Escape "." at start of a line 930 (if (eq (string-to-char data) ?.) 931 (process-send-string process ".")) 932 (process-send-string process data) 933 (process-send-string process "\r\n") 934 ) 935 936(defun smtpmail-send-data (process buffer) 937 (let ((data-continue t) sending-data) 938 (with-current-buffer buffer 939 (goto-char (point-min))) 940 (while data-continue 941 (with-current-buffer buffer 942 (setq sending-data (buffer-substring (point-at-bol) (point-at-eol))) 943 (end-of-line 2) 944 (setq data-continue (not (eobp)))) 945 (smtpmail-send-data-1 process sending-data)))) 946 947(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) 948 "Get address list suitable for smtp RCPT TO: <address>." 949 (unwind-protect 950 (with-current-buffer smtpmail-address-buffer 951 (erase-buffer) 952 (let 953 ((case-fold-search t) 954 (simple-address-list "") 955 this-line 956 this-line-end 957 addr-regexp) 958 (insert-buffer-substring smtpmail-text-buffer header-start header-end) 959 (goto-char (point-min)) 960 ;; RESENT-* fields should stop processing of regular fields. 961 (save-excursion 962 (setq addr-regexp 963 (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" 964 header-end t) 965 "^Resent-\\(to\\|cc\\|bcc\\):" 966 "^\\(To:\\|Cc:\\|Bcc:\\)"))) 967 968 (while (re-search-forward addr-regexp header-end t) 969 (replace-match "") 970 (setq this-line (match-beginning 0)) 971 (forward-line 1) 972 ;; get any continuation lines 973 (while (and (looking-at "^[ \t]+") (< (point) header-end)) 974 (forward-line 1)) 975 (setq this-line-end (point-marker)) 976 (setq simple-address-list 977 (concat simple-address-list " " 978 (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) 979 ) 980 (erase-buffer) 981 (insert " " simple-address-list "\n") 982 (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank 983 (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank 984 (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank 985 986 (goto-char (point-min)) 987 ;; tidyness in case hook is not robust when it looks at this 988 (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) 989 990 (goto-char (point-min)) 991 (let (recipient-address-list) 992 (while (re-search-forward " \\([^ ]+\\) " (point-max) t) 993 (backward-char 1) 994 (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) 995 recipient-address-list)) 996 ) 997 (setq smtpmail-recipient-address-list recipient-address-list)) 998 999 ) 1000 ) 1001 ) 1002 ) 1003 1004 1005(defun smtpmail-do-bcc (header-end) 1006 "Delete [Resent-]BCC: and their continuation lines from the header area. 1007There may be multiple BCC: lines, and each may have arbitrarily 1008many continuation lines." 1009 (let ((case-fold-search t)) 1010 (save-excursion 1011 (goto-char (point-min)) 1012 ;; iterate over all BCC: lines 1013 (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t) 1014 (delete-region (match-beginning 0) 1015 (progn (forward-line 1) (point))) 1016 ;; get rid of any continuation lines 1017 (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) 1018 (replace-match "")))))) 1019 1020 1021(provide 'smtpmail) 1022 1023;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 1024;;; smtpmail.el ends here 1025