head 1.5; access; symbols pkgsrc-2013Q2:1.5.0.26 pkgsrc-2013Q2-base:1.5 pkgsrc-2012Q4:1.5.0.24 pkgsrc-2012Q4-base:1.5 pkgsrc-2011Q4:1.5.0.22 pkgsrc-2011Q4-base:1.5 pkgsrc-2011Q2:1.5.0.20 pkgsrc-2011Q2-base:1.5 pkgsrc-2009Q4:1.5.0.18 pkgsrc-2009Q4-base:1.5 pkgsrc-2008Q4:1.5.0.16 pkgsrc-2008Q4-base:1.5 pkgsrc-2008Q3:1.5.0.14 pkgsrc-2008Q3-base:1.5 cube-native-xorg:1.5.0.12 cube-native-xorg-base:1.5 pkgsrc-2008Q2:1.5.0.10 pkgsrc-2008Q2-base:1.5 pkgsrc-2008Q1:1.5.0.8 pkgsrc-2008Q1-base:1.5 pkgsrc-2007Q4:1.5.0.6 pkgsrc-2007Q4-base:1.5 pkgsrc-2007Q3:1.5.0.4 pkgsrc-2007Q3-base:1.5 pkgsrc-2007Q2:1.5.0.2 pkgsrc-2007Q2-base:1.5 pkgsrc-2007Q1:1.4.0.2 pkgsrc-2007Q1-base:1.4 pkgsrc-2006Q4:1.3.0.26 pkgsrc-2006Q4-base:1.3 pkgsrc-2006Q3:1.3.0.24 pkgsrc-2006Q3-base:1.3 pkgsrc-2006Q2:1.3.0.22 pkgsrc-2006Q2-base:1.3 pkgsrc-2006Q1:1.3.0.20 pkgsrc-2006Q1-base:1.3 pkgsrc-2005Q4:1.3.0.18 pkgsrc-2005Q4-base:1.3 pkgsrc-2005Q3:1.3.0.16 pkgsrc-2005Q3-base:1.3 pkgsrc-2005Q2:1.3.0.14 pkgsrc-2005Q2-base:1.3 pkgsrc-2005Q1:1.3.0.12 pkgsrc-2005Q1-base:1.3 pkgsrc-2004Q4:1.3.0.10 pkgsrc-2004Q4-base:1.3 pkgsrc-2004Q3:1.3.0.8 pkgsrc-2004Q3-base:1.3 pkgsrc-2004Q2:1.3.0.6 pkgsrc-2004Q2-base:1.3 pkgsrc-2004Q1:1.3.0.4 pkgsrc-2004Q1-base:1.3 pkgsrc-2003Q4:1.3.0.2 pkgsrc-2003Q4-base:1.3 buildlink2-base:1.3 comdex-fall-1999:1.2 netbsd-1-4-PATCH001:1.2 netbsd-1-4-RELEASE:1.2; locks; strict; comment @# @; 1.5 date 2007.06.11.13.57.21; author markd; state dead; branches; next 1.4; 1.4 date 2007.01.25.20.59.15; author markd; state Exp; branches; next 1.3; 1.3 date 99.12.28.14.09.17; author tron; state dead; branches; next 1.2; 1.2 date 99.02.25.18.00.29; author sommerfe; state Exp; branches; next 1.1; 1.1 date 99.02.25.17.08.34; author sommerfe; state Exp; branches; next ; desc @@ 1.5 log @Update emacs{,-nox11} to 22.1. update based in part on wip/emacs-current and wip/emacs22 packages. Many many changes since 21.4a. Read NEWS file for details. @ text @$NetBSD: patch-bb,v 1.4 2007/01/25 20:59:15 markd Exp $ --- lisp/mail/smtpmail.el.orig 2006-09-02 00:23:45.000000000 +0300 +++ lisp/mail/smtpmail.el @@@@ -1,12 +1,15 @@@@ ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -;; Copyright (C) 1995, 1996, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani -;; Maintainer: Brian D. Carlstrom +;; Maintainer: Simon Josefsson +;; w32 Maintainer: Brian D. Carlstrom ;; ESMTP support: Simon Leinen ;; Hacked by Mike Taylor, 11th October 1999 to add support for ;; automatically appending a domain to RCPT TO: addresses. +;; AUTH=LOGIN support: Stephen Cranefield ;; Keywords: mail ;; This file is part of GNU Emacs. @@@@ -23,8 +26,8 @@@@ ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@@@ -33,20 +36,48 @@@@ ;; Please add these lines in your .emacs(_emacs) or use customize. ;; ;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail' -;;(setq message-send-mail-function 'smtpmail-send-it) ; if you are using Gnus. +;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") ;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME") ;;(setq smtpmail-debug-info t) ; only to debug problems +;;(setq smtpmail-auth-credentials ; or use ~/.authinfo +;; '(("YOUR SMTP HOST" 25 "username" "password"))) +;;(setq smtpmail-starttls-credentials +;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert"))) +;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an +;; integer or a string, just as long as they match (eq). ;; To queue mail, set smtpmail-queue-mail to t and use ;; smtpmail-send-queued-mail to send. +;; Modified by Stephen Cranefield , +;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism. +;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html +;; Rewritten by Simon Josefsson to use same credential variable as AUTH +;; support below. + +;; Modified by Simon Josefsson , 22/2/99, to support SMTP +;; Authentication by the AUTH mechanism. +;; See http://www.ietf.org/rfc/rfc2554.txt + +;; Modified by Simon Josefsson , 2000-10-07, to support +;; STARTTLS. Requires external program +;; ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz. +;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2487.txt ;;; Code: (require 'sendmail) -(require 'time-stamp) +(autoload 'starttls-open-stream "starttls") +(autoload 'starttls-negotiate "starttls") +(autoload 'mail-strip-quoted-names "mail-utils") +(autoload 'message-make-date "message") +(autoload 'message-make-message-id "message") +(autoload 'rfc2104-hash "rfc2104") +(autoload 'netrc-parse "netrc") +(autoload 'netrc-machine "netrc") +(autoload 'netrc-get "netrc") ;;; (defgroup smtpmail nil @@@@ -55,7 +86,8 @@@@ (defcustom smtpmail-default-smtp-server nil - "*Specify default SMTP server." + "*Specify default SMTP server. +This only has effect if you specify it before loading the smtpmail library." :type '(choice (const nil) string) :group 'smtpmail) @@@@ -66,8 +98,9 @@@@ :group 'smtpmail) (defcustom smtpmail-smtp-service 25 - "*SMTP service port number. smtp or 25 ." - :type 'integer + "*SMTP service port number. +The default value would be \"smtp\" or 25 ." + :type '(choice (integer :tag "Port") (string :tag "Service")) :group 'smtpmail) (defcustom smtpmail-local-domain nil @@@@ -94,7 +127,15 @@@@ buffer includes an exchange like: :group 'smtpmail) (defcustom smtpmail-debug-info nil - "*smtpmail debug info printout. messages and process buffer." + "Whether to print info in buffer *trace of SMTP session to *. +See also `smtpmail-debug-verb' which determines if the SMTP protocol should +be verbose as well." + :type 'boolean + :group 'smtpmail) + +(defcustom smtpmail-debug-verb nil + "Whether this library sends the SMTP VERB command or not. +The commands enables verbose information from the SMTP server." :type 'boolean :group 'smtpmail) @@@@ -115,6 +156,34 @@@@ and sent with `smtpmail-send-queued-mail :type 'directory :group 'smtpmail) +(defcustom smtpmail-auth-credentials "~/.authinfo" + "Specify username and password for servers, directly or via .netrc file. +This variable can either be a filename pointing to a file in netrc(5) +format, or list of four-element lists that contain, in order, +`servername' (a string), `port' (an integer), `user' (a string) and +`password' (a string, or nil to query the user when needed). If you +need to enter a `realm' too, add it to the user string, so that it +looks like `user@@realm'." + :type '(choice file + (repeat (list (string :tag "Server") + (integer :tag "Port") + (string :tag "Username") + (choice (const :tag "Query when needed" nil) + (string :tag "Password"))))) + :version "22.1" + :group 'smtpmail) + +(defcustom smtpmail-starttls-credentials '(("" 25 "" "")) + "Specify STARTTLS keys and certificates for servers. +This is a list of four-element list with `servername' (a string), +`port' (an integer), `key' (a filename) and `certificate' (a filename)." + :type '(repeat (list (string :tag "Server") + (integer :tag "Port") + (file :tag "Key") + (file :tag "Certificate"))) + :version "21.1" + :group 'smtpmail) + (defcustom smtpmail-warn-about-unknown-extensions nil "*If set, print warnings about unknown SMTP extensions. This is mainly useful for development purposes, to learn about @@@@ -130,19 +199,26 @@@@ This is relative to `smtpmail-queue-dir' (defvar smtpmail-address-buffer) (defvar smtpmail-recipient-address-list) +(defvar smtpmail-queue-counter 0) + ;; Buffer-local variable. (defvar smtpmail-read-point) (defvar smtpmail-queue-index (concat smtpmail-queue-dir smtpmail-queue-index-file)) +(defconst smtpmail-auth-supported '(cram-md5 plain login) + "List of supported SMTP AUTH mechanisms.") + ;;; ;;; ;;; +(defvar smtpmail-mail-address nil + "Value to use for envelope-from address for mail from ambient buffer.") + ;;;###autoload (defun smtpmail-send-it () - (require 'mail-utils) (let ((errbuf (if mail-interactive (generate-new-buffer " smtpmail errors") 0)) @@@@ -150,6 +226,11 @@@@ This is relative to `smtpmail-queue-dir' (case-fold-search nil) delimline (mailbuf (current-buffer)) + ;; Examine this variable now, so that + ;; local binding in the mail buffer will take effect. + (smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + user-mail-address)) (smtpmail-code-conv-from (if enable-multibyte-characters (let ((sendmail-coding-system smtpmail-code-conv-from)) @@@@ -190,7 +271,7 @@@@ This is relative to `smtpmail-queue-dir' ;; they put one in themselves. (goto-char (point-min)) (if (not (re-search-forward "^From:" delimline t)) - (let* ((login user-mail-address) + (let* ((login smtpmail-mail-address) (fullname (user-full-name))) (cond ((eq mail-from-style 'angles) (insert "From: " fullname) @@@@ -232,6 +313,14 @@@@ This is relative to `smtpmail-queue-dir' (insert ")\n")) ((null mail-from-style) (insert "From: " login "\n"))))) + ;; Insert a `Message-Id:' field if there isn't one yet. + (goto-char (point-min)) + (unless (re-search-forward "^Message-Id:" delimline t) + (insert "Message-Id: " (message-make-message-id) "\n")) + ;; Insert a `Date:' field if there isn't one yet. + (goto-char (point-min)) + (unless (re-search-forward "^Date:" delimline t) + (insert "Date: " (message-make-date) "\n")) ;; Insert an extra newline if we need it to work around ;; Sun's bug that swallows newlines. (goto-char (1+ delimline)) @@@@ -242,8 +331,7 @@@@ This is relative to `smtpmail-queue-dir' (if (re-search-forward "^FCC:" delimline t) (mail-do-fcc delimline)) (if mail-interactive - (save-excursion - (set-buffer errbuf) + (with-current-buffer errbuf (erase-buffer)))) ;; ;; @@@@ -261,19 +349,23 @@@@ This is relative to `smtpmail-queue-dir' smtpmail-recipient-address-list tembuf)) (error "Sending failed; SMTP protocol error")) (error "Sending failed; no recipients")) - (let* ((file-data (concat - smtpmail-queue-dir - (concat (time-stamp-yyyy-mm-dd) - "_" (time-stamp-hh:mm:ss)))) - (file-data (convert-standard-filename file-data)) - (file-elisp (concat file-data ".el")) + (let* ((file-data + (expand-file-name + (format "%s_%i" + (format-time-string "%Y-%m-%d_%H:%M:%S") + (setq smtpmail-queue-counter + (1+ smtpmail-queue-counter))) + smtpmail-queue-dir)) + (file-data (convert-standard-filename file-data)) + (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) + (unless (file-exists-p smtpmail-queue-dir) + (make-directory smtpmail-queue-dir t)) + (with-current-buffer buffer-data (erase-buffer) - (insert-buffer tembuf) + (insert-buffer-substring tembuf) (write-file file-data) (set-buffer buffer-elisp) (erase-buffer) @@@@ -299,35 +391,33 @@@@ This is relative to `smtpmail-queue-dir' (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) + (with-temp-buffer + ;;; Get index, get first mail, send it, update index, get second + ;;; mail, send it, etc... + (let ((file-msg "")) + (insert-file-contents smtpmail-queue-index) + (goto-char (point-min)) (while (not (eobp)) - (setq file-msg (buffer-substring (point) (save-excursion - (end-of-line) - (point)))) + (setq file-msg (buffer-substring (point) (line-end-position))) (load file-msg) ;; Insert the message literally: it is already encoded as per ;; the MIME headers, and code conversions might guess the ;; encoding wrongly. - (setq tembuf (find-file-noselect file-msg nil t)) - (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp smtpmail-recipient-address-list - tembuf)) - (error "Sending failed; SMTP protocol error")) - (error "Sending failed; no recipients")) + (with-temp-buffer + (let ((coding-system-for-read 'no-conversion)) + (insert-file-contents file-msg)) + (let ((smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + user-mail-address))) + (if (not (null smtpmail-recipient-address-list)) + (if (not (smtpmail-via-smtp smtpmail-recipient-address-list + (current-buffer))) + (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) - ))) + (delete-region (point-at-bol) (point-at-bol 2))) + (write-region (point-min) (point-max) smtpmail-queue-index)))) ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) @@@@ -336,17 +426,175 @@@@ This is relative to `smtpmail-queue-dir' (concat (system-name) "." smtpmail-local-domain) (system-name))) +(defsubst smtpmail-cred-server (cred) + (nth 0 cred)) + +(defsubst smtpmail-cred-port (cred) + (nth 1 cred)) + +(defsubst smtpmail-cred-key (cred) + (nth 2 cred)) + +(defsubst smtpmail-cred-user (cred) + (nth 2 cred)) + +(defsubst smtpmail-cred-cert (cred) + (nth 3 cred)) + +(defsubst smtpmail-cred-passwd (cred) + (nth 3 cred)) + +(defun smtpmail-find-credentials (cred server port) + (catch 'done + (let ((l cred) el) + (while (setq el (pop l)) + (when (and (equal server (smtpmail-cred-server el)) + (equal port (smtpmail-cred-port el))) + (throw 'done el)))))) + (defun smtpmail-maybe-append-domain (recipient) (if (or (not smtpmail-sendto-domain) (string-match "@@" recipient)) recipient (concat recipient "@@" smtpmail-sendto-domain))) +(defun smtpmail-intersection (list1 list2) + (let ((result nil)) + (dolist (el2 list2) + (when (memq el2 list1) + (push el2 result))) + (nreverse result))) + +(defvar starttls-extra-args) +(defvar starttls-extra-arguments) + +(defun smtpmail-open-stream (process-buffer host port) + (let ((cred (smtpmail-find-credentials + smtpmail-starttls-credentials host port))) + (if (null (and cred (condition-case () + (with-no-warnings + (require 'starttls) + (call-process (if starttls-use-gnutls + starttls-gnutls-program + starttls-program))) + (error nil)))) + ;; The normal case. + (open-network-stream "SMTP" process-buffer host port) + (let* ((cred-key (smtpmail-cred-key cred)) + (cred-cert (smtpmail-cred-cert cred)) + (starttls-extra-args + (append + starttls-extra-args + (when (and (stringp cred-key) (stringp cred-cert) + (file-regular-p + (setq cred-key (expand-file-name cred-key))) + (file-regular-p + (setq cred-cert (expand-file-name cred-cert)))) + (list "--key-file" cred-key "--cert-file" cred-cert)))) + (starttls-extra-arguments + (append + starttls-extra-arguments + (when (and (stringp cred-key) (stringp cred-cert) + (file-regular-p + (setq cred-key (expand-file-name cred-key))) + (file-regular-p + (setq cred-cert (expand-file-name cred-cert)))) + (list "--x509keyfile" cred-key "--x509certfile" cred-cert))))) + (starttls-open-stream "SMTP" process-buffer host port))))) + +(defun smtpmail-try-auth-methods (process supported-extensions host port) + (let* ((mechs (cdr-safe (assoc 'auth supported-extensions))) + (mech (car (smtpmail-intersection smtpmail-auth-supported mechs))) + (cred (if (stringp smtpmail-auth-credentials) + (let* ((netrc (netrc-parse smtpmail-auth-credentials)) + (port-name (format "%s" (or port "smtp"))) + (hostentry (netrc-machine netrc host port-name + port-name))) + (when hostentry + (list host port + (netrc-get hostentry "login") + (netrc-get hostentry "password")))) + (smtpmail-find-credentials + smtpmail-auth-credentials host port))) + (passwd (when cred + (or (smtpmail-cred-passwd cred) + (read-passwd + (format "SMTP password for %s:%s: " + (smtpmail-cred-server cred) + (smtpmail-cred-port cred)))))) + ret) + (when (and cred mech) + (cond + ((eq mech 'cram-md5) + (smtpmail-send-command process (upcase (format "AUTH %s" mech))) + (if (or (null (car (setq ret (smtpmail-read-response process)))) + (not (integerp (car ret))) + (>= (car ret) 400)) + (throw 'done nil)) + (when (eq (car ret) 334) + (let* ((challenge (substring (cadr ret) 4)) + (decoded (base64-decode-string challenge)) + (hash (rfc2104-hash 'md5 64 16 passwd decoded)) + (response (concat (smtpmail-cred-user cred) " " hash)) + (encoded (base64-encode-string response))) + (smtpmail-send-command process (format "%s" encoded)) + (if (or (null (car (setq ret (smtpmail-read-response process)))) + (not (integerp (car ret))) + (>= (car ret) 400)) + (throw 'done nil))))) + ((eq mech 'login) + (smtpmail-send-command process "AUTH LOGIN") + (if (or (null (car (setq ret (smtpmail-read-response process)))) + (not (integerp (car ret))) + (>= (car ret) 400)) + (throw 'done nil)) + (smtpmail-send-command + process (base64-encode-string (smtpmail-cred-user cred))) + (if (or (null (car (setq ret (smtpmail-read-response process)))) + (not (integerp (car ret))) + (>= (car ret) 400)) + (throw 'done nil)) + (smtpmail-send-command process (base64-encode-string passwd)) + (if (or (null (car (setq ret (smtpmail-read-response process)))) + (not (integerp (car ret))) + (>= (car ret) 400)) + (throw 'done nil))) + ((eq mech 'plain) + ;; We used to send an empty initial request, and wait for an + ;; empty response, and then send the password, but this + ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this + ;; is not sent if the server did not advertise AUTH PLAIN in + ;; the EHLO response. See RFC 2554 for more info. + (smtpmail-send-command process + (concat "AUTH PLAIN " + (base64-encode-string + (concat "\0" + (smtpmail-cred-user cred) + "\0" + passwd)))) + (if (or (null (car (setq ret (smtpmail-read-response process)))) + (not (integerp (car ret))) + (not (equal (car ret) 235))) + (throw 'done nil))) + + (t + (error "Mechanism %s not implemented" mech))) + ;; Remember the password. + (when (and (not (stringp smtpmail-auth-credentials)) + (null (smtpmail-cred-passwd cred))) + (setcar (cdr (cdr (cdr cred))) passwd))))) + (defun smtpmail-via-smtp (recipient smtpmail-text-buffer) (let ((process nil) (host (or smtpmail-smtp-server (error "`smtpmail-smtp-server' not defined"))) (port smtpmail-smtp-service) + ;; smtpmail-mail-address should be set to the appropriate + ;; buffer-local value by the caller, but in case not: + (envelope-from (or smtpmail-mail-address + (and mail-specify-envelope-from + (mail-envelope-from)) + user-mail-address)) response-code greeting process-buffer @@@@ -358,19 +606,18 @@@@ This is relative to `smtpmail-queue-dir' (get-buffer-create (format "*trace of SMTP session to %s*" host))) ;; clear the trace buffer of old output - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer + (setq buffer-undo-list t) (erase-buffer)) ;; open the connection to the server - (setq process (open-network-stream "SMTP" process-buffer host port)) + (setq process (smtpmail-open-stream process-buffer host port)) (and (null process) (throw 'done nil)) ;; set the send-filter (set-process-filter process 'smtpmail-process-filter) - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) (make-local-variable 'smtpmail-read-point) (setq smtpmail-read-point (point-min)) @@@@ -382,32 +629,58 @@@@ This is relative to `smtpmail-queue-dir' (throw 'done nil) ) + (let ((do-ehlo t) + (do-starttls t)) + (while do-ehlo ;; EHLO (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) - (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (if (or (null (car (setq response-code + (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) (progn ;; HELO - (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn))) + (smtpmail-send-command + process (format "HELO %s" (smtpmail-fqdn))) - (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (if (or (null (car (setq response-code + (smtpmail-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 (car (split-string (substring (car extension-lines) 4) "[ ]")))))) + (dolist (line (cdr (cdr response-code))) + (let ((name (mapcar (lambda (s) (intern (downcase s))) + (split-string (substring line 4) "[ ]")))) + (and (eq (length name) 1) + (setq name (car name))) (and name - (cond ((memq name '(verb xvrb 8bitmime onex xone + (cond ((memq (if (consp name) (car name) name) + '(verb xvrb 8bitmime onex xone expn size dsn etrn - help xusr)) + enhancedstatuscodes + help xusr + auth=login auth starttls)) (setq supported-extensions (cons name supported-extensions))) (smtpmail-warn-about-unknown-extensions - (message "Unknown extension %s" name))))) - (setq extension-lines (cdr extension-lines))))) + (message "Unknown extension %s" name))))))) + + (if (and do-starttls + (smtpmail-find-credentials smtpmail-starttls-credentials host port) + (member 'starttls supported-extensions) + (numberp (process-id process))) + (progn + (smtpmail-send-command process (format "STARTTLS")) + (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil)) + (starttls-negotiate process) + (setq do-starttls nil)) + (setq do-ehlo nil)))) + + (smtpmail-try-auth-methods process supported-extensions host port) (if (or (member 'onex supported-extensions) (member 'xone supported-extensions)) @@@@ -418,7 +691,7 @@@@ This is relative to `smtpmail-queue-dir' (>= (car response-code) 400)) (throw 'done nil)))) - (if (and smtpmail-debug-info + (if (and smtpmail-debug-verb (or (member 'verb supported-extensions) (member 'xvrb supported-extensions))) (progn @@@@ -436,22 +709,17 @@@@ This is relative to `smtpmail-queue-dir' (>= (car response-code) 400)) (throw 'done nil)))) - ;; MAIL FROM: + ;; MAIL FROM: (let ((size-part - (if (member 'size supported-extensions) + (if (or (member 'size supported-extensions) + (assoc 'size supported-extensions)) (format " SIZE=%d" - (save-excursion - (set-buffer smtpmail-text-buffer) + (with-current-buffer smtpmail-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))) + ;; because of CR-LF representation: + (count-lines (point-min) (point-max))))) "")) (body-part (if (member '8bitmime supported-extensions) @@@@ -471,8 +739,8 @@@@ This is relative to `smtpmail-queue-dir' "") ""))) ; (smtpmail-send-command process (format "MAIL FROM:%s@@%s" (user-login-name) (smtpmail-fqdn))) - (smtpmail-send-command process (format "MAIL FROM: <%s>%s%s" - user-mail-address + (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" + envelope-from size-part body-part)) @@@@ -482,10 +750,10 @@@@ This is relative to `smtpmail-queue-dir' (throw 'done nil) )) - ;; RCPT TO: + ;; RCPT TO: (let ((n 0)) (while (not (null (nth n recipient))) - (smtpmail-send-command process (format "RCPT TO: <%s>" (smtpmail-maybe-append-domain (nth n recipient)))) + (smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient)))) (setq n (1+ n)) (setq response-code (smtpmail-read-response process)) @@@@ -523,8 +791,7 @@@@ This is relative to `smtpmail-queue-dir' ; (throw 'done nil)) t )) (if process - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (smtpmail-send-command process "QUIT") (smtpmail-read-response process) @@@@ -533,12 +800,13 @@@@ This is relative to `smtpmail-queue-dir' ; (>= (car response-code) 400)) ; (throw 'done nil) ; ) - (delete-process process)))))) + (delete-process process) + (unless smtpmail-debug-info + (kill-buffer process-buffer))))))) (defun smtpmail-process-filter (process output) - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (goto-char (point-max)) (insert output))) @@@@ -548,49 +816,49 @@@@ This is relative to `smtpmail-queue-dir' (response-continue t) (return-value '(nil ())) match-end) - - (while response-continue - (goto-char smtpmail-read-point) - (while (not (search-forward "\r\n" nil t)) - (accept-process-output process) - (goto-char smtpmail-read-point)) - - (setq match-end (point)) - (setq response-strings - (cons (buffer-substring smtpmail-read-point (- match-end 2)) - response-strings)) - - (goto-char smtpmail-read-point) - (if (looking-at "[0-9]+ ") - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (if smtpmail-debug-info - (message "%s" (car response-strings))) - - (setq smtpmail-read-point match-end) - - ;; ignore lines that start with "0" - (if (looking-at "0[0-9]+ ") - nil + (catch 'done + (while response-continue + (goto-char smtpmail-read-point) + (while (not (search-forward "\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (throw 'done nil)) + (accept-process-output process) + (goto-char smtpmail-read-point)) + + (setq match-end (point)) + (setq response-strings + (cons (buffer-substring smtpmail-read-point (- match-end 2)) + response-strings)) + + (goto-char smtpmail-read-point) + (if (looking-at "[0-9]+ ") + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (if smtpmail-debug-info + (message "%s" (car response-strings))) + + (setq smtpmail-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-number + (buffer-substring begin end)) + (nreverse response-strings))))) + + (if (looking-at "[0-9]+-") + (progn (if smtpmail-debug-info + (message "%s" (car response-strings))) + (setq smtpmail-read-point match-end) + (setq response-continue t)) + (progn + (setq smtpmail-read-point match-end) (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 smtpmail-debug-info - (message "%s" (car response-strings))) - (setq smtpmail-read-point match-end) - (setq response-continue t)) - (progn - (setq smtpmail-read-point match-end) - (setq response-continue nil) - (setq return-value - (cons nil (nreverse response-strings))) - ) - ))) - (setq smtpmail-read-point match-end) + (cons nil (nreverse response-strings))))))) + (setq smtpmail-read-point match-end)) return-value)) @@@@ -623,41 +891,21 @@@@ This is relative to `smtpmail-queue-dir' ) (defun smtpmail-send-data (process buffer) - (let - ((data-continue t) - (sending-data nil) - this-line - this-line-end) - - (save-excursion - (set-buffer buffer) + (let ((data-continue t) sending-data) + (with-current-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 (/= (forward-line 1) 0) - (setq data-continue nil))) - - (smtpmail-send-data-1 process sending-data) - ) - ) - ) - + (with-current-buffer buffer + (setq sending-data (buffer-substring (point-at-bol) (point-at-eol))) + (end-of-line 2) + (setq data-continue (not (eobp)))) + (smtpmail-send-data-1 process sending-data)))) (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO:
." - (require 'mail-utils) ;; pick up mail-strip-quoted-names - (unwind-protect - (save-excursion - (set-buffer smtpmail-address-buffer) (erase-buffer) + (with-current-buffer smtpmail-address-buffer + (erase-buffer) (let ((case-fold-search t) (simple-address-list "") @@@@ -668,9 +916,11 @@@@ This is relative to `smtpmail-queue-dir' (goto-char (point-min)) ;; RESENT-* fields should stop processing of regular fields. (save-excursion - (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" header-end t) - (setq addr-regexp "^Resent-\\(to\\|cc\\|bcc\\):") - (setq addr-regexp "^\\(To:\\|Cc:\\|Bcc:\\)"))) + (setq addr-regexp + (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" + header-end t) + "^Resent-\\(to\\|cc\\|bcc\\):" + "^\\(To:\\|Cc:\\|Bcc:\\)"))) (while (re-search-forward addr-regexp header-end t) (replace-match "") @@@@ -685,9 +935,7 @@@@ This is relative to `smtpmail-queue-dir' (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) ) (erase-buffer) - (insert-string " ") - (insert-string simple-address-list) - (insert-string "\n") + (insert " " simple-address-list "\n") (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank @@@@ -729,4 +977,5 @@@@ many continuation lines." (provide 'smtpmail) +;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 ;;; smtpmail.el ends here @ 1.4 log @Update smtpmail.el to recent CVS version. Requested by Aleksey Cheusov in PR pkg/34455. Bump PKGREVISION. @ text @d1 1 a1 1 $NetBSD$ @ 1.3 log @Update "emacs" package to version 20.5a based on patches supplied by Minoura Makoto in PR pkg/9014. This version fixes several bugs discovered since version 20.3 and support a precompiled user startup file (".emacs.el" and ".emacs.elc"). @ text @d1 1 a1 1 $NetBSD: patch-bb,v 1.2 1999/02/25 18:00:29 sommerfe Exp $ d3 114 a116 13 --- lisp/mail/mh-utils.el.~1~ Thu Feb 25 01:31:26 1999 +++ lisp/mail/mh-utils.el Thu Feb 25 11:21:45 1999 @@@@ -38,12 +38,24 @@@@ (defvar mh-lib nil "Directory containing the MH library. This directory contains, among other things, -the mhl program and the components file.") +the components file.") + +(defvar mh-lib-progs nil + "Directory containing MH helper programs. +This directory contains, among other things, +the mhl program.") d118 9 a126 2 +(defvar mh-nmh-p nil + "Non-nil if nmh is installed on this system instead of MH") d128 53 d182 667 a848 123 (put 'mh-progs 'risky-local-variable t) ;;;###autoload (put 'mh-lib 'risky-local-variable t) +;;;###autoload +(put 'mh-lib-progs 'risky-local-variable t) +;;;###autoload +(put 'mh-nmh-p 'risky-local-variable t) ;;; User preferences: @@@@ -532,7 +544,7 @@@@ (defvar mail-user-agent 'mh-e-user-agent) ;from reporter.el 3.2 (defun mh-find-path () - ;; Set mh-progs and mh-lib. + ;; Set mh-progs, mh-lib, and mh-libs-progs ;; (This step is necessary if MH was installed after this Emacs was dumped.) ;; From profile file, set mh-user-path, mh-draft-folder, ;; mh-unseen-seq, mh-previous-seq, mh-inbox. @@@@ -587,7 +599,8 @@@@ (defun mh-find-progs () "Find the `inc' and `mhl' programs of MH. -Set the `mh-progs' and `mh-lib' variables to the file names." +Set the `mh-progs' and `mh-lib', and `mh-lib-progs' variables to the +directory names." (or (and mh-progs (mh-file-command-p (expand-file-name "inc" mh-progs))) (setq mh-progs (or (mh-path-search exec-path "inc") @@@@ -596,38 +609,53 @@@@ "/usr/bin/mh/" ;Ultrix 4.2 "/usr/new/mh/" ;Ultrix <4.2 "/usr/contrib/mh/bin/" ;BSDI + "/usr/pkg/bin/" ; NetBSD "/usr/local/bin/" ) "inc")))) + (or (null mh-progs) + (let ((mh-base mh-progs)) + (while (let ((dir-name (file-name-nondirectory + (directory-file-name mh-base)))) + (or (string= "mh" dir-name) + (string= "bin" dir-name))) + (setq mh-base + (file-name-directory (directory-file-name mh-base)))) + (or (and mh-lib + (file-exists-p (expand-file-name "components" mh-lib))) + (setq mh-lib + ;; Look for a lib directory roughly parallel to the bin + ;; directory: Strip any trailing `mh' or `bin' path + ;; components, then look for lib/mh or mh/lib. + (or (mh-path-search + (list (expand-file-name "lib/mh" mh-base) + (expand-file-name "etc/nmh" mh-base) ; NetBSD + (expand-file-name "mh/lib" mh-base)) + "components" + 'file-exists-p)))) + (or (and mh-lib-progs + (mh-file-command-p (expand-file-name "mhl" mh-lib-progs))) + (setq mh-lib-progs + (or (mh-path-search + (list (expand-file-name "lib/mh" mh-base) + (expand-file-name "libexec/nmh" mh-base) ; NetBSD + (expand-file-name "mh/lib" mh-base)) + "mhl") + (mh-path-search '("/usr/local/bin/mh/") "mhl") + (mh-path-search exec-path "mhl") ;unlikely + ))))) + (unless (and mh-progs mh-lib mh-lib-progs) + (error "Cannot find the commands `inc' and `mhl' and the file `components'")) + (setq mh-nmh-p (not (null + (or (string-match "nmh" mh-lib-progs) + (string-match "nmh" mh-lib)))))) - (or (and mh-lib (mh-file-command-p (expand-file-name "mhl" mh-lib))) - (null mh-progs) - (setq mh-lib - ;; Look for a lib directory roughly parallel to the bin - ;; directory: Strip any trailing `mh' or `bin' path - ;; components, then look for lib/mh or mh/lib. - (or (let ((mh-base mh-progs)) - (while (let ((dir-name (file-name-nondirectory - (directory-file-name mh-base)))) - (or (string= "mh" dir-name) - (string= "bin" dir-name))) - (setq mh-base - (file-name-directory (directory-file-name mh-base)))) - (mh-path-search - (list (expand-file-name "lib/mh/" mh-base) - (expand-file-name "mh/lib/" mh-base)) - "mhl")) - (mh-path-search '("/usr/local/bin/mh/") "mhl") - (mh-path-search exec-path "mhl") ;unlikely - ))) - (unless (and mh-progs mh-lib) - (error "Cannot find the commands `inc' and `mhl'"))) - -(defun mh-path-search (path file) +(defun mh-path-search (path file &optional func-p) ;; Search PATH, a list of directory names, for FILE. ;; Returns the element of PATH that contains FILE, or nil if not found. (while (and path - (not (mh-file-command-p (expand-file-name file (car path))))) + (not (funcall (or func-p 'mh-file-command-p) + (expand-file-name file (car path))))) (setq path (cdr path))) (car path)) @@@@ -646,7 +674,7 @@@@ ;; mh-exec-cmd will display to the user. ;; The MH 5 version of install-mh might try prompt the user ;; for information, which would fail here. - (mh-exec-cmd (expand-file-name "install-mh" mh-lib) "-auto") + (mh-exec-cmd (expand-file-name "install-mh" mh-lib-progs) "-auto") ;; now try again to read the profile file (erase-buffer) (condition-case err @@@@ -918,7 +946,7 @@@@ (defun mh-exec-lib-cmd-output (command &rest args) ;; Execute MH library command COMMAND with ARGS. ;; Put the output into buffer after point. Set mark after inserted text. - (apply 'mh-exec-cmd-output (expand-file-name command mh-lib) nil args)) + (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args)) d850 1 d852 2 a853 1 (defun mh-handle-process-error (command status) @ 1.2 log @Correct patches (last set didn't apply correctly). @ text @d1 1 a1 1 $NetBSD: patch-bb,v 1.1 1999/02/25 17:08:34 sommerfe Exp $ @ 1.1 log @Fix mh-e's use of nmh (previous patch was insufficient, as nmh is split in three parts, not two; also, repl's interface changed in nmh so reply-to-all was busted) Fix report-emacs-bug. Re-byte-compile patched mh-*.el @ text @d1 1 a1 1 $NetBSD$ d3 2 a4 2 --- mh-utils.el.~1~ Thu Feb 25 01:31:26 1999 +++ mh-utils.el Thu Feb 25 11:21:45 1999 @