X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-msg.el;h=8d16a426970a91e32937b4349e01382374a74e98;hp=08fef2327ad47961bd698d9c746f7122bdd29a20;hb=4b33d9287652b0d133fd6fe59971da5cece40ef8;hpb=243e2b9f043dc48b35ce77f2f283e32ef7c0291e diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 08fef2327..8d16a4269 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -1,6 +1,6 @@ ;;; gnus-msg.el --- mail and post interface for Gnus -;; Copyright (C) 1995-2011 Free Software Foundation, Inc. +;; Copyright (C) 1995-2012 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -163,6 +163,22 @@ if nil, attach files as normal parts." (const all :tag "Any") (string :tag "Regexp"))) +(defcustom gnus-gcc-self-resent-messages 'no-gcc-self + "Like `gcc-self' group parameter, only for unmodified resent messages. +Applied to messages sent by `gnus-summary-resend-message'. Non-nil +value of this variable takes precedence over any existing Gcc header. + +If this is `none', no Gcc copy will be made. If this is t, messages +resent will be Gcc'd to the current group. If this is a string, it +specifies a group to which resent messages will be Gcc'd. If this is +nil, Gcc will be done according to existing Gcc header(s), if any. +If this is `no-gcc-self', resent messages will be Gcc'd to groups that +existing Gcc header specifies, except for the current group." + :version "24.2" + :group 'gnus-message + :type '(choice (const none) (const t) string (const nil) + (const no-gcc-self))) + (gnus-define-group-parameter posting-charset-alist :type list @@ -297,6 +313,22 @@ If nil, the address field will always be empty after invoking :group 'gnus-message :type 'boolean) +(defcustom gnus-gcc-pre-body-encode-hook nil + "A hook called before encoding the body of the Gcc copy of a message. +The current buffer (when the hook is run) contains the message +including the message header. Changes made to the message will +only affect the Gcc copy, but not the original message." + :group 'gnus-message + :type 'hook) + +(defcustom gnus-gcc-post-body-encode-hook nil + "A hook called after encoding the body of the Gcc copy of a message. +The current buffer (when the hook is run) contains the message +including the message header. Changes made to the message will +only affect the Gcc copy, but not the original message." + :group 'gnus-message + :type 'hook) + (autoload 'gnus-message-citation-mode "gnus-cite" nil t) ;;; Internal variables. @@ -351,6 +383,7 @@ Thank you for your help in stamping out bugs. "r" gnus-summary-reply "y" gnus-summary-yank-message "R" gnus-summary-reply-with-original + "L" gnus-summary-reply-to-list-with-original "w" gnus-summary-wide-reply "W" gnus-summary-wide-reply-with-original "v" gnus-summary-very-wide-reply @@ -383,11 +416,13 @@ Thank you for your help in stamping out bugs. (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) (let ((winconf (make-symbol "gnus-setup-message-winconf")) + (winconf-name (make-symbol "gnus-setup-message-winconf-name")) (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)) + (,winconf-name gnus-current-window-configuration) (,buffer (buffer-name (current-buffer))) (,article gnus-article-reply) (,yanked gnus-article-yanked-articles) @@ -432,7 +467,7 @@ Thank you for your help in stamping out bugs. (progn ,@forms) (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config - ,yanked) + ,yanked ,winconf-name) (setq gnus-message-buffer (current-buffer)) (set (make-local-variable 'gnus-message-group-art) (cons ,group ,article)) @@ -475,22 +510,28 @@ Thank you for your help in stamping out bugs. ;;;###autoload (defun gnus-msg-mail (&optional to subject other-headers continue - switch-action yank-action send-actions return-action) + switch-action yank-action send-actions + return-action) "Start editing a mail message to be sent. Like `message-mail', but with Gnus paraphernalia, particularly the -Gcc: header for archiving purposes." +Gcc: header for archiving purposes. +If Gnus isn't running, a plain `message-mail' setup is used +instead." (interactive) - (let ((buf (current-buffer)) - mail-buf) - (gnus-setup-message 'message + (if (not (gnus-alive-p)) (message-mail to subject other-headers continue - nil yank-action send-actions return-action)) - (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) + nil yank-action send-actions return-action) + (let ((buf (current-buffer)) + mail-buf) + (gnus-setup-message 'message + (message-mail to subject other-headers continue + nil yank-action send-actions return-action)) + (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))) ;;;###autoload (defun gnus-button-mailto (address) @@ -527,7 +568,8 @@ Gcc: header for archiving purposes." (throw 'found (cons (cadr elem) (caddr elem))))))))) (defun gnus-inews-add-send-actions (winconf buffer article - &optional config yanked) + &optional config yanked + winconf-name) (gnus-make-local-hook 'message-sent-hook) (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc 'gnus-inews-do-gcc) nil t) @@ -538,8 +580,10 @@ Gcc: header for archiving purposes." `(lambda (&optional arg) (gnus-post-method arg ,gnus-newsgroup-name))) (message-add-action - `(when (gnus-buffer-exists-p ,buffer) - (set-window-configuration ,winconf)) + `(progn + (setq gnus-current-window-configuration ',winconf-name) + (when (gnus-buffer-exists-p ,buffer) + (set-window-configuration ,winconf))) 'exit 'postpone 'kill) (let ((to-be-marked (cond (yanked @@ -630,7 +674,7 @@ a news." (if (= 1 (prefix-numeric-value arg)) (gnus-group-completing-read "Newsgroup" nil (gnus-read-active-file-p)) - (gnus-group-group-name)) + (or (gnus-group-group-name) "")) "")) ;; make sure last viewed article doesn't affect posting styles: (gnus-article-copy)) @@ -797,9 +841,21 @@ post using the current select method." (interactive (gnus-interactive "P\ny")) (let ((message-post-method `(lambda (arg) - (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))) + (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))) + (user-mail-address user-mail-address)) (dolist (article (gnus-summary-work-articles n)) (when (gnus-summary-select-article t nil nil article) + ;; Pretend that we're doing a followup so that we can see what + ;; the From header would have ended up being. + (save-window-excursion + (save-excursion + (gnus-summary-followup nil) + (let ((from (message-fetch-field "from"))) + (when from + (setq user-mail-address + (car (mail-header-parse-address from))))) + (kill-buffer (current-buffer)))) + ;; Now cancel the article using the From header we got. (when (gnus-eval-in-buffer-window gnus-original-article-buffer (message-cancel-news)) (gnus-summary-mark-as-read article gnus-canceled-mark) @@ -1081,14 +1137,14 @@ If VERY-WIDE, make a very wide reply." (gnus-summary-work-articles 1)))) ;; 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) + (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)) + (funcall gnus-confirm-mail-reply-to-news + gnus-newsgroup-name)) (t gnus-confirm-mail-reply-to-news))) (if (or wide very-wide) t ;; Ignore gnus-confirm-mail-reply-to-news for wide and very @@ -1149,6 +1205,16 @@ The original article will be yanked." (interactive "P") (gnus-summary-reply (gnus-summary-work-articles n) wide)) +(defun gnus-summary-reply-to-list-with-original (n &optional wide) + "Start composing a reply mail to the current message. +The reply goes only to the mailing list. +The original article will be yanked." + (interactive "P") + (let ((message-reply-to-function + (lambda nil + `((To . ,(gnus-mailing-list-followup-to)))))) + (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 @@ -1209,12 +1275,12 @@ 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 +For the \"inline\" alternatives, also see the variable `message-forward-ignored-headers'." (interactive "P") (if (cdr (gnus-summary-work-articles nil)) ;; Process marks are given. - (gnus-uu-digest-mail-forward arg post) + (gnus-uu-digest-mail-forward nil post) ;; No process marks. (let ((message-forward-as-mime message-forward-as-mime) (message-forward-show-mml message-forward-show-mml)) @@ -1248,6 +1314,44 @@ For the `inline' alternatives, also see the variable (set-buffer gnus-original-article-buffer) (message-forward post))))))) +(defun gnus-summary-resend-message-insert-gcc () + "Insert Gcc header according to `gnus-gcc-self-resent-messages'." + (gnus-inews-insert-gcc) + (let ((gcc (mapcar + (lambda (group) + (mm-encode-coding-string + group + (gnus-group-name-charset (gnus-inews-group-method group) + group))) + (message-unquote-tokens + (message-tokenize-header (mail-fetch-field "gcc" nil t) + " ,")))) + (self (with-current-buffer gnus-summary-buffer + gnus-gcc-self-resent-messages))) + (message-remove-header "gcc") + (when gcc + (goto-char (point-max)) + (cond ((eq self 'none)) + ((eq self t) + (insert "Gcc: \"" gnus-newsgroup-name "\"\n")) + ((stringp self) + (insert "Gcc: " + (mm-encode-coding-string + (if (string-match " " self) + (concat "\"" self "\"") + self) + (gnus-group-name-charset (gnus-inews-group-method self) + self)) + "\n")) + ((null self) + (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n")) + ((eq self 'no-gcc-self) + (when (setq gcc (delete + gnus-newsgroup-name + (delete (concat "\"" gnus-newsgroup-name "\"") + gcc))) + (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n"))))))) + (defun gnus-summary-resend-message (address n) "Resend the current article to ADDRESS." (interactive @@ -1261,12 +1365,24 @@ For the `inline' alternatives, also see the variable (with-current-buffer gnus-original-article-buffer (nnmail-fetch-field "to")))) current-prefix-arg)) - (dolist (article (gnus-summary-work-articles n)) - (gnus-summary-select-article nil nil nil article) - (with-current-buffer gnus-original-article-buffer - (let ((gnus-gcc-externalize-attachments nil)) - (message-resend address))) - (gnus-summary-mark-article-as-forwarded article))) + (let ((message-header-setup-hook (copy-sequence message-header-setup-hook)) + (message-sent-hook (copy-sequence message-sent-hook))) + ;; `gnus-summary-resend-message-insert-gcc' must run last. + (add-hook 'message-header-setup-hook + 'gnus-summary-resend-message-insert-gcc t) + (add-hook 'message-sent-hook + `(lambda () + (let ((rfc2047-encode-encoded-words nil)) + ,(if gnus-agent + '(gnus-agent-possibly-do-gcc) + '(gnus-inews-do-gcc))))) + (dolist (article (gnus-summary-work-articles n)) + (gnus-summary-select-article nil nil nil article) + (with-current-buffer gnus-original-article-buffer + (let ((gnus-gcc-externalize-attachments nil) + (message-inhibit-body-encoding t)) + (message-resend address))) + (gnus-summary-mark-article-as-forwarded article)))) ;; From: Matthieu Moy (defun gnus-summary-resend-message-edit () @@ -1431,7 +1547,6 @@ If YANK is non-nil, include the original article." (error "Gnus has been shut down")) (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) @@ -1439,24 +1554,22 @@ If YANK is non-nil, include the original article." (goto-char (point-min))) (message-pop-to-buffer "*Gnus Bug*")) (let ((message-this-is-mail t)) - (message-setup `((To . ,gnus-maintainer) (Subject . "")))) + (message-setup `((To . ,gnus-maintainer) + (Subject . "") + (X-Debbugs-Package + . ,(format "%s" gnus-bug-package)) + (X-Debbugs-Version + . ,(format "%s" (gnus-continuum-version)))))) (when gnus-bug-create-help-buffer (push `(gnus-bug-kill-buffer) message-send-actions)) (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) - (forward-line 1) + (message-goto-body) + (insert "\n\n\n\n\n") (insert (gnus-version) "\n" (emacs-version) "\n") (when (and (boundp 'nntp-server-type) (stringp nntp-server-type)) (insert nntp-server-type)) - (insert "\n\n\n\n\n") - (let (text) - (with-current-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 ""))) @@ -1476,62 +1589,6 @@ If YANK is non-nil, include the original article." (with-current-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-debug-files) - (point (point)) - file expr olist sym) - (gnus-message 4 "Please wait while we snoop your variables...") - (sit-for 0) - ;; Go through all the files looking for non-default values for variables. - (with-current-buffer (gnus-get-buffer-create " *gnus bug info*") - (while files - (erase-buffer) - (when (and (setq file (locate-library (pop files))) - (file-exists-p file)) - (insert-file-contents file) - (goto-char (point-min)) - (if (not (re-search-forward "^;;* *Internal variables" nil t)) - (gnus-message 4 "Malformed sources in file %s" file) - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (while (setq expr (ignore-errors (read (current-buffer)))) - (ignore-errors - (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))))) - (push (nth 1 expr) olist))))))) - (kill-buffer (current-buffer))) - (when (setq olist (nreverse olist)) - (insert "------------------ Environment follows ------------------\n\n")) - (while olist - (if (boundp (car olist)) - (ignore-errors - (gnus-pp - `(setq ,(car olist) - ,(if (or (consp (setq sym (symbol-value (car olist)))) - (and (symbolp sym) - (not (or (eq sym nil) - (eq sym t))))) - (list 'quote (symbol-value (car olist))) - (symbol-value (car olist)))))) - (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) - (setq olist (cdr olist))) - (insert "\n\n") - ;; Remove any control chars - they seem to cause trouble for some - ;; mailers. (Byte-compiled output from the stuff above.) - (goto-char point) - (while (re-search-forward (mm-string-to-multibyte - "[\000-\010\013-\037\200-\237]") nil t) - (replace-match (format "\\%03o" (string-to-char (match-string 0))) - t t)))) - ;;; Treatment of rejected articles. ;;; Bounced mail. @@ -1591,7 +1648,7 @@ this is a reply." (message-narrow-to-headers) (let ((gcc (or gcc (mail-fetch-field "gcc" nil t))) (cur (current-buffer)) - groups group method group-art + groups group method group-art options mml-externalize-attachments) (when gcc (message-remove-header "gcc") @@ -1615,8 +1672,11 @@ this is a reply." gnus-gcc-externalize-attachments)) (save-excursion (nnheader-set-temp-buffer " *acc*") + (setq message-options (with-current-buffer cur message-options)) (insert-buffer-substring cur) + (run-hooks 'gnus-gcc-pre-body-encode-hook) (message-encode-message-body) + (run-hooks 'gnus-gcc-post-body-encode-hook) (save-restriction (message-narrow-to-headers) (let* ((mail-parse-charset message-default-charset) @@ -1629,7 +1689,7 @@ this is a reply." ;; 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. + ;; names with incompatible character sets. ;; -- Per Abrahamsen 2001-10-08. (group-field-charset (gnus-group-name-charset @@ -1665,12 +1725,18 @@ this is a reply." (when (and group-art ;; FIXME: Should gcc-mark-as-read work when ;; Gnus is not running? - (gnus-alive-p) - (or gnus-gcc-mark-as-read - (and - (boundp 'gnus-inews-mark-gcc-as-read) - (symbol-value 'gnus-inews-mark-gcc-as-read)))) - (gnus-group-mark-article-read group (cdr group-art))) + (gnus-alive-p)) + (if (or gnus-gcc-mark-as-read + (and (boundp 'gnus-inews-mark-gcc-as-read) + (symbol-value 'gnus-inews-mark-gcc-as-read))) + (gnus-group-mark-article-read group (cdr group-art)) + (with-current-buffer gnus-group-buffer + (let ((gnus-group-marked (list group)) + (gnus-get-new-news-hook nil) + (inhibit-read-only t)) + (gnus-group-get-new-news-this-group nil t))))) + (setq options message-options) + (with-current-buffer cur (setq message-options options)) (kill-buffer (current-buffer))))))))) (defun gnus-inews-insert-gcc (&optional group) @@ -1704,11 +1770,13 @@ this is a reply." (not (setq result (cond - ((stringp (caar var)) + ((and group + (stringp (caar var))) ;; Regexp. (when (string-match (caar var) group) (cdar var))) - ((functionp (car var)) + ((and group + (functionp (car var))) ;; Function. (funcall (car var) group)) (t @@ -1772,7 +1840,10 @@ this is a reply." "Configure posting styles according to `gnus-posting-styles'." (unless gnus-inhibit-posting-styles (let ((group (or group-name gnus-newsgroup-name "")) - (styles gnus-posting-styles) + (styles (if (gnus-buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-posting-styles) + gnus-posting-styles)) style match attribute value v results filep name address element) ;; If the group has a posting-style parameter, add it at the end with a @@ -1820,7 +1891,7 @@ this is a reply." (and header (string-match (nth 2 match) header))))))) (t - ;; This is a form to be evaled. + ;; This is a form to be evalled. (eval match))))) ;; We have a match, so we set the variables. (dolist (attribute style)