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