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-starttls-program "starttls"
 106   "The program to run in a subprocess to open an TLSv1 connection."
 107   :group 'smtp-extensions)
 108
 109 (defcustom smtp-starttls-extra-args nil
 110   "Extra arguments to `starttls-program'"
 111   :group 'smtp-extensions)
 112
 113 (defcustom smtp-use-sasl nil
 114   "If non-nil, use SMTP Authentication (RFC2554) if available."
 115   :type 'boolean
 116   :group 'smtp-extensions)
 117
 118 (defcustom smtp-sasl-user-name (user-login-name)
 119   "Identification to be used for authorization."
 120   :type 'string
 121   :group 'smtp-extensions)
 122
 123 (defcustom smtp-sasl-properties nil
 124   "Properties set to SASL client."
 125   :type 'string
 126   :group 'smtp-extensions)
 127
 128 (defcustom smtp-sasl-mechanisms nil
 129   "List of authentication mechanisms."
 130   :type '(repeat string)
 131   :group 'smtp-extensions)
 132
 133 (defvar sasl-mechanisms)
 134
 135 ;;;###autoload
 136 (defvar smtp-open-connection-function #'open-network-stream
 137   "*Function used for connecting to a SMTP server.
 138 The function will be called with the same four arguments as
 139 `open-network-stream' and should return a process object.
 140 Here is an example:
 141
 142 \(setq smtp-open-connection-function
 143       #'(lambda (name buffer host service)
 144           (let ((process-connection-type nil))
 145             (start-process name buffer \"ssh\" \"-C\" host
 146                            \"nc\" host service))))
 147
 148 It connects to a SMTP server using \"ssh\" before actually connecting
 149 to the SMTP port.  Where the command \"nc\" is the netcat executable;
 150 see http://www.atstake.com/research/tools/index.html#network_utilities
 151 for details.  In addition, you will have to modify the value for
 152 `smtp-end-of-line' to \"\\n\" if you use \"telnet\" instead of \"nc\".")
 153
 154 (defvar smtp-read-point nil)
 155
 156 (defvar smtp-connection-alist nil)
 157
 158 (defvar smtp-submit-package-function #'smtp-submit-package)
 159
 160 (defvar smtp-end-of-line "\r\n"
 161   "*String to use as end-of-line marker when talking to a SMTP server.
 162 This is \"\\r\\n\" by default, but it may have to be \"\\n\" when using a non
 163 native connection function.  See also `smtp-open-connection-function'.")
 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         (smtp-primitive-quit package)
 404         (smtp-close-connection connection)))))
 405
 406 (defun smtp-send-buffer-by-myself (sender recipients buffer)
 407   "Send a message by myself.
 408 SENDER is an envelope sender address.
 409 RECIPIENTS is a list of envelope recipient addresses.
 410 BUFFER may be a buffer or a buffer name which contains mail message."
 411   (let ((servers
 412          (smtp-find-server recipients))
 413         (smtp-open-connection-function
 414          (if smtp-use-starttls
 415              #'starttls-open-stream
 416            smtp-open-connection-function))
 417         server package)
 418       (while (car servers)
 419         (setq server (caar servers))
 420         (setq recipients (cdar servers))
 421         (if (not (and server recipients))
 422             ;; MAILER-DAEMON is required. :)
 423             (error (format "Cannot send <%s>"
 424                            (mapconcat 'concat recipients ">,<"))))
 425         (setq package
 426               (smtp-make-package sender recipients buffer))
 427         (save-excursion
 428           (set-buffer
 429            (get-buffer-create
 430             (format "*trace of SMTP session to %s*" server)))
 431           (erase-buffer)
 432           (buffer-disable-undo)
 433           (unless (smtp-find-connection (current-buffer))
 434             (smtp-open-connection (current-buffer) server smtp-service))
 435           (make-local-variable 'smtp-read-point)
 436           (setq smtp-read-point (point-min))
 437           (let ((smtp-use-sasl nil)
 438                 (smtp-use-starttls-ignore-error t))
 439             (funcall smtp-submit-package-function package)))
 440       (setq servers (cdr servers)))))
 441
 442 ;;; @ hook methods for `smtp-submit-package'
 443 ;;;
 444
 445 (defun smtp-primitive-greeting (package)
 446   (let* ((connection
 447           (smtp-find-connection (current-buffer)))
 448          (response
 449           (smtp-read-response connection)))
 450     (if (/= (car response) 220)
 451         (smtp-response-error response))))
 452
 453 (defun smtp-primitive-ehlo (package)
 454   (let* ((connection
 455           (smtp-find-connection (current-buffer)))
 456          response)
 457     (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
 458     (setq response (smtp-read-response connection))
 459     (if (/= (car response) 250)
 460         (smtp-response-error response))
 461     (smtp-connection-set-extensions-internal
 462      connection (mapcar
 463                  (lambda (extension)
 464                    (let ((extensions
 465                           (split-string extension)))
 466                      (setcar extensions
 467                              (car (read-from-string
 468                                    (downcase (car extensions)))))
 469                      extensions))
 470                  (cdr response)))))
 471
 472 (defun smtp-primitive-helo (package)
 473   (let* ((connection
 474           (smtp-find-connection (current-buffer)))
 475          response)
 476     (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
 477     (setq response (smtp-read-response connection))
 478     (if (/= (car response) 250)
 479         (smtp-response-error response))))
 480
 481 (defun smtp-primitive-auth (package)
 482   (let* ((connection
 483           (smtp-find-connection (current-buffer)))
 484          (mechanisms
 485           (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
 486          (sasl-mechanisms
 487           (or smtp-sasl-mechanisms sasl-mechanisms))
 488          (mechanism
 489           (sasl-find-mechanism mechanisms))
 490          client
 491          name
 492          step
 493          response)
 494     (unless mechanism
 495       (error "No authentication mechanism available"))
 496     (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
 497                                    (smtp-connection-server-internal connection)))
 498     (if smtp-sasl-properties
 499         (sasl-client-set-properties client smtp-sasl-properties))
 500     (setq name (sasl-mechanism-name mechanism)
 501           ;; Retrieve the initial response
 502           step (sasl-next-step client nil))
 503     (smtp-send-command
 504      connection
 505      (if (sasl-step-data step)
 506          (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
 507        (format "AUTH %s" name)))
 508     (catch 'done
 509       (while t
 510         (setq response (smtp-read-response connection))
 511         (when (= (car response) 235)
 512           ;; The authentication process is finished.
 513           (setq step (sasl-next-step client step))
 514           (if (null step)
 515               (throw 'done nil))
 516           (smtp-response-error response)) ;Bogus server?
 517         (if (/= (car response) 334)
 518             (smtp-response-error response))
 519         (sasl-step-set-data step (base64-decode-string (nth 1 response)))
 520         (setq step (sasl-next-step client step))
 521         (smtp-send-command
 522          connection
 523          (if (sasl-step-data step)
 524              (base64-encode-string (sasl-step-data step) t)
 525            ""))))
 526 ;;;    (smtp-connection-set-encoder-internal
 527 ;;;     connection (sasl-client-encoder client))
 528 ;;;    (smtp-connection-set-decoder-internal
 529 ;;;     connection (sasl-client-decoder client))
 530     ))
 531
 532 (defun smtp-primitive-starttls (package)
 533   (let* ((connection
 534           (smtp-find-connection (current-buffer)))
 535          response)
 536     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 537     (smtp-send-command connection "STARTTLS")
 538     (setq response (smtp-read-response connection))
 539     (if (/= (car response) 220)
 540         (smtp-response-error response))
 541     (starttls-negotiate (smtp-connection-process-internal connection))))
 542
 543 (defun smtp-primitive-mailfrom (package)
 544   (let* ((connection
 545           (smtp-find-connection (current-buffer)))
 546          (extensions
 547           (smtp-connection-extensions-internal
 548            connection))
 549          (sender
 550           (smtp-package-sender-internal package))
 551          extension
 552          response)
 553     ;; SIZE --- Message Size Declaration (RFC1870)
 554     (if (and smtp-use-size
 555              (assq 'size extensions))
 556         (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
 557     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 558     (if (and smtp-use-8bitmime
 559              (assq '8bitmime extensions))
 560         (setq extension (concat extension " BODY=8BITMIME")))
 561     (smtp-send-command
 562      connection
 563      (if extension
 564          (format "MAIL FROM:<%s> %s" sender extension)
 565        (format "MAIL FROM:<%s>" sender)))
 566     (setq response (smtp-read-response connection))
 567     (if (/= (car response) 250)
 568         (smtp-response-error response))))
 569
 570 (defun smtp-primitive-rcptto (package)
 571   (let* ((connection
 572           (smtp-find-connection (current-buffer)))
 573          (recipients
 574           (smtp-package-recipients-internal package))
 575          response)
 576     (while recipients
 577       (smtp-send-command
 578        connection (format "RCPT TO:<%s>" (pop recipients)))
 579       (setq response (smtp-read-response connection))
 580       (unless (memq (car response) '(250 251))
 581         (smtp-response-error response)))))
 582
 583 (defun smtp-primitive-data (package)
 584   (let* ((connection
 585           (smtp-find-connection (current-buffer)))
 586          response)
 587     (smtp-send-command connection "DATA")
 588     (setq response (smtp-read-response connection))
 589     (if (/= (car response) 354)
 590         (smtp-response-error response))
 591     (save-excursion
 592       (set-buffer (smtp-package-buffer-internal package))
 593       (goto-char (point-min))
 594       (while (not (eobp))
 595         (smtp-send-data
 596          connection (buffer-substring (point) (progn (end-of-line)(point))))
 597         (beginning-of-line 2)))
 598     (smtp-send-command connection ".")
 599     (setq response (smtp-read-response connection))
 600     (if (/= (car response) 250)
 601         (smtp-response-error response))))
 602
 603 (defun smtp-primitive-quit (package)
 604   (let* ((connection
 605           (smtp-find-connection (current-buffer)))
 606          response)
 607     (smtp-send-command connection "QUIT")
 608     (setq response (smtp-read-response connection))
 609     (if (/= (car response) 221)
 610         (smtp-response-error response))))
 611
 612 ;;; @ low level process manipulating function
 613 ;;;
 614 (defun smtp-process-filter (process output)
 615   (save-excursion
 616     (set-buffer (process-buffer process))
 617     (goto-char (point-max))
 618     (insert output)))
 619
 620 (put 'smtp-error 'error-message "SMTP error")
 621 (put 'smtp-error 'error-conditions '(smtp-error error))
 622
 623 (put 'smtp-response-error 'error-message "SMTP response error")
 624 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 625
 626 (defun smtp-response-error (response)
 627   (signal 'smtp-response-error response))
 628
 629 (defun smtp-read-response (connection)
 630   (let ((decoder
 631          (smtp-connection-decoder-internal connection))
 632         (response-continue t)
 633         response)
 634     (while response-continue
 635       (goto-char smtp-read-point)
 636       (while (not (search-forward smtp-end-of-line nil t))
 637         (accept-process-output (smtp-connection-process-internal connection))
 638         (goto-char smtp-read-point))
 639       (if decoder
 640           (let ((string (buffer-substring smtp-read-point (- (point) 2))))
 641             (delete-region smtp-read-point (point))
 642             (insert (funcall decoder string) smtp-end-of-line)))
 643       (setq response
 644             (nconc response
 645                    (list (buffer-substring
 646                           (+ 4 smtp-read-point)
 647                           (- (point) 2)))))
 648       (goto-char
 649        (prog1 smtp-read-point
 650          (setq smtp-read-point (point))))
 651       (if (looking-at "[1-5][0-9][0-9] ")
 652           (setq response (cons (read (point-marker)) response)
 653                 response-continue nil)))
 654     response))
 655
 656 (defun smtp-send-command (connection command)
 657   (save-excursion
 658     (let ((process
 659            (smtp-connection-process-internal connection))
 660           (encoder
 661            (smtp-connection-encoder-internal connection)))
 662       (set-buffer (process-buffer process))
 663       (goto-char (point-max))
 664       (setq command (concat command smtp-end-of-line))
 665       (insert command)
 666       (setq smtp-read-point (point))
 667       (if encoder
 668           (setq command (funcall encoder command)))
 669       (process-send-string process command))))
 670
 671 (defun smtp-send-data (connection data)
 672   (let ((process
 673          (smtp-connection-process-internal connection))
 674         (encoder
 675          (smtp-connection-encoder-internal connection)))
 676     ;; Escape "." at start of a line.
 677     (if (eq (string-to-char data) ?.)
 678         (setq data (concat "." data smtp-end-of-line))
 679       (setq data (concat data smtp-end-of-line)))
 680     (if encoder
 681         (setq data (funcall encoder data)))
 682     (process-send-string process data)))
 683
 684 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 685   "Get address list suitable for smtp RCPT TO:<address>."
 686   (let ((simple-address-list "")
 687         this-line
 688         this-line-end
 689         addr-regexp
 690         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 691     (unwind-protect
 692         (save-excursion
 693           ;;
 694           (set-buffer smtp-address-buffer)
 695           (setq case-fold-search t)
 696           (erase-buffer)
 697           (insert (save-excursion
 698                     (set-buffer smtp-text-buffer)
 699                     (buffer-substring-no-properties header-start header-end)))
 700           (goto-char (point-min))
 701           ;; RESENT-* fields should stop processing of regular fields.
 702           (save-excursion
 703             (if (re-search-forward "^RESENT-TO:" header-end t)
 704                 (setq addr-regexp
 705                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 706               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 707
 708           (while (re-search-forward addr-regexp header-end t)
 709             (replace-match "")
 710             (setq this-line (match-beginning 0))
 711             (forward-line 1)
 712             ;; get any continuation lines.
 713             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 714               (forward-line 1))
 715             (setq this-line-end (point-marker))
 716             (setq simple-address-list
 717                   (concat simple-address-list " "
 718                           (mail-strip-quoted-names
 719                            (buffer-substring this-line this-line-end)))))
 720           (erase-buffer)
 721           (insert-string " ")
 722           (insert-string simple-address-list)
 723           (insert-string "\n")
 724           ;; newline --> blank
 725           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 726           ;; comma   --> blank
 727           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 728           ;; tab     --> blank
 729           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 730
 731           (goto-char (point-min))
 732           ;; tidyness in case hook is not robust when it looks at this
 733           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 734
 735           (goto-char (point-min))
 736           (let (recipient-address-list)
 737             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 738               (backward-char 1)
 739               (setq recipient-address-list
 740                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 741                           recipient-address-list)))
 742             recipient-address-list))
 743       (kill-buffer smtp-address-buffer))))
 744
 745 (provide 'smtp)
 746
 747 ;;; smtp.el ends here