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