From: ichikawa Date: Mon, 29 Jun 1998 07:37:26 +0000 (+0000) Subject: Small change... X-Git-Tag: ichikawa-199811302358~50 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=ddc5d2abd802f4d56406bf2d9aa978e10be92838;p=elisp%2Fgnus.git- Small change... --- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 830e8bf..ff0c5bd 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -107,7 +107,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" + "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-From:\\|X-Sent:" "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." @@ -760,8 +760,8 @@ always hide." from reply-to (ignore-errors (equal - (nth 1 (mail-extract-address-components from)) - (nth 1 (mail-extract-address-components reply-to))))) + (nth 1 (funcall gnus-extract-address-components from)) + (nth 1 (funcall gnus-extract-address-components reply-to))))) (gnus-article-hide-header "reply-to")))) ((eq elem 'date) (let ((date (message-fetch-field "date"))) @@ -3233,20 +3233,22 @@ forbidden in URL encoding." 'gnus-original-article-mode #'gnus-article-header-presentation-method) -(defun gnus-mime-preview-quitting-method () - (if gnus-show-mime - (gnus-article-show-summary) - (mime-preview-kill-buffer) - (delete-other-windows) - (gnus-article-show-summary) - (gnus-summary-select-article nil t) +(defun mime-preview-quitting-method-for-gnus () + (if (not gnus-show-mime) + (mime-preview-kill-buffer)) + (delete-other-windows) + (gnus-article-show-summary) + (if (or (not gnus-show-mime) + (null gnus-have-all-headers)) + (gnus-summary-select-article nil t) )) (set-alist 'mime-raw-representation-type-alist 'gnus-original-article-mode 'binary) (set-alist 'mime-preview-quitting-method-alist - 'gnus-original-article-mode #'gnus-mime-preview-quitting-method) + 'gnus-original-article-mode + #'mime-preview-quitting-method-for-gnus) (defun gnus-following-method (buf) (set-buffer buf) diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el index 21e3c50..5f6fdf6 100644 --- a/lisp/gnus-cache.el +++ b/lisp/gnus-cache.el @@ -181,8 +181,12 @@ 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) - (mail-header-subject headers) - (mail-header-from 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-date headers) (mail-header-id headers) (or (mail-header-references headers) "") diff --git a/lisp/gnus-i18n.el b/lisp/gnus-i18n.el index 3737fb9..78eeb03 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))) )))) - (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) - )))) + (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))))) ;;; @ end diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 0c830cb..0f236e2 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -196,7 +196,7 @@ Thank you for your help in stamping out bugs. (setq message-post-method `(lambda (arg) (gnus-post-method arg ,gnus-newsgroup-name))) - (setq message-newsreader (setq message-mailer (gnus-extended-version))) + (setq message-user-agent (gnus-extended-version)) (message-add-action `(set-window-configuration ,winconf) 'exit 'postpone 'kill) (message-add-action @@ -511,15 +511,32 @@ 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." + "Stringified Gnus version and Emacs version." (interactive) - gnus-version) + (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))) + )) + ))) ;;; diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index be64979..0291690 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -295,8 +295,9 @@ 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 (mail-extract-address-components - from)) + (setq from (downcase (or (cadr + (funcall gnus-extract-address-components + from)) ""))) (or (setq at-idx (string-match "@" from)) (setq at-idx (length from)))) diff --git a/lisp/gnus-soup.el b/lisp/gnus-soup.el index be089bf..0b9b337 100644 --- a/lisp/gnus-soup.el +++ b/lisp/gnus-soup.el @@ -537,8 +537,7 @@ Return whether the unpacking was successful." (search-forward "\n\n") (forward-char -1) (insert mail-header-separator) - (setq message-newsreader (setq message-mailer - (gnus-extended-version))) + (setq message-user-agent (gnus-extended-version)) (cond ((string= (gnus-soup-reply-kind (car replies)) "news") (gnus-message 5 "Sending news message to %s..." diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 1e2ab96..3814d83 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) + header rawtext decoded) ;; overview: [num subject from date id refs chars lines misc] (unwind-protect @@ -3048,10 +3048,22 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (setq header (make-full-mail-header number ; number - (funcall - gnus-unstructured-field-decoder (gnus-nov-field)) ; subject - (funcall - gnus-structured-field-decoder (gnus-nov-field)) ; from + (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)) (gnus-nov-field) ; date (or (gnus-nov-field) (nnheader-generate-fake-message-id)) ; id @@ -4361,6 +4373,7 @@ 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 @@ -4390,15 +4403,27 @@ The resulting hash table is returned, or nil if no Xrefs were found." (progn (goto-char p) (if (search-forward "\nsubject: " nil t) - (funcall - gnus-unstructured-field-decoder (nnheader-header-value)) + (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)) "(none)")) ;; From. (progn (goto-char p) (if (search-forward "\nfrom: " nil t) - (funcall - gnus-structured-field-decoder (nnheader-header-value)) + (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)) "(nobody)")) ;; Date. (progn @@ -5167,12 +5192,17 @@ 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") - (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)) + (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) ) (defun gnus-summary-scroll-down () diff --git a/lisp/gnus.el b/lisp/gnus.el index f87290f..9c09a44 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. -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." + +`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." :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 f761af0..ebeb600 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -3,6 +3,7 @@ ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko +;; Shuhei KOBAYASHI ;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -232,6 +233,47 @@ 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." @@ -302,12 +344,12 @@ If t, use `message-user-organization-file'." :type 'boolean) (defcustom message-included-forward-headers - "^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:" + "^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:" "*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) @@ -378,8 +420,45 @@ 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 use) - (const ask))) + (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))) ;; stuff relating to broken sendmail in MMDF (defcustom message-sendmail-f-is-evil nil @@ -541,8 +620,6 @@ If stringp, use this; if non-nil, use no host name (user name only)." (defvar message-reply-buffer nil) (defvar message-reply-headers nil) -(defvar message-newsreader nil) -(defvar message-mailer nil) (defvar message-sent-message-via nil) (defvar message-checksum nil) (defvar message-send-actions nil @@ -607,6 +684,10 @@ 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 @@ -777,7 +858,10 @@ 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:\\)" content) + (,(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) (1 'message-header-name-face) (2 'message-header-cc-face nil t)) (,(concat "^\\([Ss]ubject:\\)" content) @@ -927,7 +1011,8 @@ 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-shorten-references) + (References . message-fill-header) (X-Mailer) (X-Newsreader)) "Alist used for formatting headers.") @@ -1193,7 +1278,9 @@ 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-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-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) @@ -1254,6 +1341,9 @@ 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] @@ -1276,6 +1366,7 @@ 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) @@ -1329,8 +1420,7 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (setq paragraph-separate paragraph-start) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) - (make-local-variable 'message-newsreader) - (make-local-variable 'message-mailer) + (make-local-variable 'message-user-agent) (make-local-variable 'message-post-method) (make-local-variable 'message-sent-message-via) (setq message-sent-message-via nil) @@ -1400,6 +1490,21 @@ 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) @@ -2014,11 +2119,12 @@ the user from the mailer." (let ((errbuf (if message-interactive (generate-new-buffer " sendmail errors") 0)) - resend-to-addresses delimline) + resend-addresses delimline) (let ((case-fold-search t)) (save-restriction (message-narrow-to-headers) - (setq resend-to-addresses (message-fetch-field "resent-to"))) + ;; XXX: We need to handle Resent-CC/Resent-BCC, too. + (setq resend-addresses (message-fetch-field "resent-to"))) ;; Change header-delimiter to be what sendmail expects. (goto-char (point-min)) (re-search-forward @@ -2058,8 +2164,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-to-addresses - (list resend-to-addresses) + (if resend-addresses + (list resend-addresses) '("-t"))))) (when message-interactive (save-excursion @@ -2077,11 +2183,12 @@ 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 @@ -2134,143 +2241,31 @@ to find out how to use this." (mh-send-letter))) (defun message-send-mail-with-smtp () - "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))))) + "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")))) (defun message-send-news (&optional arg) (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) @@ -2553,7 +2548,7 @@ to find out how to use this." (message-check 'from (let* ((case-fold-search t) (from (message-fetch-field "from")) - (ad (nth 1 (mail-extract-address-components from)))) + (ad (nth 1 (funcall gnus-extract-address-components from)))) (cond ((not from) (message "There is no From line. Posting is denied.") @@ -2730,6 +2725,16 @@ 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) @@ -2826,18 +2831,20 @@ 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 ((from (mail-header-from message-reply-headers)) + (let ((mid (mail-header-message-id message-reply-headers)) + (from (mail-header-from message-reply-headers)) (date (mail-header-date message-reply-headers))) - (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) - "\"")))))) + (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) + ")")))))))) (defun message-make-distribution () "Make a Distribution header." @@ -2941,7 +2948,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 (mail-extract-address-components user-mail-address)) + (nth 1 (funcall gnus-extract-address-components user-mail-address)) user-mail-address))) (defun message-make-fqdn () @@ -3085,13 +3092,15 @@ Headers already prepared in the buffer are not modified." (not (message-check-element 'sender)) (not (string= (downcase - (cadr (mail-extract-address-components from))) + (cadr (funcall gnus-extract-address-components + from))) (downcase secure-sender))) (or (null sender) (not (string= (downcase - (cadr (mail-extract-address-components sender))) + (cadr (funcall gnus-extract-address-components + sender))) (downcase secure-sender))))) (goto-char (point-min)) ;; Rename any old Sender headers to Original-Sender. @@ -3139,14 +3148,12 @@ Headers already prepared in the buffer are not modified." (if (or (= (following-char) ?,) (eobp)) (when (not quoted) - (if (and (> (current-column) 78) - last) - (progn - (save-excursion - (goto-char last) - (insert "\n\t")) - (setq last (1+ (point)))) - (setq last (1+ (point))))) + (if last + (save-excursion + (goto-char last) + (looking-at "[ \t]*") + (replace-match "\n " t t))) + (setq last (1+ (point)))) (setq quoted (not quoted))) (unless (eobp) (forward-char 1)))) @@ -3154,17 +3161,10 @@ 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 990) - (fill-prefix "\t")) + (fill-column 78) + (fill-prefix " ")) (insert (capitalize (symbol-name header)) ": " (if (consp value) (car value) value) @@ -3232,7 +3232,7 @@ Headers already prepared in the buffer are not modified." (concat "*" type (if to (concat " to " - (or (car (mail-extract-address-components to)) + (or (car (funcall gnus-extract-address-components to)) to) "") "") (if (and group (not (string= group ""))) (concat " on " group) "") @@ -3391,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) - mct never-mct gnus-warning) + from date subject mct mft mrt + never-mct to cc + references message-id follow-to gnus-warning) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3409,74 +3409,121 @@ 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") + date (message-fetch-field "date" t) 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 (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)) + 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))) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) - - (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)))))) + (setq subject (message-make-followup-subject 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 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))))))) + (message-pop-to-buffer (message-buffer-name (if wide "wide reply" "reply") from (if wide to-address nil))) @@ -3489,8 +3536,7 @@ Headers already prepared in the buffer are not modified." ,@follow-to ,@(if (or references message-id) `((References . ,(concat (or references "") (and references " ") - (or message-id "")))) - nil)) + (or message-id "")))))) cur))) ;;;###autoload @@ -3501,37 +3547,41 @@ Headers already prepared in the buffer are not modified." ;;;###autoload (defun message-followup (&optional to-newsgroups) - "Follow up to the message in the current buffer. -If TO-NEWSGROUPS, use that as the new Newsgroups line." + "Follow up to the message in the current buffer." (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 gnus-warning posted-to) + followup-to distribution newsgroups posted-to + references message-id follow-to gnus-warning) (save-restriction - (narrow-to-region - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max))) + (message-narrow-to-head) + ;; Allow customizations to have their say. + ;; This is a followup. (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") + date (message-fetch-field "date" t) subject (or (message-fetch-field "subject") "none") references (message-fetch-field "references") message-id (message-fetch-field "message-id" t) - followup-to (message-fetch-field "followup-to") + followup-to (when message-use-followup-to + (message-fetch-field "followup-to")) + distribution (message-fetch-field "distribution") newsgroups (message-fetch-field "newsgroups") posted-to (message-fetch-field "posted-to") - 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)) + 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)) (setq message-id (match-string 0 gnus-warning))) ;; Remove bogus distribution. (when (and (stringp distribution) @@ -3540,40 +3590,68 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (setq distribution nil)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + (setq subject (message-make-followup-subject subject)) (widen)) - (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 "\ + ;; 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 "\ 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 poster +A typical situation where `Followup-To: poster' is used is when the author does not read the newsgroup, so he wouldn't see any replies sent to it.")) - (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 "\ + (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 "\ You should normally obey the Followup-To: header. `Followup-To: " followup-to "' @@ -3588,27 +3666,46 @@ be fragmented and very difficult to follow. Also, some source/announcement newsgroups are not indented for discussion; responses here are directed to other 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))))) + (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)))))) - cur) + (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) (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 () @@ -3633,9 +3730,10 @@ responses here are directed to other newsgroups.")) (downcase sender) (downcase (message-make-sender)))) (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (cadr (mail-extract-address-components - (message-make-from)))))) + (downcase (cadr (funcall gnus-extract-address-components + from))) + (downcase (cadr (funcall gnus-extract-address-components + (message-make-from)))))) (error "This article is not yours")) ;; Make control message. (setq buf (set-buffer (get-buffer-create " *message cancel*"))) @@ -3669,8 +3767,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 (mail-extract-address-components - (message-fetch-field "from"))))) + (cadr (funcall gnus-extract-address-components + (message-fetch-field "from"))))) (downcase (message-make-sender))) (error "This article is not yours")) ;; Get a normal message buffer. @@ -3822,7 +3920,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 7dde447..bea46d0 100644 --- a/lisp/smtp.el +++ b/lisp/smtp.el @@ -25,6 +25,8 @@ ;;; Code: +(require 'mail-utils) ; pick up mail-strip-quoted-names + (defgroup smtp nil "SMTP protocol for sending mail." :group 'mail) @@ -34,15 +36,20 @@ :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 25 - "*SMTP service port number. smtp or 25 ." - :type 'integer +(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 :group 'smtp) (defcustom smtp-local-domain nil @@ -52,214 +59,178 @@ don't define this value." :type '(choice (const nil) string) :group 'smtp) -(defcustom smtp-debug-info nil - "*smtp debug info printout. messages and process buffer." - :type 'boolean - :group 'smtp) - (defcustom smtp-coding-system 'binary "*Coding-system for SMTP output." :type 'coding-system :group 'smtp) - -(defun smtp-fqdn () - (if smtp-local-domain - (concat (system-name) "." smtp-local-domain) - (system-name))) - -(defun smtp-via-smtp (recipient smtp-text-buffer) - (let ((process nil) - (host smtp-server) - (port smtp-service) - response-code - greeting - process-buffer - (supported-extensions '()) - (coding-system-for-read smtp-coding-system) - (coding-system-for-write smtp-coding-system)) - (unwind-protect - (catch 'done - ;; get or create the trace buffer - (setq process-buffer - (get-buffer-create - (format "*trace of SMTP session to %s*" host))) - - ;; clear the trace buffer of old output - (save-excursion - (set-buffer process-buffer) - (erase-buffer)) - - ;; open the connection to the server - (setq process (open-network-stream "SMTP" process-buffer host port)) - (and (null process) (throw 'done nil)) - - ;; set the send-filter - (set-process-filter process 'smtp-process-filter) - - (save-excursion - (set-buffer process-buffer) - (make-local-variable 'smtp-read-point) - (setq smtp-read-point (point-min)) - - (if (or (null (car (setq greeting (smtp-read-response process)))) - (not (integerp (car greeting))) - (>= (car greeting) 400)) - (throw 'done nil) - ) +(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)))) ;; EHLO - (smtp-send-command process (format "EHLO %s" (smtp-fqdn))) - - (if (or (null (car (setq response-code (smtp-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) + (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)) (progn ;; HELO - (smtp-send-command process (format "HELO %s" (smtp-fqdn))) - - (if (or (null (car (setq response-code (smtp-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil))) - (let ((extension-lines (cdr (cdr response-code)))) + (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)))) (while extension-lines - (let ((name (intern (downcase (substring (car extension-lines) 4))))) - (and name - (cond ((memq name '(verb xvrb 8bitmime onex xone - expn size dsn etrn - help xusr)) - (setq supported-extensions - (cons name supported-extensions))) - (t (message "unknown extension %s" - name))))) + (push (intern (downcase (substring (car extension-lines) 4))) + extensions) (setq extension-lines (cdr extension-lines))))) - (if (or (member 'onex supported-extensions) - (member 'xone supported-extensions)) + ;; ONEX --- One message transaction only (sendmail extension?) + (if (or (memq 'onex extensions) + (memq 'xone extensions)) (progn - (smtp-send-command process (format "ONEX")) - (if (or (null (car (setq response-code (smtp-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil)))) - + (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?) (if (and smtp-debug-info - (or (member 'verb supported-extensions) - (member 'xvrb supported-extensions))) + (or (memq 'verb extensions) + (memq 'xvrb extensions))) (progn - (smtp-send-command process (format "VERB")) - (if (or (null (car (setq response-code (smtp-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil)))) - - (if (member 'xusr supported-extensions) + (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) (progn - (smtp-send-command process (format "XUSR")) - (if (or (null (car (setq response-code (smtp-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil)))) - - ;; MAIL FROM: - (let ((size-part - (if (member 'size supported-extensions) - (format " SIZE=%d" - (save-excursion - (set-buffer smtp-text-buffer) - ;; size estimate: - (+ (- (point-max) (point-min)) - ;; Add one byte for each change-of-line - ;; because or CR-LF representation: - (count-lines (point-min) (point-max)) - ;; For some reason, an empty line is - ;; added to the message. Maybe this - ;; is a bug, but it can't hurt to add - ;; those two bytes anyway: - 2))) - "")) - (body-part - (if (member '8bitmime supported-extensions) - ;; FIXME: - ;; Code should be added here that transforms - ;; the contents of the message buffer into - ;; something the receiving SMTP can handle. - ;; For a receiver that supports 8BITMIME, this - ;; may mean converting BINARY to BASE64, or - ;; adding Content-Transfer-Encoding and the - ;; other MIME headers. The code should also - ;; return an indication of what encoding the - ;; message buffer is now, i.e. ASCII or - ;; 8BITMIME. - (if nil - " BODY=8BITMIME" - "") - ""))) -; (smtp-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtp-fqdn))) - (smtp-send-command process (format "MAIL FROM: <%s>%s%s" - user-mail-address - size-part - body-part)) - - (if (or (null (car (setq response-code (smtp-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - )) - - ;; RCPT TO: - (let ((n 0)) - (while (not (null (nth n recipient))) - (smtp-send-command process (format "RCPT TO: <%s>" (nth n recipient))) - (setq n (1+ n)) - - (setq response-code (smtp-read-response process)) - (if (or (null (car response-code)) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - )) - + (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))))) + ;; DATA (smtp-send-command process "DATA") - - (if (or (null (car (setq response-code (smtp-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response)))) ;; Mail contents (smtp-send-data process smtp-text-buffer) - ;;DATA end "." + ;; DATA end "." (smtp-send-command process ".") - - (if (or (null (car (setq response-code (smtp-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - - ;;QUIT -; (smtp-send-command process "QUIT") -; (and (null (car (smtp-read-response process))) -; (throw 'done nil)) - t )) - (if process - (save-excursion - (set-buffer (process-buffer process)) - (smtp-send-command process "QUIT") - (smtp-read-response process) - -; (if (or (null (car (setq response-code (smtp-read-response process)))) -; (not (integerp (car response-code))) -; (>= (car response-code) 400)) -; (throw 'done nil) -; ) - (delete-process process)))))) + (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))))))) (defun smtp-process-filter (process output) (save-excursion @@ -299,8 +270,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]+-") @@ -311,42 +282,34 @@ 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)) - (if (= (aref command 0) ?P) - (insert "PASS \r\n") - (insert command "\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) @@ -364,14 +327,10 @@ 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:
." - (require 'mail-utils) ;; pick up mail-strip-quoted-names + "Get address list suitable for smtp RCPT TO:
." (let ((case-fold-search t) (simple-address-list "") this-line @@ -383,29 +342,29 @@ don't define this value." ;; (set-buffer smtp-address-buffer) (erase-buffer) - (insert-buffer-substring smtp-text-buffer - header-start header-end) + (insert (save-excursion + (set-buffer smtp-text-buffer) + (buffer-substring-no-properties 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) @@ -415,7 +374,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 @@ -427,30 +386,9 @@ 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)) - )) - -(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 - ) + recipient-address-list))) + recipient-address-list)) + (kill-buffer smtp-address-buffer)))) (provide 'smtp) diff --git a/texi/gnus.texi b/texi/gnus.texi index c64f97e..a303db6 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @setfilename gnus -@settitle Semi-gnus 6.7.7 Manual +@settitle Semi-gnus 6.7.4 Manual @synindex fn cp @synindex vr cp @synindex pg cp @@ -316,7 +316,7 @@ into another language, under the above conditions for modified versions. @tex @titlepage -@title Semi-gnus 6.7.7 Manual +@title Semi-gnus 6.7.4 Manual @author by Lars Magne Ingebrigtsen @page @@ -359,7 +359,7 @@ internationalization/localization and multiscript features based on MULE API. So Semi-gnus does not discriminate various language communities. Oh, if you are a Klingon, please wait Unicode Next Generation. -This manual corresponds to Semi-gnus 6.7.7. +This manual corresponds to Semi-gnus 6.7.4. @end ifinfo