smtp.el

   1 ;;; smtp.el --- basic functions to send mail with SMTP server
   2
   3 ;; Copyright (C) 1995, 1996, 1998 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-k@jaist.ac.jp>
   8 ;; Keywords: SMTP, mail
   9
  10 ;; This file is part of FLIM (Faithful Library about Internet Message).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (require 'mail-utils) ; pick up mail-strip-quoted-names
  30
  31 (defgroup smtp nil
  32   "SMTP protocol for sending mail."
  33   :group 'mail)
  34
  35 (defcustom smtp-default-server nil
  36   "*Specify default SMTP server."
  37   :type '(choice (const nil) string)
  38   :group 'smtp)
  39
  40 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
  41   "*The name of the host running SMTP server.  It can also be a function
  42 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
  43   :type '(choice (string :tag "Name")
  44                  (function :tag "Function"))
  45   :group 'smtp)
  46
  47 (defcustom smtp-service "smtp"
  48   "*SMTP service port number. \"smtp\" or 25."
  49   :type '(choice (integer :tag "25" 25)
  50                  (string :tag "smtp" "smtp"))
  51   :group 'smtp)
  52
  53 (defcustom smtp-use-8bitmime t
  54   "*If non-nil, use ESMTP 8BITMIME if available."
  55   :type 'boolean
  56   :group 'smtp)
  57
  58 (defcustom smtp-local-domain nil
  59   "*Local domain name without a host name.
  60 If the function (system-name) returns the full internet address,
  61 don't define this value."
  62   :type '(choice (const nil) string)
  63   :group 'smtp)
  64
  65 (defvar smtp-debug-info nil)
  66 (defvar smtp-read-point nil)
  67
  68 (defun smtp-make-fqdn ()
  69   "Return user's fully qualified domain name."
  70   (let ((system-name (system-name)))
  71     (cond
  72      (smtp-local-domain
  73       (concat system-name "." smtp-local-domain))
  74      ((string-match "[^.]\\.[^.]" system-name)
  75       system-name)
  76      (t
  77       (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
  78
  79 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
  80   (let ((server (if (functionp smtp-server)
  81                     (funcall smtp-server sender recipients)
  82                   smtp-server))
  83         process response extensions)
  84     (save-excursion
  85       (set-buffer
  86        (get-buffer-create
  87         (format "*trace of SMTP session to %s*" server)))
  88       (erase-buffer)
  89       (make-local-variable 'smtp-read-point)
  90       (setq smtp-read-point (point-min))
  91
  92       (unwind-protect
  93           (catch 'done
  94             (setq process (open-network-stream-as-binary
  95                            "SMTP" (current-buffer) server smtp-service))
  96             (or process (throw 'done nil))
  97
  98             (set-process-filter process 'smtp-process-filter)
  99
 100             ;; Greeting
 101             (setq response (smtp-read-response process))
 102             (if (or (null (car response))
 103                     (not (integerp (car response)))
 104                     (>= (car response) 400))
 105                 (throw 'done (car (cdr response))))
 106
 107             ;; EHLO
 108             (smtp-send-command process
 109                                (format "EHLO %s" (smtp-make-fqdn)))
 110             (setq response (smtp-read-response process))
 111             (if (or (null (car response))
 112                     (not (integerp (car response)))
 113                     (>= (car response) 400))
 114                 (progn
 115                   ;; HELO
 116                   (smtp-send-command process
 117                                      (format "HELO %s" (smtp-make-fqdn)))
 118                   (setq response (smtp-read-response process))
 119                   (if (or (null (car response))
 120                           (not (integerp (car response)))
 121                           (>= (car response) 400))
 122                       (throw 'done (car (cdr response)))))
 123               (let ((extension-lines (cdr (cdr response))))
 124                 (while extension-lines
 125                   (push (intern (downcase (substring (car extension-lines) 4)))
 126                         extensions)
 127                   (setq extension-lines (cdr extension-lines)))))
 128
 129             ;; ONEX --- One message transaction only (sendmail extension?)
 130             (if (or (memq 'onex extensions)
 131                     (memq 'xone extensions))
 132                 (progn
 133                   (smtp-send-command process "ONEX")
 134                   (setq response (smtp-read-response process))
 135                   (if (or (null (car response))
 136                           (not (integerp (car response)))
 137                           (>= (car response) 400))
 138                       (throw 'done (car (cdr response))))))
 139
 140             ;; VERB --- Verbose (sendmail extension?)
 141             (if (and smtp-debug-info
 142                      (or (memq 'verb extensions)
 143                          (memq 'xvrb extensions)))
 144                 (progn
 145                   (smtp-send-command process "VERB")
 146                   (setq response (smtp-read-response process))
 147                   (if (or (null (car response))
 148                           (not (integerp (car response)))
 149                           (>= (car response) 400))
 150                       (throw 'done (car (cdr response))))))
 151
 152             ;; XUSR --- Initial (user) submission (sendmail extension?)
 153             (if (memq 'xusr extensions)
 154                 (progn
 155                   (smtp-send-command process "XUSR")
 156                   (setq response (smtp-read-response process))
 157                   (if (or (null (car response))
 158                           (not (integerp (car response)))
 159                           (>= (car response) 400))
 160                       (throw 'done (car (cdr response))))))
 161
 162             ;; MAIL FROM:<sender>
 163             (smtp-send-command
 164              process
 165              (format "MAIL FROM:<%s>%s%s"
 166                      sender
 167                      ;; SIZE --- Message Size Declaration (RFC1870)
 168                      (if (memq 'size extensions)
 169                          (format " SIZE=%d"
 170                                  (save-excursion
 171                                    (set-buffer smtp-text-buffer)
 172                                    (+ (- (point-max) (point-min))
 173                                       ;; Add one byte for each change-of-line
 174                                       ;; because or CR-LF representation:
 175                                       (count-lines (point-min) (point-max))
 176                                       ;; For some reason, an empty line is
 177                                       ;; added to the message.  Maybe this
 178                                       ;; is a bug, but it can't hurt to add
 179                                       ;; those two bytes anyway:
 180                                       2)))
 181                        "")
 182                      ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
 183                      (if (and (memq '8bitmime extensions)
 184                               smtp-use-8bitmime)
 185                          " BODY=8BITMIME"
 186                        "")))
 187             (setq response (smtp-read-response process))
 188             (if (or (null (car response))
 189                     (not (integerp (car response)))
 190                     (>= (car response) 400))
 191                 (throw 'done (car (cdr response))))
 192
 193             ;; RCPT TO:<recipient>
 194             (while recipients
 195               (smtp-send-command process
 196                                  (format "RCPT TO:<%s>" (car recipients)))
 197               (setq recipients (cdr recipients))
 198               (setq response (smtp-read-response process))
 199               (if (or (null (car response))
 200                       (not (integerp (car response)))
 201                       (>= (car response) 400))
 202                   (throw 'done (car (cdr response)))))
 203
 204             ;; DATA
 205             (smtp-send-command process "DATA")
 206             (setq response (smtp-read-response process))
 207             (if (or (null (car response))
 208                     (not (integerp (car response)))
 209                     (>= (car response) 400))
 210                 (throw 'done (car (cdr response))))
 211
 212             ;; Mail contents
 213             (smtp-send-data process smtp-text-buffer)
 214
 215             ;; DATA end "."
 216             (smtp-send-command process ".")
 217             (setq response (smtp-read-response process))
 218             (if (or (null (car response))
 219                     (not (integerp (car response)))
 220                     (>= (car response) 400))
 221                 (throw 'done (car (cdr response))))
 222
 223             t)
 224
 225         (if (and process
 226                  (eq (process-status process) 'open))
 227             (progn
 228               ;; QUIT
 229               (smtp-send-command process "QUIT")
 230               (smtp-read-response process)
 231               (delete-process process)))))))
 232
 233 (defun smtp-process-filter (process output)
 234   (save-excursion
 235     (set-buffer (process-buffer process))
 236     (goto-char (point-max))
 237     (insert output)))
 238
 239 (defun smtp-read-response (process)
 240   (let ((case-fold-search nil)
 241         (response-strings nil)
 242         (response-continue t)
 243         (return-value '(nil ()))
 244         match-end)
 245
 246     (while response-continue
 247       (goto-char smtp-read-point)
 248       (while (not (search-forward "\r\n" nil t))
 249         (accept-process-output process)
 250         (goto-char smtp-read-point))
 251
 252       (setq match-end (point))
 253       (setq response-strings
 254             (cons (buffer-substring smtp-read-point (- match-end 2))
 255                   response-strings))
 256
 257       (goto-char smtp-read-point)
 258       (if (looking-at "[0-9]+ ")
 259           (let ((begin (match-beginning 0))
 260                 (end (match-end 0)))
 261             (if smtp-debug-info
 262                 (message "%s" (car response-strings)))
 263
 264             (setq smtp-read-point match-end)
 265
 266             ;; ignore lines that start with "0"
 267             (if (looking-at "0[0-9]+ ")
 268                 nil
 269               (setq response-continue nil)
 270               (setq return-value
 271                     (cons (string-to-int
 272                            (buffer-substring begin end))
 273                           (nreverse response-strings)))))
 274
 275         (if (looking-at "[0-9]+-")
 276             (progn (if smtp-debug-info
 277                      (message "%s" (car response-strings)))
 278                    (setq smtp-read-point match-end)
 279                    (setq response-continue t))
 280           (progn
 281             (setq smtp-read-point match-end)
 282             (setq response-continue nil)
 283             (setq return-value
 284                   (cons nil (nreverse response-strings)))))))
 285     (setq smtp-read-point match-end)
 286     return-value))
 287
 288 (defun smtp-send-command (process command)
 289   (goto-char (point-max))
 290   (insert command "\r\n")
 291   (setq smtp-read-point (point))
 292   (process-send-string process command)
 293   (process-send-string process "\r\n"))
 294
 295 (defun smtp-send-data-1 (process data)
 296   (goto-char (point-max))
 297   (if smtp-debug-info
 298       (insert data "\r\n"))
 299   (setq smtp-read-point (point))
 300   ;; Escape "." at start of a line.
 301   (if (eq (string-to-char data) ?.)
 302       (process-send-string process "."))
 303   (process-send-string process data)
 304   (process-send-string process "\r\n"))
 305
 306 (defun smtp-send-data (process buffer)
 307   (let ((data-continue t)
 308         (sending-data nil)
 309         this-line
 310         this-line-end)
 311
 312     (save-excursion
 313       (set-buffer buffer)
 314       (goto-char (point-min)))
 315
 316     (while data-continue
 317       (save-excursion
 318         (set-buffer buffer)
 319         (beginning-of-line)
 320         (setq this-line (point))
 321         (end-of-line)
 322         (setq this-line-end (point))
 323         (setq sending-data nil)
 324         (setq sending-data (buffer-substring this-line this-line-end))
 325         (if (or (/= (forward-line 1) 0) (eobp))
 326             (setq data-continue nil)))
 327
 328       (smtp-send-data-1 process sending-data))))
 329
 330 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 331   "Get address list suitable for smtp RCPT TO:<address>."
 332   (let ((case-fold-search t)
 333         (simple-address-list "")
 334         this-line
 335         this-line-end
 336         addr-regexp
 337         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 338     (unwind-protect
 339         (save-excursion
 340           ;;
 341           (set-buffer smtp-address-buffer)
 342           (erase-buffer)
 343           (insert (save-excursion
 344                     (set-buffer smtp-text-buffer)
 345                     (buffer-substring-no-properties header-start header-end)))
 346           (goto-char (point-min))
 347           ;; RESENT-* fields should stop processing of regular fields.
 348           (save-excursion
 349             (if (re-search-forward "^RESENT-TO:" header-end t)
 350                 (setq addr-regexp
 351                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 352               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 353
 354           (while (re-search-forward addr-regexp header-end t)
 355             (replace-match "")
 356             (setq this-line (match-beginning 0))
 357             (forward-line 1)
 358             ;; get any continuation lines.
 359             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 360               (forward-line 1))
 361             (setq this-line-end (point-marker))
 362             (setq simple-address-list
 363                   (concat simple-address-list " "
 364                           (mail-strip-quoted-names
 365                            (buffer-substring this-line this-line-end)))))
 366           (erase-buffer)
 367           (insert-string " ")
 368           (insert-string simple-address-list)
 369           (insert-string "\n")
 370           ;; newline --> blank
 371           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 372           ;; comma   --> blank
 373           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 374           ;; tab     --> blank
 375           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 376
 377           (goto-char (point-min))
 378           ;; tidyness in case hook is not robust when it looks at this
 379           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 380
 381           (goto-char (point-min))
 382           (let (recipient-address-list)
 383             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 384               (backward-char 1)
 385               (setq recipient-address-list
 386                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 387                           recipient-address-list)))
 388             recipient-address-list))
 389       (kill-buffer smtp-address-buffer))))
 390
 391 (provide 'smtp)
 392
 393 ;;; smtp.el ends here