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