git.chise.org Git - elisp/gnus.git-/blob - lisp/smtpmail.el

   1 ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
   2
   3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
   6 ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
   7 ;; ESMTP support: Simon Leinen <simon@switch.ch>
   8 ;; Keywords: mail
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Send Mail to smtp host from smtpmail temp buffer.
  30
  31 ;; Please add these lines in your .emacs(_emacs).
  32 ;;
  33 ;;(setq send-mail-function 'smtpmail-send-it)
  34 ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST")
  35 ;;(setq smtpmail-smtp-service "smtp")
  36 ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
  37 ;;(setq smtpmail-debug-info t)
  38 ;;(load-library "smtpmail")
  39 ;;(setq user-full-name "YOUR NAME HERE")
  40
  41 ;; To queue mail, set smtpmail-queue-mail to t and use
  42 ;; smtpmail-send-queued-mail to send.
  43
  44
  45 ;;; Code:
  46
  47 (require 'sendmail)
  48 (require 'time-stamp)
  49
  50 ;;;
  51 (defgroup smtpmail nil
  52   "SMTP protocol for sending mail."
  53   :group 'mail)
  54
  55
  56 (defcustom smtpmail-default-smtp-server nil
  57   "*Specify default SMTP server."
  58   :type '(choice (const nil) string)
  59   :group 'smtpmail)
  60
  61 (defcustom smtpmail-smtp-server
  62   (or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
  63   "*The name of the host running SMTP server."
  64   :type '(choice (const nil) string)
  65   :group 'smtpmail)
  66
  67 (defcustom smtpmail-smtp-service 25
  68   "*SMTP service port number. smtp or 25 ."
  69   :type 'integer
  70   :group 'smtpmail)
  71
  72 (defcustom smtpmail-local-domain nil
  73   "*Local domain name without a host name.
  74 If the function (system-name) returns the full internet address,
  75 don't define this value."
  76   :type '(choice (const nil) string)
  77   :group 'smtpmail)
  78
  79 (defcustom smtpmail-debug-info nil
  80   "*smtpmail debug info printout. messages and process buffer."
  81   :type 'boolean
  82   :group 'smtpmail)
  83
  84 (defcustom smtpmail-coding-system 'binary
  85   "*Coding-system for SMTP output."
  86   :type 'coding-system
  87   :group 'smtpmail)
  88
  89 (defcustom smtpmail-queue-mail nil
  90   "*Specify if mail is queued (if t) or sent immediately (if nil).
  91 If queued, it is stored in the directory `smtpmail-queue-dir'
  92 and sent with `smtpmail-send-queued-mail'."
  93   :type 'boolean
  94   :group 'smtpmail)
  95
  96 (defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
  97   "*Directory where `smtpmail.el' stores queued mail."
  98   :type 'directory
  99   :group 'smtpmail)
 100
 101 (defvar smtpmail-queue-index-file "index"
 102   "File name of queued mail index,
 103 This is relative to `smtpmail-queue-dir'.")
 104
 105 (defvar smtpmail-queue-index (concat smtpmail-queue-dir
 106                                      smtpmail-queue-index-file))
 107
 108 ;;;
 109 ;;;
 110 ;;;
 111
 112 (defun smtpmail-send-it ()
 113   (require 'mail-utils)
 114   (let ((errbuf (if mail-interactive
 115                     (generate-new-buffer " smtpmail errors")
 116                   0))
 117         (tembuf (generate-new-buffer " smtpmail temp"))
 118         (case-fold-search nil)
 119         resend-to-addresses
 120         delimline
 121         (mailbuf (current-buffer)))
 122     (unwind-protect
 123         (save-excursion
 124           (set-buffer tembuf)
 125           (erase-buffer)
 126           (insert-buffer-substring mailbuf)
 127           (goto-char (point-max))
 128           ;; require one newline at the end.
 129           (or (= (preceding-char) ?\n)
 130               (insert ?\n))
 131           ;; Change header-delimiter to be what sendmail expects.
 132           (goto-char (point-min))
 133           (re-search-forward
 134             (concat "^" (regexp-quote mail-header-separator) "\n"))
 135           (replace-match "\n")
 136           (backward-char 1)
 137           (setq delimline (point-marker))
 138 ;;        (sendmail-synch-aliases)
 139           (if mail-aliases
 140               (expand-mail-aliases (point-min) delimline))
 141           (goto-char (point-min))
 142           ;; ignore any blank lines in the header
 143           (while (and (re-search-forward "\n\n\n*" delimline t)
 144                       (< (point) delimline))
 145             (replace-match "\n"))
 146           (let ((case-fold-search t))
 147             (goto-char (point-min))
 148             (goto-char (point-min))
 149             (while (re-search-forward "^Resent-to:" delimline t)
 150               (setq resend-to-addresses
 151                     (save-restriction
 152                       (narrow-to-region (point)
 153                                         (save-excursion
 154                                           (end-of-line)
 155                                           (point)))
 156                       (append (mail-parse-comma-list)
 157                               resend-to-addresses))))
 158 ;;; Apparently this causes a duplicate Sender.
 159 ;;;         ;; If the From is different than current user, insert Sender.
 160 ;;;         (goto-char (point-min))
 161 ;;;         (and (re-search-forward "^From:"  delimline t)
 162 ;;;              (progn
 163 ;;;                (require 'mail-utils)
 164 ;;;                (not (string-equal
 165 ;;;                      (mail-strip-quoted-names
 166 ;;;                       (save-restriction
 167 ;;;                         (narrow-to-region (point-min) delimline)
 168 ;;;                         (mail-fetch-field "From")))
 169 ;;;                      (user-login-name))))
 170 ;;;              (progn
 171 ;;;                (forward-line 1)
 172 ;;;                (insert "Sender: " (user-login-name) "\n")))
 173             ;; Don't send out a blank subject line
 174             (goto-char (point-min))
 175             (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
 176                 (replace-match ""))
 177             ;; Put the "From:" field in unless for some odd reason
 178             ;; they put one in themselves.
 179             (goto-char (point-min))
 180             (if (not (re-search-forward "^From:" delimline t))
 181                 (let* ((login user-mail-address)
 182                        (fullname (user-full-name)))
 183                   (cond ((eq mail-from-style 'angles)
 184                          (insert "From: " fullname)
 185                          (let ((fullname-start (+ (point-min) 6))
 186                                (fullname-end (point-marker)))
 187                            (goto-char fullname-start)
 188                            ;; Look for a character that cannot appear unquoted
 189                            ;; according to RFC 822.
 190                            (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
 191                                                   fullname-end 1)
 192                                (progn
 193                                  ;; Quote fullname, escaping specials.
 194                                  (goto-char fullname-start)
 195                                  (insert "\"")
 196                                  (while (re-search-forward "[\"\\]"
 197                                                            fullname-end 1)
 198                                    (replace-match "\\\\\\&" t))
 199                                  (insert "\""))))
 200                          (insert " <" login ">\n"))
 201                         ((eq mail-from-style 'parens)
 202                          (insert "From: " login " (")
 203                          (let ((fullname-start (point)))
 204                            (insert fullname)
 205                            (let ((fullname-end (point-marker)))
 206                              (goto-char fullname-start)
 207                              ;; RFC 822 says \ and nonmatching parentheses
 208                              ;; must be escaped in comments.
 209                              ;; Escape every instance of ()\ ...
 210                              (while (re-search-forward "[()\\]" fullname-end 1)
 211                                (replace-match "\\\\\\&" t))
 212                              ;; ... then undo escaping of matching parentheses,
 213                              ;; including matching nested parentheses.
 214                              (goto-char fullname-start)
 215                              (while (re-search-forward
 216                                      "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
 217                                      fullname-end 1)
 218                                (replace-match "\\1(\\3)" t)
 219                                (goto-char fullname-start))))
 220                          (insert ")\n"))
 221                         ((null mail-from-style)
 222                          (insert "From: " login "\n")))))
 223             ;; Insert an extra newline if we need it to work around
 224             ;; Sun's bug that swallows newlines.
 225             (goto-char (1+ delimline))
 226             (if (eval mail-mailer-swallows-blank-line)
 227                 (newline))
 228             ;; Find and handle any FCC fields.
 229             (goto-char (point-min))
 230             (if (re-search-forward "^FCC:" delimline t)
 231                 (mail-do-fcc delimline))
 232             (if mail-interactive
 233                 (save-excursion
 234                   (set-buffer errbuf)
 235                   (erase-buffer))))
 236           ;;
 237           ;;
 238           ;;
 239           (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
 240           (setq smtpmail-recipient-address-list
 241                 (or resend-to-addresses
 242                     (smtpmail-deduce-address-list tembuf (point-min) delimline)))
 243           (kill-buffer smtpmail-address-buffer)
 244
 245           (smtpmail-do-bcc delimline)
 246           ; Send or queue
 247           (if (not smtpmail-queue-mail)
 248               (if (not (null smtpmail-recipient-address-list))
 249                   (if (not (smtpmail-via-smtp
 250                             smtpmail-recipient-address-list tembuf))
 251                       (error "Sending failed; SMTP protocol error"))
 252                 (error "Sending failed; no recipients"))
 253             (let* ((file-data (concat
 254                                smtpmail-queue-dir
 255                                (time-stamp-strftime
 256                                 "%02y%02m%02d-%02H%02M%02S")))
 257                    (file-elisp (concat file-data ".el"))
 258                    (buffer-data (create-file-buffer file-data))
 259                    (buffer-elisp (create-file-buffer file-elisp))
 260                    (buffer-scratch "*queue-mail*"))
 261               (save-excursion
 262                 (set-buffer buffer-data)
 263                 (erase-buffer)
 264                 (insert-buffer tembuf)
 265                 (write-file file-data)
 266                 (set-buffer buffer-elisp)
 267                 (erase-buffer)
 268                 (insert (concat
 269                          "(setq smtpmail-recipient-address-list '"
 270                          (prin1-to-string smtpmail-recipient-address-list)
 271                          ")\n"))
 272                 (write-file file-elisp)
 273                 (set-buffer (generate-new-buffer buffer-scratch))
 274                 (insert (concat file-data "\n"))
 275                 (append-to-file (point-min)
 276                                 (point-max)
 277                                 smtpmail-queue-index)
 278                 )
 279               (kill-buffer buffer-scratch)
 280               (kill-buffer buffer-data)
 281               (kill-buffer buffer-elisp))))
 282       (kill-buffer tembuf)
 283       (if (bufferp errbuf)
 284           (kill-buffer errbuf)))))
 285
 286 (defun smtpmail-send-queued-mail ()
 287   "Send mail that was queued as a result of setting `smtpmail-queue-mail'."
 288   (interactive)
 289   ;;; Get index, get first mail, send it, get second mail, etc...
 290   (let ((buffer-index (find-file-noselect smtpmail-queue-index))
 291         (file-msg "")
 292         (tembuf nil))
 293     (save-excursion
 294       (set-buffer buffer-index)
 295       (beginning-of-buffer)
 296       (while (not (eobp))
 297         (setq file-msg (buffer-substring (point) (save-excursion
 298                                                    (end-of-line)
 299                                                    (point))))
 300         (load file-msg)
 301         (setq tembuf (find-file-noselect file-msg))
 302         (if (not (null smtpmail-recipient-address-list))
 303             (if (not (smtpmail-via-smtp smtpmail-recipient-address-list
 304                                         tembuf))
 305                 (error "Sending failed; SMTP protocol error"))
 306           (error "Sending failed; no recipients"))
 307         (delete-file file-msg)
 308         (delete-file (concat file-msg ".el"))
 309         (kill-buffer tembuf)
 310         (kill-line 1))
 311       (set-buffer buffer-index)
 312       (save-buffer smtpmail-queue-index)
 313       (kill-buffer buffer-index)
 314       )))
 315
 316 ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
 317
 318 (defun smtpmail-fqdn ()
 319   (if smtpmail-local-domain
 320       (concat (system-name) "." smtpmail-local-domain)
 321     (system-name)))
 322
 323 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
 324   (let ((process nil)
 325         (host smtpmail-smtp-server)
 326         (port smtpmail-smtp-service)
 327         response-code
 328         greeting
 329         process-buffer
 330         (supported-extensions '())
 331         (coding-system-for-write smtpmail-coding-system))
 332     (unwind-protect
 333         (catch 'done
 334           ;; get or create the trace buffer
 335           (setq process-buffer
 336                 (get-buffer-create (format "*trace of SMTP session to %s*" host)))
 337
 338           ;; clear the trace buffer of old output
 339           (save-excursion
 340             (set-buffer process-buffer)
 341             (erase-buffer))
 342
 343           ;; open the connection to the server
 344           (setq process (open-network-stream "SMTP" process-buffer host port))
 345           (and (null process) (throw 'done nil))
 346
 347           ;; set the send-filter
 348           (set-process-filter process 'smtpmail-process-filter)
 349
 350           (save-excursion
 351             (set-buffer process-buffer)
 352             (make-local-variable 'smtpmail-read-point)
 353             (setq smtpmail-read-point (point-min))
 354
 355
 356             (if (or (null (car (setq greeting (smtpmail-read-response process))))
 357                     (not (integerp (car greeting)))
 358                     (>= (car greeting) 400))
 359                 (throw 'done nil)
 360               )
 361
 362             ;; EHLO
 363             (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
 364
 365             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 366                     (not (integerp (car response-code)))
 367                     (>= (car response-code) 400))
 368                 (progn
 369                   ;; HELO
 370                   (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn)))
 371
 372                   (if (or (null (car (setq response-code (smtpmail-read-response process))))
 373                           (not (integerp (car response-code)))
 374                           (>= (car response-code) 400))
 375                       (throw 'done nil)))
 376               (let ((extension-lines (cdr (cdr response-code))))
 377                 (while extension-lines
 378                   (let ((name (intern (downcase (substring (car extension-lines) 4)))))
 379                     (and name
 380                          (cond ((memq name '(verb xvrb 8bitmime onex xone
 381                                                   expn size dsn etrn
 382                                                   help xusr))
 383                                 (setq supported-extensions
 384                                       (cons name supported-extensions)))
 385                                (t (message "unknown extension %s"
 386                                            name)))))
 387                   (setq extension-lines (cdr extension-lines)))))
 388
 389             (if (or (member 'onex supported-extensions)
 390                     (member 'xone supported-extensions))
 391                 (progn
 392                   (smtpmail-send-command process (format "ONEX"))
 393                   (if (or (null (car (setq response-code (smtpmail-read-response process))))
 394                           (not (integerp (car response-code)))
 395                           (>= (car response-code) 400))
 396                       (throw 'done nil))))
 397
 398             (if (and smtpmail-debug-info
 399                      (or (member 'verb supported-extensions)
 400                          (member 'xvrb supported-extensions)))
 401                 (progn
 402                   (smtpmail-send-command process (format "VERB"))
 403                   (if (or (null (car (setq response-code (smtpmail-read-response process))))
 404                           (not (integerp (car response-code)))
 405                           (>= (car response-code) 400))
 406                       (throw 'done nil))))
 407
 408             (if (member 'xusr supported-extensions)
 409                 (progn
 410                   (smtpmail-send-command process (format "XUSR"))
 411                   (if (or (null (car (setq response-code (smtpmail-read-response process))))
 412                           (not (integerp (car response-code)))
 413                           (>= (car response-code) 400))
 414                       (throw 'done nil))))
 415
 416             ;; MAIL FROM: <sender>
 417             (let ((size-part
 418                    (if (member 'size supported-extensions)
 419                        (format " SIZE=%d"
 420                                (save-excursion
 421                                  (set-buffer smtpmail-text-buffer)
 422                                  ;; size estimate:
 423                                  (+ (- (point-max) (point-min))
 424                                     ;; Add one byte for each change-of-line
 425                                     ;; because or CR-LF representation:
 426                                     (count-lines (point-min) (point-max))
 427                                     ;; For some reason, an empty line is
 428                                     ;; added to the message.  Maybe this
 429                                     ;; is a bug, but it can't hurt to add
 430                                     ;; those two bytes anyway:
 431                                     2)))
 432                      ""))
 433                   (body-part
 434                    (if (member '8bitmime supported-extensions)
 435                        ;; FIXME:
 436                        ;; Code should be added here that transforms
 437                        ;; the contents of the message buffer into
 438                        ;; something the receiving SMTP can handle.
 439                        ;; For a receiver that supports 8BITMIME, this
 440                        ;; may mean converting BINARY to BASE64, or
 441                        ;; adding Content-Transfer-Encoding and the
 442                        ;; other MIME headers.  The code should also
 443                        ;; return an indication of what encoding the
 444                        ;; message buffer is now, i.e. ASCII or
 445                        ;; 8BITMIME.
 446                        (if nil
 447                            " BODY=8BITMIME"
 448                          "")
 449                      "")))
 450 ;             (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
 451               (smtpmail-send-command process (format "MAIL FROM: <%s>%s%s"
 452                                                      user-mail-address
 453                                                      size-part
 454                                                      body-part))
 455
 456               (if (or (null (car (setq response-code (smtpmail-read-response process))))
 457                       (not (integerp (car response-code)))
 458                       (>= (car response-code) 400))
 459                   (throw 'done nil)
 460                 ))
 461
 462             ;; RCPT TO: <recipient>
 463             (let ((n 0))
 464               (while (not (null (nth n recipient)))
 465                 (smtpmail-send-command process (format "RCPT TO: <%s>" (nth n recipient)))
 466                 (setq n (1+ n))
 467
 468                 (setq response-code (smtpmail-read-response process))
 469                 (if (or (null (car response-code))
 470                         (not (integerp (car response-code)))
 471                         (>= (car response-code) 400))
 472                     (throw 'done nil)
 473                   )
 474                 ))
 475
 476             ;; DATA
 477             (smtpmail-send-command process "DATA")
 478
 479             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 480                     (not (integerp (car response-code)))
 481                     (>= (car response-code) 400))
 482                 (throw 'done nil)
 483               )
 484
 485             ;; Mail contents
 486             (smtpmail-send-data process smtpmail-text-buffer)
 487
 488             ;;DATA end "."
 489             (smtpmail-send-command process ".")
 490
 491             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 492                     (not (integerp (car response-code)))
 493                     (>= (car response-code) 400))
 494                 (throw 'done nil)
 495               )
 496
 497             ;;QUIT
 498 ;           (smtpmail-send-command process "QUIT")
 499 ;           (and (null (car (smtpmail-read-response process)))
 500 ;                (throw 'done nil))
 501             t ))
 502       (if process
 503           (save-excursion
 504             (set-buffer (process-buffer process))
 505             (smtpmail-send-command process "QUIT")
 506             (smtpmail-read-response process)
 507
 508 ;           (if (or (null (car (setq response-code (smtpmail-read-response process))))
 509 ;                   (not (integerp (car response-code)))
 510 ;                   (>= (car response-code) 400))
 511 ;               (throw 'done nil)
 512 ;             )
 513             (delete-process process))))))
 514
 515
 516 (defun smtpmail-process-filter (process output)
 517   (save-excursion
 518     (set-buffer (process-buffer process))
 519     (goto-char (point-max))
 520     (insert output)))
 521
 522 (defun smtpmail-read-response (process)
 523   (let ((case-fold-search nil)
 524         (response-strings nil)
 525         (response-continue t)
 526         (return-value '(nil ()))
 527         match-end)
 528
 529     (while response-continue
 530       (goto-char smtpmail-read-point)
 531       (while (not (search-forward "\r\n" nil t))
 532         (accept-process-output process)
 533         (goto-char smtpmail-read-point))
 534
 535       (setq match-end (point))
 536       (setq response-strings
 537             (cons (buffer-substring smtpmail-read-point (- match-end 2))
 538                   response-strings))
 539
 540       (goto-char smtpmail-read-point)
 541       (if (looking-at "[0-9]+ ")
 542           (let ((begin (match-beginning 0))
 543                 (end (match-end 0)))
 544             (if smtpmail-debug-info
 545                 (message "%s" (car response-strings)))
 546
 547             (setq smtpmail-read-point match-end)
 548
 549             ;; ignore lines that start with "0"
 550             (if (looking-at "0[0-9]+ ")
 551                 nil
 552               (setq response-continue nil)
 553               (setq return-value
 554                     (cons (string-to-int
 555                            (buffer-substring begin end))
 556                           (nreverse response-strings)))))
 557
 558         (if (looking-at "[0-9]+-")
 559             (progn (if smtpmail-debug-info
 560                      (message "%s" (car response-strings)))
 561                    (setq smtpmail-read-point match-end)
 562                    (setq response-continue t))
 563           (progn
 564             (setq smtpmail-read-point match-end)
 565             (setq response-continue nil)
 566             (setq return-value
 567                   (cons nil (nreverse response-strings)))
 568             )
 569           )))
 570     (setq smtpmail-read-point match-end)
 571     return-value))
 572
 573
 574 (defun smtpmail-send-command (process command)
 575   (goto-char (point-max))
 576   (if (= (aref command 0) ?P)
 577       (insert "PASS <omitted>\r\n")
 578     (insert command "\r\n"))
 579   (setq smtpmail-read-point (point))
 580   (process-send-string process command)
 581   (process-send-string process "\r\n"))
 582
 583 (defun smtpmail-send-data-1 (process data)
 584   (goto-char (point-max))
 585
 586   (if smtpmail-debug-info
 587       (insert data "\r\n"))
 588
 589   (setq smtpmail-read-point (point))
 590   ;; Escape "." at start of a line
 591   (if (eq (string-to-char data) ?.)
 592       (process-send-string process "."))
 593   (process-send-string process data)
 594   (process-send-string process "\r\n")
 595   )
 596
 597 (defun smtpmail-send-data (process buffer)
 598   (let
 599       ((data-continue t)
 600        (sending-data nil)
 601        this-line
 602        this-line-end)
 603
 604     (save-excursion
 605       (set-buffer buffer)
 606       (goto-char (point-min)))
 607
 608     (while data-continue
 609       (save-excursion
 610         (set-buffer buffer)
 611         (beginning-of-line)
 612         (setq this-line (point))
 613         (end-of-line)
 614         (setq this-line-end (point))
 615         (setq sending-data nil)
 616         (setq sending-data (buffer-substring this-line this-line-end))
 617         (if (/= (forward-line 1) 0)
 618             (setq data-continue nil)))
 619
 620       (smtpmail-send-data-1 process sending-data)
 621       )
 622     )
 623   )
 624
 625
 626 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
 627   "Get address list suitable for smtp RCPT TO: <address>."
 628   (require 'mail-utils)  ;; pick up mail-strip-quoted-names
 629   (let
 630       ((case-fold-search t)
 631        (simple-address-list "")
 632        this-line
 633        this-line-end
 634        addr-regexp)
 635
 636     (unwind-protect
 637         (save-excursion
 638           ;;
 639           (set-buffer smtpmail-address-buffer) (erase-buffer)
 640           (insert-buffer-substring smtpmail-text-buffer header-start header-end)
 641           (goto-char (point-min))
 642           ;; RESENT-* fields should stop processing of regular fields.
 643           (save-excursion
 644             (if (re-search-forward "^RESENT-TO:" header-end t)
 645                 (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 646               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 647
 648           (while (re-search-forward addr-regexp header-end t)
 649             (replace-match "")
 650             (setq this-line (match-beginning 0))
 651             (forward-line 1)
 652             ;; get any continuation lines
 653             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 654               (forward-line 1))
 655             (setq this-line-end (point-marker))
 656             (setq simple-address-list
 657                   (concat simple-address-list " "
 658                           (mail-strip-quoted-names (buffer-substring this-line this-line-end))))
 659             )
 660           (erase-buffer)
 661           (insert-string " ")
 662           (insert-string simple-address-list)
 663           (insert-string "\n")
 664           (subst-char-in-region (point-min) (point-max) 10 ?  t);; newline --> blank
 665           (subst-char-in-region (point-min) (point-max) ?, ?  t);; comma   --> blank
 666           (subst-char-in-region (point-min) (point-max)  9 ?  t);; tab     --> blank
 667
 668           (goto-char (point-min))
 669           ;; tidyness in case hook is not robust when it looks at this
 670           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 671
 672           (goto-char (point-min))
 673           (let (recipient-address-list)
 674             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 675               (backward-char 1)
 676               (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
 677                                                  recipient-address-list))
 678               )
 679             (setq smtpmail-recipient-address-list recipient-address-list))
 680
 681           )
 682       )
 683     )
 684   )
 685
 686
 687 (defun smtpmail-do-bcc (header-end)
 688   "Delete BCC: and their continuation lines from the header area.
 689 There may be multiple BCC: lines, and each may have arbitrarily
 690 many continuation lines."
 691   (let ((case-fold-search t))
 692         (save-excursion (goto-char (point-min))
 693           ;; iterate over all BCC: lines
 694           (while (re-search-forward "^BCC:" header-end t)
 695                 (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
 696                 ;; get rid of any continuation lines
 697                 (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
 698                   (replace-match ""))
 699                 )
 700           ) ;; save-excursion
 701         ) ;; let
 702   )
 703
 704
 705
 706 (provide 'smtpmail)
 707
 708 ;;; smtpmail.el ends here