X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-msg.el;h=5aebc44d5687c6ff5c9a495769805ad731a43ea9;hb=c9a326c848f0dcecef01c33349a96b1d1da44163;hp=d389ec5e3ece3fcd48ca6a408a7ab56cd8f44678;hpb=80249bc90ebe20d49eccf500fa0d42a9d3d01790;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index d389ec5..5aebc44 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -1,5 +1,6 @@ ;;; gnus-msg.el --- mail and post interface for Gnus -;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -33,27 +34,27 @@ (require 'message) (require 'gnus-art) -(defcustom gnus-post-method nil +(defcustom gnus-post-method 'current "*Preferred method for posting USENET news. -If this variable is `current', Gnus will use the \"current\" select -method when posting. If it is nil (which is the default), Gnus will -use the native posting method of the server. +If this variable is `current' (which is the default), Gnus will use +the \"current\" select method when posting. If it is `native', Gnus +will use the native select method when posting. This method will not be used in mail groups and the like, only in \"real\" newsgroups. -If not nil nor `native', the value must be a valid method as discussed -in the documentation of `gnus-select-method'. It can also be a list of -methods. If that is the case, the user will be queried for what select +If not `native' nor `current', the value must be a valid method as discussed +in the documentation of `gnus-select-method'. It can also be a list of +methods. If that is the case, the user will be queried for what select method to use when posting." :group 'gnus-group-foreign - :type `(choice (const nil) - (const current) - (const native) + :link '(custom-manual "(gnus)Posting Server") + :type `(choice (const native) + (const current) (sexp :tag "Methods" ,gnus-select-method))) -(defvar gnus-outgoing-message-group nil +(defcustom gnus-outgoing-message-group nil "*All outgoing messages will be put in this group. If you want to store all your outgoing mail and articles in the group \"nnml:archive\", you set this variable to that value. This variable @@ -62,18 +63,25 @@ can also be a list of group names. If you want to have greater control over what group to put each message in, you can set this variable to a function that checks the current newsgroup name and then returns a suitable group name (or list -of names).") +of names)." + :group 'gnus-message + :type '(choice (string :tag "Group") + (function))) -(defvar gnus-mailing-list-groups nil +(defcustom gnus-mailing-list-groups nil "*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.") +the group." + :group 'gnus-message + :type 'regexp) -(defvar gnus-add-to-list nil - "*If non-nil, add a `to-list' parameter automatically.") +(defcustom gnus-add-to-list nil + "*If non-nil, add a `to-list' parameter automatically." + :group 'gnus-message + :type 'boolean) -(defvar gnus-crosspost-complaint +(defcustom gnus-crosspost-complaint "Hi, You posted the article below with the following Newsgroups header: @@ -89,35 +97,206 @@ Thank you. " "Format string to be inserted when complaining about crossposts. The first %s will be replaced by the Newsgroups header; -the second with the current group name.") - -(defvar gnus-message-setup-hook nil - "Hook run after setting up a message buffer.") - -(defvar gnus-bug-create-help-buffer t - "*Should we create the *Gnus Help Bug* buffer?") - -(defvar gnus-posting-styles nil - "*Alist of styles to use when posting.") - -(defvar gnus-posting-style-alist - '((organization . message-user-organization) - (signature . message-signature) - (signature-file . message-signature-file) - (address . user-mail-address) - (name . user-full-name)) - "*Mapping from style parameters to variables.") +the second with the current group name." + :group 'gnus-message + :type 'string) + +(defcustom gnus-message-setup-hook nil + "Hook run after setting up a message buffer." + :group 'gnus-message + :type 'hook) + +(defcustom gnus-bug-create-help-buffer t + "*Should we create the *Gnus Help Bug* buffer?" + :group 'gnus-message + :type 'boolean) + +(defcustom gnus-posting-styles nil + "*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) + (string :tag "Header") + (regexp :tag "Regexp")) + (function) + (sexp)) + (repeat (list + (choice (const signature) + (const signature-file) + (const organization) + (const address) + (const x-face-file) + (const name) + (const body) + (symbol) + (string :tag "Header")) + (choice (string) + (function) + (variable) + (sexp))))))) + +(defcustom gnus-gcc-mark-as-read nil + "If non-nil, automatically mark Gcc articles as read." + :version "21.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) + +(defcustom gnus-gcc-externalize-attachments nil + "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" + :group 'gnus-message + :type '(choice (const nil :tag "None") + (const all :tag "Any") + (string :tag "Regexp"))) + +(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 +variable to query, +HEADER is the charset which may be left unencoded in the header (nil +means encode all charsets), +BODY-LIST is a list of charsets which may be encoded using 8bit +content-transfer encoding in the body, or one of the special values +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." + :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" + "gnus-art.el" "gnus-start.el" "gnus-async.el" + "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el" + "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" + :group 'gnus-message + :type '(repeat (string :tag "File"))) + +(defcustom gnus-debug-exclude-variables + '(mm-mime-mule-charset-alist + nnmail-split-fancy message-minibuffer-local-map) + "Variables that should not be reported in `gnus-bug'." + :version "21.1" + :group 'gnus-message + :type '(repeat (symbol :tag "Variable"))) + +(defcustom gnus-discouraged-post-methods + '(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" + :group 'gnus-group-foreign + :type '(repeat (symbol :tag "Back end"))) + +(defcustom gnus-message-replysign + nil + "Automatically sign replys 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. +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." + :group 'gnus-message + :type 'boolean) + +(defcustom gnus-confirm-mail-reply-to-news nil + "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." + :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." + :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'." + :group 'gnus-message + :type 'boolean) ;;; Internal variables. (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) (defvar gnus-last-posting-server nil) (defvar gnus-message-group-art nil) +(defvar gnus-msg-force-broken-reply-to nil) + (defconst gnus-bug-message "Sending a bug report to the Gnus Towers. ======================================== @@ -125,9 +304,10 @@ the second with the current group name.") The buffer below is a mail buffer. When you press `C-c C-c', it will be sent to the Gnus Bug Exterminators. -At the bottom of the buffer you'll see lots of variable settings. -Please do not delete those. They will tell the Bug People what your -environment is, so that it will be easier to locate the bugs. +The thing near the bottom of the buffer is how the environment +settings will be included in the mail. Please do not delete that. +They will tell the Bug People what your environment is, so that it +will be easier to locate the bugs. If you have found a bug that makes Emacs go \"beep\", set debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') @@ -152,19 +332,25 @@ Thank you for your help in stamping out bugs. (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map) "p" gnus-summary-post-news + "i" gnus-summary-news-other-window "f" gnus-summary-followup "F" gnus-summary-followup-with-original "c" gnus-summary-cancel-article "s" gnus-summary-supersede-article "r" gnus-summary-reply + "y" gnus-summary-yank-message "R" gnus-summary-reply-with-original "w" gnus-summary-wide-reply "W" gnus-summary-wide-reply-with-original + "v" gnus-summary-very-wide-reply + "V" gnus-summary-very-wide-reply-with-original "n" gnus-summary-followup-to-mail "N" gnus-summary-followup-to-mail-with-original "m" gnus-summary-mail-other-window "u" gnus-uu-post-news "\M-c" gnus-summary-mail-crosspost-complaint + "Br" gnus-summary-reply-broken-reply-to + "BR" gnus-summary-reply-broken-reply-to-with-original "om" gnus-summary-mail-forward "op" gnus-summary-post-forward "Om" gnus-uu-digest-mail-forward @@ -173,71 +359,246 @@ Thank you for your help in stamping out bugs. (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map) "b" gnus-summary-resend-bounced-mail ;; "c" gnus-summary-send-draft - "r" gnus-summary-resend-message) + "r" gnus-summary-resend-message + "e" gnus-summary-resend-message-edit) ;;; Internal functions. +(defun gnus-inews-make-draft () + `(lambda () + (gnus-inews-make-draft-meta-information + ,gnus-newsgroup-name ',gnus-article-reply))) + (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 (and gnus-article-reply (gnus-summary-article-number))) + (,article gnus-article-reply) + (,yanked gnus-article-yanked-articles) (,group gnus-newsgroup-name) (message-header-setup-hook (copy-sequence message-header-setup-hook)) + (mbl mml-buffer-list) (message-mode-hook (copy-sequence message-mode-hook))) + (setq mml-buffer-list nil) (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) - (add-hook 'message-mode-hook 'gnus-configure-posting-styles) + ;; #### FIXME: for a reason that I did not manage to identify yet, + ;; the variable `gnus-newsgroup-name' does not honor a dynamically + ;; scoped or setq'ed value from a caller like `C-u gnus-summary-mail'. + ;; After evaluation of @forms below, it gets the value we actually want + ;; to override, and the posting styles are used. For that reason, I've + ;; 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))) + (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)) + message-required-headers)) (unwind-protect (progn ,@forms) - (gnus-inews-add-send-actions ,winconf ,buffer ,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)) - (make-local-variable 'gnus-newsgroup-name) - (gnus-run-hooks 'gnus-message-setup-hook)) + (set (make-local-variable 'gnus-newsgroup-name) ,group) + (gnus-run-hooks 'gnus-message-setup-hook) + (if (eq major-mode 'message-mode) + (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) + (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))) (gnus-add-buffer) (gnus-configure-windows ,config t) + (run-hooks 'post-command-hook) (set-buffer-modified-p nil)))) -(defun gnus-inews-add-send-actions (winconf buffer article) +(defun gnus-inews-make-draft-meta-information (group article) + (concat "(\"" group "\" " + (if article (number-to-string + (if (listp article) + (car article) + article)) "\"\"") + ")")) + +;;;###autoload +(defun gnus-msg-mail (&optional to subject other-headers continue + switch-action yank-action send-actions) + "Start editing a mail message to be sent. +Like `message-mail', but with Gnus paraphernalia, particularly the +Gcc: header for archiving purposes." + (interactive) + (let ((buf (current-buffer)) + mail-buf) + (gnus-setup-message 'message + (message-mail to subject other-headers continue + nil yank-action send-actions)) + (when switch-action + (setq mail-buf (current-buffer)) + (switch-to-buffer buf) + (apply switch-action mail-buf nil))) + ;; COMPOSEFUNC should return t if succeed. Undocumented ??? + t) + +(defvar save-selected-window-window) + +;;;###autoload +(defun gnus-button-mailto (address) + "Mail to ADDRESS." + (set-buffer (gnus-copy-article-buffer)) + (gnus-setup-message 'message + (message-reply address)) + (and (boundp 'save-selected-window-window) + (not (window-live-p save-selected-window-window)) + (setq save-selected-window-window (selected-window)))) + +;;;###autoload +(defun gnus-button-reply (&optional to-address wide) + "Like `message-reply'." + (interactive) + (gnus-setup-message 'message + (message-reply to-address wide)) + (and (boundp 'save-selected-window-window) + (not (window-live-p save-selected-window-window)) + (setq save-selected-window-window (selected-window)))) + +;;;###autoload +(define-mail-user-agent 'gnus-user-agent + 'gnus-msg-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook) + +(defun gnus-setup-posting-charset (group) + (let ((alist gnus-group-posting-charset-alist) + (group (or group "")) + elem) + (when group + (catch 'found + (while (setq elem (pop alist)) + (when (or (and (stringp (car elem)) + (string-match (car elem) group)) + (and (gnus-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 yanked) (make-local-hook 'message-sent-hook) - (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) + (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) + (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 - `(gnus-summary-mark-article-as-replied ,article)))) - 'send)) + (let ((to-be-marked (cond + (yanked yanked) + (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)) ;;; Post news commands of Gnus group mode and summary mode -(defun gnus-group-mail () - "Start composing a mail." - (interactive) - (gnus-setup-message 'message - (message-mail))) +(defun gnus-group-mail (&optional arg) + "Start composing a mail. +If ARG, use the group under the point to find a posting style. +If ARG is 1, prompt for a group name to find the posting style." + (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 + (setq gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use posting style of group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + (gnus-group-group-name)) + "")) + ;; #### see comment in gnus-setup-message -- drv + (gnus-setup-message 'message (message-mail))) + (save-excursion + (set-buffer buffer) + (setq gnus-newsgroup-name group))))) + +(defun gnus-group-news (&optional arg) + "Start composing a news. +If ARG, post to group under point. +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." + (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 + (setq gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + (gnus-group-group-name)) + "")) + ;; #### see comment in gnus-setup-message -- drv + (gnus-setup-message 'message + (message-news (gnus-group-real-name gnus-newsgroup-name)))) + (save-excursion + (set-buffer buffer) + (setq gnus-newsgroup-name group))))) (defun gnus-group-post-news (&optional arg) - "Start composing a news message. -If ARG, post to the group under point. -If ARG is 1, prompt for a group name." + "Start composing a message (a news by default). +If ARG, post to group under point. If ARG is 1, prompt for group name. +Depending on the selected group, the message might be either a mail or +a news." (interactive "P") ;; Bind this variable here to make message mode hooks work ok. (let ((gnus-newsgroup-name @@ -246,22 +607,106 @@ If ARG is 1, prompt for a group name." (completing-read "Newsgroup: " gnus-active-hashtb nil (gnus-read-active-file-p)) (gnus-group-group-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. +Use the posting of the current group by default. +If ARG, don't do that. If ARG is 1, prompt for group name to find the +posting style." + (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 + (setq gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + "") + gnus-newsgroup-name)) + ;; #### see comment in gnus-setup-message -- drv + (gnus-setup-message 'message (message-mail))) + (save-excursion + (set-buffer buffer) + (setq gnus-newsgroup-name group))))) + +(defun gnus-summary-news-other-window (&optional arg) + "Start composing a news in another window. +Post to the current group by default. +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." + (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 + (setq gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + "") + gnus-newsgroup-name)) + ;; #### see comment in gnus-setup-message -- drv + (gnus-setup-message 'message + (message-news (gnus-group-real-name gnus-newsgroup-name)))) + (save-excursion + (set-buffer buffer) + (setq gnus-newsgroup-name group))))) + +(defun gnus-summary-post-news (&optional arg) + "Start composing a message. Post to the current group by default. +If ARG, don't do that. If ARG is 1, prompt for a group name to post to. +Depending on the selected group, the message might be either a mail or +a news." + (interactive "P") + ;; Bind this variable here to make message mode hooks work ok. + (let ((gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Newsgroup: " gnus-active-hashtb nil + (gnus-read-active-file-p)) + "") + gnus-newsgroup-name)) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy)) (gnus-post-news 'post gnus-newsgroup-name))) -(defun gnus-summary-post-news () - "Start composing a news message." - (interactive) - (gnus-post-news 'post gnus-newsgroup-name)) (defun gnus-summary-followup (yank &optional force-news) "Compose a followup to an article. -If prefix argument YANK is non-nil, original article is yanked automatically." +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." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) (when yank - (gnus-summary-goto-subject (car yank))) + (gnus-summary-goto-subject + (if (listp (car yank)) + (caar yank) + (car yank)))) (save-window-excursion (gnus-summary-select-article)) (let ((headers (gnus-summary-article-header (gnus-summary-article-number))) @@ -269,7 +714,8 @@ If prefix argument YANK is non-nil, original article is yanked automatically." ;; 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." @@ -289,16 +735,24 @@ If prefix argument YANK is non-nil, original article is yanked automatically." (gnus-summary-followup (gnus-summary-work-articles arg) t)) (defun gnus-inews-yank-articles (articles) - (let (beg article) + (let (beg article yank-string) (message-goto-body) (while (setq article (pop articles)) + (when (listp article) + (setq yank-string (nth 1 article) + article (nth 0 article))) (save-window-excursion (set-buffer gnus-summary-buffer) (gnus-summary-select-article nil nil nil article) (gnus-summary-remove-process-mark article)) - (gnus-copy-article-buffer) + (gnus-copy-article-buffer nil yank-string) (let ((message-reply-buffer gnus-article-copy) - (message-reply-headers gnus-current-headers)) + (message-reply-headers + ;; The headers are decoded. + (with-current-buffer gnus-article-copy + (save-restriction + (nnheader-narrow-to-headers) + (nnheader-parse-naked-head))))) (message-yank-original) (setq beg (or beg (mark t)))) (when articles @@ -315,7 +769,7 @@ post using the current select method." (let ((articles (gnus-summary-work-articles n)) (message-post-method `(lambda (arg) - (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name))) + (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))) article) (while (setq article (pop articles)) (when (gnus-summary-select-article t nil nil article) @@ -347,78 +801,98 @@ header line with the old Message-ID." -(defun gnus-copy-article-buffer (&optional article-buffer) +(defun gnus-copy-article-buffer (&optional article-buffer yank-string) ;; make a copy of the article buffer with all text properties removed ;; this copy is in the buffer gnus-article-copy. ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used ;; this buffer should be passed to all mail/news reply/post routines. (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*")) - (buffer-disable-undo gnus-article-copy) + (save-excursion + (set-buffer gnus-article-copy) + (mm-enable-multibyte)) (let ((article-buffer (or article-buffer gnus-article-buffer)) - end beg contents) + end beg) (if (not (and (get-buffer article-buffer) (gnus-buffer-exists-p article-buffer))) (error "Can't find any article buffer") (save-excursion (set-buffer article-buffer) - (save-restriction - ;; Copy over the (displayed) article buffer, delete - ;; hidden text and remove text properties. - (widen) - (copy-to-buffer gnus-article-copy (point-min) (point-max)) - (set-buffer gnus-article-copy) - (gnus-article-delete-text-of-type 'annotation) - (gnus-remove-text-with-property 'gnus-prev) - (gnus-remove-text-with-property 'gnus-next) - (insert - (prog1 - (format "%s" (buffer-string)) - (erase-buffer))) - ;; Find the original headers. - (set-buffer gnus-original-article-buffer) - (goto-char (point-min)) - (while (looking-at message-unix-mail-delimiter) - (forward-line 1)) - (setq beg (point)) - (setq end (or (search-forward "\n\n" nil t) (point))) - ;; Delete the headers from the displayed articles. - (set-buffer gnus-article-copy) - (delete-region (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point))) - ;; Insert the original article headers. - (insert-buffer-substring gnus-original-article-buffer beg end) - (gnus-article-decode-rfc1522))) + (let ((gnus-newsgroup-charset (or gnus-article-charset + gnus-newsgroup-charset)) + (gnus-newsgroup-ignored-charsets + (or gnus-article-ignored-charsets + gnus-newsgroup-ignored-charsets))) + (save-restriction + ;; Copy over the (displayed) article buffer, delete + ;; hidden text and remove text properties. + (widen) + (copy-to-buffer gnus-article-copy (point-min) (point-max)) + (set-buffer gnus-article-copy) + (when yank-string + (message-goto-body) + (delete-region (point) (point-max)) + (insert yank-string)) + (gnus-article-delete-text-of-type 'annotation) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next) + (gnus-remove-text-with-property 'gnus-decoration) + (insert + (prog1 + (buffer-substring-no-properties (point-min) (point-max)) + (erase-buffer))) + ;; Find the original headers. + (set-buffer gnus-original-article-buffer) + (goto-char (point-min)) + (while (looking-at message-unix-mail-delimiter) + (forward-line 1)) + (let ((mail-header-separator "")) + (setq beg (point) + end (or (message-goto-body) beg))) + ;; Delete the headers from the displayed articles. + (set-buffer gnus-article-copy) + (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. + (let ((gnus-article-decode-hook + (delq 'article-decode-charset + (copy-sequence gnus-article-decode-hook)))) + (run-hooks 'gnus-article-decode-hook))))) gnus-article-copy))) (defun gnus-post-news (post &optional group header article-buffer yank subject force-news) (when article-buffer (gnus-copy-article-buffer)) - (let ((gnus-article-reply 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) (t 'message)) (let* ((group (or group gnus-newsgroup-name)) + (charset (gnus-group-name-charset nil group)) (pgroup group) to-address to-group mailing-list to-list newsgroup-p) (when group - (setq to-address (gnus-group-find-parameter group 'to-address) + (setq to-address (gnus-parameter-to-address group) to-group (gnus-group-find-parameter group 'to-group) - to-list (gnus-group-find-parameter group 'to-list) + to-list (gnus-parameter-to-list group) newsgroup-p (gnus-group-find-parameter group 'newsgroup) mailing-list (when gnus-mailing-list-groups (string-match gnus-mailing-list-groups group)) - group (gnus-group-real-name group))) + group (gnus-group-name-decode (gnus-group-real-name group) + charset))) (if (or (and to-group (gnus-news-group-p to-group)) newsgroup-p force-news (and (gnus-news-group-p (or pgroup gnus-newsgroup-name) - (if header (mail-header-number header) - gnus-current-article)) + (or header gnus-current-article)) (not mailing-list) (not to-list) (not to-address))) @@ -427,7 +901,13 @@ header line with the old Message-ID." (message-news (or to-group group)) (set-buffer gnus-article-copy) (gnus-msg-treat-broken-reply-to) - (message-followup (if (or newsgroup-p force-news) nil to-group))) + (message-followup (if (or newsgroup-p force-news) + (if (save-restriction + (article-narrow-to-head) + (message-fetch-field "newsgroups")) + nil + "") + to-group))) ;; The is mail. (if post (progn @@ -445,10 +925,11 @@ header line with the old Message-ID." (when yank (gnus-inews-yank-articles yank)))))) -(defun gnus-msg-treat-broken-reply-to () - "Remove the Reply-to header iff broken-reply-to." - (when (gnus-group-find-parameter - gnus-newsgroup-name 'broken-reply-to) +(defun gnus-msg-treat-broken-reply-to (&optional force) + "Remove the Reply-to header if broken-reply-to." + (when (or force + (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to)) (save-restriction (message-narrow-to-head) (message-remove-header "reply-to")))) @@ -456,47 +937,54 @@ header line with the old Message-ID." (defun gnus-post-method (arg group &optional silent) "Return the posting method based on GROUP and ARG. If SILENT, don't prompt the user." - (let ((group-method (gnus-find-method-for-group group))) + (let ((gnus-post-method (or (gnus-parameter-post-method group) + gnus-post-method)) + (group-method (gnus-find-method-for-group group))) (cond ;; If the group-method is nil (which shouldn't happen) we use ;; the default method. ((null group-method) - (or (and (null (eq gnus-post-method 'active)) gnus-post-method) - gnus-select-method message-post-method)) + (or (and (listp gnus-post-method) ;If not current/native/nil + (not (listp (car gnus-post-method))) ; and not a list of methods + gnus-post-method) ;then use it. + gnus-select-method + message-post-method)) ;; We want the inverse of the default ((and arg (not (eq arg 0))) - (if (eq gnus-post-method 'active) + (if (eq gnus-post-method 'current) gnus-select-method group-method)) ;; We query the user for a post method. ((or arg - (and gnus-post-method - (not (eq gnus-post-method 'current)) + (and (listp gnus-post-method) (listp (car gnus-post-method)))) (let* ((methods ;; Collect all methods we know about. (append - (when (and gnus-post-method - (not (eq gnus-post-method 'current))) + (when (listp gnus-post-method) (if (listp (car gnus-post-method)) gnus-post-method (list gnus-post-method))) gnus-secondary-select-methods (mapcar 'cdr gnus-server-alist) + (mapcar 'car gnus-opened-servers) (list gnus-select-method) (list group-method))) method-alist post-methods method) ;; Weed out all mail methods. (while methods (setq method (gnus-server-get-method "" (pop methods))) - (when (or (gnus-method-option-p method 'post) - (gnus-method-option-p method 'post-mail)) + (when (and (or (gnus-method-option-p method 'post) + (gnus-method-option-p method 'post-mail)) + (not (member method post-methods))) (push method post-methods))) ;; Create a name-method alist. (setq method-alist (mapcar (lambda (m) - (list (concat (cadr m) " (" (symbol-name (car m)) ")") m)) + (if (equal (cadr m) "") + (list (symbol-name (car m)) m) + (list (concat (cadr m) " (" (symbol-name (car m)) ")") m))) post-methods)) ;; Query the user. (cadr @@ -512,80 +1000,47 @@ If SILENT, don't prompt the user." method-alist)))) ;; Override normal method. ((and (eq gnus-post-method 'current) - (not (eq (car group-method) 'nndraft)) - (not arg)) - group-method) - ((and gnus-post-method - (not (eq gnus-post-method 'current))) + (not (memq (car group-method) gnus-discouraged-post-methods)) + (gnus-get-function group-method 'request-post t)) + (assert (not arg)) + group-method) + ;; Use gnus-post-method. + ((listp gnus-post-method) ;A method... + (assert (not (listp (car gnus-post-method)))) ;... not a list of methods. gnus-post-method) - ;; Use the normal select method. + ;; Use the normal select method (nil or native). (t gnus-select-method)))) -;; Dummy to avoid byte-compile warning. -(defvar nnspool-rejected-article-hook) -(defvar xemacs-codename) +;; Dummies to avoid byte-compile warning. +(eval-when-compile + (defvar nnspool-rejected-article-hook) + (defvar xemacs-codename)) -;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might -;;; as well include the Emacs version as well. -;;; The following function works with later GNU Emacs, and XEmacs. (defun gnus-extended-version () "Stringified Gnus version and Emacs version." (interactive) (concat - gnus-version - "/" + "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t) + " (" gnus-version ")" + " " (cond - ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) - (concat "Emacs " (substring emacs-version - (match-beginning 1) - (match-end 1)))) + ((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 (substring emacs-version - (match-beginning 1) - (match-end 1)) - (format " %d.%d" emacs-major-version emacs-minor-version) + (concat (match-string 1 emacs-version) + (format "/%d.%d" emacs-major-version emacs-minor-version) (if (match-beginning 3) - (substring emacs-version - (match-beginning 3) - (match-end 3)) + (match-string 3 emacs-version) "") (if (boundp 'xemacs-codename) - (concat " - \"" xemacs-codename "\"")))) + (concat " (" xemacs-codename ", " system-configuration ")") + ""))) (t emacs-version)))) -;; Written by "Mr. Per Persson" . -(defun gnus-inews-insert-mime-headers () - "Insert MIME headers. -Assumes ISO-Latin-1 is used iff 8-bit characters are present." - (goto-char (point-min)) - (let ((mail-header-separator - (progn - (goto-char (point-min)) - (if (and (search-forward (concat "\n" mail-header-separator "\n") - nil t) - (not (search-backward "\n\n" nil t))) - mail-header-separator - "")))) - (or (mail-position-on-field "Mime-Version") - (insert "1.0") - (cond ((save-restriction - (widen) - (goto-char (point-min)) - (re-search-forward "[^\000-\177]" nil t)) - (or (mail-position-on-field "Content-Type") - (insert "text/plain; charset=ISO-8859-1")) - (or (mail-position-on-field "Content-Transfer-Encoding") - (insert "8bit"))) - (t (or (mail-position-on-field "Content-Type") - (insert "text/plain; charset=US-ASCII")) - (or (mail-position-on-field "Content-Transfer-Encoding") - (insert "7bit"))))))) - -(custom-add-option 'message-header-hook 'gnus-inews-insert-mime-headers) - ;;; ;;; Gnus Mail Functions @@ -593,25 +1048,77 @@ Assumes ISO-Latin-1 is used iff 8-bit characters are present." ;;; Mail reply commands of Gnus summary mode -(defun gnus-summary-reply (&optional yank wide) - "Start composing a reply mail to the current message. +(defun gnus-summary-reply (&optional yank wide very-wide) + "Start composing a mail reply to the current message. If prefix argument YANK is non-nil, the original article is yanked -automatically." +automatically. +If WIDE, make a wide reply. +If VERY-WIDE, make a very wide reply." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) - ;; Stripping headers should be specified with mail-yank-ignored-headers. - (when yank - (gnus-summary-goto-subject (car yank))) - (let ((gnus-article-reply t) - (gnus-inhibit-posting-styles t)) - (gnus-setup-message (if yank 'reply-yank 'reply) - (gnus-summary-select-article) - (set-buffer (gnus-copy-article-buffer)) - (gnus-msg-treat-broken-reply-to) - (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))))) + (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. @@ -619,6 +1126,24 @@ The original article will be yanked." (interactive "P") (gnus-summary-reply (gnus-summary-work-articles n) wide)) +(defun gnus-summary-reply-broken-reply-to (&optional yank wide very-wide) + "Like `gnus-summary-reply' except removing reply-to field. +If prefix argument YANK is non-nil, the original article is yanked +automatically. +If WIDE, make a wide reply. +If VERY-WIDE, make a very wide reply." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (let ((gnus-msg-force-broken-reply-to t)) + (gnus-summary-reply yank wide very-wide))) + +(defun gnus-summary-reply-broken-reply-to-with-original (n &optional wide) + "Like `gnus-summary-reply-with-original' except removing reply-to field. +The original article will be yanked." + (interactive "P") + (gnus-summary-reply-broken-reply-to (gnus-summary-work-articles n) wide)) + (defun gnus-summary-wide-reply (&optional yank) "Start composing a wide reply mail to the current message. If prefix argument YANK is non-nil, the original article is yanked @@ -634,33 +1159,127 @@ The original article will be yanked." (interactive "P") (gnus-summary-reply-with-original n t)) -(defun gnus-summary-mail-forward (&optional full-headers post) - "Forward the current message to another user. -If FULL-HEADERS (the prefix), include full headers when forwarding." +(defun gnus-summary-very-wide-reply (&optional yank) + "Start composing a very wide reply mail to the current message. +If prefix argument YANK is non-nil, the original article is yanked +automatically." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-summary-reply yank t (gnus-summary-work-articles yank))) + +(defun gnus-summary-very-wide-reply-with-original (n) + "Start composing a very wide reply mail to the current message. +The original article will be yanked." + (interactive "P") + (gnus-summary-reply + (gnus-summary-work-articles n) t (gnus-summary-work-articles n))) + +(defun gnus-summary-mail-forward (&optional arg post) + "Forward the current message(s) to another user. +If process marks exist, forward all marked messages; +if ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml'; +if ARG is 1, decode the message and forward directly inline; +if ARG is 2, forward message as an rfc822 MIME section; +if ARG is 3, decode message and forward as an rfc822 MIME section; +if ARG is 4, forward message directly inline; +otherwise, use flipped `message-forward-as-mime'. +If POST, post instead of mail. +For the `inline' alternatives, also see the variable +`message-forward-ignored-headers'." (interactive "P") - (gnus-setup-message 'forward - (gnus-summary-select-article) - (set-buffer gnus-original-article-buffer) - (let ((message-included-forward-headers - (if full-headers "" message-included-forward-headers))) - (message-forward 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 "sResend message(s) to: \nP") + (interactive + (list (message-read-from-minibuffer + "Resend message(s) to: " + (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))))) + (message-resend address)) + (gnus-summary-mark-article-as-forwarded article)))) + +;; From: Matthieu Moy +(defun gnus-summary-resend-message-edit () + "Resend an article that has already been sent. +A new buffer will be created to allow the user to modify body and +contents of the message, and then, everything will happen as when +composing a new message." + (interactive) + (let ((article (gnus-summary-article-number))) + (gnus-setup-message 'reply-yank + (gnus-summary-select-article t) + (set-buffer gnus-original-article-buffer) + (let ((cur (current-buffer)) + (to (message-fetch-field "to"))) + ;; Get a normal message buffer. + (message-pop-to-buffer (message-buffer-name "Resend" to)) + (insert-buffer-substring cur) + (mime-to-mml) + (message-narrow-to-head-1) + ;; Gnus will generate a new one when sending. + (message-remove-header "Message-ID") + (message-remove-header message-ignored-resent-headers t) + ;; Remove unwanted headers. + (goto-char (point-max)) + (insert mail-header-separator) + (goto-char (point-min)) + (re-search-forward "^To:\\|^Newsgroups:" nil 'move) + (forward-char 1) + (widen))))) -(defun gnus-summary-post-forward (&optional full-headers) +(defun gnus-summary-post-forward (&optional arg) "Forward the current article to a newsgroup. -If FULL-HEADERS (the prefix), include full headers when forwarding." +See `gnus-summary-mail-forward' for ARG." (interactive "P") - (gnus-summary-mail-forward full-headers t)) + (gnus-summary-mail-forward arg t)) (defvar gnus-nastygram-message "The following article was inappropriately posted to %s.\n\n" @@ -693,7 +1312,8 @@ The current group name will be inserted at \"%s\".") (gnus-summary-select-article) (set-buffer gnus-original-article-buffer) (if (and (<= (length (message-tokenize-header - (setq newsgroups (mail-fetch-field "newsgroups")) + (setq newsgroups + (mail-fetch-field "newsgroups")) ", ")) 1) (or (not (setq followup-to (mail-fetch-field "followup-to"))) @@ -714,12 +1334,6 @@ The current group name will be inserted at \"%s\".") (when (gnus-y-or-n-p "Send this complaint? ") (message-send-and-exit))))))) -(defun gnus-summary-mail-other-window () - "Compose mail in other window." - (interactive) - (gnus-setup-message 'message - (message-mail))) - (defun gnus-mail-parse-comma-list () (let (accumulated beg) @@ -763,35 +1377,34 @@ The current group name will be inserted at \"%s\".") (let ((reply gnus-article-reply) (winconf gnus-prev-winconf) (group gnus-newsgroup-name)) + (unless (and group + (not (gnus-group-read-only-p group))) + (setq group (read-string "Put in group: " nil (gnus-writable-groups)))) - (or (and group (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) (error "No such group: %s" group)) - (save-excursion (save-restriction (widen) (message-narrow-to-headers) - (let (gnus-deletable-headers) - (if (message-news-p) - (message-generate-headers message-required-news-headers) - (message-generate-headers message-required-mail-headers))) + (let ((gnus-deletable-headers nil)) + (message-generate-headers + (if (message-news-p) + 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 (get-buffer gnus-group-buffer) - (when (gnus-buffer-exists-p (car-safe reply)) - (set-buffer (car reply)) - (and (cdr reply) - (gnus-summary-mark-article-as-replied - (cdr reply)))) - (when winconf - (set-window-configuration winconf))))) + (when (and (get-buffer gnus-group-buffer) + (gnus-buffer-exists-p (car-safe reply)) + (cdr reply)) + (set-buffer (car reply)) + (gnus-summary-mark-article-as-replied (cdr reply))) + (when winconf + (set-window-configuration winconf)))) (defun gnus-article-mail (yank) "Send a reply to the address near point. @@ -802,7 +1415,7 @@ If YANK is non-nil, include the original article." (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point))) (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point)))))) (when address - (message-reply address) + (gnus-msg-mail address) (when yank (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) @@ -812,15 +1425,17 @@ If YANK is non-nil, include the original article." (interactive) (unless (gnus-alive-p) (error "Gnus has been shut down")) - (gnus-setup-message 'bug - (delete-other-windows) - (when gnus-bug-create-help-buffer - (switch-to-buffer "*Gnus Help Bug*") - (erase-buffer) - (insert gnus-bug-message) - (goto-char (point-min))) - (message-pop-to-buffer "*Gnus Bug*") - (message-setup `((To . ,gnus-maintainer) (Subject . ""))) + (gnus-setup-message (if (message-mail-user-agent) 'message 'bug) + (unless (message-mail-user-agent) + (delete-other-windows) + (when gnus-bug-create-help-buffer + (switch-to-buffer "*Gnus Help Bug*") + (erase-buffer) + (insert gnus-bug-message) + (goto-char (point-min))) + (message-pop-to-buffer "*Gnus Bug*")) + (let ((message-this-is-mail t)) + (message-setup `((To . ,gnus-maintainer) (Subject . "")))) (when gnus-bug-create-help-buffer (push `(gnus-bug-kill-buffer) message-send-actions)) (goto-char (point-min)) @@ -832,7 +1447,13 @@ If YANK is non-nil, include the original article." (stringp nntp-server-type)) (insert nntp-server-type)) (insert "\n\n\n\n\n") - (gnus-debug) + (let (text) + (save-excursion + (set-buffer (gnus-get-buffer-create " *gnus environment info*")) + (erase-buffer) + (gnus-debug) + (setq text (buffer-string))) + (insert "<#part type=application/emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>")) (goto-char (point-min)) (search-forward "Subject: " nil t) (message ""))) @@ -841,14 +1462,24 @@ If YANK is non-nil, include the original article." (when (get-buffer "*Gnus Help Bug*") (kill-buffer "*Gnus Help Bug*"))) +(defun gnus-summary-yank-message (buffer n) + "Yank the current article into a composed message." + (interactive + (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)) + (gnus-summary-select-article)) + (save-excursion + (set-buffer buffer) + (message-yank-buffer gnus-article-buffer)))) + (defun gnus-debug () "Attempts to go through the Gnus source file and report what variables have been changed. The source file has to be in the Emacs load path." (interactive) - (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el" - "gnus-art.el" "gnus-start.el" "gnus-async.el" - "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el" - "nnmail.el" "message.el")) + (let ((files gnus-debug-files) (point (point)) file expr olist sym) (gnus-message 4 "Please wait while we snoop your variables...") @@ -856,7 +1487,6 @@ The source file has to be in the Emacs load path." ;; Go through all the files looking for non-default values for variables. (save-excursion (set-buffer (gnus-get-buffer-create " *gnus bug info*")) - (buffer-disable-undo (current-buffer)) (while files (erase-buffer) (when (and (setq file (locate-library (pop files))) @@ -872,6 +1502,7 @@ The source file has to be in the Emacs load path." (and (or (eq (car expr) 'defvar) (eq (car expr) 'defcustom)) (stringp (nth 3 expr)) + (not (memq (nth 1 expr) gnus-debug-exclude-variables)) (or (not (boundp (nth 1 expr))) (not (equal (eval (nth 2 expr)) (symbol-value (nth 1 expr))))) @@ -881,17 +1512,15 @@ 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 + (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))) (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) (setq olist (cdr olist))) (insert "\n\n") @@ -926,53 +1555,95 @@ this is a reply." ;;; Gcc handling. +(defun gnus-inews-group-method (group) + (cond + ;; If the group doesn't exist, we assume + ;; it's an archive group... + ((and (null (gnus-get-info group)) + (eq (car (gnus-server-to-method gnus-message-archive-method)) + (car (gnus-server-to-method (gnus-group-method group))))) + gnus-message-archive-method) + ;; Use the method. + ((gnus-info-method (gnus-get-info group)) + (gnus-info-method (gnus-get-info group))) + ;; Find the method. + (t (gnus-server-to-method (gnus-group-method group))))) + ;; Do Gcc handling, which copied the message over to some group. (defun gnus-inews-do-gcc (&optional gcc) (interactive) - (when (gnus-alive-p) - (save-excursion - (save-restriction - (message-narrow-to-headers) - (let ((gcc (or gcc (mail-fetch-field "gcc" nil t))) - (cur (current-buffer)) - groups group method) - (when gcc - (message-remove-header "gcc") - (widen) - (setq groups (message-tokenize-header gcc " ,")) - ;; Copy the article over to some group(s). - (while (setq group (pop groups)) - (gnus-check-server - (setq method - (cond ((and (null (gnus-get-info group)) - (eq (car gnus-message-archive-method) - (car - (gnus-server-to-method - (gnus-group-method group))))) - ;; If the group doesn't exist, we assume - ;; it's an archive group... - gnus-message-archive-method) - ;; Use the method. - ((gnus-info-method (gnus-get-info group)) - (gnus-info-method (gnus-get-info group))) - ;; Find the method. - (t (gnus-group-method group))))) - (gnus-check-server method) - (unless (gnus-request-group group t method) - (gnus-request-create-group group method)) - (save-excursion - (nnheader-set-temp-buffer " *acc*") - (insert-buffer-substring cur) - (goto-char (point-min)) - (when (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (replace-match "" t t )) - (unless (gnus-request-accept-article group method t) - (gnus-message 1 "Couldn't store article in group %s: %s" - group (gnus-status-message method)) - (sit-for 2)) - (kill-buffer (current-buffer)))))))))) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (let ((gcc (or gcc (mail-fetch-field "gcc" nil t))) + (cur (current-buffer)) + groups group method group-art + mml-externalize-attachments) + (when gcc + (message-remove-header "gcc") + (widen) + (setq groups (message-unquote-tokens + (message-tokenize-header gcc " ,"))) + ;; Copy the article over to some group(s). + (while (setq group (pop groups)) + (unless (gnus-check-server + (setq method (gnus-inews-group-method group))) + (error "Can't open server %s" (if (stringp method) method + (car method)))) + (unless (gnus-request-group group nil method) + (gnus-request-create-group group method)) + (setq mml-externalize-attachments + (if (stringp gnus-gcc-externalize-attachments) + (string-match gnus-gcc-externalize-attachments group) + gnus-gcc-externalize-attachments)) + (save-excursion + (nnheader-set-temp-buffer " *acc*") + (insert-buffer-substring cur) + (message-encode-message-body) + (save-restriction + (message-narrow-to-headers) + (let* ((mail-parse-charset message-default-charset) + (newsgroups-field (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups"))) + (followup-field (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Followup-To"))) + ;; BUG: We really need to get the charset for + ;; each name in the Newsgroups and Followup-To + ;; lines to allow crossposting between group + ;; namess with incompatible character sets. + ;; -- Per Abrahamsen 2001-10-08. + (group-field-charset + (gnus-group-name-charset + method (or newsgroups-field ""))) + (followup-field-charset + (gnus-group-name-charset + method (or followup-field ""))) + (rfc2047-header-encoding-alist + (append + (when group-field-charset + (list (cons "Newsgroups" group-field-charset))) + (when followup-field-charset + (list (cons "Followup-To" followup-field-charset))) + rfc2047-header-encoding-alist))) + (mail-encode-encoded-word-buffer))) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (replace-match "" t t )) + (unless (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)) + (when (and group-art + (gnus-alive-p) + (or gnus-gcc-mark-as-read + gnus-inews-mark-gcc-as-read)) + (gnus-group-mark-article-read group (cdr group-art))) + (kill-buffer (current-buffer))))))))) (defun gnus-inews-insert-gcc () "Insert Gcc headers based on `gnus-outgoing-message-group'." @@ -987,8 +1658,15 @@ this is a reply." 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) @@ -997,9 +1675,10 @@ this is a reply." (group (or group gnus-newsgroup-name "")) (gcc-self-val (and gnus-newsgroup-name + (not (equal gnus-newsgroup-name "")) (gnus-group-find-parameter gnus-newsgroup-name 'gcc-self))) - result + result (groups (cond ((null gnus-message-archive-method) @@ -1048,8 +1727,12 @@ 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) + (if (string-match " " group) + (concat "\"" group "\"") + group))) (if (not (eq gcc-self-val 'none)) (insert "\n") (progn @@ -1057,96 +1740,170 @@ this is a reply." (kill-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"))))))) ;;; Posting styles. -(defvar gnus-message-style-insertions nil) - -(defun gnus-configure-posting-styles () +(defun gnus-configure-posting-styles (&optional group-name) "Configure posting styles according to `gnus-posting-styles'." (unless gnus-inhibit-posting-styles - (let ((styles gnus-posting-styles) - (gnus-newsgroup-name (or gnus-newsgroup-name "")) - style match variable attribute value value-value) - (make-local-variable 'gnus-message-style-insertions) + (let ((group (or group-name gnus-newsgroup-name "")) + (styles gnus-posting-styles) + style match variable 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 + ;; the others. + (when gnus-newsgroup-name + (let ((tmp-style (gnus-group-find-parameter group 'posting-style t))) + (when tmp-style + (setq styles (append styles (list (cons ".*" tmp-style))))))) ;; Go through all styles and look for matches. - (while styles - (setq style (pop styles) - match (pop style)) - (when (cond ((stringp match) - ;; Regexp string match on the group name. - (string-match match gnus-newsgroup-name)) - ((or (symbolp match) - (gnus-functionp match)) - (cond ((gnus-functionp match) - ;; Function to be called. - (funcall match)) - ((boundp match) - ;; Variable to be checked. - (symbol-value match)))) - ((listp match) - ;; This is a form to be evaled. - (eval match))) + (dolist (style styles) + (setq match (pop style)) + (goto-char (point-min)) + (when (cond + ((stringp match) + ;; Regexp string match on the group name. + (string-match match group)) + ((eq match 'header) + ;; 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)))))) + ((or (symbolp match) + (gnus-functionp match)) + (cond + ((gnus-functionp match) + ;; Function to be called. + (funcall match)) + ((boundp match) + ;; Variable to be checked. + (symbol-value match)))) + ((listp match) + (cond + ((eq (car match) 'header) + ;; 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)))))) + (t + ;; This is a form to be evaled. + (eval match))))) ;; We have a match, so we set the variables. - (while style - (setq attribute (pop style) - value (cadr attribute) - variable nil) - ;; We find the variable that is to be modified. - (if (and (not (stringp (car attribute))) - (not (eq 'body (car attribute))) - (not (setq variable - (cdr (assq (car attribute) - gnus-posting-style-alist))))) - (message "Couldn't find attribute %s" (car attribute)) - ;; We get the value. - (setq value-value - (cond ((stringp value) - value) - ((or (symbolp value) - (gnus-functionp value)) - (cond ((gnus-functionp value) - (funcall value)) - ((boundp value) - (symbol-value value)))) - ((listp value) - (eval value)))) - (if variable - ;; This is an ordinary variable. - (set (make-local-variable variable) value-value) - ;; This is either a body or a header to be inserted in the - ;; message. - (when value-value - (let ((attr (car attribute))) - (make-local-variable 'message-setup-hook) - (if (eq 'body attr) - (add-hook 'message-setup-hook - `(lambda () - (save-excursion - (message-goto-body) - (insert ,value-value)))) - (add-hook 'message-setup-hook - 'gnus-message-insert-stylings) - (push (cons (if (stringp attr) attr - (symbol-name attr)) - value-value) - gnus-message-style-insertions)))))))))))) - -(defun gnus-message-insert-stylings () - (let (val) - (save-excursion - (message-goto-eoh) - (while (setq val (pop gnus-message-style-insertions)) - (when (cdr val) - (insert (car val) ": " (cdr val) "\n")) - (gnus-pull (car val) gnus-message-style-insertions))))) + (dolist (attribute style) + (setq element (pop attribute) + variable nil + filep nil) + (setq value + (cond + ((eq (car attribute) :file) + (setq filep t) + (cadr attribute)) + ((eq (car attribute) :value) + (cadr attribute)) + (t + (car attribute)))) + ;; We get the value. + (setq v + (cond + ((stringp value) + value) + ((or (symbolp value) + (gnus-functionp value)) + (cond ((gnus-functionp value) + (funcall value)) + ((boundp value) + (symbol-value value)))) + ((listp value) + (eval value)))) + ;; Translate obsolescent value. + (cond + ((eq element 'signature-file) + (setq element 'signature + filep t)) + ((eq element 'x-face-file) + (setq element 'x-face + filep t))) + ;; Get the contents of file elems. + (when (and filep v) + (setq v (with-temp-buffer + (insert-file-contents v) + (goto-char (point-max)) + (while (bolp) + (delete-char -1)) + (buffer-string)))) + (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) + (setq results (sort results (lambda (x y) + (string-lessp (car x) (car y))))) + (dolist (result results) + (add-hook 'message-setup-hook + (cond + ((eq 'eval (car result)) + 'ignore) + ((eq 'body (car result)) + `(lambda () + (save-excursion + (message-goto-body) + (insert ,(cdr result))))) + ((eq 'signature (car result)) + (set (make-local-variable 'message-signature) nil) + (set (make-local-variable 'message-signature-file) nil) + (if (not (cdr result)) + 'ignore + `(lambda () + (save-excursion + (let ((message-signature ,(cdr result))) + (when message-signature + (message-insert-signature))))))) + (t + (let ((header + (if (symbolp (car result)) + (capitalize (symbol-name (car result))) + (car result)))) + `(lambda () + (save-excursion + (message-remove-header ,header) + (let ((value ,(cdr result))) + (when value + (message-goto-eoh) + (insert ,header ": " value) + (unless (bolp) + (insert "\n"))))))))) + nil 'local)) + (when (or name address) + (add-hook 'message-setup-hook + `(lambda () + (set (make-local-variable 'user-mail-address) + ,(or (cdr address) user-mail-address)) + (let ((user-full-name ,(or (cdr name) (user-full-name))) + (user-mail-address + ,(or (cdr address) user-mail-address))) + (save-excursion + (message-remove-header "From") + (message-goto-eoh) + (insert "From: " (message-make-from) "\n")))) + nil 'local))))) ;;; Allow redefinition of functions.