smtp.el

   1 ;;; smtp.el --- basic functions to send mail with SMTP server
   2
   3 ;; Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
   6 ;;      Simon Leinen <simon@switch.ch> (ESMTP support)
   7 ;;      Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   8 ;;      Daiki Ueno <ueno@unixuser.org>
   9 ;; Keywords: SMTP, mail
  10
  11 ;; This file is part of FLIM (Faithful Library about Internet Message).
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28
  29 ;;; Commentary:
  30 ;;
  31
  32 ;;; Code:
  33
  34 (require 'custom)
  35 (require 'mail-utils)                   ; mail-strip-quoted-names
  36 (require 'sasl)
  37 (require 'luna)
  38 (require 'mel) ; binary-funcall
  39
  40 (defgroup smtp nil
  41   "SMTP protocol for sending mail."
  42   :group 'mail)
  43
  44 (defgroup smtp-extensions nil
  45   "SMTP service extensions (RFC1869)."
  46   :group 'smtp)
  47
  48 (defcustom smtp-default-server nil
  49   "Specify default SMTP server."
  50   :type '(choice (const nil) string)
  51   :group 'smtp)
  52
  53 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  54   "The name of the host running SMTP server.
  55 It can also be a function
  56 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  57   :type '(choice (string :tag "Name")
  58                  (function :tag "Function"))
  59   :group 'smtp)
  60
  61 (defcustom smtp-send-by-myself nil
  62   "If non-nil, smtp.el send a mail by myself without smtp-server.
  63 This option requires \"dig.el\"."
  64   :type 'boolean
  65   :group 'smtp)
  66
  67 (defcustom smtp-service "smtp"
  68   "SMTP service port number.  \"smtp\" or 25."
  69   :type '(choice (integer :tag "25" 25)
  70                  (string :tag "smtp" "smtp"))
  71   :group 'smtp)
  72
  73 (defcustom smtp-local-domain nil
  74   "Local domain name without a host name.
  75 If the function (system-name) returns the full internet address,
  76 don't define this value."
  77   :type '(choice (const nil) string)
  78   :group 'smtp)
  79
  80 (defcustom smtp-fqdn nil
  81   "Fully qualified domain name used for Message-ID."
  82   :type '(choice (const nil) string)
  83   :group 'smtp)
  84
  85 (defcustom smtp-use-8bitmime t
  86   "If non-nil, use ESMTP 8BITMIME (RFC1652) if available."
  87   :type 'boolean
  88   :group 'smtp-extensions)
  89
  90 (defcustom smtp-use-size t
  91   "If non-nil, use ESMTP SIZE (RFC1870) if available."
  92   :type 'boolean
  93   :group 'smtp-extensions)
  94
  95 (defcustom smtp-use-starttls nil
  96   "If non-nil, use STARTTLS (RFC2595) if available."
  97   :type 'boolean
  98   :group 'smtp-extensions)
  99
 100 (defcustom smtp-use-starttls-ignore-error nil
 101   "If non-nil, do not use STARTTLS if STARTTLS is not available."
 102   :type 'boolean
 103   :group 'smtp-extensions)
 104
 105 (defcustom smtp-use-sasl nil
 106   "If non-nil, use SMTP Authentication (RFC2554) if available."
 107   :type 'boolean
 108   :group 'smtp-extensions)
 109
 110 (defcustom smtp-sasl-user-name (user-login-name)
 111   "Identification to be used for authorization."
 112   :type 'string
 113   :group 'smtp-extensions)
 114
 115 (defcustom smtp-sasl-properties nil
 116   "Properties set to SASL client."
 117   :type 'string
 118   :group 'smtp-extensions)
 119
 120 (defcustom smtp-sasl-mechanisms nil
 121   "List of authentication mechanisms."
 122   :type '(repeat string)
 123   :group 'smtp-extensions)
 124
 125 (defvar sasl-mechanisms)
 126
 127 ;;;###autoload
 128 (defvar smtp-open-connection-function #'open-network-stream
 129   "*Function used for connecting to a SMTP server.
 130 The function will be called with the same four arguments as
 131 `open-network-stream' and should return a process object.
 132 Here is an example:
 133
 134 \(setq smtp-open-connection-function
 135       #'(lambda (name buffer host service)
 136           (let ((process-connection-type nil))
 137             (start-process name buffer \"ssh\" \"-C\" host
 138                            \"nc\" host service))))
 139
 140 It connects to a SMTP server using \"ssh\" before actually connecting
 141 to the SMTP port.  Where the command \"nc\" is the netcat executable;
 142 see http://www.atstake.com/research/tools/index.html#network_utilities
 143 for details.  In addition, you will have to modify the value for
 144 `smtp-end-of-line' to \"\\n\" if you use \"telnet\" instead of \"nc\".")
 145
 146 (defvar smtp-read-point nil)
 147
 148 (defvar smtp-connection-alist nil)
 149
 150 (defvar smtp-submit-package-function #'smtp-submit-package)
 151
 152 (defvar smtp-end-of-line "\r\n"
 153   "*String to use as end-of-line marker when talking to a SMTP server.
 154 This is \"\\r\\n\" by default, but it may have to be \"\\n\" when using a non
 155 native connection function.  See also `smtp-open-connection-function'.")
 156
 157 ;;; @ SMTP package
 158 ;;; A package contains a mail message, an envelope sender address,
 159 ;;; and one or more envelope recipient addresses.  In ESMTP model
 160 ;;; the current sending package should be guaranteed to be accessible
 161 ;;; anywhere from the hook methods (or SMTP commands).
 162
 163 (eval-and-compile
 164   (luna-define-class smtp-package ()
 165                      (sender
 166                       recipients
 167                       buffer))
 168
 169   (luna-define-internal-accessors 'smtp-package))
 170
 171 (defun smtp-make-package (sender recipients buffer)
 172   "Create a new package structure.
 173 A package is a unit of SMTP message
 174 SENDER specifies the package sender, a string.
 175 RECIPIENTS is a list of recipients.
 176 BUFFER may be a buffer or a buffer name which contains mail message."
 177   (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer))
 178
 179 (defun smtp-package-buffer-internal-size (package)
 180   "Return the size of PACKAGE, an integer."
 181   (save-excursion
 182     (set-buffer (smtp-package-buffer-internal package))
 183     (let ((size
 184            (+ (buffer-size)
 185               ;; Add one byte for each change-of-line
 186               ;; because or CR-LF representation:
 187               (count-lines (point-min) (point-max))
 188               ;; For some reason, an empty line is
 189               ;; added to the message.  Maybe this
 190               ;; is a bug, but it can't hurt to add
 191               ;; those two bytes anyway:
 192               2)))
 193       (goto-char (point-min))
 194       (while (re-search-forward "^\\." nil t)
 195         (setq size (1+ size)))
 196       size)))
 197
 198 ;;; @ SMTP connection
 199 ;;; We should consider the function `open-network-stream' is a emulation
 200 ;;; for another network stream.  They are likely to be implemented with an
 201 ;;; external program and the function `process-contact' returns the
 202 ;;; process id instead of `(HOST SERVICE)' pair.
 203
 204 (eval-and-compile
 205   (luna-define-class smtp-connection ()
 206                      (process
 207                       server
 208                       service
 209                       extensions
 210                       encoder
 211                       decoder))
 212
 213   (luna-define-internal-accessors 'smtp-connection))
 214
 215 (defun smtp-make-connection (process server service)
 216   "Create a new connection structure.
 217 PROCESS is an internal subprocess-object.  SERVER is name of the host
 218 to connect to.  SERVICE is name of the service desired."
 219   (luna-make-entity 'smtp-connection :process process :server server :service service))
 220
 221 (luna-define-generic smtp-connection-opened (connection)
 222   "Say whether the CONNECTION to server has been opened.")
 223
 224 (luna-define-generic smtp-close-connection (connection)
 225   "Close the CONNECTION to server.")
 226
 227 (luna-define-method smtp-connection-opened ((connection smtp-connection))
 228   (let ((process (smtp-connection-process-internal connection)))
 229     (if (memq (process-status process) '(open run))
 230         t)))
 231
 232 (luna-define-method smtp-close-connection ((connection smtp-connection))
 233   (let ((process (smtp-connection-process-internal connection)))
 234     (delete-process process)))
 235
 236 (defun smtp-make-fqdn ()
 237   "Return user's fully qualified domain name."
 238   (if smtp-fqdn
 239       smtp-fqdn
 240     (let ((system-name (system-name)))
 241       (cond
 242        (smtp-local-domain
 243         (concat system-name "." smtp-local-domain))
 244        ((string-match "[^.]\\.[^.]" system-name)
 245         system-name)
 246        (t
 247         (error "Cannot generate valid FQDN"))))))
 248
 249 (defun smtp-find-connection (buffer)
 250   "Find the connection delivering to BUFFER."
 251   (let ((entry (assq buffer smtp-connection-alist))
 252         connection)
 253     (when entry
 254       (setq connection (nth 1 entry))
 255       (if (smtp-connection-opened connection)
 256           connection
 257         (setq smtp-connection-alist
 258               (delq entry smtp-connection-alist))
 259         nil))))
 260
 261 (eval-and-compile
 262   (autoload 'starttls-open-stream "starttls")
 263   (autoload 'starttls-negotiate "starttls"))
 264
 265 (defun smtp-open-connection (buffer server service)
 266   "Open a SMTP connection for a service to a host.
 267 Return a newly allocated connection-object.
 268 BUFFER is the buffer to associate with the connection.  SERVER is name
 269 of the host to connect to.  SERVICE is name of the service desired."
 270   (let ((process
 271          (binary-funcall smtp-open-connection-function
 272                          "SMTP" buffer server service))
 273         connection)
 274     (when process
 275       (setq connection (smtp-make-connection process server service))
 276       (set-process-filter process 'smtp-process-filter)
 277       (setq smtp-connection-alist
 278             (cons (list buffer connection)
 279                   smtp-connection-alist))
 280       connection)))
 281
 282 (eval-and-compile
 283   (autoload 'dig-invoke "dig")
 284   (autoload 'dig-extract-rr "dig"))
 285
 286 (defun smtp-find-mx (domain &optional doerror)
 287   (let (server)
 288     ;; dig.el resolves only primally MX.
 289     (cond ((setq server (smtp-dig domain "MX"))
 290            (progn (string-match " \\([^ ]*\\)$" server)
 291                   (match-string 1 server)))
 292           ((smtp-dig domain "A")
 293             domain)
 294           (t
 295            (if doerror
 296                 (error (format "SMTP cannot resolve %s" domain)))))))
 297
 298 (defun smtp-dig (domain type)
 299   (let (dig-buf)
 300     (set-buffer
 301      (setq dig-buf (dig-invoke domain type)))
 302     (prog1
 303         (dig-extract-rr domain type)
 304       (kill-buffer dig-buf))))
 305
 306 (defun smtp-find-server (recipients)
 307   (save-excursion
 308     (let ((rec
 309            (mapcar (lambda (recipient)
 310                      (let (server)
 311                        (if (and (string-match "@\\([^\t\n ]*\\)" recipient)
 312                                 (setq server
 313                                       (smtp-find-mx
 314                                        (match-string 1 recipient))))
 315                            (cons server (list recipient))
 316                          (error (format "cannot find server for %s." recipient)))))
 317                    recipients))
 318           ret rets rlist)
 319       (while (setq rets (pop rec))
 320         (if (setq ret (assoc (car rets) rec))
 321             (setcdr ret
 322                     (append (cdr ret) (cdr rets)))
 323           (setq rlist
 324                 (append rlist (list rets)))))
 325       rlist)))
 326
 327 ;;;###autoload
 328 (defun smtp-via-smtp (sender recipients buffer)
 329   "Like `smtp-send-buffer', but sucks in any errors."
 330   (condition-case nil
 331       (progn
 332         (smtp-send-buffer sender recipients buffer)
 333         t)
 334     (smtp-error)))
 335
 336 (make-obsolete 'smtp-via-smtp "It's old API.")
 337
 338 ;;;###autoload
 339 (defun smtp-send-buffer (sender recipients buffer)
 340   "Send a message.
 341 SENDER is an envelope sender address.
 342 RECIPIENTS is a list of envelope recipient addresses.
 343 BUFFER may be a buffer or a buffer name which contains mail message."
 344   (if smtp-send-by-myself
 345       (smtp-send-buffer-by-myself sender recipients buffer)
 346     (let ((server
 347            (if (functionp smtp-server)
 348                (funcall smtp-server sender recipients)
 349              smtp-server))
 350           (package
 351            (smtp-make-package sender recipients buffer))
 352           (smtp-open-connection-function
 353            (if smtp-use-starttls
 354                #'starttls-open-stream
 355              smtp-open-connection-function)))
 356       (save-excursion
 357         (set-buffer
 358          (get-buffer-create
 359           (format "*trace of SMTP session to %s*" server)))
 360         (erase-buffer)
 361         (buffer-disable-undo)
 362         (unless (smtp-find-connection (current-buffer))
 363           (smtp-open-connection (current-buffer) server smtp-service))
 364         (make-local-variable 'smtp-read-point)
 365         (setq smtp-read-point (point-min))
 366         (funcall smtp-submit-package-function package)))))
 367
 368 (defun smtp-submit-package (package)
 369   (unwind-protect
 370       (progn
 371         (smtp-primitive-greeting package)
 372         (condition-case nil
 373             (smtp-primitive-ehlo package)
 374           (smtp-response-error
 375            (smtp-primitive-helo package)))
 376         (if smtp-use-starttls
 377             (if (assq 'starttls
 378                       (smtp-connection-extensions-internal
 379                        (smtp-find-connection (current-buffer))))
 380                 (progn
 381                   (smtp-primitive-starttls package)
 382                   (smtp-primitive-ehlo package))
 383               (unless smtp-use-starttls-ignore-error
 384                 (error "STARTTLS is not supported on this server"))))
 385         (if smtp-use-sasl
 386             (smtp-primitive-auth package))
 387         (smtp-primitive-mailfrom package)
 388         (smtp-primitive-rcptto package)
 389         (smtp-primitive-data package))
 390     (let ((connection (smtp-find-connection (current-buffer))))
 391       (when (smtp-connection-opened connection)
 392         (smtp-primitive-quit package)
 393         (smtp-close-connection connection)))))
 394
 395 (defun smtp-send-buffer-by-myself (sender recipients buffer)
 396   "Send a message by myself.
 397 SENDER is an envelope sender address.
 398 RECIPIENTS is a list of envelope recipient addresses.
 399 BUFFER may be a buffer or a buffer name which contains mail message."
 400   (let ((servers
 401          (smtp-find-server recipients))
 402         (smtp-open-connection-function
 403          (if smtp-use-starttls
 404              #'starttls-open-stream
 405            smtp-open-connection-function))
 406         server package)
 407       (while (car servers)
 408         (setq server (caar servers))
 409         (setq recipients (cdar servers))
 410         (if (not (and server recipients))
 411             ;; MAILER-DAEMON is required. :)
 412             (error (format "Cannot send <%s>"
 413                            (mapconcat 'concat recipients ">,<"))))
 414         (setq package
 415               (smtp-make-package sender recipients buffer))
 416         (save-excursion
 417           (set-buffer
 418            (get-buffer-create
 419             (format "*trace of SMTP session to %s*" server)))
 420           (erase-buffer)
 421           (buffer-disable-undo)
 422           (unless (smtp-find-connection (current-buffer))
 423             (smtp-open-connection (current-buffer) server smtp-service))
 424           (make-local-variable 'smtp-read-point)
 425           (setq smtp-read-point (point-min))
 426           (let ((smtp-use-sasl nil)
 427                 (smtp-use-starttls-ignore-error t))
 428             (funcall smtp-submit-package-function package)))
 429       (setq servers (cdr servers)))))
 430
 431 ;;; @ hook methods for `smtp-submit-package'
 432 ;;;
 433
 434 (defun smtp-primitive-greeting (package)
 435   (let* ((connection
 436           (smtp-find-connection (current-buffer)))
 437          (response
 438           (smtp-read-response connection)))
 439     (if (/= (car response) 220)
 440         (smtp-response-error response))))
 441
 442 (defun smtp-primitive-ehlo (package)
 443   (let* ((connection
 444           (smtp-find-connection (current-buffer)))
 445          response)
 446     (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
 447     (setq response (smtp-read-response connection))
 448     (if (/= (car response) 250)
 449         (smtp-response-error response))
 450     (smtp-connection-set-extensions-internal
 451      connection (mapcar
 452                  (lambda (extension)
 453                    (let ((extensions
 454                           (split-string extension)))
 455                      (setcar extensions
 456                              (car (read-from-string
 457                                    (downcase (car extensions)))))
 458                      extensions))
 459                  (cdr response)))))
 460
 461 (defun smtp-primitive-helo (package)
 462   (let* ((connection
 463           (smtp-find-connection (current-buffer)))
 464          response)
 465     (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
 466     (setq response (smtp-read-response connection))
 467     (if (/= (car response) 250)
 468         (smtp-response-error response))))
 469
 470 (defun smtp-primitive-auth (package)
 471   (let* ((connection
 472           (smtp-find-connection (current-buffer)))
 473          (mechanisms
 474           (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
 475          (sasl-mechanisms
 476           (or smtp-sasl-mechanisms sasl-mechanisms))
 477          (mechanism
 478           (sasl-find-mechanism mechanisms))
 479          client
 480          name
 481          step
 482          response)
 483     (unless mechanism
 484       (error "No authentication mechanism available"))
 485     (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
 486                                    (smtp-connection-server-internal connection)))
 487     (if smtp-sasl-properties
 488         (sasl-client-set-properties client smtp-sasl-properties))
 489     (setq name (sasl-mechanism-name mechanism)
 490           ;; Retrieve the initial response
 491           step (sasl-next-step client nil))
 492     (smtp-send-command
 493      connection
 494      (if (sasl-step-data step)
 495          (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
 496        (format "AUTH %s" name)))
 497     (catch 'done
 498       (while t
 499         (setq response (smtp-read-response connection))
 500         (when (= (car response) 235)
 501           ;; The authentication process is finished.
 502           (setq step (sasl-next-step client step))
 503           (if (null step)
 504               (throw 'done nil))
 505           (smtp-response-error response)) ;Bogus server?
 506         (if (/= (car response) 334)
 507             (smtp-response-error response))
 508         (sasl-step-set-data step (base64-decode-string (nth 1 response)))
 509         (setq step (sasl-next-step client step))
 510         (smtp-send-command
 511          connection
 512          (if (sasl-step-data step)
 513              (base64-encode-string (sasl-step-data step) t)
 514            ""))))
 515 ;;;    (smtp-connection-set-encoder-internal
 516 ;;;     connection (sasl-client-encoder client))
 517 ;;;    (smtp-connection-set-decoder-internal
 518 ;;;     connection (sasl-client-decoder client))
 519     ))
 520
 521 (defun smtp-primitive-starttls (package)
 522   (let* ((connection
 523           (smtp-find-connection (current-buffer)))
 524          response)
 525     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 526     (smtp-send-command connection "STARTTLS")
 527     (setq response (smtp-read-response connection))
 528     (if (/= (car response) 220)
 529         (smtp-response-error response))
 530     (starttls-negotiate (smtp-connection-process-internal connection))))
 531
 532 (defun smtp-primitive-mailfrom (package)
 533   (let* ((connection
 534           (smtp-find-connection (current-buffer)))
 535          (extensions
 536           (smtp-connection-extensions-internal
 537            connection))
 538          (sender
 539           (smtp-package-sender-internal package))
 540          extension
 541          response)
 542     ;; SIZE --- Message Size Declaration (RFC1870)
 543     (if (and smtp-use-size
 544              (assq 'size extensions))
 545         (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
 546     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 547     (if (and smtp-use-8bitmime
 548              (assq '8bitmime extensions))
 549         (setq extension (concat extension " BODY=8BITMIME")))
 550     (smtp-send-command
 551      connection
 552      (if extension
 553          (format "MAIL FROM:<%s> %s" sender extension)
 554        (format "MAIL FROM:<%s>" sender)))
 555     (setq response (smtp-read-response connection))
 556     (if (/= (car response) 250)
 557         (smtp-response-error response))))
 558
 559 (defun smtp-primitive-rcptto (package)
 560   (let* ((connection
 561           (smtp-find-connection (current-buffer)))
 562          (recipients
 563           (smtp-package-recipients-internal package))
 564          response)
 565     (while recipients
 566       (smtp-send-command
 567        connection (format "RCPT TO:<%s>" (pop recipients)))
 568       (setq response (smtp-read-response connection))
 569       (unless (memq (car response) '(250 251))
 570         (smtp-response-error response)))))
 571
 572 (defun smtp-primitive-data (package)
 573   (let* ((connection
 574           (smtp-find-connection (current-buffer)))
 575          response)
 576     (smtp-send-command connection "DATA")
 577     (setq response (smtp-read-response connection))
 578     (if (/= (car response) 354)
 579         (smtp-response-error response))
 580     (save-excursion
 581       (set-buffer (smtp-package-buffer-internal package))
 582       (goto-char (point-min))
 583       (while (not (eobp))
 584         (smtp-send-data
 585          connection (buffer-substring (point) (progn (end-of-line)(point))))
 586         (beginning-of-line 2)))
 587     (smtp-send-command connection ".")
 588     (setq response (smtp-read-response connection))
 589     (if (/= (car response) 250)
 590         (smtp-response-error response))))
 591
 592 (defun smtp-primitive-quit (package)
 593   (let* ((connection
 594           (smtp-find-connection (current-buffer)))
 595          response)
 596     (smtp-send-command connection "QUIT")
 597     (setq response (smtp-read-response connection))
 598     (if (/= (car response) 221)
 599         (smtp-response-error response))))
 600
 601 ;;; @ low level process manipulating function
 602 ;;;
 603 (defun smtp-process-filter (process output)
 604   (save-excursion
 605     (set-buffer (process-buffer process))
 606     (goto-char (point-max))
 607     (insert output)))
 608
 609 (put 'smtp-error 'error-message "SMTP error")
 610 (put 'smtp-error 'error-conditions '(smtp-error error))
 611
 612 (put 'smtp-response-error 'error-message "SMTP response error")
 613 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 614
 615 (defun smtp-response-error (response)
 616   (signal 'smtp-response-error response))
 617
 618 (defun smtp-read-response (connection)
 619   (let ((decoder
 620          (smtp-connection-decoder-internal connection))
 621         (response-continue t)
 622         response)
 623     (while response-continue
 624       (goto-char smtp-read-point)
 625       (while (not (search-forward smtp-end-of-line nil t))
 626         (accept-process-output (smtp-connection-process-internal connection))
 627         (goto-char smtp-read-point))
 628       (if decoder
 629           (let ((string (buffer-substring smtp-read-point (- (point) 2))))
 630             (delete-region smtp-read-point (point))
 631             (insert (funcall decoder string) smtp-end-of-line)))
 632       (setq response
 633             (nconc response
 634                    (list (buffer-substring
 635                           (+ 4 smtp-read-point)
 636                           (- (point) 2)))))
 637       (goto-char
 638        (prog1 smtp-read-point
 639          (setq smtp-read-point (point))))
 640       (if (looking-at "[1-5][0-9][0-9] ")
 641           (setq response (cons (read (point-marker)) response)
 642                 response-continue nil)))
 643     response))
 644
 645 (defun smtp-send-command (connection command)
 646   (save-excursion
 647     (let ((process
 648            (smtp-connection-process-internal connection))
 649           (encoder
 650            (smtp-connection-encoder-internal connection)))
 651       (set-buffer (process-buffer process))
 652       (goto-char (point-max))
 653       (setq command (concat command smtp-end-of-line))
 654       (insert command)
 655       (setq smtp-read-point (point))
 656       (if encoder
 657           (setq command (funcall encoder command)))
 658       (process-send-string process command))))
 659
 660 (defun smtp-send-data (connection data)
 661   (let ((process
 662          (smtp-connection-process-internal connection))
 663         (encoder
 664          (smtp-connection-encoder-internal connection)))
 665     ;; Escape "." at start of a line.
 666     (if (eq (string-to-char data) ?.)
 667         (setq data (concat "." data smtp-end-of-line))
 668       (setq data (concat data smtp-end-of-line)))
 669     (if encoder
 670         (setq data (funcall encoder data)))
 671     (process-send-string process data)))
 672
 673 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 674   "Get address list suitable for smtp RCPT TO:<address>."
 675   (let ((simple-address-list "")
 676         this-line
 677         this-line-end
 678         addr-regexp
 679         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 680     (unwind-protect
 681         (save-excursion
 682           ;;
 683           (set-buffer smtp-address-buffer)
 684           (setq case-fold-search t)
 685           (erase-buffer)
 686           (insert (save-excursion
 687                     (set-buffer smtp-text-buffer)
 688                     (buffer-substring-no-properties header-start header-end)))
 689           (goto-char (point-min))
 690           ;; RESENT-* fields should stop processing of regular fields.
 691           (save-excursion
 692             (if (re-search-forward "^RESENT-TO:" header-end t)
 693                 (setq addr-regexp
 694                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 695               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 696
 697           (while (re-search-forward addr-regexp header-end t)
 698             (replace-match "")
 699             (setq this-line (match-beginning 0))
 700             (forward-line 1)
 701             ;; get any continuation lines.
 702             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 703               (forward-line 1))
 704             (setq this-line-end (point-marker))
 705             (setq simple-address-list
 706                   (concat simple-address-list " "
 707                           (mail-strip-quoted-names
 708                            (buffer-substring this-line this-line-end)))))
 709           (erase-buffer)
 710           (insert-string " ")
 711           (insert-string simple-address-list)
 712           (insert-string "\n")
 713           ;; newline --> blank
 714           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 715           ;; comma   --> blank
 716           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 717           ;; tab     --> blank
 718           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 719
 720           (goto-char (point-min))
 721           ;; tidyness in case hook is not robust when it looks at this
 722           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 723
 724           (goto-char (point-min))
 725           (let (recipient-address-list)
 726             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 727               (backward-char 1)
 728               (setq recipient-address-list
 729                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 730                           recipient-address-list)))
 731             recipient-address-list))
 732       (kill-buffer smtp-address-buffer))))
 733
 734 (provide 'smtp)
 735
 736 ;;; smtp.el ends here