smtp.el

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