smtp.el

   1 ;;; smtp.el --- basic functions to send mail with SMTP server
   2
   3 ;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
   6 ;;      Simon Leinen <simon@switch.ch> (ESMTP support)
   7 ;;      Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   8 ;;      Kenichi OKADA <okada@opaopa.org> (SASL support)
   9 ;;      Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
  10 ;; Maintainer: Kenichi OKADA <okada@opaopa.org>
  11 ;; Keywords: SMTP, mail, SASL
  12
  13 ;; This file is part of FLIM (Faithful Library about Internet Message).
  14
  15 ;; This program is free software; you can redistribute it and/or
  16 ;; modify it under the terms of the GNU General Public License as
  17 ;; published by the Free Software Foundation; either version 2, or (at
  18 ;; your option) any later version.
  19
  20 ;; This program is distributed in the hope that it will be useful, but
  21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  23 ;; General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with this program; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Code:
  31
  32 (require 'poe)
  33 (require 'poem)
  34 (require 'pcustom)
  35 (require 'mail-utils)                   ; mail-strip-quoted-names
  36
  37 (eval-when-compile (require 'sasl))
  38 (eval-and-compile
  39   (autoload 'starttls-open-stream "starttls")
  40   (autoload 'starttls-negotiate "starttls")
  41   (autoload 'sasl-cram-md5 "sasl")
  42   (autoload 'sasl-plain "sasl")
  43   (autoload 'sasl-scram-md5-client-msg-1 "sasl")
  44   (autoload 'sasl-scram-md5-client-msg-2 "sasl")
  45   (autoload 'sasl-scram-md5-authenticate-server "sasl")
  46   (autoload 'sasl-digest-md5-digest-response "sasl"))
  47
  48 (eval-when-compile (require 'cl))       ; push
  49
  50 (defgroup smtp nil
  51   "SMTP protocol for sending mail."
  52   :group 'mail)
  53
  54 (defcustom smtp-default-server nil
  55   "*Specify default SMTP server."
  56   :type '(choice (const nil) string)
  57   :group 'smtp)
  58
  59 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  60   "*The name of the host running SMTP server.  It can also be a function
  61 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  62   :type '(choice (string :tag "Name")
  63                  (function :tag "Function"))
  64   :group 'smtp)
  65
  66 (defcustom smtp-service "smtp"
  67   "*SMTP service port number. \"smtp\" or 25."
  68   :type '(choice (integer :tag "25" 25)
  69                  (string :tag "smtp" "smtp"))
  70   :group 'smtp)
  71
  72 (defcustom smtp-use-8bitmime t
  73   "*If non-nil, use ESMTP 8BITMIME if available."
  74   :type 'boolean
  75   :group 'smtp)
  76
  77 (defcustom smtp-local-domain nil
  78   "*Local domain name without a host name.
  79 If the function (system-name) returns the full internet address,
  80 don't define this value."
  81   :type '(choice (const nil) string)
  82   :group 'smtp)
  83
  84 (defcustom smtp-fqdn nil
  85   "*User's fully qualified domain name."
  86   :type '(choice (const nil) string)
  87   :group 'smtp)
  88
  89 (defcustom smtp-debug-info nil
  90   "*smtp debug info printout. messages and process buffer."
  91   :type 'boolean
  92   :group 'smtp)
  93
  94 (defcustom smtp-notify-success nil
  95   "*If non-nil, notification for successful mail delivery is returned
  96  to user (RFC1891)."
  97   :type 'boolean
  98   :group 'smtp)
  99
 100 (defcustom smtp-authenticate-type nil
 101   "*SMTP authentication mechanism (RFC2554)."
 102   :type 'symbol
 103   :group 'smtp)
 104
 105 (defvar smtp-authenticate-user nil)
 106 (defvar smtp-authenticate-passphrase nil)
 107
 108 (defvar smtp-authenticate-method-alist
 109   '((cram-md5 smtp-auth-cram-md5)
 110     (plain smtp-auth-plain)
 111     (login smtp-auth-login)
 112     (anonymous smtp-auth-anonymous)
 113     (scram-md5 smtp-auth-scram-md5)
 114     (digest-md5 smtp-auth-digest-md5)))
 115
 116 (defcustom smtp-connection-type nil
 117   "*SMTP connection type."
 118   :type '(choice (const nil) (const :tag "TLS" starttls))
 119   :group 'smtp)
 120
 121 (defvar smtp-read-point nil)
 122
 123 (defun smtp-make-fqdn ()
 124   "Return user's fully qualified domain name."
 125   (let ((system-name (system-name)))
 126     (cond
 127      (smtp-fqdn
 128       smtp-fqdn)
 129      (smtp-local-domain
 130       (concat system-name "." smtp-local-domain))
 131      ((string-match "[^.]\\.[^.]" system-name)
 132       system-name)
 133      (t
 134       (error "Cannot generate valid FQDN. Set `smtp-fqdn' or `smtp-local-domain' correctly.")))))
 135
 136 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
 137   (let ((server (if (functionp smtp-server)
 138                     (funcall smtp-server sender recipients)
 139                   smtp-server))
 140         process response extensions)
 141     (save-excursion
 142       (set-buffer
 143        (get-buffer-create
 144         (format "*trace of SMTP session to %s*" server)))
 145       (erase-buffer)
 146       (make-local-variable 'smtp-read-point)
 147       (setq smtp-read-point (point-min))
 148
 149       (unwind-protect
 150           (catch 'done
 151             (setq process
 152                   (if smtp-connection-type
 153                       (as-binary-process
 154                        (starttls-open-stream
 155                         "SMTP" (current-buffer) server smtp-service))
 156                     (open-network-stream-as-binary
 157                      "SMTP" (current-buffer) server smtp-service)))
 158
 159             (set-process-filter process 'smtp-process-filter)
 160
 161             (if (eq smtp-connection-type 'force)
 162                 (starttls-negotiate process))
 163
 164             ;; Greeting
 165             (setq response (smtp-read-response process))
 166             (if (or (null (car response))
 167                     (not (integerp (car response)))
 168                     (>= (car response) 400))
 169                 (throw 'done (car (cdr response))))
 170
 171             ;; EHLO
 172             (smtp-send-command process
 173                                (format "EHLO %s" (smtp-make-fqdn)))
 174             (setq response (smtp-read-response process))
 175             (if (or (null (car response))
 176                     (not (integerp (car response)))
 177                     (>= (car response) 400))
 178                 (progn
 179                   ;; HELO
 180                   (smtp-send-command process
 181                                      (format "HELO %s" (smtp-make-fqdn)))
 182                   (setq response (smtp-read-response process))
 183                   (if (or (null (car response))
 184                           (not (integerp (car response)))
 185                           (>= (car response) 400))
 186                       (throw 'done (car (cdr response)))))
 187               (let ((extension-lines (cdr (cdr response)))
 188                     extension)
 189                 (while extension-lines
 190                   (if (string-match
 191                        "^auth "
 192                        (setq extension
 193                              (downcase (substring (car extension-lines) 4))))
 194                       (while (string-match "\\([^ ]+\\)" extension (match-end 1))
 195                         (push (intern (match-string 1 extension)) extensions))
 196                     (push (intern extension) extensions))
 197                   (setq extension-lines (cdr extension-lines)))))
 198
 199             ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
 200             (when (and smtp-connection-type
 201                        (null (eq smtp-connection-type 'force))
 202                        (memq 'starttls extensions))
 203               (smtp-send-command process "STARTTLS")
 204               (setq response (smtp-read-response process))
 205               (if (or (null (car response))
 206                       (not (integerp (car response)))
 207                       (>= (car response) 400))
 208                   (throw 'done (car (cdr response))))
 209               (starttls-negotiate process)
 210               ;; for sendmail warning XXX
 211               (smtp-send-command process (format "HELO %s" (smtp-make-fqdn)))
 212               (setq response (smtp-read-response process)))
 213
 214             ;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
 215             (when smtp-authenticate-type
 216               (let ((auth smtp-authenticate-type) method)
 217                 (if (and
 218                      (memq auth extensions)
 219                      (setq method (nth 1 (assq auth smtp-authenticate-method-alist))))
 220                     (funcall method process)
 221                   (throw 'done
 222                          (format "AUTH mechanism %s not available" auth)))))
 223
 224             ;; ONEX --- One message transaction only (sendmail extension?)
 225 ;;;         (if (or (memq 'onex extensions)
 226 ;;;                 (memq 'xone extensions))
 227 ;;;             (progn
 228 ;;;               (smtp-send-command process "ONEX")
 229 ;;;               (setq response (smtp-read-response process))
 230 ;;;               (if (or (null (car response))
 231 ;;;                       (not (integerp (car response)))
 232 ;;;                       (>= (car response) 400))
 233 ;;;                   (throw 'done (car (cdr response))))))
 234
 235             ;; VERB --- Verbose (sendmail extension?)
 236 ;;;         (if (and smtp-debug-info
 237 ;;;                  (or (memq 'verb extensions)
 238 ;;;                      (memq 'xvrb extensions)))
 239 ;;;             (progn
 240 ;;;               (smtp-send-command process "VERB")
 241 ;;;               (setq response (smtp-read-response process))
 242 ;;;               (if (or (null (car response))
 243 ;;;                       (not (integerp (car response)))
 244 ;;;                       (>= (car response) 400))
 245 ;;;                   (throw 'done (car (cdr response))))))
 246
 247             ;; XUSR --- Initial (user) submission (sendmail extension?)
 248 ;;;         (if (memq 'xusr extensions)
 249 ;;;             (progn
 250 ;;;               (smtp-send-command process "XUSR")
 251 ;;;               (setq response (smtp-read-response process))
 252 ;;;               (if (or (null (car response))
 253 ;;;                       (not (integerp (car response)))
 254 ;;;                       (>= (car response) 400))
 255 ;;;                   (throw 'done (car (cdr response))))))
 256
 257             ;; MAIL FROM:<sender>
 258             (smtp-send-command
 259              process
 260              (format "MAIL FROM:<%s>%s%s"
 261                      sender
 262                      ;; SIZE --- Message Size Declaration (RFC1870)
 263                      (if (memq 'size extensions)
 264                          (format " SIZE=%d"
 265                                  (save-excursion
 266                                    (set-buffer smtp-text-buffer)
 267                                    (+ (- (point-max) (point-min))
 268                                       ;; Add one byte for each change-of-line
 269                                       ;; because or CR-LF representation:
 270                                       (count-lines (point-min) (point-max))
 271                                       ;; For some reason, an empty line is
 272                                       ;; added to the message.  Maybe this
 273                                       ;; is a bug, but it can't hurt to add
 274                                       ;; those two bytes anyway:
 275                                       2)))
 276                        "")
 277                      ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 278                      (if (and (memq '8bitmime extensions)
 279                               smtp-use-8bitmime)
 280                          " BODY=8BITMIME"
 281                        "")))
 282             (setq response (smtp-read-response process))
 283             (if (or (null (car response))
 284                     (not (integerp (car response)))
 285                     (>= (car response) 400))
 286                 (throw 'done (car (cdr response))))
 287
 288             ;; RCPT TO:<recipient>
 289             (while recipients
 290               (smtp-send-command process
 291                                  (format
 292                                   (if smtp-notify-success
 293                                       "RCPT TO:<%s> NOTIFY=SUCCESS"
 294                                     "RCPT TO:<%s>")
 295                                   (car recipients)))
 296               (setq recipients (cdr recipients))
 297               (setq response (smtp-read-response process))
 298               (if (or (null (car response))
 299                       (not (integerp (car response)))
 300                       (>= (car response) 400))
 301                   (throw 'done (car (cdr response)))))
 302
 303             ;; DATA
 304             (smtp-send-command process "DATA")
 305             (setq response (smtp-read-response process))
 306             (if (or (null (car response))
 307                     (not (integerp (car response)))
 308                     (>= (car response) 400))
 309                 (throw 'done (car (cdr response))))
 310
 311             ;; Mail contents
 312             (smtp-send-data process smtp-text-buffer)
 313
 314             ;; DATA end "."
 315             (smtp-send-command process ".")
 316             (setq response (smtp-read-response process))
 317             (if (or (null (car response))
 318                     (not (integerp (car response)))
 319                     (>= (car response) 400))
 320                 (throw 'done (car (cdr response))))
 321
 322             t)
 323
 324         (if (and process
 325                  (memq (process-status process) '(open run)))
 326         (progn
 327           ;; QUIT
 328           (smtp-send-command process "QUIT")
 329           (smtp-read-response process)
 330           (delete-process process)))))))
 331
 332 (defun smtp-process-filter (process output)
 333   (save-excursion
 334     (set-buffer (process-buffer process))
 335     (goto-char (point-max))
 336     (insert output)))
 337
 338 (defun smtp-read-response (process)
 339   (let ((case-fold-search nil)
 340         (response-strings nil)
 341         (response-continue t)
 342         (return-value '(nil ()))
 343         match-end)
 344
 345     (while response-continue
 346       (goto-char smtp-read-point)
 347       (while (not (search-forward "\r\n" nil t))
 348         (accept-process-output process)
 349         (goto-char smtp-read-point))
 350
 351       (setq match-end (point))
 352       (setq response-strings
 353             (cons (buffer-substring smtp-read-point (- match-end 2))
 354                   response-strings))
 355
 356       (goto-char smtp-read-point)
 357       (if (looking-at "[0-9]+ ")
 358           (let ((begin (match-beginning 0))
 359                 (end (match-end 0)))
 360             (if smtp-debug-info
 361                 (message "%s" (car response-strings)))
 362
 363             (setq smtp-read-point match-end)
 364
 365             ;; ignore lines that start with "0"
 366             (if (looking-at "0[0-9]+ ")
 367                 nil
 368               (setq response-continue nil)
 369               (setq return-value
 370                     (cons (string-to-int
 371                            (buffer-substring begin end))
 372                           (nreverse response-strings)))))
 373
 374         (if (looking-at "[0-9]+-")
 375             (progn (if smtp-debug-info
 376                      (message "%s" (car response-strings)))
 377                    (setq smtp-read-point match-end)
 378                    (setq response-continue t))
 379           (progn
 380             (setq smtp-read-point match-end)
 381             (setq response-continue nil)
 382             (setq return-value
 383                   (cons nil (nreverse response-strings)))))))
 384     (setq smtp-read-point match-end)
 385     return-value))
 386
 387 (defun smtp-send-command (process command &optional secure)
 388   (goto-char (point-max))
 389   (if secure
 390       (insert "Here is insecure words.\r\n")
 391     (insert command "\r\n"))
 392   (setq smtp-read-point (point))
 393   (process-send-string process command)
 394   (process-send-string process "\r\n"))
 395
 396 (defun smtp-send-data-1 (process data)
 397   (goto-char (point-max))
 398   (if smtp-debug-info
 399       (insert data "\r\n"))
 400   (setq smtp-read-point (point))
 401   ;; Escape "." at start of a line.
 402   (if (eq (string-to-char data) ?.)
 403       (process-send-string process "."))
 404   (process-send-string process data)
 405   (process-send-string process "\r\n"))
 406
 407 (defun smtp-send-data (process buffer)
 408   (let ((data-continue t)
 409         (sending-data nil)
 410         this-line
 411         this-line-end)
 412
 413     (save-excursion
 414       (set-buffer buffer)
 415       (goto-char (point-min)))
 416
 417     (while data-continue
 418       (save-excursion
 419         (set-buffer buffer)
 420         (beginning-of-line)
 421         (setq this-line (point))
 422         (end-of-line)
 423         (setq this-line-end (point))
 424         (setq sending-data nil)
 425         (setq sending-data (buffer-substring this-line this-line-end))
 426         (if (or (/= (forward-line 1) 0) (eobp))
 427             (setq data-continue nil)))
 428
 429       (smtp-send-data-1 process sending-data))))
 430
 431 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 432   "Get address list suitable for smtp RCPT TO:<address>."
 433   (let ((simple-address-list "")
 434         this-line
 435         this-line-end
 436         addr-regexp
 437         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 438     (unwind-protect
 439         (save-excursion
 440           ;;
 441           (set-buffer smtp-address-buffer)
 442           (setq case-fold-search t)
 443           (erase-buffer)
 444           (insert (save-excursion
 445                     (set-buffer smtp-text-buffer)
 446                     (buffer-substring-no-properties header-start header-end)))
 447           (goto-char (point-min))
 448           ;; RESENT-* fields should stop processing of regular fields.
 449           (save-excursion
 450             (if (re-search-forward "^RESENT-TO:" header-end t)
 451                 (setq addr-regexp
 452                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 453               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 454
 455           (while (re-search-forward addr-regexp header-end t)
 456             (replace-match "")
 457             (setq this-line (match-beginning 0))
 458             (forward-line 1)
 459             ;; get any continuation lines.
 460             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 461               (forward-line 1))
 462             (setq this-line-end (point-marker))
 463             (setq simple-address-list
 464                   (concat simple-address-list " "
 465                           (mail-strip-quoted-names
 466                            (buffer-substring this-line this-line-end)))))
 467           (erase-buffer)
 468           (insert-string " ")
 469           (insert-string simple-address-list)
 470           (insert-string "\n")
 471           ;; newline --> blank
 472           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 473           ;; comma   --> blank
 474           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 475           ;; tab     --> blank
 476           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 477
 478           (goto-char (point-min))
 479           ;; tidyness in case hook is not robust when it looks at this
 480           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 481
 482           (goto-char (point-min))
 483           (let (recipient-address-list)
 484             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 485               (backward-char 1)
 486               (setq recipient-address-list
 487                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 488                           recipient-address-list)))
 489             recipient-address-list))
 490       (kill-buffer smtp-address-buffer))))
 491
 492 (defun smtp-auth-cram-md5 (process)
 493   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 494         response)
 495     (smtp-send-command process "AUTH CRAM-MD5")
 496     (setq response (smtp-read-response process))
 497     (if (or (null (car response))
 498             (not (integerp (car response)))
 499             (>= (car response) 400))
 500         (throw 'done (car (cdr response))))
 501     (smtp-send-command
 502      process
 503      (setq secure-word (unwind-protect
 504                            (sasl-cram-md5
 505                             smtp-authenticate-user secure-word
 506                             (base64-decode-string
 507                              (substring (car (cdr response)) 4)))
 508                          (fillarray secure-word 0))
 509            secure-word (unwind-protect
 510                            (base64-encode-string secure-word)
 511                          (fillarray secure-word 0))) t)
 512     (fillarray secure-word 0)
 513     (setq response (smtp-read-response process))
 514     (if (or (null (car response))
 515             (not (integerp (car response)))
 516             (>= (car response) 400))
 517         (throw 'done (car (cdr response))))))
 518
 519 (defun smtp-auth-plain (process)
 520   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 521         response)
 522     (smtp-send-command
 523      process
 524      (setq secure-word (unwind-protect
 525                            (sasl-plain "" smtp-authenticate-user secure-word)
 526                          (fillarray secure-word 0))
 527            secure-word (unwind-protect
 528                            (base64-encode-string secure-word)
 529                          (fillarray secure-word 0))
 530            secure-word (unwind-protect
 531                            (concat "AUTH PLAIN " secure-word)
 532                          (fillarray secure-word 0))) t)
 533     (fillarray secure-word 0)
 534     (setq response (smtp-read-response process))
 535     (if (or (null (car response))
 536             (not (integerp (car response)))
 537             (>= (car response) 400))
 538         (throw 'done (car (cdr response))))))
 539
 540 (defun smtp-auth-login (process)
 541   (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
 542         response)
 543     (smtp-send-command process "AUTH LOGIN")
 544     (setq response (smtp-read-response process))
 545     (if (or (null (car response))
 546             (not (integerp (car response)))
 547             (>= (car response) 400))
 548         (throw 'done (car (cdr response))))
 549     (smtp-send-command
 550      process
 551      (base64-encode-string
 552       smtp-authenticate-user))
 553     (setq response (smtp-read-response process))
 554     (if (or (null (car response))
 555             (not (integerp (car response)))
 556             (>= (car response) 400))
 557         (throw 'done (car (cdr response))))
 558     (smtp-send-command
 559      process
 560      (setq secure-word (unwind-protect
 561                            (base64-encode-string secure-word)
 562                          (fillarray secure-word 0))) t)
 563     (fillarray secure-word 0)
 564     (setq response (smtp-read-response process))
 565     (if (or (null (car response))
 566             (not (integerp (car response)))
 567             (>= (car response) 400))
 568         (throw 'done (car (cdr response))))))
 569
 570 (defun smtp-auth-anonymous (process &optional token)
 571   (let (response)
 572     (smtp-send-command
 573      process "AUTH ANONYMOUS")
 574     (setq response (smtp-read-response process))
 575     (if (or (null (car response))
 576             (not (integerp (car response)))
 577             (>= (car response) 400))
 578         (throw 'done (car (cdr response))))
 579     (smtp-send-command process
 580                        (base64-encode-string
 581                         (or token
 582                             user-mail-address
 583                             "")))
 584     (setq response (smtp-read-response process))
 585     (if (or (null (car response))
 586             (not (integerp (car response)))
 587             (>= (car response) 400))
 588         (throw 'done (car (cdr response))))))
 589
 590 (defun smtp-auth-scram-md5 (process)
 591   ;; now tesing
 592   (let (server-msg-1 server-msg-2 client-msg-1 salted-pass
 593                      response secure-word)
 594     (smtp-send-command process "AUTH SCRAM-MD5")
 595     (setq response (smtp-read-response process))
 596     (if (or (null (car response))
 597             (not (integerp (car response)))
 598             (>= (car response) 400))
 599         (throw 'done (car (cdr response))))
 600     (unwind-protect
 601         (smtp-send-command
 602          process
 603          (setq secure-word
 604                (base64-encode-string
 605                 (setq client-msg-1
 606                       (sasl-scram-md5-client-msg-1
 607                        smtp-authenticate-user)))) t)
 608       (fillarray secure-word 0))
 609     (setq response (smtp-read-response process))
 610     (if (or (null (car response))
 611             (not (integerp (car response)))
 612             (>= (car response) 400))
 613         (progn
 614           (fillarray client-msg-1 0)
 615           (throw 'done (car (cdr response)))))
 616     (setq secure-word
 617           (unwind-protect
 618               (substring (car (cdr response)) 4)
 619             (fillarray (car (cdr response)) 0)))
 620     (setq server-msg-1
 621           (unwind-protect
 622               (base64-decode-string secure-word)
 623             (fillarray secure-word 0)))
 624     (setq secure-word
 625           (sasl-scram-md5-client-msg-2
 626            server-msg-1 client-msg-1
 627            (setq salted-pass
 628                  (sasl-scram-md5-make-salted-pass
 629                   smtp-authenticate-passphrase server-msg-1))))
 630     (setq secure-word
 631           (unwind-protect
 632               (base64-encode-string secure-word)
 633             (fillarray secure-word 0)))
 634     (unwind-protect
 635         (smtp-send-command process secure-word t)
 636       (fillarray secure-word 0))
 637     (setq response (smtp-read-response process))
 638     (if (or (null (car response))
 639             (not (integerp (car response)))
 640             (>= (car response) 400))
 641         (progn
 642           (fillarray salted-pass 0)
 643           (fillarray server-msg-1 0)
 644           (fillarray client-msg-1 0)
 645           (throw 'done (car (cdr response)))))
 646     (setq server-msg-2
 647           (unwind-protect
 648               (base64-decode-string
 649                (setq secure-word
 650                      (substring (car (cdr response)) 4)))
 651             (fillarray secure-word 0)))
 652     (if (null
 653          (unwind-protect
 654              (sasl-scram-md5-authenticate-server
 655               server-msg-1
 656               server-msg-2
 657               client-msg-1
 658               salted-pass)
 659            (fillarray salted-pass 0)
 660            (fillarray server-msg-1 0)
 661            (fillarray server-msg-2 0)
 662            (fillarray client-msg-1 0)))
 663         (throw 'done nil))
 664     (smtp-send-command process "")
 665     (setq response (smtp-read-response process))
 666     (if (or (null (car response))
 667             (not (integerp (car response)))
 668             (>= (car response) 400))
 669         (throw 'done (car (cdr response)))) ))
 670
 671 (defun smtp-auth-digest-md5 (process)
 672   "Login to server using the AUTH DIGEST-MD5 method."
 673   (let (user realm response)
 674     (smtp-send-command process "AUTH DIGEST-MD5")
 675     (setq response (smtp-read-response process))
 676     (if (or (null (car response))
 677             (not (integerp (car response)))
 678             (>= (car response) 400))
 679         (throw 'done (car (cdr response))))
 680     (if (string-match "^\\([^@]*\\)@\\([^@]*\\)"
 681                       smtp-authenticate-user)
 682         (setq user (match-string 1 smtp-authenticate-user)
 683               realm (match-string 2 smtp-authenticate-user))
 684       (setq user smtp-authenticate-user
 685             realm nil))
 686     (smtp-send-command process
 687                        (base64-encode-string
 688                         (sasl-digest-md5-digest-response
 689                          (base64-decode-string
 690                           (substring (car (cdr response)) 4))
 691                          user
 692                          smtp-authenticate-passphrase
 693                          "smtp" smtp-server realm)
 694                         'no-line-break) t)
 695     (setq response (smtp-read-response process))
 696     (if (or (null (car response))
 697             (not (integerp (car response)))
 698             (>= (car response) 400))
 699         (throw 'done (car (cdr response))))
 700     (smtp-send-command process "")))
 701
 702 (provide 'smtp)
 703
 704 ;;; smtp.el ends here