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                 (or resend-to-addresses
 201                     (smtpmail-deduce-address-list tembuf (point-min) delimline)))
 202           (kill-buffer smtpmail-address-buffer)
 203
 204           (smtpmail-do-bcc delimline)
 205
 206           (if (not (null smtpmail-recipient-address-list))
 207               (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf))
 208                   (error "Sending failed; SMTP protocol error"))
 209             (error "Sending failed; no recipients"))
 210           )
 211       (kill-buffer tembuf)
 212       (if (bufferp errbuf)
 213           (kill-buffer errbuf)))))
 214
 215
 216 ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
 217
 218 (defun smtpmail-fqdn ()
 219   (if smtpmail-local-domain
 220       (concat (system-name) "." smtpmail-local-domain)
 221     (system-name)))
 222
 223 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
 224   (let ((process nil)
 225         (host smtpmail-smtp-server)
 226         (port smtpmail-smtp-service)
 227         response-code
 228         greeting
 229         process-buffer)
 230     (unwind-protect
 231         (catch 'done
 232           ;; get or create the trace buffer
 233           (setq process-buffer
 234                 (get-buffer-create (format "*trace of SMTP session to %s*" host)))
 235
 236           ;; clear the trace buffer of old output
 237           (save-excursion
 238             (set-buffer process-buffer)
 239             (erase-buffer))
 240
 241           ;; open the connection to the server
 242           (setq process (open-network-stream "SMTP" process-buffer host port))
 243           (and (null process) (throw 'done nil))
 244
 245           ;; set the send-filter
 246           (set-process-filter process 'smtpmail-process-filter)
 247
 248           (save-excursion
 249             (set-buffer process-buffer)
 250             (make-local-variable 'smtpmail-read-point)
 251             (setq smtpmail-read-point (point-min))
 252
 253
 254             (if (or (null (car (setq greeting (smtpmail-read-response process))))
 255                     (not (integerp (car greeting)))
 256                     (>= (car greeting) 400))
 257                 (throw 'done nil)
 258               )
 259
 260             ;; HELO
 261             (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn)))
 262
 263             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 264                     (not (integerp (car response-code)))
 265                     (>= (car response-code) 400))
 266                 (throw 'done nil)
 267               )
 268
 269             ;; MAIL FROM: <sender>
 270 ;           (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
 271             (smtpmail-send-command process (format "MAIL FROM: <%s>" user-mail-address))
 272
 273             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 274                     (not (integerp (car response-code)))
 275                     (>= (car response-code) 400))
 276                 (throw 'done nil)
 277               )
 278
 279             ;; RCPT TO: <recipient>
 280             (let ((n 0))
 281               (while (not (null (nth n recipient)))
 282                 (smtpmail-send-command process (format "RCPT TO: <%s>" (nth n recipient)))
 283                 (setq n (1+ n))
 284
 285                 (if (or (null (car (setq response-code (smtpmail-read-response process))))
 286                         (not (integerp (car response-code)))
 287                         (>= (car response-code) 400))
 288                     (throw 'done nil)
 289                   )
 290                 ))
 291
 292             ;; DATA
 293             (smtpmail-send-command process "DATA")
 294
 295             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 296                     (not (integerp (car response-code)))
 297                     (>= (car response-code) 400))
 298                 (throw 'done nil)
 299               )
 300
 301             ;; Mail contents
 302             (smtpmail-send-data process smtpmail-text-buffer)
 303
 304             ;;DATA end "."
 305             (smtpmail-send-command process ".")
 306
 307             (if (or (null (car (setq response-code (smtpmail-read-response process))))
 308                     (not (integerp (car response-code)))
 309                     (>= (car response-code) 400))
 310                 (throw 'done nil)
 311               )
 312
 313             ;;QUIT
 314 ;           (smtpmail-send-command process "QUIT")
 315 ;           (and (null (car (smtpmail-read-response process)))
 316 ;                (throw 'done nil))
 317             t ))
 318       (if process
 319           (save-excursion
 320             (set-buffer (process-buffer process))
 321             (smtpmail-send-command process "QUIT")
 322             (smtpmail-read-response 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             (delete-process process))))))
 330
 331
 332 (defun smtpmail-process-filter (process output)
 333   (save-excursion
 334     (set-buffer (process-buffer process))
 335     (goto-char (point-max))
 336     (insert output)))
 337
 338 (defun smtpmail-read-response (process)
 339   (let ((case-fold-search nil)
 340         (response-string nil)
 341         (response-continue t)
 342         (return-value '(nil ""))
 343         match-end)
 344
 345 ;    (setq response-string nil)
 346 ;    (setq response-continue t)
 347 ;    (setq return-value '(nil ""))
 348
 349     (while response-continue
 350       (goto-char smtpmail-read-point)
 351       (while (not (search-forward "\r\n" nil t))
 352         (accept-process-output process)
 353         (goto-char smtpmail-read-point))
 354
 355       (setq match-end (point))
 356       (if (null response-string)
 357           (setq response-string
 358                 (buffer-substring smtpmail-read-point (- match-end 2))))
 359
 360       (goto-char smtpmail-read-point)
 361       (if (looking-at "[0-9]+ ")
 362           (progn (setq response-continue nil)
 363 ;                (setq return-value response-string)
 364
 365                  (if smtpmail-debug-info
 366                      (message response-string))
 367
 368                  (setq smtpmail-read-point match-end)
 369                  (setq return-value
 370                        (cons (string-to-int
 371                               (buffer-substring (match-beginning 0) (match-end 0)))
 372                              response-string)))
 373
 374         (if (looking-at "[0-9]+-")
 375             (progn (setq smtpmail-read-point match-end)
 376                    (setq response-continue t))
 377           (progn
 378             (setq smtpmail-read-point match-end)
 379             (setq response-continue nil)
 380             (setq return-value
 381                   (cons nil response-string))
 382             )
 383           )))
 384     (setq smtpmail-read-point match-end)
 385     return-value))
 386
 387
 388 (defun smtpmail-send-command (process command)
 389   (goto-char (point-max))
 390   (if (= (aref command 0) ?P)
 391       (insert "PASS <omitted>\r\n")
 392     (insert command "\r\n"))
 393   (setq smtpmail-read-point (point))
 394   (process-send-string process command)
 395   (process-send-string process "\r\n"))
 396
 397 (defun smtpmail-send-data-1 (process data)
 398   (goto-char (point-max))
 399
 400   (if (not (null smtpmail-code-conv-from))
 401       (setq data (code-convert-string data smtpmail-code-conv-from *internal*)))
 402
 403   (if smtpmail-debug-info
 404       (insert data "\r\n"))
 405
 406   (setq smtpmail-read-point (point))
 407   ;; Escape "." at start of a line
 408   (if (eq (string-to-char data) ?.)
 409       (process-send-string process "."))
 410   (process-send-string process data)
 411   (process-send-string process "\r\n")
 412   )
 413
 414 (defun smtpmail-send-data (process buffer)
 415   (let
 416       ((data-continue t)
 417        (sending-data nil)
 418        this-line
 419        this-line-end)
 420
 421     (save-excursion
 422       (set-buffer buffer)
 423       (goto-char (point-min)))
 424
 425     (while data-continue
 426       (save-excursion
 427         (set-buffer buffer)
 428         (beginning-of-line)
 429         (setq this-line (point))
 430         (end-of-line)
 431         (setq this-line-end (point))
 432         (setq sending-data nil)
 433         (setq sending-data (buffer-substring this-line this-line-end))
 434         (if (/= (forward-line 1) 0)
 435             (setq data-continue nil)))
 436
 437       (smtpmail-send-data-1 process sending-data)
 438       )
 439     )
 440   )
 441
 442
 443 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
 444   "Get address list suitable for smtp RCPT TO: <address>."
 445   (require 'mail-utils)  ;; pick up mail-strip-quoted-names
 446   (let
 447       ((case-fold-search t)
 448        (simple-address-list "")
 449        this-line
 450        this-line-end
 451        addr-regexp)
 452
 453     (unwind-protect
 454         (save-excursion
 455           ;;
 456           (set-buffer smtpmail-address-buffer) (erase-buffer)
 457           (insert-buffer-substring smtpmail-text-buffer header-start header-end)
 458           (goto-char (point-min))
 459           ;; RESENT-* fields should stop processing of regular fields.
 460           (save-excursion
 461             (if (re-search-forward "^RESENT-TO:" header-end t)
 462                 (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
 463               (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
 464
 465           (while (re-search-forward addr-regexp header-end t)
 466             (replace-match "")
 467             (setq this-line (match-beginning 0))
 468             (forward-line 1)
 469             ;; get any continuation lines
 470             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 471               (forward-line 1))
 472             (setq this-line-end (point-marker))
 473             (setq simple-address-list
 474                   (concat simple-address-list " "
 475                           (mail-strip-quoted-names (buffer-substring this-line this-line-end))))
 476             )
 477           (erase-buffer)
 478           (insert-string " ")
 479           (insert-string simple-address-list)
 480           (insert-string "\n")
 481           (subst-char-in-region (point-min) (point-max) 10 ?  t);; newline --> blank
 482           (subst-char-in-region (point-min) (point-max) ?, ?  t);; comma   --> blank
 483           (subst-char-in-region (point-min) (point-max)  9 ?  t);; tab     --> blank
 484
 485           (goto-char (point-min))
 486           ;; tidyness in case hook is not robust when it looks at this
 487           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 488
 489           (goto-char (point-min))
 490           (let (recipient-address-list)
 491             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 492               (backward-char 1)
 493               (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
 494                                                  recipient-address-list))
 495               )
 496             (setq smtpmail-recipient-address-list recipient-address-list))
 497
 498           )
 499       )
 500     )
 501   )
 502
 503
 504 (defun smtpmail-do-bcc (header-end)
 505   "Delete BCC: and their continuation lines from the header area.
 506 There may be multiple BCC: lines, and each may have arbitrarily
 507 many continuation lines."
 508   (let ((case-fold-search t))
 509         (save-excursion (goto-char (point-min))
 510           ;; iterate over all BCC: lines
 511           (while (re-search-forward "^BCC:" header-end t)
 512                 (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
 513                 ;; get rid of any continuation lines
 514                 (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
 515                   (replace-match ""))
 516                 )
 517           ) ;; save-excursion
 518         ) ;; let
 519   )
 520
 521
 522
 523 (provide 'smtpmail)
 524
 525 ;; smtpmail.el ends here