X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-msg.el;h=b3bb7aad00a053d0618e4c7c12a291f0a5d86859;hb=e405b22c6b46721607c5e6c712a4705c23dee751;hp=562fa2b96320b8243ab7ef035d80b4354b773d98;hpb=4949d2926c37c778e3207a90240960d661711b82;p=gnus diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 562fa2b96..b3bb7aad0 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -1,6 +1,6 @@ ;;; gnus-msg.el --- mail and post interface for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 -;; Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -33,6 +33,7 @@ (require 'gnus-ems) (require 'message) (require 'gnus-art) +(require 'gnus-util) (defcustom gnus-post-method 'current "*Preferred method for posting USENET news. @@ -69,12 +70,13 @@ of names)." (function))) (defcustom gnus-mailing-list-groups nil - "*Regexp matching groups that are really mailing lists. + "*If non-nil a regexp matching groups that are really mailing lists. This is useful when you're reading a mailing list that has been gatewayed to a newsgroup, and you want to followup to an article in the group." :group 'gnus-message - :type 'regexp) + :type '(choice (regexp) + (const nil))) (defcustom gnus-add-to-list nil "*If non-nil, add a `to-list' parameter automatically." @@ -115,6 +117,7 @@ the second with the current group name." "*Alist of styles to use when posting. See Info node `(gnus)Posting Styles'." :group 'gnus-message + :link '(custom-manual "(gnus)Posting Styles") :type '(repeat (cons (choice (regexp) (variable) (list (const header) @@ -139,13 +142,10 @@ See Info node `(gnus)Posting Styles'." (defcustom gnus-gcc-mark-as-read nil "If non-nil, automatically mark Gcc articles as read." - :version "21.1" + :version "22.1" :group 'gnus-message :type 'boolean) -(defvar gnus-inews-mark-gcc-as-read nil - "Obsolete variable. Use `gnus-gcc-mark-as-read' instead.") - (make-obsolete-variable 'gnus-inews-mark-gcc-as-read 'gnus-gcc-mark-as-read) @@ -153,18 +153,25 @@ See Info node `(gnus)Posting Styles'." "Should local-file attachments be included as external parts in Gcc copies? If it is `all', attach files as external parts; if a regexp and matches the Gcc group name, attach files as external parts; -If nil, attach files as normal parts." - :version "21.1" +if nil, attach files as normal parts." + :version "22.1" :group 'gnus-message :type '(choice (const nil :tag "None") (const all :tag "Any") (string :tag "Regexp"))) -(defcustom gnus-group-posting-charset-alist +(gnus-define-group-parameter + posting-charset-alist + :type list + :function-document + "Return the permitted unencoded charsets for posting of GROUP." + :variable gnus-group-posting-charset-alist + :variable-default '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1)) ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r)) (message-this-is-mail nil nil) (message-this-is-news nil t)) + :variable-document "Alist of regexps and permitted unencoded charsets for posting. Each element of the alist has the form (TEST HEADER BODY-LIST), where TEST is either a regular expression matching the newsgroup header or a @@ -177,20 +184,26 @@ nil (always encode using quoted-printable) or t (always use 8bit). Note that any value other than nil for HEADER infringes some RFCs, so use this option with care." - :type '(repeat (list :tag "Permitted unencoded charsets" - (choice :tag "Where" - (regexp :tag "Group") - (const :tag "Mail message" :value message-this-is-mail) - (const :tag "News article" :value message-this-is-news)) - (choice :tag "Header" - (const :tag "None" nil) - (symbol :tag "Charset")) - (choice :tag "Body" - (const :tag "Any" :value t) - (const :tag "None" :value nil) - (repeat :tag "Charsets" - (symbol :tag "Charset"))))) - :group 'gnus-charset) + :variable-group gnus-charset + :variable-type + '(repeat (list :tag "Permitted unencoded charsets" + (choice :tag "Where" + (regexp :tag "Group") + (const :tag "Mail message" :value message-this-is-mail) + (const :tag "News article" :value message-this-is-news)) + (choice :tag "Header" + (const :tag "None" nil) + (symbol :tag "Charset")) + (choice :tag "Body" + (const :tag "Any" :value t) + (const :tag "None" :value nil) + (repeat :tag "Charsets" + (symbol :tag "Charset"))))) + :parameter-type '(choice :tag "Permitted unencoded charsets" + :value nil + (repeat (symbol))) + :parameter-document "\ +List of charsets that are permitted to be unencoded.") (defcustom gnus-debug-files '("gnus.el" "gnus-sum.el" "gnus-group.el" @@ -199,7 +212,7 @@ use this option with care." "gnus-agent.el" "gnus-cache.el" "gnus-srvr.el" "mm-util.el" "mm-decode.el" "nnmail.el" "message.el") "Files whose variables will be reported in `gnus-bug'." - :version "21.1" + :version "22.1" :group 'gnus-message :type '(repeat (string :tag "File"))) @@ -207,7 +220,7 @@ use this option with care." '(mm-mime-mule-charset-alist nnmail-split-fancy message-minibuffer-local-map) "Variables that should not be reported in `gnus-bug'." - :version "21.1" + :version "22.1" :group 'gnus-message :type '(repeat (symbol :tag "Variable"))) @@ -215,27 +228,60 @@ use this option with care." '(nndraft nnml nnimap nnmaildir nnmh nnfolder nndir) "A list of back ends that are not used in \"real\" newsgroups. This variable is used only when `gnus-post-method' is `current'." - :version "21.3" + :version "22.1" :group 'gnus-group-foreign :type '(repeat (symbol :tag "Back end"))) (defcustom gnus-message-replysign nil - "Automatically sign replys to signed messages. + "Automatically sign replies to signed messages. See also the `mml-default-sign-method' variable." :group 'gnus-message :type 'boolean) (defcustom gnus-message-replyencrypt nil - "Automatically encrypt replys to encrypted messages. + "Automatically encrypt replies to encrypted messages. See also the `mml-default-encrypt-method' variable." :group 'gnus-message :type 'boolean) (defcustom gnus-message-replysignencrypted t - "Setting this causes automatically encryped messages to also be signed." + "Setting this causes automatically encrypted messages to also be signed." + :group 'gnus-message + :type 'boolean) + +(defcustom gnus-confirm-mail-reply-to-news gnus-novice-user + "If non-nil, Gnus requests confirmation when replying to news. +This is done because new users often reply by mistake when reading +news. +This can also be a function receiving the group name as the only +parameter which should return non-nil iff a confirmation is needed, or +a regexp, in which case a confirmation is asked for iff the group name +matches the regexp." + :version "22.1" + :group 'gnus-message + :type '(choice (const :tag "No" nil) + (const :tag "Yes" t) + (regexp :tag "Iff group matches regexp") + (function :tag "Iff function evaluates to non-nil"))) + +(defcustom gnus-confirm-treat-mail-like-news + nil + "If non-nil, Gnus will treat mail like news with regard to confirmation +when replying by mail. See the `gnus-confirm-mail-reply-to-news' variable +for fine-tuning this. +If nil, Gnus will never ask for confirmation if replying to mail." + :version "22.1" + :group 'gnus-message + :type 'boolean) + +(defcustom gnus-summary-resend-default-address t + "If non-nil, Gnus tries to suggest a default address to resend to. +If nil, the address field will always be empty after invoking +`gnus-summary-resend-message'." + :version "22.1" :group 'gnus-message :type 'boolean) @@ -244,6 +290,7 @@ See also the `mml-default-encrypt-method' variable." (defvar gnus-inhibit-posting-styles nil "Inhibit the use of posting styles.") +(defvar gnus-article-yanked-articles nil) (defvar gnus-message-buffer "*Mail Gnus*") (defvar gnus-article-copy nil) (defvar gnus-check-before-posting nil) @@ -274,11 +321,7 @@ Thank you for your help in stamping out bugs. ") (eval-and-compile - (autoload 'gnus-uu-post-news "gnus-uu" nil t) - (autoload 'news-setup "rnewspost") - (autoload 'news-reply-mode "rnewspost") - (autoload 'rmail-dont-reply-to "mail-utils") - (autoload 'rmail-output "rmailout")) + (autoload 'gnus-uu-post-news "gnus-uu" nil t)) ;;; @@ -319,15 +362,22 @@ Thank you for your help in stamping out bugs. ;;; Internal functions. +(defun gnus-inews-make-draft (articles) + `(lambda () + (gnus-inews-make-draft-meta-information + ,gnus-newsgroup-name ',articles))) + (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) (let ((winconf (make-symbol "gnus-setup-message-winconf")) (buffer (make-symbol "gnus-setup-message-buffer")) (article (make-symbol "gnus-setup-message-article")) + (yanked (make-symbol "gnus-setup-yanked-articles")) (group (make-symbol "gnus-setup-message-group"))) `(let ((,winconf (current-window-configuration)) (,buffer (buffer-name (current-buffer))) (,article gnus-article-reply) + (,yanked gnus-article-yanked-articles) (,group gnus-newsgroup-name) (message-header-setup-hook (copy-sequence message-header-setup-hook)) @@ -344,13 +394,26 @@ Thank you for your help in stamping out bugs. ;; added an optional argument to `gnus-configure-posting-styles' to ;; make sure that the correct value for the group name is used. -- drv (add-hook 'message-mode-hook - (lambda () - (gnus-configure-posting-styles ,group))) + (if (memq ,config '(reply-yank reply)) + (lambda () + (gnus-configure-posting-styles ,group)) + (lambda () + ;; There may be an old " *gnus article copy*" buffer. + (let (gnus-article-copy) + (gnus-configure-posting-styles ,group))))) + (gnus-pull ',(intern gnus-draft-meta-information-header) + message-required-headers) + (when (and ,group + (not (string= ,group ""))) + (push (cons + (intern gnus-draft-meta-information-header) + (gnus-inews-make-draft (or ,yanked ,article))) + message-required-headers)) (unwind-protect (progn ,@forms) - (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config) - (gnus-inews-insert-draft-meta-information ,group ,article) + (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config + ,yanked) (setq gnus-message-buffer (current-buffer)) (set (make-local-variable 'gnus-message-group-art) (cons ,group ,article)) @@ -360,31 +423,33 @@ Thank you for your help in stamping out bugs. (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) ;; Global value (set (make-local-variable 'mml-buffer-list) mbl1);; Local value - ;; LOCAL argument of add-hook differs between GNU Emacs - ;; and XEmacs. make-local-hook makes sure they are local. - (make-local-hook 'kill-buffer-hook) - (make-local-hook 'change-major-mode-hook) + (gnus-make-local-hook 'kill-buffer-hook) + (gnus-make-local-hook 'change-major-mode-hook) (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)) (mml-destroy-buffers) (setq mml-buffer-list mbl))) + (message-hide-headers) (gnus-add-buffer) (gnus-configure-windows ,config t) (run-hooks 'post-command-hook) (set-buffer-modified-p nil)))) -(defun gnus-inews-insert-draft-meta-information (group article) - (save-excursion - (when (and group - (not (string= group "")) - (not (message-fetch-field gnus-draft-meta-information-header))) - (goto-char (point-min)) - (insert gnus-draft-meta-information-header ": (\"" group "\" " - (if article (number-to-string - (if (listp article) - (car article) - article)) "\"\"") - ")\n")))) +(defun gnus-inews-make-draft-meta-information (group articles) + (when (numberp articles) + (setq articles (list articles))) + (concat "(\"" group "\"" + (if articles + (concat " " + (mapconcat + (lambda (elem) + (number-to-string + (if (consp elem) + (car elem) + elem))) + articles " ")) + "") + ")")) ;;;###autoload (defun gnus-msg-mail (&optional to subject other-headers continue @@ -441,34 +506,43 @@ Gcc: header for archiving purposes." (while (setq elem (pop alist)) (when (or (and (stringp (car elem)) (string-match (car elem) group)) - (and (gnus-functionp (car elem)) + (and (functionp (car elem)) (funcall (car elem) group)) (and (symbolp (car elem)) (symbol-value (car elem)))) (throw 'found (cons (cadr elem) (caddr elem))))))))) -(defun gnus-inews-add-send-actions (winconf buffer article &optional config) - (make-local-hook 'message-sent-hook) +(defun gnus-inews-add-send-actions (winconf buffer article + &optional config yanked) + (gnus-make-local-hook 'message-sent-hook) (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc 'gnus-inews-do-gcc) nil t) (when gnus-agent - (make-local-hook 'message-header-hook) + (gnus-make-local-hook 'message-header-hook) (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t)) (setq message-post-method `(lambda (arg) (gnus-post-method arg ,gnus-newsgroup-name))) (setq message-newsreader (setq message-mailer (gnus-extended-version))) - (message-add-action - `(set-window-configuration ,winconf) 'exit 'postpone 'kill) (message-add-action `(when (gnus-buffer-exists-p ,buffer) - (save-excursion - (set-buffer ,buffer) - ,(when article - (if (eq config 'forward) - `(gnus-summary-mark-article-as-forwarded ',article) - `(gnus-summary-mark-article-as-replied ',article))))) - 'send)) + (set-window-configuration ,winconf)) + 'exit 'postpone 'kill) + (let ((to-be-marked (cond + (yanked + (mapcar + (lambda (x) (if (listp x) (car x) x)) yanked)) + (article (if (listp article) article (list article))) + (t nil)))) + (message-add-action + `(when (gnus-buffer-exists-p ,buffer) + (save-excursion + (set-buffer ,buffer) + ,(when to-be-marked + (if (eq config 'forward) + `(gnus-summary-mark-article-as-forwarded ',to-be-marked) + `(gnus-summary-mark-article-as-replied ',to-be-marked))))) + 'send))) (put 'gnus-setup-message 'lisp-indent-function 1) (put 'gnus-setup-message 'edebug-form-spec '(form body)) @@ -483,6 +557,8 @@ If ARG is 1, prompt for a group name to find the posting style." ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. (let ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) (buffer (current-buffer))) (unwind-protect (progn @@ -507,11 +583,13 @@ If ARG is 1, prompt for group name to post to. This function prepares a news even when using mail groups. This is useful for posting messages to mail groups without actually sending them over the -network. The corresponding backend must have a 'request-post method." +network. The corresponding back end must have a 'request-post method." (interactive "P") ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. (let ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) (buffer (current-buffer))) (unwind-protect (progn @@ -543,8 +621,11 @@ a news." (completing-read "Newsgroup: " gnus-active-hashtb nil (gnus-read-active-file-p)) (gnus-group-group-name)) - ""))) - (gnus-post-news 'post gnus-newsgroup-name))) + "")) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy)) + (gnus-post-news 'post gnus-newsgroup-name nil nil nil nil + (string= gnus-newsgroup-name "")))) (defun gnus-summary-mail-other-window (&optional arg) "Start composing a mail in another window. @@ -555,6 +636,8 @@ posting style." ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. (let ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) (buffer (current-buffer))) (unwind-protect (progn @@ -579,11 +662,13 @@ If ARG, don't do that. If ARG is 1, prompt for group name to post to. This function prepares a news even when using mail groups. This is useful for posting messages to mail groups without actually sending them over the -network. The corresponding backend must have a 'request-post method." +network. The corresponding back end must have a 'request-post method." (interactive "P") ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. (let ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) (buffer (current-buffer))) (unwind-protect (progn @@ -597,7 +682,12 @@ network. The corresponding backend must have a 'request-post method." gnus-newsgroup-name)) ;; #### see comment in gnus-setup-message -- drv (gnus-setup-message 'message - (message-news (gnus-group-real-name gnus-newsgroup-name)))) + (progn + (message-news (gnus-group-real-name gnus-newsgroup-name)) + (set (make-local-variable 'gnus-discouraged-post-methods) + (remove + (car (gnus-find-method-for-group gnus-newsgroup-name)) + gnus-discouraged-post-methods))))) (save-excursion (set-buffer buffer) (setq gnus-newsgroup-name group))))) @@ -615,7 +705,9 @@ a news." (completing-read "Newsgroup: " gnus-active-hashtb nil (gnus-read-active-file-p)) "") - gnus-newsgroup-name))) + gnus-newsgroup-name)) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy)) (gnus-post-news 'post gnus-newsgroup-name))) @@ -624,8 +716,7 @@ a news." If prefix argument YANK is non-nil, the original article is yanked automatically. YANK is a list of elements, where the car of each element is the -article number, and the two following numbers is the region to be -yanked." +article number, and the cdr is the string to be yanked." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) @@ -641,10 +732,13 @@ yanked." ;; Send a followup. (gnus-post-news nil gnus-newsgroup-name headers gnus-article-buffer - yank nil force-news))) + yank nil force-news) + (gnus-summary-handle-replysign))) (defun gnus-summary-followup-with-original (n &optional force-news) - "Compose a followup to an article and include the original article." + "Compose a followup to an article and include the original article. +The text in the region will be yanked. If the region isn't +active, the entire article will be yanked." (interactive "P") (gnus-summary-followup (gnus-summary-work-articles n) force-news)) @@ -676,7 +770,9 @@ yanked." (message-reply-headers ;; The headers are decoded. (with-current-buffer gnus-article-copy - (nnheader-parse-head t)))) + (save-restriction + (nnheader-narrow-to-headers) + (nnheader-parse-naked-head))))) (message-yank-original) (setq beg (or beg (mark t)))) (when articles @@ -690,12 +786,10 @@ Uses the process-prefix convention. If given the symbolic prefix `a', cancel using the standard posting method; if not post using the current select method." (interactive (gnus-interactive "P\ny")) - (let ((articles (gnus-summary-work-articles n)) - (message-post-method + (let ((message-post-method `(lambda (arg) - (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))) - article) - (while (setq article (pop articles)) + (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))) + (dolist (article (gnus-summary-work-articles n)) (when (gnus-summary-select-article t nil nil article) (when (gnus-eval-in-buffer-window gnus-original-article-buffer (message-cancel-news)) @@ -769,12 +863,16 @@ header line with the old Message-ID." (goto-char (point-min)) (while (looking-at message-unix-mail-delimiter) (forward-line 1)) - (setq beg (point) - end (or (message-goto-body) beg)) + (let ((mail-header-separator "")) + (setq beg (point) + end (or (message-goto-body) + ;; There may be just a header. + (point-max)))) ;; Delete the headers from the displayed articles. (set-buffer gnus-article-copy) - (delete-region (goto-char (point-min)) - (or (message-goto-body) (point-max))) + (let ((mail-header-separator "")) + (delete-region (goto-char (point-min)) + (or (message-goto-body) (point-max)))) ;; Insert the original article headers. (insert-buffer-substring gnus-original-article-buffer beg end) ;; Decode charsets. @@ -789,6 +887,7 @@ header line with the old Message-ID." (when article-buffer (gnus-copy-article-buffer)) (let ((gnus-article-reply (and article-buffer (gnus-summary-article-number))) + (gnus-article-yanked-articles yank) (add-to-list gnus-add-to-list)) (gnus-setup-message (cond (yank 'reply-yank) (article-buffer 'reply) @@ -819,7 +918,9 @@ header line with the old Message-ID." (not to-address))) ;; This is news. (if post - (message-news (or to-group group)) + (message-news + (or to-group + (and (not (gnus-virtual-group-p pgroup)) group))) (set-buffer gnus-article-copy) (gnus-msg-treat-broken-reply-to) (message-followup (if (or newsgroup-p force-news) @@ -847,7 +948,7 @@ header line with the old Message-ID." (gnus-inews-yank-articles yank)))))) (defun gnus-msg-treat-broken-reply-to (&optional force) - "Remove the Reply-to header iff broken-reply-to." + "Remove the Reply-to header if broken-reply-to." (when (or force (gnus-group-find-parameter gnus-newsgroup-name 'broken-reply-to)) @@ -934,33 +1035,22 @@ If SILENT, don't prompt the user." -;; Dummies to avoid byte-compile warning. -(eval-when-compile - (defvar nnspool-rejected-article-hook) - (defvar xemacs-codename)) - (defun gnus-extended-version () - "Stringified Gnus version and Emacs version." + "Stringified Gnus version and Emacs version. +See the variable `gnus-user-agent'." (interactive) - (concat - "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t) - " (" gnus-version ")" - " " - (cond - ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) - (concat "Emacs/" (match-string 1 emacs-version) - " (" system-configuration ")")) - ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" - emacs-version) - (concat (match-string 1 emacs-version) - (format "/%d.%d" emacs-major-version emacs-minor-version) - (if (match-beginning 3) - (match-string 3 emacs-version) - "") - (if (boundp 'xemacs-codename) - (concat " (" xemacs-codename ", " system-configuration ")") - ""))) - (t emacs-version)))) + (if (stringp gnus-user-agent) + gnus-user-agent + ;; `gnus-user-agent' is a list: + (let* ((float-output-format nil) + (gnus-v + (when (memq 'gnus gnus-user-agent) + (concat "Gnus/" + (prin1-to-string (gnus-continuum-version gnus-version) t) + " (" gnus-version ")"))) + (emacs-v (gnus-emacs-version))) + (concat gnus-v (when (and gnus-v emacs-v) " ") + emacs-v)))) ;;; @@ -978,51 +1068,68 @@ If VERY-WIDE, make a very wide reply." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) - (let* ((article - (if (listp (car yank)) - (caar yank) - (car yank))) - (gnus-article-reply (or article (gnus-summary-article-number))) - (headers "")) - ;; Stripping headers should be specified with mail-yank-ignored-headers. - (when yank - (gnus-summary-goto-subject article)) - (gnus-setup-message (if yank 'reply-yank 'reply) - (if (not very-wide) - (gnus-summary-select-article) - (dolist (article very-wide) - (gnus-summary-select-article nil nil nil article) - (save-excursion - (set-buffer (gnus-copy-article-buffer)) - (gnus-msg-treat-broken-reply-to) - (save-restriction - (message-narrow-to-head) - (setq headers (concat headers (buffer-string))))))) - (set-buffer (gnus-copy-article-buffer)) - (gnus-msg-treat-broken-reply-to gnus-msg-force-broken-reply-to) - (save-restriction - (message-narrow-to-head) - (when very-wide - (erase-buffer) - (insert headers)) - (goto-char (point-max))) - (mml-quote-region (point) (point-max)) - (message-reply nil wide) + ;; Allow user to require confirmation before replying by mail to the + ;; author of a news article (or mail message). + (when (or + (not (or (gnus-news-group-p gnus-newsgroup-name) + gnus-confirm-treat-mail-like-news)) + (not (cond ((stringp gnus-confirm-mail-reply-to-news) + (string-match gnus-confirm-mail-reply-to-news + gnus-newsgroup-name)) + ((functionp gnus-confirm-mail-reply-to-news) + (funcall gnus-confirm-mail-reply-to-news gnus-newsgroup-name)) + (t gnus-confirm-mail-reply-to-news))) + (y-or-n-p "Really reply by mail to article author? ")) + (let* ((article + (if (listp (car yank)) + (caar yank) + (car yank))) + (gnus-article-reply (or article (gnus-summary-article-number))) + (gnus-article-yanked-articles yank) + (headers "")) + ;; Stripping headers should be specified with mail-yank-ignored-headers. (when yank - (gnus-inews-yank-articles yank)) - (when (or gnus-message-replysign gnus-message-replyencrypt) - (let (signed encrypted) - (save-excursion - (set-buffer gnus-article-buffer) - (setq signed (memq 'signed gnus-article-wash-types)) - (setq encrypted (memq 'encrypted gnus-article-wash-types))) - (cond ((and gnus-message-replysign signed) - (mml-secure-message mml-default-sign-method 'sign)) - ((and gnus-message-replyencrypt encrypted) - (mml-secure-message mml-default-encrypt-method - (if gnus-message-replysignencrypted - 'signencrypt - 'encrypt))))))))) + (gnus-summary-goto-subject article)) + (gnus-setup-message (if yank 'reply-yank 'reply) + (if (not very-wide) + (gnus-summary-select-article) + (dolist (article very-wide) + (gnus-summary-select-article nil nil nil article) + (save-excursion + (set-buffer (gnus-copy-article-buffer)) + (gnus-msg-treat-broken-reply-to) + (save-restriction + (message-narrow-to-head) + (setq headers (concat headers (buffer-string))))))) + (set-buffer (gnus-copy-article-buffer)) + (gnus-msg-treat-broken-reply-to gnus-msg-force-broken-reply-to) + (save-restriction + (message-narrow-to-head) + (when very-wide + (erase-buffer) + (insert headers)) + (goto-char (point-max))) + (mml-quote-region (point) (point-max)) + (message-reply nil wide) + (when yank + (gnus-inews-yank-articles yank)) + (gnus-summary-handle-replysign))))) + +(defun gnus-summary-handle-replysign () + "Check the various replysign variables and take action accordingly." + (when (or gnus-message-replysign gnus-message-replyencrypt) + (let (signed encrypted) + (save-excursion + (set-buffer gnus-article-buffer) + (setq signed (memq 'signed gnus-article-wash-types)) + (setq encrypted (memq 'encrypted gnus-article-wash-types))) + (cond ((and gnus-message-replyencrypt encrypted) + (mml-secure-message mml-default-encrypt-method + (if gnus-message-replysignencrypted + 'signencrypt + 'encrypt))) + ((and gnus-message-replysign signed) + (mml-secure-message mml-default-sign-method 'sign)))))) (defun gnus-summary-reply-with-original (n &optional wide) "Start composing a reply mail to the current message. @@ -1059,7 +1166,8 @@ automatically." (defun gnus-summary-wide-reply-with-original (n) "Start composing a wide reply mail to the current message. -The original article will be yanked." +The original article will be yanked. +Uses the process/prefix convention." (interactive "P") (gnus-summary-reply-with-original n t)) @@ -1092,58 +1200,61 @@ If POST, post instead of mail. For the `inline' alternatives, also see the variable `message-forward-ignored-headers'." (interactive "P") - (if (null (cdr (gnus-summary-work-articles nil))) - (let ((message-forward-as-mime message-forward-as-mime) - (message-forward-show-mml message-forward-show-mml)) - (cond - ((null arg)) - ((eq arg 1) - (setq message-forward-as-mime nil - message-forward-show-mml t)) - ((eq arg 2) - (setq message-forward-as-mime t - message-forward-show-mml nil)) - ((eq arg 3) - (setq message-forward-as-mime t - message-forward-show-mml t)) - ((eq arg 4) - (setq message-forward-as-mime nil - message-forward-show-mml nil)) - (t - (setq message-forward-as-mime (not message-forward-as-mime)))) - (let ((gnus-article-reply (gnus-summary-article-number))) - (gnus-setup-message 'forward - (gnus-summary-select-article) - (let ((mail-parse-charset - (or (and (gnus-buffer-live-p gnus-article-buffer) - (with-current-buffer gnus-article-buffer - gnus-article-charset)) - gnus-newsgroup-charset)) - (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)) - (set-buffer gnus-original-article-buffer) - (message-forward post))))) - (gnus-uu-digest-mail-forward arg post))) + (if (cdr (gnus-summary-work-articles nil)) + ;; Process marks are given. + (gnus-uu-digest-mail-forward arg post) + ;; No process marks. + (let ((message-forward-as-mime message-forward-as-mime) + (message-forward-show-mml message-forward-show-mml)) + (cond + ((null arg)) + ((eq arg 1) + (setq message-forward-as-mime nil + message-forward-show-mml t)) + ((eq arg 2) + (setq message-forward-as-mime t + message-forward-show-mml nil)) + ((eq arg 3) + (setq message-forward-as-mime t + message-forward-show-mml t)) + ((eq arg 4) + (setq message-forward-as-mime nil + message-forward-show-mml nil)) + (t + (setq message-forward-as-mime (not message-forward-as-mime)))) + (let* ((gnus-article-reply (gnus-summary-article-number)) + (gnus-article-yanked-articles (list gnus-article-reply))) + (gnus-setup-message 'forward + (gnus-summary-select-article) + (let ((mail-parse-charset + (or (and (gnus-buffer-live-p gnus-article-buffer) + (with-current-buffer gnus-article-buffer + gnus-article-charset)) + gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + gnus-newsgroup-ignored-charsets)) + (set-buffer gnus-original-article-buffer) + (message-forward post))))))) (defun gnus-summary-resend-message (address n) "Resend the current article to ADDRESS." (interactive (list (message-read-from-minibuffer "Resend message(s) to: " - (when (gnus-buffer-live-p gnus-original-article-buffer) + (when (and gnus-summary-resend-default-address + (gnus-buffer-live-p gnus-original-article-buffer)) ;; If some other article is currently selected, the ;; initial-contents is wrong. Whatever, it is just the ;; initial-contents. (with-current-buffer gnus-original-article-buffer (nnmail-fetch-field "to")))) current-prefix-arg)) - (let ((articles (gnus-summary-work-articles n)) - article) - (while (setq article (pop articles)) - (gnus-summary-select-article nil nil nil article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (message-resend address)) - (gnus-summary-mark-article-as-forwarded article)))) + (dolist (article (gnus-summary-work-articles n)) + (gnus-summary-select-article nil nil nil article) + (save-excursion + (set-buffer gnus-original-article-buffer) + (message-resend address)) + (gnus-summary-mark-article-as-forwarded article))) ;; From: Matthieu Moy (defun gnus-summary-resend-message-edit () @@ -1170,8 +1281,8 @@ composing a new message." (goto-char (point-max)) (insert mail-header-separator) (goto-char (point-min)) - (re-search-forward "^To:\\|^Newsgroups:" nil 'move) - (forward-char 1) + (when (re-search-forward "^To:\\|^Newsgroups:" nil 'move) + (forward-char 1)) (widen))))) (defun gnus-summary-post-forward (&optional arg) @@ -1201,37 +1312,35 @@ The current group name will be inserted at \"%s\".") (defun gnus-summary-mail-crosspost-complaint (n) "Send a complaint about crossposting to the current article(s)." (interactive "P") - (let ((articles (gnus-summary-work-articles n)) - article) - (while (setq article (pop articles)) - (set-buffer gnus-summary-buffer) - (gnus-summary-goto-subject article) - (let ((group (gnus-group-real-name gnus-newsgroup-name)) - newsgroups followup-to) - (gnus-summary-select-article) - (set-buffer gnus-original-article-buffer) - (if (and (<= (length (message-tokenize-header - (setq newsgroups - (mail-fetch-field "newsgroups")) - ", ")) - 1) - (or (not (setq followup-to (mail-fetch-field "followup-to"))) - (not (member group (message-tokenize-header - followup-to ", "))))) - (if followup-to - (gnus-message 1 "Followup-to restricted") - (gnus-message 1 "Not a crossposted article")) - (set-buffer gnus-summary-buffer) - (gnus-summary-reply-with-original 1) - (set-buffer gnus-message-buffer) - (message-goto-body) - (insert (format gnus-crosspost-complaint newsgroups group)) - (message-goto-subject) - (re-search-forward " *$") - (replace-match " (crosspost notification)" t t) - (gnus-deactivate-mark) - (when (gnus-y-or-n-p "Send this complaint? ") - (message-send-and-exit))))))) + (dolist (article (gnus-summary-work-articles n)) + (set-buffer gnus-summary-buffer) + (gnus-summary-goto-subject article) + (let ((group (gnus-group-real-name gnus-newsgroup-name)) + newsgroups followup-to) + (gnus-summary-select-article) + (set-buffer gnus-original-article-buffer) + (if (and (<= (length (message-tokenize-header + (setq newsgroups + (mail-fetch-field "newsgroups")) + ", ")) + 1) + (or (not (setq followup-to (mail-fetch-field "followup-to"))) + (not (member group (message-tokenize-header + followup-to ", "))))) + (if followup-to + (gnus-message 1 "Followup-to restricted") + (gnus-message 1 "Not a crossposted article")) + (set-buffer gnus-summary-buffer) + (gnus-summary-reply-with-original 1) + (set-buffer gnus-message-buffer) + (message-goto-body) + (insert (format gnus-crosspost-complaint newsgroups group)) + (message-goto-subject) + (re-search-forward " *$") + (replace-match " (crosspost notification)" t t) + (gnus-deactivate-mark) + (when (gnus-y-or-n-p "Send this complaint? ") + (message-send-and-exit)))))) (defun gnus-mail-parse-comma-list () (let (accumulated @@ -1267,7 +1376,7 @@ The current group name will be inserted at \"%s\".") ;; This mail group doesn't have a `to-list', so we add one ;; here. Magic! (when (gnus-y-or-n-p - (format "Do you want to add this as `to-list': %s " to-address)) + (format "Do you want to add this as `to-list': %s? " to-address)) (gnus-group-add-parameter group (cons 'to-list to-address)))))) (defun gnus-put-message () @@ -1280,7 +1389,7 @@ The current group name will be inserted at \"%s\".") (not (gnus-group-read-only-p group))) (setq group (read-string "Put in group: " nil (gnus-writable-groups)))) - (when (gnus-gethash group gnus-newsrc-hashtb) + (when (gnus-group-entry group) (error "No such group: %s" group)) (save-excursion (save-restriction @@ -1292,7 +1401,9 @@ The current group name will be inserted at \"%s\".") message-required-news-headers message-required-mail-headers))) (goto-char (point-max)) - (insert "Gcc: " group "\n") + (if (string-match " " group) + (insert "Gcc: \"" group "\"\n") + (insert "Gcc: " group "\n")) (widen))) (gnus-inews-do-gcc) (when (and (get-buffer gnus-group-buffer) @@ -1365,8 +1476,7 @@ If YANK is non-nil, include the original article." (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t) current-prefix-arg)) (gnus-summary-iterate n - (let ((gnus-display-mime-function nil) - (gnus-inhibit-treatment t)) + (let ((gnus-inhibit-treatment t)) (gnus-summary-select-article)) (save-excursion (set-buffer buffer) @@ -1409,24 +1519,23 @@ The source file has to be in the Emacs load path." (insert "------------------ Environment follows ------------------\n\n")) (while olist (if (boundp (car olist)) - (condition-case () - (pp `(setq ,(car olist) - ,(if (or (consp (setq sym (symbol-value (car olist)))) - (and (symbolp sym) - (not (or (eq sym nil) - (eq sym t))))) - (list 'quote (symbol-value (car olist))) - (symbol-value (car olist)))) - (current-buffer)) - (error - (format "(setq %s 'whatever)\n" (car olist)))) + (ignore-errors + (gnus-pp + `(setq ,(car olist) + ,(if (or (consp (setq sym (symbol-value (car olist)))) + (and (symbolp sym) + (not (or (eq sym nil) + (eq sym t))))) + (list 'quote (symbol-value (car olist))) + (symbol-value (car olist)))))) (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) (setq olist (cdr olist))) (insert "\n\n") ;; Remove any control chars - they seem to cause trouble for some ;; mailers. (Byte-compiled output from the stuff above.) (goto-char point) - (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t) + (while (re-search-forward (mm-string-as-multibyte + "[\000-\010\013-\037\200-\237]") nil t) (replace-match (format "\\%03o" (string-to-char (match-string 0))) t t)))) @@ -1435,7 +1544,7 @@ The source file has to be in the Emacs load path." (defun gnus-summary-resend-bounced-mail (&optional fetch) "Re-mail the current message. -This only makes sense if the current message is a bounce message than +This only makes sense if the current message is a bounce message that contains some mail you have written which has been bounced back to you. If FETCH, try to fetch the article that this is a reply to, if indeed @@ -1532,14 +1641,21 @@ this is a reply." (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match "" t t )) - (unless (setq group-art - (gnus-request-accept-article group method t t)) + (when (or (not (gnus-check-backend-function + 'request-accept-article group)) + (not (setq group-art + (gnus-request-accept-article + group method t t)))) (gnus-message 1 "Couldn't store article in group %s: %s" - group (gnus-status-message method)) - (sit-for 2)) + group (gnus-status-message method))) (when (and group-art + ;; FIXME: Should gcc-mark-as-read work when + ;; Gnus is not running? + (gnus-alive-p) (or gnus-gcc-mark-as-read - gnus-inews-mark-gcc-as-read)) + (and + (boundp 'gnus-inews-mark-gcc-as-read) + (symbol-value 'gnus-inews-mark-gcc-as-read)))) (gnus-group-mark-article-read group (cdr group-art))) (kill-buffer (current-buffer))))))))) @@ -1550,14 +1666,21 @@ this is a reply." (message-narrow-to-headers) (let* ((group gnus-outgoing-message-group) (gcc (cond - ((gnus-functionp group) + ((functionp group) (funcall group)) ((or (stringp group) (list group)) group)))) (when gcc (insert "Gcc: " - (if (stringp gcc) gcc - (mapconcat 'identity gcc " ")) + (if (stringp gcc) + (if (string-match " " gcc) + (concat "\"" gcc "\"") + gcc) + (mapconcat (lambda (group) + (if (string-match " " group) + (concat "\"" group "\"") + group)) + gcc " ")) "\n")))))) (defun gnus-inews-insert-archive-gcc (&optional group) @@ -1584,7 +1707,7 @@ this is a reply." ((and (listp var) (stringp (car var))) ;; A list of groups. var) - ((gnus-functionp var) + ((functionp var) ;; A function. (funcall var group)) (t @@ -1597,7 +1720,7 @@ this is a reply." ;; Regexp. (when (string-match (caar var) group) (cdar var))) - ((gnus-functionp (car var)) + ((functionp (car var)) ;; Function. (funcall (car var) group)) (t @@ -1618,23 +1741,43 @@ this is a reply." (progn (insert (if (stringp gcc-self-val) - gcc-self-val - group)) + (if (string-match " " gcc-self-val) + (concat "\"" gcc-self-val "\"") + gcc-self-val) + ;; In nndoc groups, we use the parent group name + ;; instead of the current group. + (let ((group (or (gnus-group-find-parameter + gnus-newsgroup-name 'parent-group) + group))) + (if (string-match " " group) + (concat "\"" group "\"") + group)))) (if (not (eq gcc-self-val 'none)) (insert "\n") - (progn - (beginning-of-line) - (kill-line)))) + (gnus-delete-line))) ;; Use the list of groups. (while (setq name (pop groups)) - (insert (if (string-match ":" name) - name - (gnus-group-prefixed-name - name gnus-message-archive-method))) + (let ((str (if (string-match ":" name) + name + (gnus-group-prefixed-name + name gnus-message-archive-method)))) + (insert (if (string-match " " str) + (concat "\"" str "\"") + str))) (when groups (insert " "))) (insert "\n"))))))) +(defun gnus-mailing-list-followup-to () + "Look at the headers in the current buffer and return a Mail-Followup-To address." + (let ((x-been-there (gnus-fetch-original-field "x-beenthere")) + (list-post (gnus-fetch-original-field "list-post"))) + (when (and list-post + (string-match "mailto:\\([^>]+\\)" list-post)) + (setq list-post (match-string 1 list-post))) + (or list-post + x-been-there))) + ;;; Posting styles. (defun gnus-configure-posting-styles (&optional group-name) @@ -1642,7 +1785,7 @@ this is a reply." (unless gnus-inhibit-posting-styles (let ((group (or group-name gnus-newsgroup-name "")) (styles gnus-posting-styles) - style match variable attribute value v results + style match attribute value v results filep name address element) ;; If the group has a posting-style parameter, add it at the end with a ;; regexp matching everything, to be sure it takes precedence over all @@ -1663,13 +1806,15 @@ this is a reply." ;; Obsolete format of header match. (and (gnus-buffer-live-p gnus-article-copy) (with-current-buffer gnus-article-copy - (let ((header (message-fetch-field (pop style)))) - (and header - (string-match (pop style) header)))))) + (save-restriction + (nnheader-narrow-to-headers) + (let ((header (message-fetch-field (pop style)))) + (and header + (string-match (pop style) header))))))) ((or (symbolp match) - (gnus-functionp match)) + (functionp match)) (cond - ((gnus-functionp match) + ((functionp match) ;; Function to be called. (funcall match)) ((boundp match) @@ -1681,16 +1826,17 @@ this is a reply." ;; New format of header match. (and (gnus-buffer-live-p gnus-article-copy) (with-current-buffer gnus-article-copy - (let ((header (message-fetch-field (nth 1 match)))) - (and header - (string-match (nth 2 match) header)))))) + (save-restriction + (nnheader-narrow-to-headers) + (let ((header (message-fetch-field (nth 1 match)))) + (and header + (string-match (nth 2 match) header))))))) (t ;; This is a form to be evaled. (eval match))))) ;; We have a match, so we set the variables. (dolist (attribute style) (setq element (pop attribute) - variable nil filep nil) (setq value (cond @@ -1707,8 +1853,8 @@ this is a reply." ((stringp value) value) ((or (symbolp value) - (gnus-functionp value)) - (cond ((gnus-functionp value) + (functionp value)) + (cond ((functionp value) (funcall value)) ((boundp value) (symbol-value value)))) @@ -1726,18 +1872,22 @@ this is a reply." (when (and filep v) (setq v (with-temp-buffer (insert-file-contents v) - (goto-char (point-max)) - (while (bolp) - (delete-char -1)) - (buffer-string)))) + (buffer-substring + (point-min) + (progn + (goto-char (point-max)) + (if (zerop (skip-chars-backward "\n")) + (point) + (1+ (point)))))))) (setq results (delq (assoc element results) results)) (push (cons element v) results)))) ;; Now we have all the styles, so we insert them. (setq name (assq 'name results) address (assq 'address results)) (setq results (delq name (delq address results))) - ;; make-local-hook is not obsolete in Emacs 20 or XEmacs. - (make-local-hook 'message-setup-hook) + (gnus-make-local-hook 'message-setup-hook) + (setq results (sort results (lambda (x y) + (string-lessp (car x) (car y))))) (dolist (result results) (add-hook 'message-setup-hook (cond @@ -1769,7 +1919,9 @@ this is a reply." (let ((value ,(cdr result))) (when value (message-goto-eoh) - (insert ,header ": " value "\n")))))))) + (insert ,header ": " value) + (unless (bolp) + (insert "\n"))))))))) nil 'local)) (when (or name address) (add-hook 'message-setup-hook @@ -1791,4 +1943,5 @@ this is a reply." (provide 'gnus-msg) +;;; arch-tag: 9f22b2f5-1c0a-49de-916e-4c88e984852b ;;; gnus-msg.el ends here