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