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.  In addition, you will have to modify the value for
 175 `smtp-end-of-line' to \"\\n\" if you use \"telnet\" instead of \"nc\".")
 176
 177 (defvar smtp-read-point nil)
 178
 179 (defvar smtp-connection-alist nil)
 180
 181 (defvar smtp-submit-package-function #'smtp-submit-package)
 182
 183 (defvar smtp-end-of-line "\r\n"
 184   "*String to use as end-of-line marker when talking to a SMTP server.
 185 This is \"\\r\\n\" by default, but it may have to be \"\\n\" when using a non
 186 native connection function.  See also `smtp-open-connection-function'.")
 187
 188 ;;; @ SMTP package
 189 ;;; A package contains a mail message, an envelope sender address,
 190 ;;; and one or more envelope recipient addresses.  In ESMTP model
 191 ;;; the current sending package should be guaranteed to be accessible
 192 ;;; anywhere from the hook methods (or SMTP commands).
 193
 194 (eval-and-compile
 195   (luna-define-class smtp-package ()
 196                      (sender
 197                       recipients
 198                       buffer))
 199
 200   (luna-define-internal-accessors 'smtp-package))
 201
 202 (defun smtp-make-package (sender recipients buffer)
 203   "Create a new package structure.
 204 A package is a unit of SMTP message
 205 SENDER specifies the package sender, a string.
 206 RECIPIENTS is a list of recipients.
 207 BUFFER may be a buffer or a buffer name which contains mail message."
 208   (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer))
 209
 210 (defun smtp-package-buffer-internal-size (package)
 211   "Return the size of PACKAGE, an integer."
 212   (save-excursion
 213     (set-buffer (smtp-package-buffer-internal package))
 214     (let ((size
 215            (+ (buffer-size)
 216               ;; Add one byte for each change-of-line
 217               ;; because or CR-LF representation:
 218               (count-lines (point-min) (point-max))
 219               ;; For some reason, an empty line is
 220               ;; added to the message.  Maybe this
 221               ;; is a bug, but it can't hurt to add
 222               ;; those two bytes anyway:
 223               2)))
 224       (goto-char (point-min))
 225       (while (re-search-forward "^\\." nil t)
 226         (setq size (1+ size)))
 227       size)))
 228
 229 ;;; @ SMTP connection
 230 ;;; We should consider the function `open-network-stream' is a emulation
 231 ;;; for another network stream.  They are likely to be implemented with an
 232 ;;; external program and the function `process-contact' returns the
 233 ;;; process id instead of `(HOST SERVICE)' pair.
 234
 235 (eval-and-compile
 236   (luna-define-class smtp-connection ()
 237                      (process
 238                       server
 239                       service
 240                       extensions
 241                       encoder
 242                       decoder))
 243
 244   (luna-define-internal-accessors 'smtp-connection))
 245
 246 (defun smtp-make-connection (process server service)
 247   "Create a new connection structure.
 248 PROCESS is an internal subprocess-object.  SERVER is name of the host
 249 to connect to.  SERVICE is name of the service desired."
 250   (luna-make-entity 'smtp-connection :process process :server server :service service))
 251
 252 (luna-define-generic smtp-connection-opened (connection)
 253   "Say whether the CONNECTION to server has been opened.")
 254
 255 (luna-define-generic smtp-close-connection (connection)
 256   "Close the CONNECTION to server.")
 257
 258 (luna-define-method smtp-connection-opened ((connection smtp-connection))
 259   (let ((process (smtp-connection-process-internal connection)))
 260     (if (memq (process-status process) '(open run))
 261         t)))
 262
 263 (luna-define-method smtp-close-connection ((connection smtp-connection))
 264   (let ((process (smtp-connection-process-internal connection)))
 265     (delete-process process)))
 266
 267 (defun smtp-make-fqdn ()
 268   "Return user's fully qualified domain name."
 269   (if smtp-fqdn
 270       smtp-fqdn
 271     (let ((system-name (system-name)))
 272       (cond
 273        (smtp-local-domain
 274         (concat system-name "." smtp-local-domain))
 275        ((string-match "[^.]\\.[^.]" system-name)
 276         system-name)
 277        (t
 278         (error "Cannot generate valid FQDN"))))))
 279
 280 (defun smtp-find-connection (buffer)
 281   "Find the connection delivering to BUFFER."
 282   (let ((entry (assq buffer smtp-connection-alist))
 283         connection)
 284     (when entry
 285       (setq connection (nth 1 entry))
 286       (if (smtp-connection-opened connection)
 287           connection
 288         (setq smtp-connection-alist
 289               (delq entry smtp-connection-alist))
 290         nil))))
 291
 292 (eval-and-compile
 293   (autoload 'starttls-open-stream "starttls")
 294   (autoload 'starttls-negotiate "starttls"))
 295
 296 (defun smtp-open-connection (buffer server service)
 297   "Open a SMTP connection for a service to a host.
 298 Return a newly allocated connection-object.
 299 BUFFER is the buffer to associate with the connection.  SERVER is name
 300 of the host to connect to.  SERVICE is name of the service desired."
 301   (let ((process
 302          (binary-funcall smtp-open-connection-function
 303                          "SMTP" buffer server service))
 304         connection)
 305     (when process
 306       (setq connection (smtp-make-connection process server service))
 307       (set-process-filter process 'smtp-process-filter)
 308       (setq smtp-connection-alist
 309             (cons (list buffer connection)
 310                   smtp-connection-alist))
 311       connection)))
 312
 313 (eval-and-compile
 314   (autoload 'dig-invoke "dig")
 315   (autoload 'dig-extract-rr "dig"))
 316
 317 (defun smtp-find-mx (domain &optional doerror)
 318   (let (server)
 319     ;; dig.el resolves only primally MX.
 320     (cond ((setq server (smtp-dig domain "MX"))
 321            (progn (string-match " \\([^ ]*\\)$" server)
 322                   (match-string 1 server)))
 323           ((smtp-dig domain "A")
 324             domain)
 325           (t
 326            (if doerror
 327                 (error (format "SMTP cannot resolve %s" domain)))))))
 328
 329 (defun smtp-dig (domain type)
 330   (let (dig-buf)
 331     (set-buffer
 332      (setq dig-buf (dig-invoke domain type)))
 333     (prog1
 334         (dig-extract-rr domain type)
 335       (kill-buffer dig-buf))))
 336
 337 (defun smtp-find-server (recipients)
 338   (save-excursion
 339     (let ((rec
 340            (mapcar (lambda (recipient)
 341                      (let (server)
 342                        (if (and (string-match "@\\([^\t\n ]*\\)" recipient)
 343                                 (setq server
 344                                       (smtp-find-mx
 345                                        (match-string 1 recipient))))
 346                            (cons server (list recipient))
 347                          (error (format "cannot find server for %s." recipient)))))
 348                    recipients))
 349           ret rets rlist)
 350       (while (setq rets (pop rec))
 351         (if (setq ret (assoc (car rets) rec))
 352             (setcdr ret
 353                     (append (cdr ret) (cdr rets)))
 354           (setq rlist
 355                 (append rlist (list rets)))))
 356       rlist)))
 357
 358 ;;;###autoload
 359 (defun smtp-via-smtp (sender recipients buffer)
 360   "Like `smtp-send-buffer', but sucks in any errors."
 361   (condition-case nil
 362       (progn
 363         (smtp-send-buffer sender recipients buffer)
 364         t)
 365     (smtp-error)))
 366
 367 (make-obsolete 'smtp-via-smtp "It's old API.")
 368
 369 ;;;###autoload
 370 (defun smtp-send-buffer (sender recipients buffer)
 371   "Send a message.
 372 SENDER is an envelope sender address.
 373 RECIPIENTS is a list of envelope recipient addresses.
 374 BUFFER may be a buffer or a buffer name which contains mail message."
 375   (if smtp-send-by-myself
 376       (smtp-send-buffer-by-myself sender recipients buffer)
 377     (let* ((server
 378             (if (functionp smtp-server)
 379                 (funcall smtp-server sender recipients)
 380               (or smtp-server
 381                   (error "`smtp-server' not defined"))))
 382            (package
 383             (smtp-make-package sender recipients buffer))
 384            (starttls-program smtp-starttls-program)
 385            (starttls-extra-args smtp-starttls-extra-args)
 386            (smtp-open-connection-function
 387             (if smtp-use-starttls
 388                 #'starttls-open-stream
 389               smtp-open-connection-function)))
 390       (save-excursion
 391         (set-buffer
 392          (get-buffer-create
 393           (format "*trace of SMTP session to %s*" server)))
 394         (erase-buffer)
 395         (buffer-disable-undo)
 396         (unless (smtp-find-connection (current-buffer))
 397           (smtp-open-connection (current-buffer) server smtp-service))
 398         (make-local-variable 'smtp-read-point)
 399         (setq smtp-read-point (point-min))
 400         (funcall smtp-submit-package-function package)))))
 401
 402 (defun smtp-submit-package (package)
 403   (unwind-protect
 404       (progn
 405         (smtp-primitive-greeting package)
 406         (condition-case nil
 407             (smtp-primitive-ehlo package)
 408           (smtp-response-error
 409            (smtp-primitive-helo package)))
 410         (if smtp-use-starttls
 411             (if (assq 'starttls
 412                       (smtp-connection-extensions-internal
 413                        (smtp-find-connection (current-buffer))))
 414                 (progn
 415                   (smtp-primitive-starttls package)
 416                   (smtp-primitive-ehlo package))
 417               (unless smtp-use-starttls-ignore-error
 418                 (error "STARTTLS is not supported on this server"))))
 419         (if smtp-use-sasl
 420             (smtp-primitive-auth package))
 421         (smtp-primitive-mailfrom package)
 422         (smtp-primitive-rcptto package)
 423         (smtp-primitive-data package))
 424     (let ((connection (smtp-find-connection (current-buffer))))
 425       (when (smtp-connection-opened connection)
 426         (smtp-primitive-quit package)
 427         (smtp-close-connection connection)))))
 428
 429 (defun smtp-send-buffer-by-myself (sender recipients buffer)
 430   "Send a message by myself.
 431 SENDER is an envelope sender address.
 432 RECIPIENTS is a list of envelope recipient addresses.
 433 BUFFER may be a buffer or a buffer name which contains mail message."
 434   (let ((servers
 435          (smtp-find-server recipients))
 436         (smtp-open-connection-function
 437          (if smtp-use-starttls
 438              #'starttls-open-stream
 439            smtp-open-connection-function))
 440         server package)
 441       (while (car servers)
 442         (setq server (caar servers))
 443         (setq recipients (cdar servers))
 444         (if (not (and server recipients))
 445             ;; MAILER-DAEMON is required. :)
 446             (error (format "Cannot send <%s>"
 447                            (mapconcat 'concat recipients ">,<"))))
 448         (setq package
 449               (smtp-make-package sender recipients buffer))
 450         (save-excursion
 451           (set-buffer
 452            (get-buffer-create
 453             (format "*trace of SMTP session to %s*" server)))
 454           (erase-buffer)
 455           (buffer-disable-undo)
 456           (unless (smtp-find-connection (current-buffer))
 457             (smtp-open-connection (current-buffer) server smtp-service))
 458           (make-local-variable 'smtp-read-point)
 459           (setq smtp-read-point (point-min))
 460           (let ((smtp-use-sasl nil)
 461                 (smtp-use-starttls-ignore-error t))
 462             (funcall smtp-submit-package-function package)))
 463         (setq servers (cdr servers)))))
 464
 465 ;;; @ hook methods for `smtp-submit-package'
 466 ;;;
 467
 468 (defun smtp-primitive-greeting (package)
 469   (let* ((connection
 470           (smtp-find-connection (current-buffer)))
 471          (response
 472           (smtp-read-response connection)))
 473     (if (/= (car response) 220)
 474         (smtp-response-error response))))
 475
 476 (defun smtp-primitive-ehlo (package)
 477   (let* ((connection
 478           (smtp-find-connection (current-buffer)))
 479          response)
 480     (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
 481     (setq response (smtp-read-response connection))
 482     (if (/= (car response) 250)
 483         (smtp-response-error response))
 484     (smtp-connection-set-extensions-internal
 485      connection (mapcar
 486                  (lambda (extension)
 487                    (let ((extensions
 488                           (split-string extension)))
 489                      (setcar extensions
 490                              (car (read-from-string
 491                                    (downcase (car extensions)))))
 492                      extensions))
 493                  (cdr response)))))
 494
 495 (defun smtp-primitive-helo (package)
 496   (let* ((connection
 497           (smtp-find-connection (current-buffer)))
 498          response)
 499     (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
 500     (setq response (smtp-read-response connection))
 501     (if (/= (car response) 250)
 502         (smtp-response-error response))))
 503
 504 (defun smtp-primitive-auth (package)
 505   (let* ((connection
 506           (smtp-find-connection (current-buffer)))
 507          (mechanisms
 508           (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
 509          (sasl-mechanisms
 510           (or smtp-sasl-mechanisms sasl-mechanisms))
 511          (mechanism
 512           (sasl-find-mechanism mechanisms))
 513          client
 514          name
 515          step
 516          response)
 517     (unless mechanism
 518       (error "No authentication mechanism available"))
 519     (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
 520                                    (smtp-connection-server-internal connection)))
 521     (if smtp-sasl-properties
 522         (sasl-client-set-properties client smtp-sasl-properties))
 523     (setq name (sasl-mechanism-name mechanism)
 524           ;; Retrieve the initial response
 525           step (sasl-next-step client nil))
 526     (smtp-send-command
 527      connection
 528      (if (sasl-step-data step)
 529          (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
 530        (format "AUTH %s" name)))
 531     (catch 'done
 532       (while t
 533         (setq response (smtp-read-response connection))
 534         (when (= (car response) 235)
 535           ;; The authentication process is finished.
 536           (setq step (sasl-next-step client step))
 537           (if (null step)
 538               (throw 'done nil))
 539           (smtp-response-error response)) ;Bogus server?
 540         (if (/= (car response) 334)
 541             (smtp-response-error response))
 542         (sasl-step-set-data step (base64-decode-string (nth 1 response)))
 543         (setq step (sasl-next-step client step))
 544         (smtp-send-command
 545          connection
 546          (if (sasl-step-data step)
 547              (base64-encode-string (sasl-step-data step) t)
 548            ""))))
 549 ;;;    (smtp-connection-set-encoder-internal
 550 ;;;     connection (sasl-client-encoder client))
 551 ;;;    (smtp-connection-set-decoder-internal
 552 ;;;     connection (sasl-client-decoder client))
 553     ))
 554
 555 (defun smtp-primitive-starttls (package)
 556   (let* ((connection
 557           (smtp-find-connection (current-buffer)))
 558          response)
 559     ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 560     (smtp-send-command connection "STARTTLS")
 561     (setq response (smtp-read-response connection))
 562     (if (/= (car response) 220)
 563         (smtp-response-error response))
 564     (starttls-negotiate (smtp-connection-process-internal connection))))
 565
 566 (defun smtp-primitive-mailfrom (package)
 567   (let* ((connection
 568           (smtp-find-connection (current-buffer)))
 569          (extensions
 570           (smtp-connection-extensions-internal
 571            connection))
 572          (sender
 573           (smtp-package-sender-internal package))
 574          extension
 575          response)
 576     ;; SIZE --- Message Size Declaration (RFC1870)
 577     (if (and smtp-use-size
 578              (assq 'size extensions))
 579         (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
 580     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 581     (if (and smtp-use-8bitmime
 582              (assq '8bitmime extensions))
 583         (setq extension (concat extension " BODY=8BITMIME")))
 584     (smtp-send-command
 585      connection
 586      (if extension
 587          (format "MAIL FROM:<%s> %s" sender extension)
 588        (format "MAIL FROM:<%s>" sender)))
 589     (setq response (smtp-read-response connection))
 590     (if (/= (car response) 250)
 591         (smtp-response-error response))))
 592
 593 (defun smtp-primitive-rcptto (package)
 594   (let* ((connection
 595           (smtp-find-connection (current-buffer)))
 596          (recipients
 597           (smtp-package-recipients-internal package))
 598          response)
 599     (while recipients
 600       (smtp-send-command
 601        connection (format "RCPT TO:<%s>" (pop recipients)))
 602       (setq response (smtp-read-response connection))
 603       (unless (memq (car response) '(250 251))
 604         (smtp-response-error response)))))
 605
 606 (defun smtp-primitive-data (package)
 607   (let* ((connection
 608           (smtp-find-connection (current-buffer)))
 609          response def prev)
 610     (smtp-send-command connection "DATA")
 611     (setq response (smtp-read-response connection))
 612     (if (/= (car response) 354)
 613         (smtp-response-error response))
 614     (save-excursion
 615       (set-buffer (smtp-package-buffer-internal package))
 616       (setq def (smtp-parse-progress-message-format))
 617       (goto-char (point-min))
 618       (while (not (eobp))
 619         (smtp-send-data
 620          connection (buffer-substring (point) (progn (end-of-line)(point))))
 621         (beginning-of-line 2)
 622         (setq prev (smtp-show-progress-message def prev))))
 623     (smtp-send-command connection ".")
 624     (setq response (smtp-read-response connection))
 625     (if (/= (car response) 250)
 626         (smtp-response-error response))))
 627
 628 (defun smtp-primitive-quit (package)
 629   (let* ((connection
 630           (smtp-find-connection (current-buffer)))
 631          response)
 632     (smtp-send-command connection "QUIT")
 633     (setq response (smtp-read-response connection))
 634     (if (/= (car response) 221)
 635         (smtp-response-error response))))
 636
 637 ;;; @ low level process manipulating function
 638 ;;;
 639 (defun smtp-process-filter (process output)
 640   (save-excursion
 641     (set-buffer (process-buffer process))
 642     (goto-char (point-max))
 643     (insert output)))
 644
 645 (put 'smtp-error 'error-message "SMTP error")
 646 (put 'smtp-error 'error-conditions '(smtp-error error))
 647
 648 (put 'smtp-response-error 'error-message "SMTP response error")
 649 (put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
 650
 651 (defun smtp-response-error (response)
 652   (signal 'smtp-response-error response))
 653
 654 (defun smtp-read-response (connection)
 655   (let ((decoder
 656          (smtp-connection-decoder-internal connection))
 657         (response-continue t)
 658         response)
 659     (while response-continue
 660       (goto-char smtp-read-point)
 661       (while (not (re-search-forward "\r?\n" nil t))
 662         (unless (smtp-connection-opened connection)
 663           (signal 'smtp-error "Connection closed"))
 664         (accept-process-output (smtp-connection-process-internal connection))
 665         (goto-char smtp-read-point))
 666       (let ((bol smtp-read-point)
 667             (eol (match-beginning 0))
 668             (reply-code nil))
 669         (when decoder
 670           (let ((string (buffer-substring bol eol)))
 671             (delete-region bol (point))
 672             (insert (funcall decoder string))
 673             (setq eol (point))
 674             (insert smtp-end-of-line)))
 675         (setq smtp-read-point (point))
 676         (goto-char bol)
 677         (if (not (looking-at "[1-5][0-9][0-9]\\([ -]\\)"))
 678             (when smtp-debug
 679               (message "Invalid response: %s" (buffer-substring bol eol)))
 680           (when (string= (match-string 1) " ")
 681             (setq reply-code (read (point-marker))))
 682           (setq response
 683                 (nconc response
 684                        (list (buffer-substring (match-end 0) eol))))
 685           (when reply-code
 686             (setq response (cons reply-code response)
 687                   response-continue nil)))))
 688     response))
 689
 690 (defun smtp-send-command (connection command)
 691   (save-excursion
 692     (let ((process
 693            (smtp-connection-process-internal connection))
 694           (encoder
 695            (smtp-connection-encoder-internal connection)))
 696       (set-buffer (process-buffer process))
 697       (goto-char (point-max))
 698       (setq command (concat command smtp-end-of-line))
 699       (insert command)
 700       (setq smtp-read-point (point))
 701       (if encoder
 702           (setq command (funcall encoder command)))
 703       (process-send-string process command))))
 704
 705 (defun smtp-send-data (connection data)
 706   (let ((process
 707          (smtp-connection-process-internal connection))
 708         (encoder
 709          (smtp-connection-encoder-internal connection)))
 710     ;; Escape "." at start of a line.
 711     (if (eq (string-to-char data) ?.)
 712         (setq data (concat "." data smtp-end-of-line))
 713       (setq data (concat data smtp-end-of-line)))
 714     (if encoder
 715         (setq data (funcall encoder data)))
 716     (process-send-string process data)))
 717
 718 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 719   "Get address list suitable for smtp RCPT TO:<address>."
 720   (let ((simple-address-list "")
 721         this-line
 722         this-line-end
 723         addr-regexp
 724         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 725     (unwind-protect
 726         (save-excursion
 727           ;;
 728           (set-buffer smtp-address-buffer)
 729           (setq case-fold-search t)
 730           (erase-buffer)
 731           (insert (save-excursion
 732                     (set-buffer smtp-text-buffer)
 733                     (buffer-substring-no-properties header-start header-end)))
 734           (goto-char (point-min))
 735           ;; RESENT-* fields should stop processing of regular fields.
 736           (save-excursion
 737             (if (re-search-forward "^RESENT-TO:" header-end t)
 738                 (setq addr-regexp
 739                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 740               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 741
 742           (while (re-search-forward addr-regexp header-end t)
 743             (replace-match "")
 744             (setq this-line (match-beginning 0))
 745             (forward-line 1)
 746             ;; get any continuation lines.
 747             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 748               (forward-line 1))
 749             (setq this-line-end (point-marker))
 750             (setq simple-address-list
 751                   (concat simple-address-list " "
 752                           (mail-strip-quoted-names
 753                            (buffer-substring this-line this-line-end)))))
 754           (erase-buffer)
 755           (insert " " simple-address-list "\n")
 756           ;; newline --> blank
 757           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 758           ;; comma   --> blank
 759           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 760           ;; tab     --> blank
 761           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 762
 763           (goto-char (point-min))
 764           ;; tidyness in case hook is not robust when it looks at this
 765           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 766
 767           (goto-char (point-min))
 768           (let (recipient-address-list)
 769             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 770               (backward-char 1)
 771               (setq recipient-address-list
 772                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 773                           recipient-address-list)))
 774             recipient-address-list))
 775       (kill-buffer smtp-address-buffer))))
 776
 777 ;;; @ functions used to show progress message
 778 ;;;
 779 (defun smtp-parse-progress-message-format ()
 780   "Parse the `smtp-progress-message-format' variable.
 781 Return nil, or a cons of an ordinary format string and a type including
 782 nil, the symbols `b', `k' and `l'."
 783   (when smtp-progress-message-format
 784     (let ((format smtp-progress-message-format)
 785           (index 0)
 786           type)
 787       (while (string-match "%\\([bkl]\\)\\|%\\([^%bkl]\\|\\'\\)" format index)
 788         (if (and (not type)
 789                  (match-beginning 1))
 790             (setq index (match-end 0)
 791                   type (intern (match-string 1 format))
 792                   format (replace-match
 793                           (cond ((eq type 'b)
 794                                  (concat "%d/"
 795                                          (number-to-string (buffer-size))))
 796                                 ((eq type 'k)
 797                                  (if (>= (buffer-size) 512)
 798                                      (concat "%dk/"
 799                                              (number-to-string
 800                                               (/ (+ (buffer-size) 512) 1024))
 801                                              "k")
 802                                    (setq type 'b)
 803                                    (concat "%d/"
 804                                            (number-to-string (buffer-size)))))
 805                                 (t
 806                                  (concat "%d/"
 807                                          (number-to-string
 808                                           (count-lines (point-min)
 809                                                        (point-max))))))
 810                           nil nil format))
 811           (setq index (1+ (match-end 0))
 812                 format (replace-match "%\\&" nil nil format))))
 813       (cons format type))))
 814
 815 (defun smtp-show-progress-message (def prev)
 816   "Show progress message while sending mails.
 817 DEF is a cons cell which is pre-computed by the
 818 `smtp-parse-progress-message-format' function or nil.
 819 PREV is a number shown last time or nil.
 820 Return a number computed this time."
 821   (when (car def)
 822     (let* ((fmt (car def))
 823            (type (cdr def))
 824            (value (cond ((eq type 'b)
 825                          (- (point) (point-min)))
 826                         ((eq type 'k)
 827                          (/ (- (point) (point-min) -512) 1024))
 828                         ((eq type 'l)
 829                          (count-lines (point-min) (point)))))
 830            message-log-max)
 831       (unless (and prev
 832                    value
 833                    (eq type 'k)
 834                    (<= value prev))
 835         (cond ((featurep 'xemacs)
 836                (display-message 'no-log (if value
 837                                             (format fmt value)
 838                                           fmt)))
 839               (value
 840                (message fmt value))
 841               (t
 842                (message "%s" fmt))))
 843       value)))
 844
 845 (provide 'smtp)
 846
 847 ;;; smtp.el ends here