code.delx.au - gnu-emacs/blob - lisp/mail/smtpmail.el

   1 ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
   2
   3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
   6 ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
   7 ;; Keywords: 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 ;;; Commentary:
  27
  28 ;; Send Mail to smtp host from smtpmail temp buffer.
  29
  30 ;; Please add these lines in your .emacs(_emacs).
  31 ;;
  32 ;;(setq send-mail-function 'smtpmail-send-it)
  33 ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST")
  34 ;;(setq smtpmail-smtp-service "smtp")
  35 ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
  36 ;;(setq smtpmail-debug-info t)
  37 ;;(load-library "smtpmail")
  38 ;;(setq smtpmail-code-conv-from nil)
  39 ;;(setq user-full-name "YOUR NAME HERE")
  40
  41 ;;; Code:
  42
  43 (require 'sendmail)
  44
  45 ;;;
  46 (defgroup smtpmail nil
  47   "SMTP protocol for sending mail."
  48   :group 'mail)
  49
  50
  51 (defcustom smtpmail-default-smtp-server nil
  52   "*Specify default SMTP server."
  53   :type '(choice (const nil) string)
  54   :group 'smtpmail)
  55
  56 (defcustom smtpmail-smtp-server
  57   (or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
  58   "*The name of the host running SMTP server."
  59   :type '(choice (const nil) string)
  60   :group 'smtpmail)
  61
  62 (defcustom smtpmail-smtp-service 25
  63   "*SMTP service port number. smtp or 25 ."
  64   :type 'integer
  65   :group 'smtpmail)
  66
  67 (defcustom smtpmail-local-domain nil
  68   "*Local domain name without a host name.
  69 If the function (system-name) returns the full internet address,
  70 don't define this value."
  71   :type '(choice (const nil) string)
  72   :group 'smtpmail)
  73
  74 (defcustom smtpmail-debug-info nil
  75   "*smtpmail debug info printout. messages and process buffer."
  76   :type 'boolean
  77   :group 'smtpmail)
  78
  79 (defcustom smtpmail-code-conv-from nil ;; *junet*
  80   "*smtpmail code convert from this code to *internal*..for tiny-mime.."
  81   :type 'boolean
  82   :group 'smtpmail)
  83
  84 ;;;
  85 ;;;
  86 ;;;
  87
  88 (defun smtpmail-send-it ()
  89   (require 'mail-utils)
  90   (let ((errbuf (if mail-interactive
  91                     (generate-new-buffer " smtpmail errors")
  92                   0))
  93         (tembuf (generate-new-buffer " smtpmail temp"))
  94         (case-fold-search nil)
  95         resend-to-addresses
  96         delimline
  97         (mailbuf (current-buffer)))
  98     (unwind-protect
  99         (save-excursion
 100           (set-buffer tembuf)
 101           (erase-buffer)
 102           (insert-buffer-substring mailbuf)
 103           (goto-char (point-max))
 104           ;; require one newline at the end.
 105           (or (= (preceding-char) ?\n)
 106               (insert ?\n))
 107           ;; Change header-delimiter to be what sendmail expects.
 108           (goto-char (point-min))
 109           (re-search-forward
 110             (concat "^" (regexp-quote mail-header-separator) "\n"))
 111           (replace-match "\n")
 112           (backward-char 1)
 113           (setq delimline (point-marker))
 114 ;;        (sendmail-synch-aliases)
 115           (if mail-aliases
 116               (expand-mail-aliases (point-min) delimline))
 117           (goto-char (point-min))
 118           ;; ignore any blank lines in the header
 119           (while (and (re-search-forward "\n\n\n*" delimline t)
 120                       (< (point) delimline))
 121             (replace-match "\n"))
 122           (let ((case-fold-search t))
 123             (goto-char (point-min))
 124             (goto-char (point-min))
 125             (while (re-search-forward "^Resent-to:" delimline t)
 126               (setq resend-to-addresses
 127                     (save-restriction
 128                       (narrow-to-region (point)
 129                                         (save-excursion
 130                                           (end-of-line)
 131                                           (point)))
 132                       (append (mail-parse-comma-list)
 133                               resend-to-addresses))))
 134 ;;; Apparently this causes a duplicate Sender.
 135 ;;;         ;; If the From is different than current user, insert Sender.
 136 ;;;         (goto-char (point-min))
 137 ;;;         (and (re-search-forward "^From:"  delimline t)
 138 ;;;              (progn
 139 ;;;                (require 'mail-utils)
 140 ;;;                (not (string-equal
 141 ;;;                      (mail-strip-quoted-names
 142 ;;;                       (save-restriction
 143 ;;;                         (narrow-to-region (point-min) delimline)
 144 ;;;                         (mail-fetch-field "From")))
 145 ;;;                      (user-login-name))))
 146 ;;;              (progn
 147 ;;;                (forward-line 1)
 148 ;;;                (insert "Sender: " (user-login-name) "\n")))
 149             ;; Don't send out a blank subject line
 150             (goto-char (point-min))
 151             (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
 152                 (replace-match ""))
 153             ;; Put the "From:" field in unless for some odd reason
 154             ;; they put one in themselves.
 155             (goto-char (point-min))
 156             (if (not (re-search-forward "^From:" delimline t))
 157                 (let* ((login user-mail-address)
 158                        (fullname (user-full-name)))
 159                   (cond ((eq mail-from-style 'angles)
 160                          (insert "From: " fullname)
 161                          (let ((fullname-start (+ (point-min) 6))
 162                                (fullname-end (point-marker)))
 163                            (goto-char fullname-start)
 164                            ;; Look for a character that cannot appear unquoted
 165                            ;; according to RFC 822.
 166                            (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
 167                                                   fullname-end 1)
 168                                (progn
 169                                  ;; Quote fullname, escaping specials.
 170                                  (goto-char fullname-start)
 171                                  (insert "\"")
 172                                  (while (re-search-forward "[\"\\]"
 173                                                            fullname-end 1)
 174                                    (replace-match "\\\\\\&" t))
 175                                  (insert "\""))))
 176                          (insert " <" login ">\n"))
 177                         ((eq mail-from-style 'parens)
 178                          (insert "From: " login " (")
 179                          (let ((fullname-start (point)))
 180                            (insert fullname)
 181                            (let ((fullname-end (point-marker)))
 182                              (goto-char fullname-start)
 183                              ;; RFC 822 says \ and nonmatching parentheses
 184                              ;; must be escaped in comments.
 185                              ;; Escape every instance of ()\ ...
 186                              (while (re-search-forward "[()\\]" fullname-end 1)
 187                                (replace-match "\\\\\\&" t))
 188                              ;; ... then undo escaping of matching parentheses,
 189                              ;; including matching nested parentheses.
 190                              (goto-char fullname-start)
 191                              (while (re-search-forward
 192                                      "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
 193                                      fullname-end 1)
 194                                (replace-match "\\1(\\3)" t)
 195                                (goto-char fullname-start))))
 196                          (insert ")\n"))
 197                         ((null mail-from-style)
 198                          (insert "From: " login "\n")))))
 199             ;; Insert an extra newline if we need it to work around
 200             ;; Sun's bug that swallows newlines.
 201             (goto-char (1+ delimline))
 202             (if (eval mail-mailer-swallows-blank-line)
 203                 (newline))
 204             ;; Find and handle any FCC fields.
 205             (goto-char (point-min))
 206             (if (re-search-forward "^FCC:" delimline t)
 207                 (mail-do-fcc delimline))
 208             (if mail-interactive
 209                 (save-excursion
 210                   (set-buffer errbuf)
 211                   (erase-buffer))))
 212           ;;
 213           ;;
 214           ;;
 215           (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
 216           (setq smtpmail-recipient-address-list
 217                 (or resend-to-addresses
 218                     (smtpmail-deduce-address-list tembuf (point-min) delimline)))
 219           (kill-buffer smtpmail-address-buffer)
 220
 221           (smtpmail-do-bcc delimline)
 222
 223           (if (not (null smtpmail-recipient-address-list))
 224               (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf))
 225                   (error "Sending failed; SMTP protocol error"))
 226             (error "Sending failed; no recipients"))
 227           )
 228       (kill-buffer tembuf)
 229       (if (bufferp errbuf)
 230           (kill-buffer errbuf)))))
 231
 232
 233 ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
 234
 235 (defun smtpmail-fqdn ()
 236   (if smtpmail-local-domain
 237       (concat (system-name) "." smtpmail-local-domain)
 238     (system-name)))
 239
 240 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
 241   (let ((process nil)
 242         (host smtpmail-smtp-server)
 243         (port smtpmail-smtp-service)
 244         response-code
 245         greeting
 246         process-buffer)
 247     (unwind-protect
 248         (catch 'done
 249           ;; get or create the trace buffer
 250           (setq process-buffer
 251                 (get-buffer-create (format "*trace of SMTP session to %s*" host)))
 252
 253           ;; clear the trace buffer of old output
 254           (save-excursion
 255             (set-buffer process-buffer)
 256             (erase-buffer))
 257
 258           ;; open the connection to the server
 259           (setq process (open-network-stream "SMTP" process-buffer host port))
 260           (and (null process) (throw 'done nil))
 261
 262           ;; set the send-filter
 263           (set-process-filter process 'smtpmail-process-filter)
 264
 265           (save-excursion
 266             (set-buffer process-buffer)
 267             (make-local-variable 'smtpmail-read-point)
 268             (setq smtpmail-read-point (point-min))
 269
 270
 271             (if (or (null (car (setq greeting (smtpmail-read-response process))))
 272                     (not (integerp (car greeting)))
 273                     (>= (car greeting) 400))
 274                 (throw 'done nil)
 275               )
 276
 277             ;; HELO
 278             (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn)))
 279
 280             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 281                     (not (integerp (car response-code)))
 282                     (>= (car response-code) 400))
 283                 (throw 'done nil)
 284               )
 285
 286             ;; MAIL FROM: <sender>
 287 ;           (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
 288             (smtpmail-send-command process (format "MAIL FROM: <%s>" user-mail-address))
 289
 290             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 291                     (not (integerp (car response-code)))
 292                     (>= (car response-code) 400))
 293                 (throw 'done nil)
 294               )
 295
 296             ;; RCPT TO: <recipient>
 297             (let ((n 0))
 298               (while (not (null (nth n recipient)))
 299                 (smtpmail-send-command process (format "RCPT TO: <%s>" (nth n recipient)))
 300                 (setq n (1+ n))
 301
 302                 (if (or (null (car (setq response-code (smtpmail-read-response process))))
 303                         (not (integerp (car response-code)))
 304                         (>= (car response-code) 400))
 305                     (throw 'done nil)
 306                   )
 307                 ))
 308
 309             ;; DATA
 310             (smtpmail-send-command process "DATA")
 311
 312             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 313                     (not (integerp (car response-code)))
 314                     (>= (car response-code) 400))
 315                 (throw 'done nil)
 316               )
 317
 318             ;; Mail contents
 319             (smtpmail-send-data process smtpmail-text-buffer)
 320
 321             ;;DATA end "."
 322             (smtpmail-send-command process ".")
 323
 324             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 325                     (not (integerp (car response-code)))
 326                     (>= (car response-code) 400))
 327                 (throw 'done nil)
 328               )
 329
 330             ;;QUIT
 331 ;           (smtpmail-send-command process "QUIT")
 332 ;           (and (null (car (smtpmail-read-response process)))
 333 ;                (throw 'done nil))
 334             t ))
 335       (if process
 336           (save-excursion
 337             (set-buffer (process-buffer process))
 338             (smtpmail-send-command process "QUIT")
 339             (smtpmail-read-response process)
 340
 341 ;           (if (or (null (car (setq response-code (smtpmail-read-response process))))
 342 ;                   (not (integerp (car response-code)))
 343 ;                   (>= (car response-code) 400))
 344 ;               (throw 'done nil)
 345 ;             )
 346             (delete-process process))))))
 347
 348
 349 (defun smtpmail-process-filter (process output)
 350   (save-excursion
 351     (set-buffer (process-buffer process))
 352     (goto-char (point-max))
 353     (insert output)))
 354
 355 (defun smtpmail-read-response (process)
 356   (let ((case-fold-search nil)
 357         (response-string nil)
 358         (response-continue t)
 359         (return-value '(nil ""))
 360         match-end)
 361
 362 ;    (setq response-string nil)
 363 ;    (setq response-continue t)
 364 ;    (setq return-value '(nil ""))
 365
 366     (while response-continue
 367       (goto-char smtpmail-read-point)
 368       (while (not (search-forward "\r\n" nil t))
 369         (accept-process-output process)
 370         (goto-char smtpmail-read-point))
 371
 372       (setq match-end (point))
 373       (if (null response-string)
 374           (setq response-string
 375                 (buffer-substring smtpmail-read-point (- match-end 2))))
 376
 377       (goto-char smtpmail-read-point)
 378       (if (looking-at "[0-9]+ ")
 379           (progn (setq response-continue nil)
 380 ;                (setq return-value response-string)
 381
 382                  (if smtpmail-debug-info
 383                      (message "%s" response-string))
 384
 385                  (setq smtpmail-read-point match-end)
 386                  (setq return-value
 387                        (cons (string-to-int
 388                               (buffer-substring (match-beginning 0) (match-end 0)))
 389                              response-string)))
 390
 391         (if (looking-at "[0-9]+-")
 392             (progn (setq smtpmail-read-point match-end)
 393                    (setq response-continue t))
 394           (progn
 395             (setq smtpmail-read-point match-end)
 396             (setq response-continue nil)
 397             (setq return-value
 398                   (cons nil response-string))
 399             )
 400           )))
 401     (setq smtpmail-read-point match-end)
 402     return-value))
 403
 404
 405 (defun smtpmail-send-command (process command)
 406   (goto-char (point-max))
 407   (if (= (aref command 0) ?P)
 408       (insert "PASS <omitted>\r\n")
 409     (insert command "\r\n"))
 410   (setq smtpmail-read-point (point))
 411   (process-send-string process command)
 412   (process-send-string process "\r\n"))
 413
 414 (defun smtpmail-send-data-1 (process data)
 415   (goto-char (point-max))
 416
 417   (if (not (null smtpmail-code-conv-from))
 418       (setq data (code-convert-string data smtpmail-code-conv-from *internal*)))
 419
 420   (if smtpmail-debug-info
 421       (insert data "\r\n"))
 422
 423   (setq smtpmail-read-point (point))
 424   ;; Escape "." at start of a line
 425   (if (eq (string-to-char data) ?.)
 426       (process-send-string process "."))
 427   (process-send-string process data)
 428   (process-send-string process "\r\n")
 429   )
 430
 431 (defun smtpmail-send-data (process buffer)
 432   (let
 433       ((data-continue t)
 434        (sending-data nil)
 435        this-line
 436        this-line-end)
 437
 438     (save-excursion
 439       (set-buffer buffer)
 440       (goto-char (point-min)))
 441
 442     (while data-continue
 443       (save-excursion
 444         (set-buffer buffer)
 445         (beginning-of-line)
 446         (setq this-line (point))
 447         (end-of-line)
 448         (setq this-line-end (point))
 449         (setq sending-data nil)
 450         (setq sending-data (buffer-substring this-line this-line-end))
 451         (if (/= (forward-line 1) 0)
 452             (setq data-continue nil)))
 453
 454       (smtpmail-send-data-1 process sending-data)
 455       )
 456     )
 457   )
 458
 459
 460 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
 461   "Get address list suitable for smtp RCPT TO: <address>."
 462   (require 'mail-utils)  ;; pick up mail-strip-quoted-names
 463   (let
 464       ((case-fold-search t)
 465        (simple-address-list "")
 466        this-line
 467        this-line-end
 468        addr-regexp)
 469
 470     (unwind-protect
 471         (save-excursion
 472           ;;
 473           (set-buffer smtpmail-address-buffer) (erase-buffer)
 474           (insert-buffer-substring smtpmail-text-buffer header-start header-end)
 475           (goto-char (point-min))
 476           ;; RESENT-* fields should stop processing of regular fields.
 477           (save-excursion
 478             (if (re-search-forward "^RESENT-TO:" header-end t)
 479                 (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 480               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 481
 482           (while (re-search-forward addr-regexp header-end t)
 483             (replace-match "")
 484             (setq this-line (match-beginning 0))
 485             (forward-line 1)
 486             ;; get any continuation lines
 487             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 488               (forward-line 1))
 489             (setq this-line-end (point-marker))
 490             (setq simple-address-list
 491                   (concat simple-address-list " "
 492                           (mail-strip-quoted-names (buffer-substring this-line this-line-end))))
 493             )
 494           (erase-buffer)
 495           (insert-string " ")
 496           (insert-string simple-address-list)
 497           (insert-string "\n")
 498           (subst-char-in-region (point-min) (point-max) 10 ?  t);; newline --> blank
 499           (subst-char-in-region (point-min) (point-max) ?, ?  t);; comma   --> blank
 500           (subst-char-in-region (point-min) (point-max)  9 ?  t);; tab     --> blank
 501
 502           (goto-char (point-min))
 503           ;; tidyness in case hook is not robust when it looks at this
 504           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 505
 506           (goto-char (point-min))
 507           (let (recipient-address-list)
 508             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 509               (backward-char 1)
 510               (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
 511                                                  recipient-address-list))
 512               )
 513             (setq smtpmail-recipient-address-list recipient-address-list))
 514
 515           )
 516       )
 517     )
 518   )
 519
 520
 521 (defun smtpmail-do-bcc (header-end)
 522   "Delete BCC: and their continuation lines from the header area.
 523 There may be multiple BCC: lines, and each may have arbitrarily
 524 many continuation lines."
 525   (let ((case-fold-search t))
 526         (save-excursion (goto-char (point-min))
 527           ;; iterate over all BCC: lines
 528           (while (re-search-forward "^BCC:" header-end t)
 529                 (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
 530                 ;; get rid of any continuation lines
 531                 (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
 532                   (replace-match ""))
 533                 )
 534           ) ;; save-excursion
 535         ) ;; let
 536   )
 537
 538
 539
 540 (provide 'smtpmail)
 541
 542 ;;; smtpmail.el ends here