From: morioka Date: Mon, 30 Nov 1998 19:12:53 +0000 (+0000) Subject: Add smtp.el and smtpmail.el (copied from Semi-gnus 6.8). X-Git-Tag: flim-1_12-199811302358~5 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=0b66de14fc7c344fc8dbd6ed4f07f39894b24bbd;p=elisp%2Fflim.git Add smtp.el and smtpmail.el (copied from Semi-gnus 6.8). --- diff --git a/FLIM-ELS b/FLIM-ELS index 44fdc70..d389fa4 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -9,7 +9,8 @@ mel mel-q mel-u mel-g eword-decode eword-encode mime mime-parse mmgeneric mmbuffer mmcooked - mailcap)) + mailcap + smtp smtpmail)) (unless (and (fboundp 'base64-encode-string) (subrp (symbol-function 'base64-encode-string))) diff --git a/smtp.el b/smtp.el new file mode 100644 index 0000000..3d2e113 --- /dev/null +++ b/smtp.el @@ -0,0 +1,457 @@ +;;; smtp.el --- basic functions to send mail with SMTP server + +;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc. + +;; Author: Tomoji Kagatani +;; ESMTP support: Simon Leinen +;; Keywords: SMTP, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(defgroup smtp nil + "SMTP protocol for sending mail." + :group 'mail) + +(defcustom smtp-default-server nil + "*Specify default SMTP server." + :type '(choice (const nil) string) + :group 'smtp) + +(defcustom smtp-server + (or (getenv "SMTPSERVER") smtp-default-server) + "*The name of the host running SMTP server." + :type '(choice (const nil) string) + :group 'smtp) + +(defcustom smtp-service 25 + "*SMTP service port number. smtp or 25 ." + :type 'integer + :group 'smtp) + +(defcustom smtp-local-domain nil + "*Local domain name without a host name. +If the function (system-name) returns the full internet address, +don't define this value." + :type '(choice (const nil) string) + :group 'smtp) + +(defcustom smtp-debug-info nil + "*smtp debug info printout. messages and process buffer." + :type 'boolean + :group 'smtp) + +(defcustom smtp-coding-system 'binary + "*Coding-system for SMTP output." + :type 'coding-system + :group 'smtp) + + +(defun smtp-fqdn () + (if smtp-local-domain + (concat (system-name) "." smtp-local-domain) + (system-name))) + +(defun smtp-via-smtp (recipient smtp-text-buffer) + (let ((process nil) + (host smtp-server) + (port smtp-service) + response-code + greeting + process-buffer + (supported-extensions '()) + (coding-system-for-read smtp-coding-system) + (coding-system-for-write smtp-coding-system)) + (unwind-protect + (catch 'done + ;; get or create the trace buffer + (setq process-buffer + (get-buffer-create + (format "*trace of SMTP session to %s*" host))) + + ;; clear the trace buffer of old output + (save-excursion + (set-buffer process-buffer) + (erase-buffer)) + + ;; open the connection to the server + (setq process (open-network-stream "SMTP" process-buffer host port)) + (and (null process) (throw 'done nil)) + + ;; set the send-filter + (set-process-filter process 'smtp-process-filter) + + (save-excursion + (set-buffer process-buffer) + (make-local-variable 'smtp-read-point) + (setq smtp-read-point (point-min)) + + (if (or (null (car (setq greeting (smtp-read-response process)))) + (not (integerp (car greeting))) + (>= (car greeting) 400)) + (throw 'done nil) + ) + + ;; EHLO + (smtp-send-command process (format "EHLO %s" (smtp-fqdn))) + + (if (or (null (car (setq response-code (smtp-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (progn + ;; HELO + (smtp-send-command process (format "HELO %s" (smtp-fqdn))) + + (if (or (null (car (setq response-code (smtp-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil))) + (let ((extension-lines (cdr (cdr response-code)))) + (while extension-lines + (let ((name (intern (downcase (substring (car extension-lines) 4))))) + (and name + (cond ((memq name '(verb xvrb 8bitmime onex xone + expn size dsn etrn + help xusr)) + (setq supported-extensions + (cons name supported-extensions))) + (t (message "unknown extension %s" + name))))) + (setq extension-lines (cdr extension-lines))))) + + (if (or (member 'onex supported-extensions) + (member 'xone supported-extensions)) + (progn + (smtp-send-command process (format "ONEX")) + (if (or (null (car (setq response-code (smtp-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil)))) + + (if (and smtp-debug-info + (or (member 'verb supported-extensions) + (member 'xvrb supported-extensions))) + (progn + (smtp-send-command process (format "VERB")) + (if (or (null (car (setq response-code (smtp-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil)))) + + (if (member 'xusr supported-extensions) + (progn + (smtp-send-command process (format "XUSR")) + (if (or (null (car (setq response-code (smtp-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil)))) + + ;; MAIL FROM: + (let ((size-part + (if (member 'size supported-extensions) + (format " SIZE=%d" + (save-excursion + (set-buffer smtp-text-buffer) + ;; size estimate: + (+ (- (point-max) (point-min)) + ;; Add one byte for each change-of-line + ;; because or CR-LF representation: + (count-lines (point-min) (point-max)) + ;; For some reason, an empty line is + ;; added to the message. Maybe this + ;; is a bug, but it can't hurt to add + ;; those two bytes anyway: + 2))) + "")) + (body-part + (if (member '8bitmime supported-extensions) + ;; FIXME: + ;; Code should be added here that transforms + ;; the contents of the message buffer into + ;; something the receiving SMTP can handle. + ;; For a receiver that supports 8BITMIME, this + ;; may mean converting BINARY to BASE64, or + ;; adding Content-Transfer-Encoding and the + ;; other MIME headers. The code should also + ;; return an indication of what encoding the + ;; message buffer is now, i.e. ASCII or + ;; 8BITMIME. + (if nil + " BODY=8BITMIME" + "") + ""))) +; (smtp-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtp-fqdn))) + (smtp-send-command process (format "MAIL FROM: <%s>%s%s" + user-mail-address + size-part + body-part)) + + (if (or (null (car (setq response-code (smtp-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + )) + + ;; RCPT TO: + (let ((n 0)) + (while (not (null (nth n recipient))) + (smtp-send-command process (format "RCPT TO: <%s>" (nth n recipient))) + (setq n (1+ n)) + + (setq response-code (smtp-read-response process)) + (if (or (null (car response-code)) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + ) + )) + + ;; DATA + (smtp-send-command process "DATA") + + (if (or (null (car (setq response-code (smtp-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + ) + + ;; Mail contents + (smtp-send-data process smtp-text-buffer) + + ;;DATA end "." + (smtp-send-command process ".") + + (if (or (null (car (setq response-code (smtp-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + ) + + ;;QUIT +; (smtp-send-command process "QUIT") +; (and (null (car (smtp-read-response process))) +; (throw 'done nil)) + t )) + (if process + (save-excursion + (set-buffer (process-buffer process)) + (smtp-send-command process "QUIT") + (smtp-read-response process) + +; (if (or (null (car (setq response-code (smtp-read-response process)))) +; (not (integerp (car response-code))) +; (>= (car response-code) 400)) +; (throw 'done nil) +; ) + (delete-process process)))))) + +(defun smtp-process-filter (process output) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (insert output))) + +(defun smtp-read-response (process) + (let ((case-fold-search nil) + (response-strings nil) + (response-continue t) + (return-value '(nil ())) + match-end) + + (while response-continue + (goto-char smtp-read-point) + (while (not (search-forward "\r\n" nil t)) + (accept-process-output process) + (goto-char smtp-read-point)) + + (setq match-end (point)) + (setq response-strings + (cons (buffer-substring smtp-read-point (- match-end 2)) + response-strings)) + + (goto-char smtp-read-point) + (if (looking-at "[0-9]+ ") + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (if smtp-debug-info + (message "%s" (car response-strings))) + + (setq smtp-read-point match-end) + + ;; ignore lines that start with "0" + (if (looking-at "0[0-9]+ ") + nil + (setq response-continue nil) + (setq return-value + (cons (string-to-int + (buffer-substring begin end)) + (nreverse response-strings))))) + + (if (looking-at "[0-9]+-") + (progn (if smtp-debug-info + (message "%s" (car response-strings))) + (setq smtp-read-point match-end) + (setq response-continue t)) + (progn + (setq smtp-read-point match-end) + (setq response-continue nil) + (setq return-value + (cons nil (nreverse response-strings))) + ) + ))) + (setq smtp-read-point match-end) + return-value)) + +(defun smtp-send-command (process command) + (goto-char (point-max)) + (if (= (aref command 0) ?P) + (insert "PASS \r\n") + (insert command "\r\n")) + (setq smtp-read-point (point)) + (process-send-string process command) + (process-send-string process "\r\n")) + +(defun smtp-send-data-1 (process data) + (goto-char (point-max)) + + (if smtp-debug-info + (insert data "\r\n")) + + (setq smtp-read-point (point)) + ;; Escape "." at start of a line + (if (eq (string-to-char data) ?.) + (process-send-string process ".")) + (process-send-string process data) + (process-send-string process "\r\n") + ) + +(defun smtp-send-data (process buffer) + (let + ((data-continue t) + (sending-data nil) + this-line + this-line-end) + + (save-excursion + (set-buffer buffer) + (goto-char (point-min))) + + (while data-continue + (save-excursion + (set-buffer buffer) + (beginning-of-line) + (setq this-line (point)) + (end-of-line) + (setq this-line-end (point)) + (setq sending-data nil) + (setq sending-data (buffer-substring this-line this-line-end)) + (if (or (/= (forward-line 1) 0) (eobp)) + (setq data-continue nil))) + + (smtp-send-data-1 process sending-data) + ) + ) + ) + +(defun smtp-deduce-address-list (smtp-text-buffer header-start header-end) + "Get address list suitable for smtp RCPT TO:
." + (require 'mail-utils) ;; pick up mail-strip-quoted-names + (let ((case-fold-search t) + (simple-address-list "") + this-line + this-line-end + addr-regexp + (smtp-address-buffer (generate-new-buffer " *smtp-mail*"))) + (unwind-protect + (save-excursion + ;; + (set-buffer smtp-address-buffer) + (erase-buffer) + (insert-buffer-substring smtp-text-buffer + header-start header-end) + (goto-char (point-min)) + ;; RESENT-* fields should stop processing of regular fields. + (save-excursion + (if (re-search-forward "^RESENT-TO:" header-end t) + (setq addr-regexp + "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)") + (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)"))) + + (while (re-search-forward addr-regexp header-end t) + (replace-match "") + (setq this-line (match-beginning 0)) + (forward-line 1) + ;; get any continuation lines + (while (and (looking-at "^[ \t]+") (< (point) header-end)) + (forward-line 1)) + (setq this-line-end (point-marker)) + (setq simple-address-list + (concat simple-address-list " " + (mail-strip-quoted-names + (buffer-substring this-line this-line-end)))) + ) + (erase-buffer) + (insert-string " ") + (insert-string simple-address-list) + (insert-string "\n") + ;; newline --> blank + (subst-char-in-region (point-min) (point-max) 10 ? t) + ;; comma --> blank + (subst-char-in-region (point-min) (point-max) ?, ? t) + ;; tab --> blank + (subst-char-in-region (point-min) (point-max) 9 ? t) + + (goto-char (point-min)) + ;; tidyness in case hook is not robust when it looks at this + (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) + + (goto-char (point-min)) + (let (recipient-address-list) + (while (re-search-forward " \\([^ ]+\\) " (point-max) t) + (backward-char 1) + (setq recipient-address-list + (cons (buffer-substring (match-beginning 1) (match-end 1)) + recipient-address-list)) + ) + recipient-address-list) + ) + (kill-buffer smtp-address-buffer)) + )) + +(defun smtp-do-bcc (header-end) + "Delete BCC: and their continuation lines from the header area. +There may be multiple BCC: lines, and each may have arbitrarily +many continuation lines." + (let ((case-fold-search t)) + (save-excursion + (goto-char (point-min)) + ;; iterate over all BCC: lines + (while (re-search-forward "^BCC:" header-end t) + (delete-region (match-beginning 0) (progn (forward-line 1) (point))) + ;; get rid of any continuation lines + (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) + (replace-match "")) + ) + ) ;; save-excursion + ) ;; let + ) + +(provide 'smtp) + +;;; smtp.el ends here diff --git a/smtpmail.el b/smtpmail.el new file mode 100644 index 0000000..77a5947 --- /dev/null +++ b/smtpmail.el @@ -0,0 +1,285 @@ +;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail + +;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. + +;; Author: Tomoji Kagatani +;; Maintainer: Brian D. Carlstrom +;; ESMTP support: Simon Leinen +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Send Mail to smtp host from smtpmail temp buffer. + +;; Please add these lines in your .emacs(_emacs). +;; +;;(setq send-mail-function 'smtpmail-send-it) +;;(setq smtp-default-server "YOUR SMTP HOST") +;;(setq smtp-service "smtp") +;;(setq smtp-local-domain "YOUR DOMAIN NAME") +;;(setq smtp-debug-info t) +;;(autoload 'smtpmail-send-it "smtpmail") +;;(setq user-full-name "YOUR NAME HERE") + +;; To queue mail, set smtpmail-queue-mail to t and use +;; smtpmail-send-queued-mail to send. + + +;;; Code: + +(require 'smtp) +(require 'sendmail) +(require 'time-stamp) + +;;; + +(defcustom smtpmail-queue-mail nil + "*Specify if mail is queued (if t) or sent immediately (if nil). +If queued, it is stored in the directory `smtpmail-queue-dir' +and sent with `smtpmail-send-queued-mail'." + :type 'boolean + :group 'smtp) + +(defcustom smtpmail-queue-dir "~/Mail/queued-mail/" + "*Directory where `smtpmail.el' stores queued mail." + :type 'directory + :group 'smtp) + +(defvar smtpmail-queue-index-file "index" + "File name of queued mail index, +This is relative to `smtpmail-queue-dir'.") + +(defvar smtpmail-queue-index (concat smtpmail-queue-dir + smtpmail-queue-index-file)) + +(defvar smtpmail-recipient-address-list nil) + + +;;; +;;; +;;; + +(defun smtpmail-send-it () + (require 'mail-utils) + (let ((errbuf (if mail-interactive + (generate-new-buffer " smtpmail errors") + 0)) + (tembuf (generate-new-buffer " smtpmail temp")) + (case-fold-search nil) + resend-to-addresses + delimline + (mailbuf (current-buffer))) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (erase-buffer) + (insert-buffer-substring mailbuf) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) +;; (sendmail-synch-aliases) + (if mail-aliases + (expand-mail-aliases (point-min) delimline)) + (goto-char (point-min)) + ;; ignore any blank lines in the header + (while (and (re-search-forward "\n\n\n*" delimline t) + (< (point) delimline)) + (replace-match "\n")) + (let ((case-fold-search t)) + (goto-char (point-min)) + (goto-char (point-min)) + (while (re-search-forward "^Resent-to:" delimline t) + (setq resend-to-addresses + (save-restriction + (narrow-to-region (point) + (save-excursion + (end-of-line) + (point))) + (append (mail-parse-comma-list) + resend-to-addresses)))) +;;; Apparently this causes a duplicate Sender. +;;; ;; If the From is different than current user, insert Sender. +;;; (goto-char (point-min)) +;;; (and (re-search-forward "^From:" delimline t) +;;; (progn +;;; (require 'mail-utils) +;;; (not (string-equal +;;; (mail-strip-quoted-names +;;; (save-restriction +;;; (narrow-to-region (point-min) delimline) +;;; (mail-fetch-field "From"))) +;;; (user-login-name)))) +;;; (progn +;;; (forward-line 1) +;;; (insert "Sender: " (user-login-name) "\n"))) + ;; Don't send out a blank subject line + (goto-char (point-min)) + (if (re-search-forward "^Subject:[ \t]*\n" delimline t) + (replace-match "")) + ;; Put the "From:" field in unless for some odd reason + ;; they put one in themselves. + (goto-char (point-min)) + (if (not (re-search-forward "^From:" delimline t)) + (let* ((login user-mail-address) + (fullname (user-full-name))) + (cond ((eq mail-from-style 'angles) + (insert "From: " fullname) + (let ((fullname-start (+ (point-min) 6)) + (fullname-end (point-marker))) + (goto-char fullname-start) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" + fullname-end 1) + (progn + ;; Quote fullname, escaping specials. + (goto-char fullname-start) + (insert "\"") + (while (re-search-forward "[\"\\]" + fullname-end 1) + (replace-match "\\\\\\&" t)) + (insert "\"")))) + (insert " <" login ">\n")) + ((eq mail-from-style 'parens) + (insert "From: " login " (") + (let ((fullname-start (point))) + (insert fullname) + (let ((fullname-end (point-marker))) + (goto-char fullname-start) + ;; RFC 822 says \ and nonmatching parentheses + ;; must be escaped in comments. + ;; Escape every instance of ()\ ... + (while (re-search-forward "[()\\]" fullname-end 1) + (replace-match "\\\\\\&" t)) + ;; ... then undo escaping of matching parentheses, + ;; including matching nested parentheses. + (goto-char fullname-start) + (while (re-search-forward + "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" + fullname-end 1) + (replace-match "\\1(\\3)" t) + (goto-char fullname-start)))) + (insert ")\n")) + ((null mail-from-style) + (insert "From: " login "\n"))))) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (if (eval mail-mailer-swallows-blank-line) + (newline)) + ;; Find and handle any FCC fields. + (goto-char (point-min)) + (if (re-search-forward "^FCC:" delimline t) + (mail-do-fcc delimline)) + (if mail-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + ;; + ;; + ;; + (setq smtpmail-recipient-address-list + (or resend-to-addresses + (smtp-deduce-address-list tembuf (point-min) delimline))) + + (smtp-do-bcc delimline) + ; Send or queue + (if (not smtpmail-queue-mail) + (if smtpmail-recipient-address-list + (if (not (smtp-via-smtp + smtpmail-recipient-address-list tembuf)) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")) + (let* ((file-data (concat + smtpmail-queue-dir + (time-stamp-strftime + "%02y%02m%02d-%02H%02M%02S"))) + (file-elisp (concat file-data ".el")) + (buffer-data (create-file-buffer file-data)) + (buffer-elisp (create-file-buffer file-elisp)) + (buffer-scratch "*queue-mail*")) + (save-excursion + (set-buffer buffer-data) + (erase-buffer) + (insert-buffer tembuf) + (write-file file-data) + (set-buffer buffer-elisp) + (erase-buffer) + (insert (concat + "(setq smtpmail-recipient-address-list '" + (prin1-to-string smtpmail-recipient-address-list) + ")\n")) + (write-file file-elisp) + (set-buffer (generate-new-buffer buffer-scratch)) + (insert (concat file-data "\n")) + (append-to-file (point-min) + (point-max) + smtpmail-queue-index) + ) + (kill-buffer buffer-scratch) + (kill-buffer buffer-data) + (kill-buffer buffer-elisp)))) + (kill-buffer tembuf) + (if (bufferp errbuf) + (kill-buffer errbuf))))) + +(defun smtpmail-send-queued-mail () + "Send mail that was queued as a result of setting `smtpmail-queue-mail'." + (interactive) + ;;; Get index, get first mail, send it, get second mail, etc... + (let ((buffer-index (find-file-noselect smtpmail-queue-index)) + (file-msg "") + (tembuf nil)) + (save-excursion + (set-buffer buffer-index) + (beginning-of-buffer) + (while (not (eobp)) + (setq file-msg (buffer-substring (point) (save-excursion + (end-of-line) + (point)))) + (load file-msg) + (setq tembuf (find-file-noselect file-msg)) + (if smtpmail-recipient-address-list + (if (not (smtp-via-smtp smtpmail-recipient-address-list tembuf)) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")) + (delete-file file-msg) + (delete-file (concat file-msg ".el")) + (kill-buffer tembuf) + (kill-line 1)) + (set-buffer buffer-index) + (save-buffer smtpmail-queue-index) + (kill-buffer buffer-index) + ))) + + +;;; + +(provide 'smtpmail) + +;;; smtpmail.el ends here