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

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