smtp.el

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