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
 130 (defvar smtp-read-point nil)
 131
 132 (defvar smtp-connection-alist nil)
 133
 134 (defvar smtp-submit-package-function #'smtp-submit-package)
 135
 136 ;;; @ SMTP package
 137 ;;; A package contains a mail message, an envelope sender address,
 138 ;;; and one or more envelope recipient addresses.  In ESMTP model
 139 ;;; the current sending package should be guaranteed to be accessible
 140 ;;; anywhere from the hook methods (or SMTP commands).
 141
 142 (eval-and-compile
 143   (luna-define-class smtp-package ()
 144                      (sender
 145                       recipients
 146                       buffer))
 147
 148   (luna-define-internal-accessors 'smtp-package))
 149
 150 (defun smtp-make-package (sender recipients buffer)
 151   "Create a new package structure.
 152 A package is a unit of SMTP message
 153 SENDER specifies the package sender, a string.
 154 RECIPIENTS is a list of recipients.
 155 BUFFER may be a buffer or a buffer name which contains mail message."
 156   (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer))
 157
 158 (defun smtp-package-buffer-internal-size (package)
 159   "Return the size of PACKAGE, an integer."
 160   (save-excursion
 161     (set-buffer (smtp-package-buffer-internal package))
 162     (let ((size
 163            (+ (buffer-size)
 164               ;; Add one byte for each change-of-line
 165               ;; because or CR-LF representation:
 166               (count-lines (point-min) (point-max))
 167               ;; For some reason, an empty line is
 168               ;; added to the message.  Maybe this
 169               ;; is a bug, but it can't hurt to add
 170               ;; those two bytes anyway:
 171               2)))
 172       (goto-char (point-min))
 173       (while (re-search-forward "^\\." nil t)
 174         (setq size (1+ size)))
 175       size)))
 176
 177 ;;; @ SMTP connection
 178 ;;; We should consider the function `open-network-stream' is a emulation
 179 ;;; for another network stream.  They are likely to be implemented with an
 180 ;;; external program and the function `process-contact' returns the
 181 ;;; process id instead of `(HOST SERVICE)' pair.
 182
 183 (eval-and-compile
 184   (luna-define-class smtp-connection ()
 185                      (process
 186                       server
 187                       service
 188                       extensions
 189                       encoder
 190                       decoder))
 191
 192   (luna-define-internal-accessors 'smtp-connection))
 193
 194 (defun smtp-make-connection (process server service)
 195   "Create a new connection structure.
 196 PROCESS is an internal subprocess-object.  SERVER is name of the host
 197 to connect to.  SERVICE is name of the service desired."
 198   (luna-make-entity 'smtp-connection :process process :server server :service service))
 199
 200 (luna-define-generic smtp-connection-opened (connection)
 201   "Say whether the CONNECTION to server has been opened.")
 202
 203 (luna-define-generic smtp-close-connection (connection)
 204   "Close the CONNECTION to server.")
 205
 206 (luna-define-method smtp-connection-opened ((connection smtp-connection))
 207   (let ((process (smtp-connection-process-internal connection)))
 208     (if (memq (process-status process) '(open run))
 209         t)))
 210
 211 (luna-define-method smtp-close-connection ((connection smtp-connection))
 212   (let ((process (smtp-connection-process-internal connection)))
 213     (delete-process process)))
 214
 215 (defun smtp-make-fqdn ()
 216   "Return user's fully qualified domain name."
 217   (if smtp-fqdn
 218       smtp-fqdn
 219     (let ((system-name (system-name)))
 220       (cond
 221        (smtp-local-domain
 222         (concat system-name "." smtp-local-domain))
 223        ((string-match "[^.]\\.[^.]" system-name)
 224         system-name)
 225        (t
 226         (error "Cannot generate valid FQDN"))))))
 227
 228 (defun smtp-find-connection (buffer)
 229   "Find the connection delivering to BUFFER."
 230   (let ((entry (assq buffer smtp-connection-alist))
 231         connection)
 232     (when entry
 233       (setq connection (nth 1 entry))
 234       (if (smtp-connection-opened connection)
 235           connection
 236         (setq smtp-connection-alist
 237               (delq entry smtp-connection-alist))
 238         nil))))
 239
 240 (eval-and-compile
 241   (autoload 'starttls-open-stream "starttls")
 242   (autoload 'starttls-negotiate "starttls"))
 243
 244 (defun smtp-open-connection (buffer server service)
 245   "Open a SMTP connection for a service to a host.
 246 Return a newly allocated connection-object.
 247 BUFFER is the buffer to associate with the connection.  SERVER is name
 248 of the host to connect to.  SERVICE is name of the service desired."
 249   (let ((process
 250          (binary-funcall smtp-open-connection-function
 251                          "SMTP" buffer server service))
 252         connection)
 253     (when process
 254       (setq connection (smtp-make-connection process server service))
 255       (set-process-filter process 'smtp-process-filter)
 256       (setq smtp-connection-alist
 257             (cons (list buffer connection)
 258                   smtp-connection-alist))
 259       connection)))
 260
 261 (eval-and-compile
 262   (autoload 'dig-invoke "dig")
 263   (autoload 'dig-extract-rr "dig"))
 264
 265 (defun smtp-find-mx (domain &optional doerror)
 266   (let (server)
 267     ;; dig.el resolves only primally MX.
 268     (cond ((setq server (smtp-dig domain "MX"))
 269            (progn (string-match " \\([^ ]*\\)$" server)
 270                   (match-string 1 server)))
 271           ((smtp-dig domain "A")
 272             domain)
 273           (t
 274            (if doerror
 275                 (error (format "SMTP cannot resolve %s" domain)))))))
 276
 277 (defun smtp-dig (domain type)
 278   (let (dig-buf)
 279     (set-buffer
 280      (setq dig-buf (dig-invoke domain type)))
 281     (prog1
 282         (dig-extract-rr domain type)
 283       (kill-buffer dig-buf))))
 284
 285 (defun smtp-find-server (recipients)
 286   (save-excursion
 287     (let ((rec
 288            (mapcar (lambda (recipient)
 289                      (let (server)
 290                        (if (and (string-match "@\\([^\t\n ]*\\)" recipient)
 291                                 (setq server
 292                                       (smtp-find-mx
 293                                        (match-string 1 recipient))))
 294                            (cons server (list recipient))
 295                          (error (format "cannot find server for %s." recipient)))))
 296                    recipients))
 297           ret rets rlist)
 298       (while (setq rets (pop rec))
 299         (if (setq ret (assoc (car rets) rec))
 300             (setcdr ret
 301                     (append (cdr ret) (cdr rets)))
 302           (setq rlist
 303                 (append rlist (list rets)))))
 304       rlist)))
 305
 306 ;;;###autoload
 307 (defun smtp-via-smtp (sender recipients buffer)
 308   "Like `smtp-send-buffer', but sucks in any errors."
 309   (condition-case nil
 310       (progn
 311         (smtp-send-buffer sender recipients buffer)
 312         t)
 313     (smtp-error)))
 314
 315 (make-obsolete 'smtp-via-smtp "It's old API.")
 316
 317 ;;;###autoload
 318 (defun smtp-send-buffer (sender recipients buffer)
 319   "Send a message.
 320 SENDER is an envelope sender address.
 321 RECIPIENTS is a list of envelope recipient addresses.
 322 BUFFER may be a buffer or a buffer name which contains mail message."
 323   (if smtp-send-by-myself
 324       (smtp-send-buffer-by-myself sender recipients buffer)
 325     (let ((server
 326            (if (functionp smtp-server)
 327                (funcall smtp-server sender recipients)
 328              smtp-server))
 329           (package
 330            (smtp-make-package sender recipients buffer))
 331           (smtp-open-connection-function
 332            (if smtp-use-starttls
 333                #'starttls-open-stream
 334              smtp-open-connection-function)))
 335       (save-excursion
 336         (set-buffer
 337          (get-buffer-create
 338           (format "*trace of SMTP session to %s*" server)))
 339         (erase-buffer)
 340         (buffer-disable-undo)
 341         (unless (smtp-find-connection (current-buffer))
 342           (smtp-open-connection (current-buffer) server smtp-service))
 343         (make-local-variable 'smtp-read-point)
 344         (setq smtp-read-point (point-min))
 345         (funcall smtp-submit-package-function package)))))
 346
 347 (defun smtp-submit-package (package)
 348   (unwind-protect
 349       (progn
 350         (smtp-primitive-greeting package)
 351         (condition-case nil
 352             (smtp-primitive-ehlo package)
 353           (smtp-response-error
 354            (smtp-primitive-helo package)))
 355         (if smtp-use-starttls
 356             (if (assq 'starttls
 357                       (smtp-connection-extensions-internal
 358                        (smtp-find-connection (current-buffer))))
 359                 (progn
 360                   (smtp-primitive-starttls package)
 361                   (smtp-primitive-ehlo package))
 362               (unless smtp-use-starttls-ignore-error
 363                 (error "STARTTLS is not supported on this server"))))
 364         (if smtp-use-sasl
 365             (smtp-primitive-auth package))
 366         (smtp-primitive-mailfrom package)
 367         (smtp-primitive-rcptto package)
 368         (smtp-primitive-data package))
 369     (let ((connection (smtp-find-connection (current-buffer))))
 370       (when (smtp-connection-opened connection)
 371         (smtp-primitive-quit package)
 372         (smtp-close-connection connection)))))
 373
 374 (defun smtp-send-buffer-by-myself (sender recipients buffer)
 375   "Send a message by myself.
 376 SENDER is an envelope sender address.
 377 RECIPIENTS is a list of envelope recipient addresses.
 378 BUFFER may be a buffer or a buffer name which contains mail message."
 379   (let ((servers
 380          (smtp-find-server recipients))
 381         (smtp-open-connection-function
 382          (if smtp-use-starttls
 383              #'starttls-open-stream
 384            smtp-open-connection-function))
 385         server package)
 386       (while (car servers)
 387         (setq server (caar servers))
 388         (setq recipients (cdar servers))
 389         (if (not (and server recipients))
 390             ;; MAILER-DAEMON is required. :)
 391             (error (format "Cannot send <%s>"
 392                            (mapconcat 'concat recipients ">,<"))))
 393         (setq package
 394               (smtp-make-package sender recipients buffer))
 395         (save-excursion
 396           (set-buffer
 397            (get-buffer-create
 398             (format "*trace of SMTP session to %s*" server)))
 399           (erase-buffer)
 400           (buffer-disable-undo)
 401           (unless (smtp-find-connection (current-buffer))
 402             (smtp-open-connection (current-buffer) server smtp-service))
 403           (make-local-variable 'smtp-read-point)
 404           (setq smtp-read-point (point-min))
 405           (let ((smtp-use-sasl nil)
 406                 (smtp-use-starttls-ignore-error t))
 407             (funcall smtp-submit-package-function package)))
 408       (setq servers (cdr servers)))))
 409
 410 ;;; @ hook methods for `smtp-submit-package'
 411 ;;;
 412
 413 (defun smtp-primitive-greeting (package)
 414   (let* ((connection
 415           (smtp-find-connection (current-buffer)))
 416          (response
 417           (smtp-read-response connection)))
 418     (if (/= (car response) 220)
 419         (smtp-response-error response))))
 420
 421 (defun smtp-primitive-ehlo (package)
 422   (let* ((connection
 423           (smtp-find-connection (current-buffer)))
 424          response)
 425     (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
 426     (setq response (smtp-read-response connection))
 427     (if (/= (car response) 250)
 428         (smtp-response-error response))
 429     (smtp-connection-set-extensions-internal
 430      connection (mapcar
 431                  (lambda (extension)
 432                    (let ((extensions
 433                           (split-string extension)))
 434                      (setcar extensions
 435                              (car (read-from-string
 436                                    (downcase (car extensions)))))
 437                      extensions))
 438                  (cdr response)))))
 439
 440 (defun smtp-primitive-helo (package)
 441   (let* ((connection
 442           (smtp-find-connection (current-buffer)))
 443          response)
 444     (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
 445     (setq response (smtp-read-response connection))
 446     (if (/= (car response) 250)
 447         (smtp-response-error response))))
 448
 449 (defun smtp-primitive-auth (package)
 450   (let* ((connection
 451           (smtp-find-connection (current-buffer)))
 452          (mechanisms
 453           (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
 454          (sasl-mechanisms
 455           (or smtp-sasl-mechanisms sasl-mechanisms))
 456          (mechanism
 457           (sasl-find-mechanism mechanisms))
 458          client
 459          name
 460          step
 461          response)
 462     (unless mechanism
 463       (error "No authentication mechanism available"))
 464     (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
 465                                    (smtp-connection-server-internal connection)))
 466     (if smtp-sasl-properties
 467         (sasl-client-set-properties client smtp-sasl-properties))
 468     (setq name (sasl-mechanism-name mechanism)
 469           ;; Retrieve the initial response
 470           step (sasl-next-step client nil))
 471     (smtp-send-command
 472      connection
 473      (if (sasl-step-data step)
 474          (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
 475        (format "AUTH %s" name)))
 476     (catch 'done
 477       (while t
 478         (setq response (smtp-read-response connection))
 479         (when (= (car response) 235)
 480           ;; The authentication process is finished.
 481           (setq step (sasl-next-step client step))
 482           (if (null step)
 483               (throw 'done nil))
 484           (smtp-response-error response)) ;Bogus server?
 485         (if (/= (car response) 334)
 486             (smtp-response-error response))
 487         (sasl-step-set-data step (base64-decode-string (nth 1 response)))
 488         (setq step (sasl-next-step client step))
 489         (smtp-send-command
 490          connection
 491          (if (sasl-step-data step)
 492              (base64-encode-string (sasl-step-data step) t)
 493            ""))))
 494 ;;;    (smtp-connection-set-encoder-internal
 495 ;;;     connection (sasl-client-encoder client))
 496 ;;;    (smtp-connection-set-decoder-internal
 497 ;;;     connection (sasl-client-decoder client))
 498     ))
 499
 500 (defun smtp-primitive-starttls (package)
 501   (let* ((connection
 502           (smtp-find-connection (current-buffer)))
 503          response)
 504     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 505     (smtp-send-command connection "STARTTLS")
 506     (setq response (smtp-read-response connection))
 507     (if (/= (car response) 220)
 508         (smtp-response-error response))
 509     (starttls-negotiate (smtp-connection-process-internal connection))))
 510
 511 (defun smtp-primitive-mailfrom (package)
 512   (let* ((connection
 513           (smtp-find-connection (current-buffer)))
 514          (extensions
 515           (smtp-connection-extensions-internal
 516            connection))
 517          (sender
 518           (smtp-package-sender-internal package))
 519          extension
 520          response)
 521     ;; SIZE --- Message Size Declaration (RFC1870)
 522     (if (and smtp-use-size
 523              (assq 'size extensions))
 524         (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
 525     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 526     (if (and smtp-use-8bitmime
 527              (assq '8bitmime extensions))
 528         (setq extension (concat extension " BODY=8BITMIME")))
 529     (smtp-send-command
 530      connection
 531      (if extension
 532          (format "MAIL FROM:<%s> %s" sender extension)
 533        (format "MAIL FROM:<%s>" sender)))
 534     (setq response (smtp-read-response connection))
 535     (if (/= (car response) 250)
 536         (smtp-response-error response))))
 537
 538 (defun smtp-primitive-rcptto (package)
 539   (let* ((connection
 540           (smtp-find-connection (current-buffer)))
 541          (recipients
 542           (smtp-package-recipients-internal package))
 543          response)
 544     (while recipients
 545       (smtp-send-command
 546        connection (format "RCPT TO:<%s>" (pop recipients)))
 547       (setq response (smtp-read-response connection))
 548       (unless (memq (car response) '(250 251))
 549         (smtp-response-error response)))))
 550
 551 (defun smtp-primitive-data (package)
 552   (let* ((connection
 553           (smtp-find-connection (current-buffer)))
 554          response)
 555     (smtp-send-command connection "DATA")
 556     (setq response (smtp-read-response connection))
 557     (if (/= (car response) 354)
 558         (smtp-response-error response))
 559     (save-excursion
 560       (set-buffer (smtp-package-buffer-internal package))
 561       (goto-char (point-min))
 562       (while (not (eobp))
 563         (smtp-send-data
 564          connection (buffer-substring (point) (progn (end-of-line)(point))))
 565         (beginning-of-line 2)))
 566     (smtp-send-command connection ".")
 567     (setq response (smtp-read-response connection))
 568     (if (/= (car response) 250)
 569         (smtp-response-error response))))
 570
 571 (defun smtp-primitive-quit (package)
 572   (let* ((connection
 573           (smtp-find-connection (current-buffer)))
 574          response)
 575     (smtp-send-command connection "QUIT")
 576     (setq response (smtp-read-response connection))
 577     (if (/= (car response) 221)
 578         (smtp-response-error response))))
 579
 580 ;;; @ low level process manipulating function
 581 ;;;
 582 (defun smtp-process-filter (process output)
 583   (save-excursion
 584     (set-buffer (process-buffer process))
 585     (goto-char (point-max))
 586     (insert output)))
 587
 588 (put 'smtp-error 'error-message "SMTP error")
 589 (put 'smtp-error 'error-conditions '(smtp-error error))
 590
 591 (put 'smtp-response-error 'error-message "SMTP response error")
 592 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 593
 594 (defun smtp-response-error (response)
 595   (signal 'smtp-response-error response))
 596
 597 (defun smtp-read-response (connection)
 598   (let ((decoder
 599          (smtp-connection-decoder-internal connection))
 600         (response-continue t)
 601         response)
 602     (while response-continue
 603       (goto-char smtp-read-point)
 604       (while (not (search-forward "\r\n" nil t))
 605         (accept-process-output (smtp-connection-process-internal connection))
 606         (goto-char smtp-read-point))
 607       (if decoder
 608           (let ((string (buffer-substring smtp-read-point (- (point) 2))))
 609             (delete-region smtp-read-point (point))
 610             (insert (funcall decoder string) "\r\n")))
 611       (setq response
 612             (nconc response
 613                    (list (buffer-substring
 614                           (+ 4 smtp-read-point)
 615                           (- (point) 2)))))
 616       (goto-char
 617        (prog1 smtp-read-point
 618          (setq smtp-read-point (point))))
 619       (if (looking-at "[1-5][0-9][0-9] ")
 620           (setq response (cons (read (point-marker)) response)
 621                 response-continue nil)))
 622     response))
 623
 624 (defun smtp-send-command (connection command)
 625   (save-excursion
 626     (let ((process
 627            (smtp-connection-process-internal connection))
 628           (encoder
 629            (smtp-connection-encoder-internal connection)))
 630       (set-buffer (process-buffer process))
 631       (goto-char (point-max))
 632       (setq command (concat command "\r\n"))
 633       (insert command)
 634       (setq smtp-read-point (point))
 635       (if encoder
 636           (setq command (funcall encoder command)))
 637       (process-send-string process command))))
 638
 639 (defun smtp-send-data (connection data)
 640   (let ((process
 641          (smtp-connection-process-internal connection))
 642         (encoder
 643          (smtp-connection-encoder-internal connection)))
 644     ;; Escape "." at start of a line.
 645     (if (eq (string-to-char data) ?.)
 646         (setq data (concat "." data "\r\n"))
 647       (setq data (concat data "\r\n")))
 648     (if encoder
 649         (setq data (funcall encoder data)))
 650     (process-send-string process data)))
 651
 652 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 653   "Get address list suitable for smtp RCPT TO:<address>."
 654   (let ((simple-address-list "")
 655         this-line
 656         this-line-end
 657         addr-regexp
 658         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 659     (unwind-protect
 660         (save-excursion
 661           ;;
 662           (set-buffer smtp-address-buffer)
 663           (setq case-fold-search t)
 664           (erase-buffer)
 665           (insert (save-excursion
 666                     (set-buffer smtp-text-buffer)
 667                     (buffer-substring-no-properties header-start header-end)))
 668           (goto-char (point-min))
 669           ;; RESENT-* fields should stop processing of regular fields.
 670           (save-excursion
 671             (if (re-search-forward "^RESENT-TO:" header-end t)
 672                 (setq addr-regexp
 673                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 674               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 675
 676           (while (re-search-forward addr-regexp header-end t)
 677             (replace-match "")
 678             (setq this-line (match-beginning 0))
 679             (forward-line 1)
 680             ;; get any continuation lines.
 681             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 682               (forward-line 1))
 683             (setq this-line-end (point-marker))
 684             (setq simple-address-list
 685                   (concat simple-address-list " "
 686                           (mail-strip-quoted-names
 687                            (buffer-substring this-line this-line-end)))))
 688           (erase-buffer)
 689           (insert-string " ")
 690           (insert-string simple-address-list)
 691           (insert-string "\n")
 692           ;; newline --> blank
 693           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 694           ;; comma   --> blank
 695           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 696           ;; tab     --> blank
 697           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 698
 699           (goto-char (point-min))
 700           ;; tidyness in case hook is not robust when it looks at this
 701           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 702
 703           (goto-char (point-min))
 704           (let (recipient-address-list)
 705             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 706               (backward-char 1)
 707               (setq recipient-address-list
 708                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 709                           recipient-address-list)))
 710             recipient-address-list))
 711       (kill-buffer smtp-address-buffer))))
 712
 713 (provide 'smtp)
 714
 715 ;;; smtp.el ends here