X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-msg.el;h=5e863eb8df74b1c82cb967c34e69076508d29232;hb=3a75505b36e914f05480b86020edd727c6abe2fb;hp=9bc80d5b3a0ab215a91c050cc32e5c72e44b6204;hpb=c971b856674f06a000b973ef6ac5e5e7134cd705;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 9bc80d5..5e863eb 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,99 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; 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,33 +97,92 @@ 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.") - -(defcustom gnus-group-posting-charset-alist - '(("^no\\." iso-8859-1) - (".*" iso-8859-1) - (message-this-is-mail nil) - ) - "Alist of regexps (to match group names) and default charsets to be unencoded when posting." - :type '(repeat (list (regexp :tag "Group") - (symbol :tag "Charset"))) +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 + :type '(repeat (cons (choice (regexp) + (function) + (variable) + (sexp)) + (repeat (list + (choice (const signature) + (const signature-file) + (const organization) + (const address) + (const name) + (const body) + (string :tag "Header")) + (choice (string) + (function) + (variable) + (sexp))))))) + +(defcustom gnus-gcc-mark-as-read nil + "If non-nil, automatically mark Gcc articles as read." + :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." + :group 'gnus-message + :type '(choice (const nil :tag "None") + (const all :tag "Any") + (string :tag "Regexp"))) + +(defcustom gnus-group-posting-charset-alist + '(("^\\(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)) + "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." + :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) ;;; Internal variables. @@ -125,9 +192,12 @@ the second with the current group name.") (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. ======================================== @@ -135,9 +205,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') @@ -162,19 +233,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 @@ -195,45 +272,133 @@ Thank you for your help in stamping out bugs. (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) (,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))) (unwind-protect (progn ,@forms) - (gnus-inews-add-send-actions ,winconf ,buffer ,article) + (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config) + (gnus-inews-insert-draft-meta-information ,group ,article) (setq gnus-message-buffer (current-buffer)) (set (make-local-variable 'gnus-message-group-art) (cons ,group ,article)) (set (make-local-variable 'gnus-newsgroup-name) ,group) - (set (make-local-variable 'message-posting-charset) - (gnus-setup-posting-charset ,group)) - (gnus-run-hooks 'gnus-message-setup-hook)) + (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-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")))) + +;;;###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) - (catch 'found - (while (setq elem (pop alist)) - (when (or (and (stringp (car alist)) - (string-match (car alist) group)) - (and (gnus-functionp (car alist)) - (funcall (car alist) group)) - (and (symbolp (car alist)) - (symbol-value (car alist)))) - (throw 'found (cadr alist))))))) - -(defun gnus-inews-add-send-actions (winconf buffer article) + (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) (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))) @@ -245,7 +410,9 @@ Thank you for your help in stamping out bugs. (save-excursion (set-buffer ,buffer) ,(when article - `(gnus-summary-mark-article-as-replied ,article)))) + (if (eq config 'forward) + `(gnus-summary-mark-article-as-forwarded ',article) + `(gnus-summary-mark-article-as-replied ',article))))) 'send)) (put 'gnus-setup-message 'lisp-indent-function 1) @@ -272,15 +439,47 @@ If ARG is 1, prompt for a group name to find the posting style." (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) + (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 @@ -292,19 +491,94 @@ If ARG is 1, prompt for a group name." ""))) (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-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) + (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) + (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))) + (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))) @@ -332,16 +606,22 @@ 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 + (nnheader-parse-head t)))) (message-yank-original) (setq beg (or beg (mark t)))) (when articles @@ -390,7 +670,7 @@ 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 @@ -406,64 +686,78 @@ header line with the old Message-ID." (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-max))) - ;; Insert the original article headers. - (insert-buffer-substring gnus-original-article-buffer beg end) - (article-decode-encoded-words))) + (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) + (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)) + (setq beg (point) + end (or (message-goto-body) beg)) + ;; Delete the headers from the displayed articles. + (set-buffer gnus-article-copy) + (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))) (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))) @@ -472,7 +766,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 @@ -490,10 +790,11 @@ header line with the old Message-ID." (when yank (gnus-inews-yank-articles yank)))))) -(defun gnus-msg-treat-broken-reply-to () +(defun gnus-msg-treat-broken-reply-to (&optional force) "Remove the Reply-to header iff broken-reply-to." - (when (gnus-group-find-parameter - gnus-newsgroup-name '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")))) @@ -501,28 +802,31 @@ 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))) @@ -543,7 +847,9 @@ If SILENT, don't prompt the user." (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 @@ -560,19 +866,22 @@ If SILENT, don't prompt the user." ;; Override normal method. ((and (eq gnus-post-method 'current) (not (eq (car group-method) 'nndraft)) - (not arg)) + (gnus-get-function group-method 'request-post t)) + (assert (not arg)) group-method) - ((and gnus-post-method - (not (eq gnus-post-method 'current))) + ;; 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)))) ;; Dummies to avoid byte-compile warning. -(defvar nnspool-rejected-article-hook) -(defvar xemacs-codename) +(eval-when-compile + (defvar nnspool-rejected-article-hook) + (defvar xemacs-codename)) (defun gnus-extended-version () "Stringified Gnus version and Emacs version." @@ -582,8 +891,9 @@ If SILENT, don't prompt the user." " (" gnus-version ")" " " (cond - ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) - (concat "Emacs/" (match-string 1 emacs-version))) + ((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) @@ -592,7 +902,7 @@ If SILENT, don't prompt the user." (match-string 3 emacs-version) "") (if (boundp 'xemacs-codename) - (concat " (" xemacs-codename ")") + (concat " (" xemacs-codename ", " system-configuration ")") ""))) (t emacs-version)))) @@ -603,21 +913,44 @@ If SILENT, don't prompt the user." ;;; 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)) + (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) - (gnus-summary-select-article) + (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-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))))) @@ -628,6 +961,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 @@ -643,40 +994,89 @@ 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-setup-message 'forward - (gnus-summary-select-article) - (let (text) - (save-excursion - (set-buffer gnus-original-article-buffer) - (setq text (buffer-string))) - (set-buffer (gnus-get-buffer-create " *Gnus forward*")) - (erase-buffer) - (insert text) - (run-hooks 'gnus-article-decode-hook) - (let ((message-included-forward-headers - (if full-headers "" message-included-forward-headers))) - (message-forward post))))) + (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") + (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 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))) (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 (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)))) -(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" @@ -731,12 +1131,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) @@ -780,35 +1174,32 @@ 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") (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. @@ -829,15 +1220,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)) @@ -849,7 +1242,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 ""))) @@ -858,6 +1257,19 @@ 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." @@ -942,53 +1354,94 @@ 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 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 + (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'." @@ -1013,6 +1466,7 @@ 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 @@ -1083,31 +1537,34 @@ this is a reply." ;;; 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. - (unless (zerop (length gnus-newsgroup-name)) - (let ((tmp-style (gnus-group-find-parameter - gnus-newsgroup-name 'posting-style t))) + (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)) + (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 gnus-newsgroup-name)) + (string-match match group)) + ((eq match 'header) + (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 @@ -1121,58 +1578,95 @@ this is a reply." ;; 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. - (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 t))))) + (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. + (when (eq element 'signature-file) + (setq element 'signature + filep t)) + ;; Get the contents of file elems. + (when (and filep v) + (setq v (with-temp-buffer + (insert-file-contents v) + (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) + (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 "\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.