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