smtp.el

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