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              (or smtp-server
 350                  (error "`smtp-server' not defined"))))
 351           (package
 352            (smtp-make-package sender recipients buffer))
 353           (smtp-open-connection-function
 354            (if smtp-use-starttls
 355                #'starttls-open-stream
 356              smtp-open-connection-function)))
 357       (save-excursion
 358         (set-buffer
 359          (get-buffer-create
 360           (format "*trace of SMTP session to %s*" server)))
 361         (erase-buffer)
 362         (buffer-disable-undo)
 363         (unless (smtp-find-connection (current-buffer))
 364           (smtp-open-connection (current-buffer) server smtp-service))
 365         (make-local-variable 'smtp-read-point)
 366         (setq smtp-read-point (point-min))
 367         (funcall smtp-submit-package-function package)))))
 368
 369 (defun smtp-submit-package (package)
 370   (unwind-protect
 371       (progn
 372         (smtp-primitive-greeting package)
 373         (condition-case nil
 374             (smtp-primitive-ehlo package)
 375           (smtp-response-error
 376            (smtp-primitive-helo package)))
 377         (if smtp-use-starttls
 378             (if (assq 'starttls
 379                       (smtp-connection-extensions-internal
 380                        (smtp-find-connection (current-buffer))))
 381                 (progn
 382                   (smtp-primitive-starttls package)
 383                   (smtp-primitive-ehlo package))
 384               (unless smtp-use-starttls-ignore-error
 385                 (error "STARTTLS is not supported on this server"))))
 386         (if smtp-use-sasl
 387             (smtp-primitive-auth package))
 388         (smtp-primitive-mailfrom package)
 389         (smtp-primitive-rcptto package)
 390         (smtp-primitive-data package))
 391     (let ((connection (smtp-find-connection (current-buffer))))
 392       (when (smtp-connection-opened connection)
 393         (smtp-primitive-quit package)
 394         (smtp-close-connection connection)))))
 395
 396 (defun smtp-send-buffer-by-myself (sender recipients buffer)
 397   "Send a message by myself.
 398 SENDER is an envelope sender address.
 399 RECIPIENTS is a list of envelope recipient addresses.
 400 BUFFER may be a buffer or a buffer name which contains mail message."
 401   (let ((servers
 402          (smtp-find-server recipients))
 403         (smtp-open-connection-function
 404          (if smtp-use-starttls
 405              #'starttls-open-stream
 406            smtp-open-connection-function))
 407         server package)
 408       (while (car servers)
 409         (setq server (caar servers))
 410         (setq recipients (cdar servers))
 411         (if (not (and server recipients))
 412             ;; MAILER-DAEMON is required. :)
 413             (error (format "Cannot send <%s>"
 414                            (mapconcat 'concat recipients ">,<"))))
 415         (setq package
 416               (smtp-make-package sender recipients buffer))
 417         (save-excursion
 418           (set-buffer
 419            (get-buffer-create
 420             (format "*trace of SMTP session to %s*" server)))
 421           (erase-buffer)
 422           (buffer-disable-undo)
 423           (unless (smtp-find-connection (current-buffer))
 424             (smtp-open-connection (current-buffer) server smtp-service))
 425           (make-local-variable 'smtp-read-point)
 426           (setq smtp-read-point (point-min))
 427           (let ((smtp-use-sasl nil)
 428                 (smtp-use-starttls-ignore-error t))
 429             (funcall smtp-submit-package-function package)))
 430       (setq servers (cdr servers)))))
 431
 432 ;;; @ hook methods for `smtp-submit-package'
 433 ;;;
 434
 435 (defun smtp-primitive-greeting (package)
 436   (let* ((connection
 437           (smtp-find-connection (current-buffer)))
 438          (response
 439           (smtp-read-response connection)))
 440     (if (/= (car response) 220)
 441         (smtp-response-error response))))
 442
 443 (defun smtp-primitive-ehlo (package)
 444   (let* ((connection
 445           (smtp-find-connection (current-buffer)))
 446          response)
 447     (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
 448     (setq response (smtp-read-response connection))
 449     (if (/= (car response) 250)
 450         (smtp-response-error response))
 451     (smtp-connection-set-extensions-internal
 452      connection (mapcar
 453                  (lambda (extension)
 454                    (let ((extensions
 455                           (split-string extension)))
 456                      (setcar extensions
 457                              (car (read-from-string
 458                                    (downcase (car extensions)))))
 459                      extensions))
 460                  (cdr response)))))
 461
 462 (defun smtp-primitive-helo (package)
 463   (let* ((connection
 464           (smtp-find-connection (current-buffer)))
 465          response)
 466     (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
 467     (setq response (smtp-read-response connection))
 468     (if (/= (car response) 250)
 469         (smtp-response-error response))))
 470
 471 (defun smtp-primitive-auth (package)
 472   (let* ((connection
 473           (smtp-find-connection (current-buffer)))
 474          (mechanisms
 475           (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
 476          (sasl-mechanisms
 477           (or smtp-sasl-mechanisms sasl-mechanisms))
 478          (mechanism
 479           (sasl-find-mechanism mechanisms))
 480          client
 481          name
 482          step
 483          response)
 484     (unless mechanism
 485       (error "No authentication mechanism available"))
 486     (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
 487                                    (smtp-connection-server-internal connection)))
 488     (if smtp-sasl-properties
 489         (sasl-client-set-properties client smtp-sasl-properties))
 490     (setq name (sasl-mechanism-name mechanism)
 491           ;; Retrieve the initial response
 492           step (sasl-next-step client nil))
 493     (smtp-send-command
 494      connection
 495      (if (sasl-step-data step)
 496          (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
 497        (format "AUTH %s" name)))
 498     (catch 'done
 499       (while t
 500         (setq response (smtp-read-response connection))
 501         (when (= (car response) 235)
 502           ;; The authentication process is finished.
 503           (setq step (sasl-next-step client step))
 504           (if (null step)
 505               (throw 'done nil))
 506           (smtp-response-error response)) ;Bogus server?
 507         (if (/= (car response) 334)
 508             (smtp-response-error response))
 509         (sasl-step-set-data step (base64-decode-string (nth 1 response)))
 510         (setq step (sasl-next-step client step))
 511         (smtp-send-command
 512          connection
 513          (if (sasl-step-data step)
 514              (base64-encode-string (sasl-step-data step) t)
 515            ""))))
 516 ;;;    (smtp-connection-set-encoder-internal
 517 ;;;     connection (sasl-client-encoder client))
 518 ;;;    (smtp-connection-set-decoder-internal
 519 ;;;     connection (sasl-client-decoder client))
 520     ))
 521
 522 (defun smtp-primitive-starttls (package)
 523   (let* ((connection
 524           (smtp-find-connection (current-buffer)))
 525          response)
 526     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 527     (smtp-send-command connection "STARTTLS")
 528     (setq response (smtp-read-response connection))
 529     (if (/= (car response) 220)
 530         (smtp-response-error response))
 531     (starttls-negotiate (smtp-connection-process-internal connection))))
 532
 533 (defun smtp-primitive-mailfrom (package)
 534   (let* ((connection
 535           (smtp-find-connection (current-buffer)))
 536          (extensions
 537           (smtp-connection-extensions-internal
 538            connection))
 539          (sender
 540           (smtp-package-sender-internal package))
 541          extension
 542          response)
 543     ;; SIZE --- Message Size Declaration (RFC1870)
 544     (if (and smtp-use-size
 545              (assq 'size extensions))
 546         (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
 547     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 548     (if (and smtp-use-8bitmime
 549              (assq '8bitmime extensions))
 550         (setq extension (concat extension " BODY=8BITMIME")))
 551     (smtp-send-command
 552      connection
 553      (if extension
 554          (format "MAIL FROM:<%s> %s" sender extension)
 555        (format "MAIL FROM:<%s>" sender)))
 556     (setq response (smtp-read-response connection))
 557     (if (/= (car response) 250)
 558         (smtp-response-error response))))
 559
 560 (defun smtp-primitive-rcptto (package)
 561   (let* ((connection
 562           (smtp-find-connection (current-buffer)))
 563          (recipients
 564           (smtp-package-recipients-internal package))
 565          response)
 566     (while recipients
 567       (smtp-send-command
 568        connection (format "RCPT TO:<%s>" (pop recipients)))
 569       (setq response (smtp-read-response connection))
 570       (unless (memq (car response) '(250 251))
 571         (smtp-response-error response)))))
 572
 573 (defun smtp-primitive-data (package)
 574   (let* ((connection
 575           (smtp-find-connection (current-buffer)))
 576          response)
 577     (smtp-send-command connection "DATA")
 578     (setq response (smtp-read-response connection))
 579     (if (/= (car response) 354)
 580         (smtp-response-error response))
 581     (save-excursion
 582       (set-buffer (smtp-package-buffer-internal package))
 583       (goto-char (point-min))
 584       (while (not (eobp))
 585         (smtp-send-data
 586          connection (buffer-substring (point) (progn (end-of-line)(point))))
 587         (beginning-of-line 2)))
 588     (smtp-send-command connection ".")
 589     (setq response (smtp-read-response connection))
 590     (if (/= (car response) 250)
 591         (smtp-response-error response))))
 592
 593 (defun smtp-primitive-quit (package)
 594   (let* ((connection
 595           (smtp-find-connection (current-buffer)))
 596          response)
 597     (smtp-send-command connection "QUIT")
 598     (setq response (smtp-read-response connection))
 599     (if (/= (car response) 221)
 600         (smtp-response-error response))))
 601
 602 ;;; @ low level process manipulating function
 603 ;;;
 604 (defun smtp-process-filter (process output)
 605   (save-excursion
 606     (set-buffer (process-buffer process))
 607     (goto-char (point-max))
 608     (insert output)))
 609
 610 (put 'smtp-error 'error-message "SMTP error")
 611 (put 'smtp-error 'error-conditions '(smtp-error error))
 612
 613 (put 'smtp-response-error 'error-message "SMTP response error")
 614 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 615
 616 (defun smtp-response-error (response)
 617   (signal 'smtp-response-error response))
 618
 619 (defun smtp-read-response (connection)
 620   (let ((decoder
 621          (smtp-connection-decoder-internal connection))
 622         (response-continue t)
 623         response)
 624     (while response-continue
 625       (goto-char smtp-read-point)
 626       (while (not (search-forward smtp-end-of-line nil t))
 627         (accept-process-output (smtp-connection-process-internal connection))
 628         (goto-char smtp-read-point))
 629       (if decoder
 630           (let ((string (buffer-substring smtp-read-point (- (point) 2))))
 631             (delete-region smtp-read-point (point))
 632             (insert (funcall decoder string) smtp-end-of-line)))
 633       (setq response
 634             (nconc response
 635                    (list (buffer-substring
 636                           (+ 4 smtp-read-point)
 637                           (- (point) 2)))))
 638       (goto-char
 639        (prog1 smtp-read-point
 640          (setq smtp-read-point (point))))
 641       (if (looking-at "[1-5][0-9][0-9] ")
 642           (setq response (cons (read (point-marker)) response)
 643                 response-continue nil)))
 644     response))
 645
 646 (defun smtp-send-command (connection command)
 647   (save-excursion
 648     (let ((process
 649            (smtp-connection-process-internal connection))
 650           (encoder
 651            (smtp-connection-encoder-internal connection)))
 652       (set-buffer (process-buffer process))
 653       (goto-char (point-max))
 654       (setq command (concat command smtp-end-of-line))
 655       (insert command)
 656       (setq smtp-read-point (point))
 657       (if encoder
 658           (setq command (funcall encoder command)))
 659       (process-send-string process command))))
 660
 661 (defun smtp-send-data (connection data)
 662   (let ((process
 663          (smtp-connection-process-internal connection))
 664         (encoder
 665          (smtp-connection-encoder-internal connection)))
 666     ;; Escape "." at start of a line.
 667     (if (eq (string-to-char data) ?.)
 668         (setq data (concat "." data smtp-end-of-line))
 669       (setq data (concat data smtp-end-of-line)))
 670     (if encoder
 671         (setq data (funcall encoder data)))
 672     (process-send-string process data)))
 673
 674 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 675   "Get address list suitable for smtp RCPT TO:<address>."
 676   (let ((simple-address-list "")
 677         this-line
 678         this-line-end
 679         addr-regexp
 680         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 681     (unwind-protect
 682         (save-excursion
 683           ;;
 684           (set-buffer smtp-address-buffer)
 685           (setq case-fold-search t)
 686           (erase-buffer)
 687           (insert (save-excursion
 688                     (set-buffer smtp-text-buffer)
 689                     (buffer-substring-no-properties header-start header-end)))
 690           (goto-char (point-min))
 691           ;; RESENT-* fields should stop processing of regular fields.
 692           (save-excursion
 693             (if (re-search-forward "^RESENT-TO:" header-end t)
 694                 (setq addr-regexp
 695                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 696               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 697
 698           (while (re-search-forward addr-regexp header-end t)
 699             (replace-match "")
 700             (setq this-line (match-beginning 0))
 701             (forward-line 1)
 702             ;; get any continuation lines.
 703             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 704               (forward-line 1))
 705             (setq this-line-end (point-marker))
 706             (setq simple-address-list
 707                   (concat simple-address-list " "
 708                           (mail-strip-quoted-names
 709                            (buffer-substring this-line this-line-end)))))
 710           (erase-buffer)
 711           (insert-string " ")
 712           (insert-string simple-address-list)
 713           (insert-string "\n")
 714           ;; newline --> blank
 715           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 716           ;; comma   --> blank
 717           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 718           ;; tab     --> blank
 719           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 720
 721           (goto-char (point-min))
 722           ;; tidyness in case hook is not robust when it looks at this
 723           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 724
 725           (goto-char (point-min))
 726           (let (recipient-address-list)
 727             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 728               (backward-char 1)
 729               (setq recipient-address-list
 730                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 731                           recipient-address-list)))
 732             recipient-address-list))
 733       (kill-buffer smtp-address-buffer))))
 734
 735 (provide 'smtp)
 736
 737 ;;; smtp.el ends here