From 90cd1f789d04ff0dcbbec389745542b279324dff Mon Sep 17 00:00:00 2001 From: ichikawa Date: Mon, 29 Jun 1998 08:47:11 +0000 Subject: [PATCH] Huuumm ... Bug Bug Bug Fix... --- ChangeLog | 1 + lisp/gnus-cache.el | 8 +- lisp/gnus-i18n.el | 18 +- lisp/gnus-msg.el | 27 +- lisp/gnus-picon.el | 5 +- lisp/gnus-spec.el | 4 +- lisp/gnus-sum.el | 60 ++--- lisp/gnus.el | 8 +- lisp/message.el | 733 ++++++++++++++++++++++------------------------------ lisp/smtp.el | 430 +++++++++++++++++------------- 10 files changed, 602 insertions(+), 692 deletions(-) diff --git a/ChangeLog b/ChangeLog index aa73f0c..a053395 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,7 @@ 1998-06-29 Tatsuya Ichikawa * lisp/gnus-art.el : Bug fix. + * lisp/gnus-spec.el : Bug fix. 1998-06-29 Tatsuya Ichikawa diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el index 5f6fdf6..21e3c50 100644 --- a/lisp/gnus-cache.el +++ b/lisp/gnus-cache.el @@ -181,12 +181,8 @@ variable to \"^nnml\"." ;; [number subject from date id references chars lines xref] (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n" (mail-header-number headers) - (let ((subject (mail-header-subject headers))) - (or (get-text-property 0 'raw-text subject) - subject)) - (let ((from (mail-header-from headers))) - (or (get-text-property 0 'raw-text from) - from)) + (mail-header-subject headers) + (mail-header-from headers) (mail-header-date headers) (mail-header-id headers) (or (mail-header-references headers) "") diff --git a/lisp/gnus-i18n.el b/lisp/gnus-i18n.el index 78eeb03..3737fb9 100644 --- a/lisp/gnus-i18n.el +++ b/lisp/gnus-i18n.el @@ -76,15 +76,15 @@ It is specified by variable `gnus-newsgroup-default-charset-alist' )) (setq alist (cdr alist))) )))) - (if charset - (progn - (save-excursion - (set-buffer gnus-summary-buffer) - (make-local-variable 'default-mime-charset) - (setq default-mime-charset charset)) - (make-local-variable 'default-mime-charset) - (setq default-mime-charset charset)) - (kill-local-variable 'default-mime-charset))))) + (when charset + (save-excursion + (set-buffer gnus-summary-buffer) + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + ) + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + )))) ;;; @ end diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 3a2f261..0c830cb 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -511,32 +511,15 @@ If SILENT, don't prompt the user." ;; Dummy to avoid byte-compile warning. (defvar nnspool-rejected-article-hook) -(defvar mule-version) (defvar xemacs-codename) +;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might +;;; as well include the Emacs version as well. +;;; The following function works with later GNU Emacs, and XEmacs. (defun gnus-extended-version () - "Stringified Gnus version and Emacs version." + "Stringified gnus version." (interactive) - (concat - "Semi-gnus/" gnus-version-number " " - (cond - ((featurep 'xemacs) - (concat (format "XEmacs/%d.%d" emacs-major-version emacs-minor-version) - ;; XXX: beta? - (if (featurep 'mule) - "-mule") - (if (boundp 'xemacs-codename) - (concat " (" xemacs-codename ")")) - )) - (t - (concat (format "Emacs/%d.%d" emacs-major-version emacs-minor-version) - ;; XXX: unibyte or multibyte - (if (boundp 'mule-version) - (concat " Mule/" mule-version)) - (if (featurep 'meadow) - (concat " " (Meadow-version))) - )) - ))) + gnus-version) ;;; diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index 0291690..be64979 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -295,9 +295,8 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x)) (setq from (mail-fetch-field "from")) - (setq from (downcase (or (cadr - (funcall gnus-extract-address-components - from)) + (setq from (downcase (or (cadr (mail-extract-address-components + from)) ""))) (or (setq at-idx (string-match "@" from)) (setq at-idx (length from)))) diff --git a/lisp/gnus-spec.el b/lisp/gnus-spec.el index 9163180..4f3a103 100644 --- a/lisp/gnus-spec.el +++ b/lisp/gnus-spec.el @@ -239,8 +239,8 @@ (defun gnus-face-face-function (form type) `(gnus-add-text-properties (point) (progn ,@form (point)) - '(gnus-face t - face ',(symbol-value (intern (format "gnus-face-%d" type)))))) + (list 'gnus-face t + 'face ',(symbol-value (intern (format "gnus-face-%d" type)))))) (defun gnus-tilde-max-form (el max-width) "Return a form that limits EL to MAX-WIDTH." diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 3814d83..1e2ab96 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -3036,7 +3036,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (defsubst gnus-nov-parse-line (number dependencies &optional force-new) (let ((eol (gnus-point-at-eol)) (buffer (current-buffer)) - header rawtext decoded) + header) ;; overview: [num subject from date id refs chars lines misc] (unwind-protect @@ -3048,22 +3048,10 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (setq header (make-full-mail-header number ; number - (progn - (setq rawtext (gnus-nov-field) ; subject - decoded (funcall - gnus-unstructured-field-decoder rawtext)) - (if (string= rawtext decoded) - rawtext - (put-text-property 0 (length decoded) 'raw-text rawtext decoded) - decoded)) - (progn - (setq rawtext (gnus-nov-field) ; from - decoded (funcall - gnus-structured-field-decoder rawtext)) - (if (string= rawtext decoded) - rawtext - (put-text-property 0 (length decoded) 'raw-text rawtext decoded) - decoded)) + (funcall + gnus-unstructured-field-decoder (gnus-nov-field)) ; subject + (funcall + gnus-structured-field-decoder (gnus-nov-field)) ; from (gnus-nov-field) ; date (or (gnus-nov-field) (nnheader-generate-fake-message-id)) ; id @@ -4373,7 +4361,6 @@ The resulting hash table is returned, or nil if no Xrefs were found." (subst-char-in-region (point-min) (point-max) ?\t ? t) (gnus-run-hooks 'gnus-parse-headers-hook) (let ((case-fold-search t) - rawtext decoded in-reply-to header p lines chars) (goto-char (point-min)) ;; Search to the beginning of the next header. Error messages @@ -4403,27 +4390,15 @@ The resulting hash table is returned, or nil if no Xrefs were found." (progn (goto-char p) (if (search-forward "\nsubject: " nil t) - (progn - (setq rawtext (nnheader-header-value) - decoded (funcall - gnus-unstructured-field-decoder rawtext)) - (if (string-equal rawtext decoded) - rawtext - (put-text-property 0 (length decoded) 'raw-text rawtext decoded) - decoded)) + (funcall + gnus-unstructured-field-decoder (nnheader-header-value)) "(none)")) ;; From. (progn (goto-char p) (if (search-forward "\nfrom: " nil t) - (progn - (setq rawtext (nnheader-header-value) - decoded (funcall - gnus-structured-field-decoder rawtext)) - (if (string-equal rawtext decoded) - rawtext - (put-text-property 0 (length decoded) 'raw-text rawtext decoded) - decoded)) + (funcall + gnus-structured-field-decoder (nnheader-header-value)) "(nobody)")) ;; Date. (progn @@ -5192,17 +5167,12 @@ The state which existed when entering the ephemeral is reset." (defun gnus-summary-preview-mime-message (arg) "MIME decode and play this message." (interactive "P") - (let ((gnus-break-pages nil)) - (gnus-summary-select-article t t) - ) - (pop-to-buffer gnus-original-article-buffer t) - (let (buffer-read-only) - (if (text-property-any (point-min) (point-max) 'invisible t) - (remove-text-properties (point-min) (point-max) - gnus-hidden-properties) - )) - (mime-view-mode nil nil nil gnus-original-article-buffer - gnus-article-buffer) + (or gnus-show-mime + (let ((gnus-break-pages nil) + (gnus-show-mime t)) + (gnus-summary-select-article t t) + )) + (select-window (get-buffer-window gnus-article-buffer)) ) (defun gnus-summary-scroll-down () diff --git a/lisp/gnus.el b/lisp/gnus.el index 9c09a44..f87290f 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -1102,10 +1102,10 @@ commands will still require prompting." (defcustom gnus-extract-address-components 'gnus-extract-address-components "*Function for extracting address components from a From header. - -`gnus-extract-address-components' is a quite fast, and too simplistic. -`mail-extract-address-components' works much better, but is slower. -`std11-extract-address-components' also works better, and less slower." +Two pre-defined function exist: `gnus-extract-address-components', +which is the default, quite fast, and too simplistic solution, and +`mail-extract-address-components', which works much better, but is +slower." :group 'gnus-summary-format :type '(radio (function-item gnus-extract-address-components) (function-item mail-extract-address-components) diff --git a/lisp/message.el b/lisp/message.el index abfb752..f761af0 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -3,7 +3,6 @@ ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko -;; Shuhei KOBAYASHI ;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -233,47 +232,6 @@ any confusion." :group 'message-various :type 'regexp) -;;; Some sender agents encode the whole subject including leading "Re: ". -;;; And if followup agent does not decode it for some reason (e.g. unknown -;;; charset) and just add a new "Re: " in front of the encoded-word, the -;;; result will contain multiple "Re: "'s. -(defcustom message-subject-encoded-re-regexp - (concat - "^[ \t]*" - (regexp-quote "=?") - "[-!#$%&'*+0-9A-Z^_`a-z{|}~]+" ; charset - (regexp-quote "?") - "\\(" - "[Bb]" (regexp-quote "?") ; B encoding - "\\(\\(CQk\\|CSA\\|IAk\\|ICA\\)[Jg]\\)*" ; \([ \t][ \t][ \t]\)* - "\\(" - "[Uc][km]U6" ; [Rr][Ee]: - "\\|" - "\\(C[VX]\\|I[FH]\\)J[Fl]O[g-v]" ; [ \t][Rr][Ee]: - "\\|" - "\\(CQl\\|CSB\\|IAl\\|ICB\\)[Sy][RZ]T[o-r]" ; [ \t][ \t][Rr][Ee]: - "\\)" - "\\|" - "[Qb]" (regexp-quote "?") ; Q encoding - "\\(_\\|=09\\|=20\\)*" - "\\([Rr]\\|=[57]2\\)\\([Ee]\\|=[46]5\\)\\(:\\|=3[Aa]\\)" - "\\)" - ) - "*Regexp matching \"Re: \" in the subject line. -Unlike `message-subject-re-regexp', this regexp matches \"Re: \" within -an encoded-word." - :group 'message-various - :type 'regexp) - -(defcustom message-use-subject-re t - "*If t, remove any (buggy) \"Re: \"'s from the subject of the precursor -and add a new \"Re: \". If it is nil, use the subject \"as-is\". If it -is the symbol `guess', try to detect \"Re: \" within an encoded-word." - :group 'message-various - :type '(choice (const :tag "off" nil) - (const :tag "on" t) - (const guess))) - ;;;###autoload (defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." @@ -344,12 +302,12 @@ If t, use `message-user-organization-file'." :type 'boolean) (defcustom message-included-forward-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-\\|^MIME-Version:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" "*Regexp matching headers to be included in forwarded messages." :group 'message-forwarding :type 'regexp) -(defcustom message-ignored-resent-headers "^Return-Receipt" +(defcustom message-ignored-resent-headers "^Return-receipt" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :type 'regexp) @@ -420,45 +378,8 @@ always query the user whether to use the value. If it is the symbol `use', always use the value." :group 'message-interface :type '(choice (const :tag "ignore" nil) - (const :tag "maybe" t) - (const :tag "always" use) - (const :tag "ask" ask))) - -(defcustom message-use-mail-copies-to 'ask - "*Specifies what to do with Mail-Copies-To header. -If nil, always ignore the header. If it is t, use its value, but -query before using the value other than \"always\" or \"never\". -If it is the symbol `ask', always query the user whether to use -the value. If it is the symbol `use', always use the value." - :group 'message-interface - :type '(choice (const :tag "ignore" nil) - (const :tag "maybe" t) - (const :tag "always" use) - (const :tag "ask" ask))) - -(defcustom message-use-mail-followup-to 'ask - "*Specifies what to do with Mail-Followup-To header. -If nil, always ignore the header. If it is the symbol `ask', always -query the user whether to use the value. If it is t or the symbol -`use', always use the value." - :group 'message-interface - :type '(choice (const :tag "ignore" nil) - (const :tag "maybe" t) - (const :tag "always" use) - (const :tag "ask" ask))) - -;;; XXX: 'ask and 'use are not implemented yet. -(defcustom message-use-mail-reply-to 'ask - "*Specifies what to do with Mail-Reply-To/Reply-To header. -If nil, always ignore the header. If it is t or the symbol `use', use -its value. If it is the symbol `ask', always query the user whether to -use the value. Not that if \"Reply-To\" is marked as \"broken\", its value -is never used." - :group 'message-interface - :type '(choice (const :tag "ignore" nil) - (const :tag "maybe" t) - (const :tag "always" use) - (const :tag "ask" ask))) + (const use) + (const ask))) ;; stuff relating to broken sendmail in MMDF (defcustom message-sendmail-f-is-evil nil @@ -686,10 +607,6 @@ actually occur." :group 'message-sending :type 'sexp) -;;; XXX: This symbol is overloaded! See below. -(defvar message-user-agent nil - "String of the form of PRODUCT/VERSION. Used for User-Agent header field.") - ;; Ignore errors in case this is used in Emacs 19. ;; Don't use ignore-errors because this is copied into loaddefs.el. ;;;###autoload @@ -860,10 +777,7 @@ Defaults to `text-mode-abbrev-table'.") `((,(concat "^\\([Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-to-face nil t)) - (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|" - "[Mm]ail-[Cc]opies-[Tt]o:\\|" - "[Mm]ail-[Rr]eply-[Tt]o:\\|" - "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content) + (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-cc-face nil t)) (,(concat "^\\([Ss]ubject:\\)" content) @@ -1013,8 +927,7 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - ;; (References . message-shorten-references) - (References . message-fill-header) + (References . message-shorten-references) (X-Mailer) (X-Newsreader)) "Alist used for formatting headers.") @@ -1280,9 +1193,7 @@ Return the number of headers removed." (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject) - ;; (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) - (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-mail-reply-to) - (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to) + (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) @@ -1343,9 +1254,6 @@ Return the number of headers removed." ["Subject" message-goto-subject t] ["Cc" message-goto-cc t] ["Reply-To" message-goto-reply-to t] - ["Mail-Reply-To" message-goto-mail-reply-to t] - ["Mail-Followup-To" message-goto-mail-followup-to t] - ["Mail-Copies-To" message-goto-mail-copies-to t] ["Summary" message-goto-summary t] ["Keywords" message-goto-keywords t] ["Newsgroups" message-goto-newsgroups t] @@ -1368,7 +1276,6 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution - C-c C-f C-m move to Mail-Followup-To C-c C-f C-f move to Followup-To C-c C-t message-insert-to (add a To header to a news followup) C-c C-n message-insert-newsgroups (add a Newsgroup header to a news reply) @@ -1493,21 +1400,6 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (message-position-on-field "Reply-To" "Subject")) -(defun message-goto-mail-reply-to () - "Move point to the Mail-Reply-To header." - (interactive) - (message-position-on-field "Mail-Reply-To" "Subject")) - -(defun message-goto-mail-followup-to () - "Move point to the Mail-Followup-To header." - (interactive) - (message-position-on-field "Mail-Followup-To" "Subject")) - -(defun message-goto-mail-copies-to () - "Move point to the Mail-Copies-To header." - (interactive) - (message-position-on-field "Mail-Copies-To" "Subject")) - (defun message-goto-newsgroups () "Move point to the Newsgroups header." (interactive) @@ -2122,12 +2014,11 @@ the user from the mailer." (let ((errbuf (if message-interactive (generate-new-buffer " sendmail errors") 0)) - resend-addresses delimline) + resend-to-addresses delimline) (let ((case-fold-search t)) (save-restriction (message-narrow-to-headers) - ;; XXX: We need to handle Resent-CC/Resent-BCC, too. - (setq resend-addresses (message-fetch-field "resent-to"))) + (setq resend-to-addresses (message-fetch-field "resent-to"))) ;; Change header-delimiter to be what sendmail expects. (goto-char (point-min)) (re-search-forward @@ -2167,8 +2058,8 @@ the user from the mailer." ;; We must not do that for a resend ;; because we would find the original addresses. ;; For a resend, include the specific addresses. - (if resend-addresses - (list resend-addresses) + (if resend-to-addresses + (list resend-to-addresses) '("-t"))))) (when message-interactive (save-excursion @@ -2186,12 +2077,11 @@ the user from the mailer." "Pass the prepared message buffer to qmail-inject. Refer to the documentation for the variable `message-send-mail-function' to find out how to use this." - ;; replace the header delimiter with a blank line. + ;; replace the header delimiter with a blank line (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") - (backward-char 1) (run-hooks 'message-send-mail-hook) ;; send the message (case @@ -2244,31 +2134,143 @@ to find out how to use this." (mh-send-letter))) (defun message-send-mail-with-smtp () - "Send off the prepared buffer with SMTP." - (let ((case-fold-search t) - recipients) - (save-restriction - (message-narrow-to-headers) - (setq recipients - ;; XXX: Should be replaced by better one. - (smtp-deduce-address-list (current-buffer) - (point-min) (point-max))) - ;; Remove BCC lines. - (message-remove-header "bcc")) - ;; replace the header delimiter with a blank line. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (run-hooks 'message-send-mail-hook) - (if recipients - (let ((result (smtp-via-smtp user-mail-address - recipients - (current-buffer)))) - (unless (eq result t) - (error "Sending failed; " result))) - (error "Sending failed; no recipients")))) + "Send the prepared message buffer with SMTP." + (require 'smtp) + (let ((errbuf (if mail-interactive + (generate-new-buffer " smtp errors") + 0)) + (case-fold-search nil) + resend-to-addresses + delimline) + (unwind-protect + (save-excursion + (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)) + (run-hooks 'message-send-mail-hook) + ;; (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)))) + ;; + ;; + ;; + (let ((recipient-address-list + (or resend-to-addresses + (smtp-deduce-address-list (current-buffer) + (point-min) delimline)))) + (smtp-do-bcc delimline) + + (if recipient-address-list + (if (not (smtp-via-smtp recipient-address-list + (current-buffer))) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")) + )) + (if (bufferp errbuf) + (kill-buffer errbuf))))) (defun message-send-news (&optional arg) (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) @@ -2551,7 +2553,7 @@ to find out how to use this." (message-check 'from (let* ((case-fold-search t) (from (message-fetch-field "from")) - (ad (nth 1 (funcall gnus-extract-address-components from)))) + (ad (nth 1 (mail-extract-address-components from)))) (cond ((not from) (message "There is no From line. Posting is denied.") @@ -2728,16 +2730,6 @@ to find out how to use this." (timezone-make-date-arpa-standard (current-time-string now) (current-time-zone now)))) -(defun message-make-followup-subject (subject) - "Make a followup Subject." - (cond - ((and (eq message-use-subject-re 'guess) - (string-match message-subject-encoded-re-regexp subject)) - subject) - (message-use-subject-re - (concat "Re: " (message-strip-subject-re subject))) - (t subject))) - (defun message-make-message-id () "Make a unique Message-ID." (concat "<" (message-unique-id) @@ -2834,20 +2826,18 @@ to find out how to use this." (defun message-make-in-reply-to () "Return the In-Reply-To header for this message." (when message-reply-headers - (let ((mid (mail-header-message-id message-reply-headers)) - (from (mail-header-from message-reply-headers)) + (let ((from (mail-header-from message-reply-headers)) (date (mail-header-date message-reply-headers))) - (when mid - (concat mid - (when from - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat "\n (" - (if stop-pos (substring from 0 stop-pos) from) - "'s message of " - (if (or (not date) (string= date "")) - "(unknown date)" date) - ")")))))))) + (when from + (let ((stop-pos + (string-match " *at \\| *@ \\| *(\\| *<" from))) + (concat (if (and stop-pos + (not (zerop stop-pos))) + (substring from 0 stop-pos) from) + "'s message of \"" + (if (or (not date) (string= date "")) + "(unknown date)" date) + "\"")))))) (defun message-make-distribution () "Make a Distribution header." @@ -2951,7 +2941,7 @@ give as trustworthy answer as possible." "Return the pertinent part of `user-mail-address'." (when user-mail-address (if (string-match " " user-mail-address) - (nth 1 (funcall gnus-extract-address-components user-mail-address)) + (nth 1 (mail-extract-address-components user-mail-address)) user-mail-address))) (defun message-make-fqdn () @@ -3095,15 +3085,13 @@ Headers already prepared in the buffer are not modified." (not (message-check-element 'sender)) (not (string= (downcase - (cadr (funcall gnus-extract-address-components - from))) + (cadr (mail-extract-address-components from))) (downcase secure-sender))) (or (null sender) (not (string= (downcase - (cadr (funcall gnus-extract-address-components - sender))) + (cadr (mail-extract-address-components sender))) (downcase secure-sender))))) (goto-char (point-min)) ;; Rename any old Sender headers to Original-Sender. @@ -3151,12 +3139,14 @@ Headers already prepared in the buffer are not modified." (if (or (= (following-char) ?,) (eobp)) (when (not quoted) - (if last - (save-excursion - (goto-char last) - (looking-at "[ \t]*") - (replace-match "\n " t t))) - (setq last (1+ (point)))) + (if (and (> (current-column) 78) + last) + (progn + (save-excursion + (goto-char last) + (insert "\n\t")) + (setq last (1+ (point)))) + (setq last (1+ (point))))) (setq quoted (not quoted))) (unless (eobp) (forward-char 1)))) @@ -3164,10 +3154,17 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(defun message-fill-references (header value) + (insert (capitalize (symbol-name header)) + ": " + (std11-fill-msg-id-list-string + (if (consp value) (car value) value)) + "\n")) + (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 78) - (fill-prefix " ")) + (fill-column 990) + (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " (if (consp value) (car value) value) @@ -3235,7 +3232,7 @@ Headers already prepared in the buffer are not modified." (concat "*" type (if to (concat " to " - (or (car (funcall gnus-extract-address-components to)) + (or (car (mail-extract-address-components to)) to) "") "") (if (and group (not (string= group ""))) (concat " on " group) "") @@ -3394,10 +3391,10 @@ Headers already prepared in the buffer are not modified." "Start editing a reply to the article in the current buffer." (interactive) (let ((cur (current-buffer)) + from subject date reply-to to cc + references message-id follow-to (inhibit-point-motion-hooks t) - from date subject mct mft mrt - never-mct to cc - references message-id follow-to gnus-warning) + mct never-mct gnus-warning) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3412,120 +3409,73 @@ Headers already prepared in the buffer are not modified." (funcall message-wide-reply-to-function))))) ;; Find all relevant headers we need. (setq from (message-fetch-field "from") - date (message-fetch-field "date" t) + date (message-fetch-field "date") subject (or (message-fetch-field "subject") "none") - references (message-fetch-field "references") - message-id (message-fetch-field "message-id" t) to (message-fetch-field "to") cc (message-fetch-field "cc") - mct (when (and wide message-use-mail-copies-to) - (message-fetch-field "mail-copies-to")) - mft (when (and wide message-use-mail-followup-to) - (message-fetch-field "mail-followup-to")) - mrt (when message-use-mail-reply-to - (or (message-fetch-field "mail-reply-to") - (message-fetch-field "reply-to"))) - gnus-warning (message-fetch-field "gnus-warning")) - (when (and gnus-warning (string-match "<[^>]+>" gnus-warning)) - (setq message-id (match-string 0 gnus-warning))) + mct (message-fetch-field "mail-copies-to") + reply-to (message-fetch-field "reply-to") + references (message-fetch-field "references") + message-id (message-fetch-field "message-id" t)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (setq subject (message-make-followup-subject subject)) - (widen)) + (when (string-match message-subject-re-regexp subject) + (setq subject (substring subject (match-end 0)))) + (setq subject (concat "Re: " subject)) - ;; Handle special values of Mail-Copies-To. - (when mct - (cond - ((and (equal (downcase mct) "never") - (or (not (eq message-use-mail-copies-to 'ask)) - (message-y-or-n-p - (concat "Obey Mail-Copies-To: never? ") t "\ -You should normally obey the Mail-Copies-To: header. - - `Mail-Copies-To: never' -directs you not to send your response to the author."))) - (setq never-mct t) - (setq mct nil)) - ((and (equal (downcase mct) "always") - (or (not (eq message-use-mail-copies-to 'ask)) - (message-y-or-n-p - (concat "Obey Mail-Copies-To: always? ") t "\ -You should normally obey the Mail-Copies-To: header. - - `Mail-Copies-To: always' -sends a copy of your response to the author."))) - (setq mct (or mrt from))) - ((and (eq message-use-mail-copies-to 'ask) - (not - (message-y-or-n-p - (concat "Obey Mail-Copies-To: " mct " ? ") t "\ -You should normally obey the Mail-Copies-To: header. - - `Mail-Copies-To: " mct "' -sends a copy of your response to " (if (string-match "," mct) - "the specified addresses" - "that address") "."))) - (setq mct nil)) - )) - - (unless follow-to - (cond - (to-address (setq follow-to (list (cons 'To to-address)))) - ((not wide) (setq follow-to (list (cons 'To (or mrt from))))) - ;; Handle Mail-Followup-To. - ((and mft - (or (not (eq message-use-mail-followup-to 'ask)) - (message-y-or-n-p - (concat "Obey Mail-Followup-To: " mft "? ") t "\ -You should normally obey the Mail-Followup-To: header. - - `Mail-Followup-To: " mft "' -directs your response to " (if (string-match "," mft) - "the specified addresses" - "that address only") ". - -A typical situation where Mail-Followup-To is used is when the author thinks -that further discussion should take place only in " - (if (string-match "," mft) - "the specified mailing lists" - "that mailing list") "."))) - (setq follow-to (list (cons 'To mft))) - (when mct - (push (cons 'Cc mct) follow-to))) - (t - (let (ccalist) - (save-excursion - (message-set-work-buffer) - (unless never-mct - (insert (or mrt from ""))) - (insert (if to (concat (if (bolp) "" ", ") to "") "")) - (insert (if mct (concat (if (bolp) "" ", ") mct) "")) - (insert (if cc (concat (if (bolp) "" ", ") cc) "")) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+" nil t) - (replace-match " " t t)) - ;; Remove addresses that match `rmail-dont-reply-to-names'. - (insert (prog1 (rmail-dont-reply-to (buffer-string)) - (erase-buffer))) - (goto-char (point-min)) - ;; Perhaps Mail-Copies-To: never removed the only address? - (when (eobp) - (insert (or mrt from ""))) - (setq ccalist - (mapcar - (lambda (addr) - (cons (mail-strip-quoted-names addr) addr)) - (message-tokenize-header (buffer-string)))) - (let ((s ccalist)) - (while s - (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) - (setq follow-to (list (cons 'To (cdr (pop ccalist))))) - (when ccalist - (let ((ccs (cons 'Cc (mapconcat - (lambda (addr) (cdr addr)) ccalist ", ")))) - (when (string-match "^ +" (cdr ccs)) - (setcdr ccs (substring (cdr ccs) (match-end 0)))) - (push ccs follow-to))))))) + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) + (setq message-id (match-string 0 gnus-warning))) + + ;; Handle special values of Mail-Copies-To. + (when mct + (cond ((equal (downcase mct) "never") + (setq never-mct t) + (setq mct nil)) + ((equal (downcase mct) "always") + (setq mct (or reply-to from))))) + + (unless follow-to + (if (or (not wide) + to-address) + (progn + (setq follow-to (list (cons 'To (or to-address reply-to from)))) + (when (and wide mct) + (push (cons 'Cc mct) follow-to))) + (let (ccalist) + (save-excursion + (message-set-work-buffer) + (unless never-mct + (insert (or reply-to from ""))) + (insert (if to (concat (if (bolp) "" ", ") to "") "")) + (insert (if mct (concat (if (bolp) "" ", ") mct) "")) + (insert (if cc (concat (if (bolp) "" ", ") cc) "")) + (goto-char (point-min)) + (while (re-search-forward "[ \t]+" nil t) + (replace-match " " t t)) + ;; Remove addresses that match `rmail-dont-reply-to-names'. + (insert (prog1 (rmail-dont-reply-to (buffer-string)) + (erase-buffer))) + (goto-char (point-min)) + ;; Perhaps Mail-Copies-To: never removed the only address? + (when (eobp) + (insert (or reply-to from ""))) + (setq ccalist + (mapcar + (lambda (addr) + (cons (mail-strip-quoted-names addr) addr)) + (message-tokenize-header (buffer-string)))) + (let ((s ccalist)) + (while s + (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) + (setq follow-to (list (cons 'To (cdr (pop ccalist))))) + (when ccalist + (let ((ccs (cons 'Cc (mapconcat + (lambda (addr) (cdr addr)) ccalist ", ")))) + (when (string-match "^ +" (cdr ccs)) + (setcdr ccs (substring (cdr ccs) (match-end 0)))) + (push ccs follow-to)))))) + (widen)) (message-pop-to-buffer (message-buffer-name (if wide "wide reply" "reply") from @@ -3539,7 +3489,8 @@ that further discussion should take place only in " ,@follow-to ,@(if (or references message-id) `((References . ,(concat (or references "") (and references " ") - (or message-id "")))))) + (or message-id "")))) + nil)) cur))) ;;;###autoload @@ -3550,41 +3501,37 @@ that further discussion should take place only in " ;;;###autoload (defun message-followup (&optional to-newsgroups) - "Follow up to the message in the current buffer." + "Follow up to the message in the current buffer. +If TO-NEWSGROUPS, use that as the new Newsgroups line." (interactive) (let ((cur (current-buffer)) + from subject date reply-to mct + references message-id follow-to (inhibit-point-motion-hooks t) - from date subject mct mft mrt (message-this-is-news t) - followup-to distribution newsgroups posted-to - references message-id follow-to gnus-warning) + followup-to distribution newsgroups gnus-warning posted-to) (save-restriction - (message-narrow-to-head) - ;; Allow customizations to have their say. - ;; This is a followup. + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) (when (message-functionp message-followup-to-function) (setq follow-to (funcall message-followup-to-function))) - ;; Find all relevant headers we need. (setq from (message-fetch-field "from") - date (message-fetch-field "date" t) + date (message-fetch-field "date") subject (or (message-fetch-field "subject") "none") references (message-fetch-field "references") message-id (message-fetch-field "message-id" t) - followup-to (when message-use-followup-to - (message-fetch-field "followup-to")) - distribution (message-fetch-field "distribution") + followup-to (message-fetch-field "followup-to") newsgroups (message-fetch-field "newsgroups") posted-to (message-fetch-field "posted-to") - mct (when message-use-mail-copies-to - (message-fetch-field "mail-copies-to")) - mft (when message-use-mail-followup-to - (message-fetch-field "mail-followup-to")) - mrt (when message-use-mail-reply-to - (or (message-fetch-field "mail-reply-to") - (message-fetch-field "reply-to"))) - gnus-warning (message-fetch-field "gnus-warning")) - (when (and gnus-warning (string-match "<[^>]+>" gnus-warning)) + reply-to (message-fetch-field "reply-to") + distribution (message-fetch-field "distribution") + mct (message-fetch-field "mail-copies-to")) + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) ;; Remove bogus distribution. (when (and (stringp distribution) @@ -3593,68 +3540,40 @@ that further discussion should take place only in " (setq distribution nil)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (setq subject (message-make-followup-subject subject)) + (when (string-match message-subject-re-regexp subject) + (setq subject (substring subject (match-end 0)))) + (setq subject (concat "Re: " subject)) (widen)) - ;; Handle special values of Mail-Copies-To. - (when mct - (cond - ((and (equal (downcase mct) "never") - (or (not (eq message-use-mail-copies-to 'ask)) - (message-y-or-n-p - (concat "Obey Mail-Copies-To: never? ") t "\ -You should normally obey the Mail-Copies-To: header. - - `Mail-Copies-To: never' -directs you not to send your response to the author."))) - (setq mct nil)) - ((and (equal (downcase mct) "always") - (or (not (eq message-use-mail-copies-to 'ask)) - (message-y-or-n-p - (concat "Obey Mail-Copies-To: always? ") t "\ -You should normally obey the Mail-Copies-To: header. - - `Mail-Copies-To: always' -sends a copy of your response to the author."))) - (setq mct (or mrt from))) - ((and (eq message-use-mail-copies-to 'ask) - (not - (message-y-or-n-p - (concat "Obey Mail-Copies-To: " mct " ? ") t "\ -You should normally obey the Mail-Copies-To: header. - - `Mail-Copies-To: " mct "' -sends a copy of your response to " (if (string-match "," mct) - "the specified addresses" - "that address") "."))) - (setq mct nil)) - )) - - (unless follow-to - (cond - (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups)))) - ;; Handle Followup-To. - (followup-to - (cond - ((equal (downcase followup-to) "poster") - (if (or (eq message-use-followup-to 'use) - (message-y-or-n-p "Obey Followup-To: poster? " t "\ + (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) + + (message-setup + `((Subject . ,subject) + ,@(cond + (to-newsgroups + (list (cons 'Newsgroups to-newsgroups))) + (follow-to follow-to) + ((and followup-to message-use-followup-to) + (list + (cond + ((equal (downcase followup-to) "poster") + (if (or (eq message-use-followup-to 'use) + (message-y-or-n-p "Obey Followup-To: poster? " t "\ You should normally obey the Followup-To: header. - `Followup-To: poster' -sends your response via e-mail instead of news. +`Followup-To: poster' sends your response via e-mail instead of news. -A typical situation where `Followup-To: poster' is used is when the author +A typical situation where `Followup-To: poster' is used is when the poster does not read the newsgroup, so he wouldn't see any replies sent to it.")) - (setq message-this-is-news nil - distribution nil - follow-to (list (cons 'To (or mrt from "")))) - (setq follow-to (list (cons 'Newsgroups newsgroups))))) - (t - (if (or (equal followup-to newsgroups) - (not (eq message-use-followup-to 'ask)) - (message-y-or-n-p - (concat "Obey Followup-To: " followup-to "? ") t "\ + (progn + (setq message-this-is-news nil) + (cons 'To (or reply-to from ""))) + (cons 'Newsgroups newsgroups))) + (t + (if (or (equal followup-to newsgroups) + (not (eq message-use-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Followup-To: " followup-to "? ") t "\ You should normally obey the Followup-To: header. `Followup-To: " followup-to "' @@ -3669,46 +3588,27 @@ be fragmented and very difficult to follow. Also, some source/announcement newsgroups are not indented for discussion; responses here are directed to other newsgroups.")) - (setq follow-to (list (cons 'Newsgroups followup-to))) - (setq follow-to (list (cons 'Newsgroups newsgroups))))))) - ;; Handle Mail-Followup-To, followup via e-mail. - ((and mft - (or (not (eq message-use-mail-followup-to 'ask)) - (message-y-or-n-p - (concat "Obey Mail-Followup-To: " mft "? ") t "\ -You should normally obey the Mail-Followup-To: header. - - `Mail-Followup-To: " mft "' -directs your response to " (if (string-match "," mft) - "the specified addresses" - "that address only") " instead of news. - -A typical situation where Mail-Followup-To is used is when the author thinks -that further discussion should take place only in " - (if (string-match "," mft) - "the specified mailing lists" - "that mailing list") "."))) - (setq message-this-is-news nil - distribution nil - follow-to (list (cons 'To mft)))) - (posted-to (setq follow-to (list (cons 'Newsgroups posted-to)))) - (t - (setq follow-to (list (cons 'Newsgroups newsgroups)))))) + (cons 'Newsgroups followup-to) + (cons 'Newsgroups newsgroups)))))) + (posted-to + `((Newsgroups . ,posted-to))) + (t + `((Newsgroups . ,newsgroups)))) + ,@(and distribution (list (cons 'Distribution distribution))) + ,@(if (or references message-id) + `((References . ,(concat (or references "") (and references " ") + (or message-id ""))))) + ,@(when (and mct + (not (equal (downcase mct) "never"))) + (list (cons 'Cc (if (equal (downcase mct) "always") + (or reply-to from "") + mct))))) - (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) + cur) (setq message-reply-headers - (vector 0 subject from date message-id references 0 0 "")) + (vector 0 subject from date message-id references 0 0 "")))) - (message-setup - `((Subject . ,subject) - ,@follow-to - ,@(and mct (list (cons 'Cc mct))) - ,@(and distribution (list (cons 'Distribution distribution))) - ,@(if (or references message-id) - `((References . ,(concat (or references "") (and references " ") - (or message-id "")))))) - cur))) ;;;###autoload (defun message-cancel-news () @@ -3733,10 +3633,9 @@ that further discussion should take place only in " (downcase sender) (downcase (message-make-sender)))) (string-equal - (downcase (cadr (funcall gnus-extract-address-components - from))) - (downcase (cadr (funcall gnus-extract-address-components - (message-make-from)))))) + (downcase (cadr (mail-extract-address-components from))) + (downcase (cadr (mail-extract-address-components + (message-make-from)))))) (error "This article is not yours")) ;; Make control message. (setq buf (set-buffer (get-buffer-create " *message cancel*"))) @@ -3770,8 +3669,8 @@ header line with the old Message-ID." ;; Check whether the user owns the article that is to be superseded. (unless (string-equal (downcase (or (message-fetch-field "sender") - (cadr (funcall gnus-extract-address-components - (message-fetch-field "from"))))) + (cadr (mail-extract-address-components + (message-fetch-field "from"))))) (downcase (message-make-sender))) (error "This article is not yours")) ;; Get a normal message buffer. @@ -3923,7 +3822,7 @@ you." (insert-buffer-substring cur) (undo-boundary) (message-narrow-to-head) - (if (and (message-fetch-field "MIME-Version") + (if (and (message-fetch-field "Mime-Version") (setq boundary (message-fetch-field "Content-Type"))) (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary) (setq boundary (concat (match-string 1 boundary) " *\n" diff --git a/lisp/smtp.el b/lisp/smtp.el index bea46d0..7dde447 100644 --- a/lisp/smtp.el +++ b/lisp/smtp.el @@ -25,8 +25,6 @@ ;;; Code: -(require 'mail-utils) ; pick up mail-strip-quoted-names - (defgroup smtp nil "SMTP protocol for sending mail." :group 'mail) @@ -36,20 +34,15 @@ :type '(choice (const nil) string) :group 'smtp) -(defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server) +(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 "smtp" - "*SMTP service port number. \"smtp\" or 25." - :type '(choice (integer :tag "25" 25) - (string :tag "smtp" "smtp")) - :group 'smtp) - -(defcustom smtp-use-8bitmime t - "*If non-nil, use ESMTP 8BITMIME if available." - :type 'boolean +(defcustom smtp-service 25 + "*SMTP service port number. smtp or 25 ." + :type 'integer :group 'smtp) (defcustom smtp-local-domain nil @@ -59,178 +52,214 @@ 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) -(defvar smtp-debug-info nil) -(defvar smtp-read-point nil) - -(defun smtp-make-fqdn () - "Return user's fully qualified domain name." - (let ((system-name (system-name))) - (cond - (smtp-local-domain - (concat system-name "." smtp-local-domain)) - ((string-match "[^.]\\.[^.]" system-name) - system-name) - (t - (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly."))))) - -(defun smtp-via-smtp (sender recipients smtp-text-buffer) - (let ((coding-system-for-read smtp-coding-system) - (coding-system-for-write smtp-coding-system) - process response extensions) - (save-excursion - (set-buffer - (get-buffer-create - (format "*trace of SMTP session to %s*" smtp-server))) - (erase-buffer) - (make-local-variable 'smtp-read-point) - (setq smtp-read-point (point-min)) - - (unwind-protect - (catch 'done - (setq process (open-network-stream "SMTP" - (current-buffer) - smtp-server smtp-service)) - (or process (throw 'done nil)) - - (set-process-filter process 'smtp-process-filter) - - ;; Greeting - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) + +(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-make-fqdn))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) + (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-make-fqdn))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response))))) - (let ((extension-lines (cdr (cdr response)))) + (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 - (push (intern (downcase (substring (car extension-lines) 4))) - extensions) + (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))))) - ;; ONEX --- One message transaction only (sendmail extension?) - (if (or (memq 'onex extensions) - (memq 'xone extensions)) + (if (or (member 'onex supported-extensions) + (member 'xone supported-extensions)) (progn - (smtp-send-command process "ONEX") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; VERB --- Verbose (sendmail extension?) + (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 (memq 'verb extensions) - (memq 'xvrb extensions))) + (or (member 'verb supported-extensions) + (member 'xvrb supported-extensions))) (progn - (smtp-send-command process "VERB") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; XUSR --- Initial (user) submission (sendmail extension?) - (if (memq 'xusr extensions) + (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 "XUSR") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; MAIL FROM: - (smtp-send-command - process - (format "MAIL FROM:<%s>%s%s" - sender - ;; SIZE --- Message Size Declaration (RFC1870) - (if (memq 'size extensions) - (format " SIZE=%d" - (save-excursion - (set-buffer smtp-text-buffer) - (+ (- (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))) - "") - ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652) - (if (and (memq '8bitmime extensions) - smtp-use-8bitmime) - " BODY=8BITMIME" - ""))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - ;; RCPT TO: - (while recipients - (smtp-send-command process - (format "RCPT TO:<%s>" (car recipients))) - (setq recipients (cdr recipients)) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response))))) - + (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") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) + + (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 "." + ;;DATA end "." (smtp-send-command process ".") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - t) - - (if (and process - (eq (process-status process) 'open)) - (progn - ;; QUIT - (smtp-send-command process "QUIT") - (smtp-read-response process) - (delete-process 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 @@ -270,8 +299,8 @@ don't define this value." nil (setq response-continue nil) (setq return-value - (cons (string-to-int - (buffer-substring begin end)) + (cons (string-to-int + (buffer-substring begin end)) (nreverse response-strings))))) (if (looking-at "[0-9]+-") @@ -282,34 +311,42 @@ don't define this value." (progn (setq smtp-read-point match-end) (setq response-continue nil) - (setq return-value - (cons nil (nreverse response-strings))))))) + (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)) - (insert command "\r\n") + (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. + ;; 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")) + (process-send-string process "\r\n") + ) (defun smtp-send-data (process buffer) - (let ((data-continue t) - (sending-data nil) - this-line - this-line-end) + (let + ((data-continue t) + (sending-data nil) + this-line + this-line-end) (save-excursion (set-buffer buffer) @@ -327,10 +364,14 @@ don't define this value." (if (/= (forward-line 1) 0) (setq data-continue nil))) - (smtp-send-data-1 process sending-data)))) + (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:
." + "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 @@ -342,29 +383,29 @@ don't define this value." ;; (set-buffer smtp-address-buffer) (erase-buffer) - (insert (save-excursion - (set-buffer smtp-text-buffer) - (buffer-substring-no-properties header-start header-end))) + (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:\\)"))) + (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. + ;; 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))))) + (buffer-substring this-line this-line-end)))) + ) (erase-buffer) (insert-string " ") (insert-string simple-address-list) @@ -374,7 +415,7 @@ don't define this value." ;; comma --> blank (subst-char-in-region (point-min) (point-max) ?, ? t) ;; tab --> blank - (subst-char-in-region (point-min) (point-max) 9 ? t) + (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 @@ -386,9 +427,30 @@ don't define this value." (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)))) + 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) -- 1.7.10.4