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