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