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 (defgroup smtp nil
  29   "SMTP protocol for sending mail."
  30   :group 'mail)
  31
  32 (defcustom smtp-default-server nil
  33   "*Specify default SMTP server."
  34   :type '(choice (const nil) string)
  35   :group 'smtp)
  36
  37 (defcustom smtp-server
  38   (or (getenv "SMTPSERVER") smtp-default-server)
  39   "*The name of the host running SMTP server."
  40   :type '(choice (const nil) string)
  41   :group 'smtp)
  42
  43 (defcustom smtp-service 25
  44   "*SMTP service port number. smtp or 25 ."
  45   :type 'integer
  46   :group 'smtp)
  47
  48 (defcustom smtp-local-domain nil
  49   "*Local domain name without a host name.
  50 If the function (system-name) returns the full internet address,
  51 don't define this value."
  52   :type '(choice (const nil) string)
  53   :group 'smtp)
  54
  55 (defcustom smtp-debug-info nil
  56   "*smtp debug info printout. messages and process buffer."
  57   :type 'boolean
  58   :group 'smtp)
  59
  60
  61 (defun smtp-fqdn ()
  62   (if smtp-local-domain
  63       (concat (system-name) "." smtp-local-domain)
  64     (system-name)))
  65
  66 (defun smtp-via-smtp (recipient smtp-text-buffer)
  67   (let ((process nil)
  68         (host smtp-server)
  69         (port smtp-service)
  70         response-code
  71         greeting
  72         process-buffer
  73         (supported-extensions '()))
  74     (unwind-protect
  75         (catch 'done
  76           ;; get or create the trace buffer
  77           (setq process-buffer
  78                 (get-buffer-create
  79                  (format "*trace of SMTP session to %s*" host)))
  80
  81           ;; clear the trace buffer of old output
  82           (save-excursion
  83             (set-buffer process-buffer)
  84             (erase-buffer))
  85
  86           ;; open the connection to the server
  87           (setq process (open-network-stream-as-binary
  88                          "SMTP" process-buffer host port))
  89           (and (null process) (throw 'done nil))
  90
  91           ;; set the send-filter
  92           (set-process-filter process 'smtp-process-filter)
  93
  94           (save-excursion
  95             (set-buffer process-buffer)
  96             (make-local-variable 'smtp-read-point)
  97             (setq smtp-read-point (point-min))
  98
  99             (if (or (null (car (setq greeting (smtp-read-response process))))
 100                     (not (integerp (car greeting)))
 101                     (>= (car greeting) 400))
 102                 (throw 'done nil)
 103               )
 104
 105             ;; EHLO
 106             (smtp-send-command process (format "EHLO %s" (smtp-fqdn)))
 107
 108             (if (or (null (car (setq response-code (smtp-read-response process))))
 109                     (not (integerp (car response-code)))
 110                     (>= (car response-code) 400))
 111                 (progn
 112                   ;; HELO
 113                   (smtp-send-command process (format "HELO %s" (smtp-fqdn)))
 114
 115                   (if (or (null (car (setq response-code (smtp-read-response process))))
 116                           (not (integerp (car response-code)))
 117                           (>= (car response-code) 400))
 118                       (throw 'done nil)))
 119               (let ((extension-lines (cdr (cdr response-code))))
 120                 (while extension-lines
 121                   (let ((name (intern (downcase (substring (car extension-lines) 4)))))
 122                     (and name
 123                          (cond ((memq name '(verb xvrb 8bitmime onex xone
 124                                                   expn size dsn etrn
 125                                                   help xusr))
 126                                 (setq supported-extensions
 127                                       (cons name supported-extensions)))
 128                                (t (message "unknown extension %s"
 129                                            name)))))
 130                   (setq extension-lines (cdr extension-lines)))))
 131
 132             (if (or (member 'onex supported-extensions)
 133                     (member 'xone supported-extensions))
 134                 (progn
 135                   (smtp-send-command process (format "ONEX"))
 136                   (if (or (null (car (setq response-code (smtp-read-response process))))
 137                           (not (integerp (car response-code)))
 138                           (>= (car response-code) 400))
 139                       (throw 'done nil))))
 140
 141             (if (and smtp-debug-info
 142                      (or (member 'verb supported-extensions)
 143                          (member 'xvrb supported-extensions)))
 144                 (progn
 145                   (smtp-send-command process (format "VERB"))
 146                   (if (or (null (car (setq response-code (smtp-read-response process))))
 147                           (not (integerp (car response-code)))
 148                           (>= (car response-code) 400))
 149                       (throw 'done nil))))
 150
 151             (if (member 'xusr supported-extensions)
 152                 (progn
 153                   (smtp-send-command process (format "XUSR"))
 154                   (if (or (null (car (setq response-code (smtp-read-response process))))
 155                           (not (integerp (car response-code)))
 156                           (>= (car response-code) 400))
 157                       (throw 'done nil))))
 158
 159             ;; MAIL FROM: <sender>
 160             (let ((size-part
 161                    (if (member 'size supported-extensions)
 162                        (format " SIZE=%d"
 163                                (save-excursion
 164                                  (set-buffer smtp-text-buffer)
 165                                  ;; size estimate:
 166                                  (+ (- (point-max) (point-min))
 167                                     ;; Add one byte for each change-of-line
 168                                     ;; because or CR-LF representation:
 169                                     (count-lines (point-min) (point-max))
 170                                     ;; For some reason, an empty line is
 171                                     ;; added to the message.  Maybe this
 172                                     ;; is a bug, but it can't hurt to add
 173                                     ;; those two bytes anyway:
 174                                     2)))
 175                      ""))
 176                   (body-part
 177                    (if (member '8bitmime supported-extensions)
 178                        ;; FIXME:
 179                        ;; Code should be added here that transforms
 180                        ;; the contents of the message buffer into
 181                        ;; something the receiving SMTP can handle.
 182                        ;; For a receiver that supports 8BITMIME, this
 183                        ;; may mean converting BINARY to BASE64, or
 184                        ;; adding Content-Transfer-Encoding and the
 185                        ;; other MIME headers.  The code should also
 186                        ;; return an indication of what encoding the
 187                        ;; message buffer is now, i.e. ASCII or
 188                        ;; 8BITMIME.
 189                        (if nil
 190                            " BODY=8BITMIME"
 191                          "")
 192                      "")))
 193 ;             (smtp-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtp-fqdn)))
 194               (smtp-send-command process (format "MAIL FROM: <%s>%s%s"
 195                                                      user-mail-address
 196                                                      size-part
 197                                                      body-part))
 198
 199               (if (or (null (car (setq response-code (smtp-read-response process))))
 200                       (not (integerp (car response-code)))
 201                       (>= (car response-code) 400))
 202                   (throw 'done nil)
 203                 ))
 204
 205             ;; RCPT TO: <recipient>
 206             (let ((n 0))
 207               (while (not (null (nth n recipient)))
 208                 (smtp-send-command process (format "RCPT TO: <%s>" (nth n recipient)))
 209                 (setq n (1+ n))
 210
 211                 (setq response-code (smtp-read-response process))
 212                 (if (or (null (car response-code))
 213                         (not (integerp (car response-code)))
 214                         (>= (car response-code) 400))
 215                     (throw 'done nil)
 216                   )
 217                 ))
 218
 219             ;; DATA
 220             (smtp-send-command process "DATA")
 221
 222             (if (or (null (car (setq response-code (smtp-read-response process))))
 223                     (not (integerp (car response-code)))
 224                     (>= (car response-code) 400))
 225                 (throw 'done nil)
 226               )
 227
 228             ;; Mail contents
 229             (smtp-send-data process smtp-text-buffer)
 230
 231             ;;DATA end "."
 232             (smtp-send-command process ".")
 233
 234             (if (or (null (car (setq response-code (smtp-read-response process))))
 235                     (not (integerp (car response-code)))
 236                     (>= (car response-code) 400))
 237                 (throw 'done nil)
 238               )
 239
 240             ;;QUIT
 241 ;           (smtp-send-command process "QUIT")
 242 ;           (and (null (car (smtp-read-response process)))
 243 ;                (throw 'done nil))
 244             t ))
 245       (if process
 246           (save-excursion
 247             (set-buffer (process-buffer process))
 248             (smtp-send-command process "QUIT")
 249             (smtp-read-response process)
 250
 251 ;           (if (or (null (car (setq response-code (smtp-read-response process))))
 252 ;                   (not (integerp (car response-code)))
 253 ;                   (>= (car response-code) 400))
 254 ;               (throw 'done nil)
 255 ;             )
 256             (delete-process process))))))
 257
 258 (defun smtp-process-filter (process output)
 259   (save-excursion
 260     (set-buffer (process-buffer process))
 261     (goto-char (point-max))
 262     (insert output)))
 263
 264 (defun smtp-read-response (process)
 265   (let ((case-fold-search nil)
 266         (response-strings nil)
 267         (response-continue t)
 268         (return-value '(nil ()))
 269         match-end)
 270
 271     (while response-continue
 272       (goto-char smtp-read-point)
 273       (while (not (search-forward "\r\n" nil t))
 274         (accept-process-output process)
 275         (goto-char smtp-read-point))
 276
 277       (setq match-end (point))
 278       (setq response-strings
 279             (cons (buffer-substring smtp-read-point (- match-end 2))
 280                   response-strings))
 281
 282       (goto-char smtp-read-point)
 283       (if (looking-at "[0-9]+ ")
 284           (let ((begin (match-beginning 0))
 285                 (end (match-end 0)))
 286             (if smtp-debug-info
 287                 (message "%s" (car response-strings)))
 288
 289             (setq smtp-read-point match-end)
 290
 291             ;; ignore lines that start with "0"
 292             (if (looking-at "0[0-9]+ ")
 293                 nil
 294               (setq response-continue nil)
 295               (setq return-value
 296                     (cons (string-to-int
 297                            (buffer-substring begin end))
 298                           (nreverse response-strings)))))
 299
 300         (if (looking-at "[0-9]+-")
 301             (progn (if smtp-debug-info
 302                      (message "%s" (car response-strings)))
 303                    (setq smtp-read-point match-end)
 304                    (setq response-continue t))
 305           (progn
 306             (setq smtp-read-point match-end)
 307             (setq response-continue nil)
 308             (setq return-value
 309                   (cons nil (nreverse response-strings)))
 310             )
 311           )))
 312     (setq smtp-read-point match-end)
 313     return-value))
 314
 315 (defun smtp-send-command (process command)
 316   (goto-char (point-max))
 317   (if (= (aref command 0) ?P)
 318       (insert "PASS <omitted>\r\n")
 319     (insert command "\r\n"))
 320   (setq smtp-read-point (point))
 321   (process-send-string process command)
 322   (process-send-string process "\r\n"))
 323
 324 (defun smtp-send-data-1 (process data)
 325   (goto-char (point-max))
 326
 327   (if smtp-debug-info
 328       (insert data "\r\n"))
 329
 330   (setq smtp-read-point (point))
 331   ;; Escape "." at start of a line
 332   (if (eq (string-to-char data) ?.)
 333       (process-send-string process "."))
 334   (process-send-string process data)
 335   (process-send-string process "\r\n")
 336   )
 337
 338 (defun smtp-send-data (process buffer)
 339   (let
 340       ((data-continue t)
 341        (sending-data nil)
 342        this-line
 343        this-line-end)
 344
 345     (save-excursion
 346       (set-buffer buffer)
 347       (goto-char (point-min)))
 348
 349     (while data-continue
 350       (save-excursion
 351         (set-buffer buffer)
 352         (beginning-of-line)
 353         (setq this-line (point))
 354         (end-of-line)
 355         (setq this-line-end (point))
 356         (setq sending-data nil)
 357         (setq sending-data (buffer-substring this-line this-line-end))
 358         (if (or (/= (forward-line 1) 0) (eobp))
 359             (setq data-continue nil)))
 360
 361       (smtp-send-data-1 process sending-data)
 362       )
 363     )
 364   )
 365
 366 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
 367   "Get address list suitable for smtp RCPT TO: <address>."
 368   (require 'mail-utils)  ;; pick up mail-strip-quoted-names
 369   (let ((case-fold-search t)
 370         (simple-address-list "")
 371         this-line
 372         this-line-end
 373         addr-regexp
 374         (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
 375     (unwind-protect
 376         (save-excursion
 377           ;;
 378           (set-buffer smtp-address-buffer)
 379           (erase-buffer)
 380           (insert-buffer-substring smtp-text-buffer
 381                                    header-start header-end)
 382           (goto-char (point-min))
 383           ;; RESENT-* fields should stop processing of regular fields.
 384           (save-excursion
 385             (if (re-search-forward "^RESENT-TO:" header-end t)
 386                 (setq addr-regexp
 387                       "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 388               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 389
 390           (while (re-search-forward addr-regexp header-end t)
 391             (replace-match "")
 392             (setq this-line (match-beginning 0))
 393             (forward-line 1)
 394             ;; get any continuation lines
 395             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 396               (forward-line 1))
 397             (setq this-line-end (point-marker))
 398             (setq simple-address-list
 399                   (concat simple-address-list " "
 400                           (mail-strip-quoted-names
 401                            (buffer-substring this-line this-line-end))))
 402             )
 403           (erase-buffer)
 404           (insert-string " ")
 405           (insert-string simple-address-list)
 406           (insert-string "\n")
 407           ;; newline --> blank
 408           (subst-char-in-region (point-min) (point-max) 10 ?  t)
 409           ;; comma   --> blank
 410           (subst-char-in-region (point-min) (point-max) ?, ?  t)
 411           ;; tab     --> blank
 412           (subst-char-in-region (point-min) (point-max)  9 ?  t)
 413
 414           (goto-char (point-min))
 415           ;; tidyness in case hook is not robust when it looks at this
 416           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 417
 418           (goto-char (point-min))
 419           (let (recipient-address-list)
 420             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 421               (backward-char 1)
 422               (setq recipient-address-list
 423                     (cons (buffer-substring (match-beginning 1) (match-end 1))
 424                           recipient-address-list))
 425               )
 426             recipient-address-list)
 427           )
 428       (kill-buffer smtp-address-buffer))
 429     ))
 430
 431 (defun smtp-do-bcc (header-end)
 432   "Delete BCC: and their continuation lines from the header area.
 433 There may be multiple BCC: lines, and each may have arbitrarily
 434 many continuation lines."
 435   (let ((case-fold-search t))
 436     (save-excursion
 437       (goto-char (point-min))
 438       ;; iterate over all BCC: lines
 439       (while (re-search-forward "^BCC:" header-end t)
 440         (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
 441         ;; get rid of any continuation lines
 442         (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
 443           (replace-match ""))
 444         )
 445       ) ;; save-excursion
 446     ) ;; let
 447   )
 448
 449 (provide 'smtp)
 450
 451 ;;; smtp.el ends here