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