X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-msg.el;h=556bb40e3f86e087b01b29b4983a09a5cc456112;hp=3af3beec267aef7149d63b734f10341e86e83121;hb=bbaa6736e285258f29be9409b7b75751bb847e96;hpb=dc5f28288604704f9312c03e50a46226e7053a78 diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 3af3beec2..556bb40e3 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -1,5 +1,5 @@ ;;; gnus-msg.el --- mail and post interface for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA @@ -33,6 +33,7 @@ (require 'gnus-ems) (require 'message) (require 'gnus-art) +(require 'gnus-util) (defcustom gnus-post-method 'current "*Preferred method for posting USENET news. @@ -69,12 +70,13 @@ of names)." (function))) (defcustom gnus-mailing-list-groups nil - "*Regexp matching groups that are really mailing lists. + "*If non-nil a regexp matching groups that are really mailing lists. This is useful when you're reading a mailing list that has been gatewayed to a newsgroup, and you want to followup to an article in the group." :group 'gnus-message - :type 'regexp) + :type '(choice (regexp) + (const nil))) (defcustom gnus-add-to-list nil "*If non-nil, add a `to-list' parameter automatically." @@ -144,9 +146,6 @@ See Info node `(gnus)Posting Styles'." :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) @@ -235,28 +234,44 @@ This variable is used only when `gnus-post-method' is `current'." (defcustom gnus-message-replysign nil - "Automatically sign replys to signed messages. + "Automatically sign replies to signed messages. See also the `mml-default-sign-method' variable." :group 'gnus-message :type 'boolean) (defcustom gnus-message-replyencrypt nil - "Automatically encrypt replys to encrypted messages. + "Automatically encrypt replies to encrypted messages. See also the `mml-default-encrypt-method' variable." :group 'gnus-message :type 'boolean) (defcustom gnus-message-replysignencrypted t - "Setting this causes automatically encryped messages to also be signed." + "Setting this causes automatically encrypted messages to also be signed." :group 'gnus-message :type 'boolean) (defcustom gnus-confirm-mail-reply-to-news nil "If non-nil, Gnus requests confirmation when replying to news. This is done because new users often reply by mistake when reading -news." +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) @@ -303,11 +318,7 @@ Thank you for your help in stamping out bugs. ") (eval-and-compile - (autoload 'gnus-uu-post-news "gnus-uu" nil t) - (autoload 'news-setup "rnewspost") - (autoload 'news-reply-mode "rnewspost") - (autoload 'rmail-dont-reply-to "mail-utils") - (autoload 'rmail-output "rmailout")) + (autoload 'gnus-uu-post-news "gnus-uu" nil t)) ;;; @@ -348,10 +359,10 @@ Thank you for your help in stamping out bugs. ;;; Internal functions. -(defun gnus-inews-make-draft () +(defun gnus-inews-make-draft (articles) `(lambda () (gnus-inews-make-draft-meta-information - ,gnus-newsgroup-name ',gnus-article-reply))) + ,gnus-newsgroup-name ',articles))) (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) @@ -380,15 +391,20 @@ Thank you for your help in stamping out bugs. ;; added an optional argument to `gnus-configure-posting-styles' to ;; make sure that the correct value for the group name is used. -- drv (add-hook 'message-mode-hook - (lambda () - (gnus-configure-posting-styles ,group))) + (if (memq ,config '(reply-yank reply)) + (lambda () + (gnus-configure-posting-styles ,group)) + (lambda () + ;; There may be an old " *gnus article copy*" buffer. + (let (gnus-article-copy) + (gnus-configure-posting-styles ,group))))) (gnus-pull ',(intern gnus-draft-meta-information-header) message-required-headers) (when (and ,group (not (string= ,group ""))) (push (cons (intern gnus-draft-meta-information-header) - (gnus-inews-make-draft)) + (gnus-inews-make-draft ,yanked)) message-required-headers)) (unwind-protect (progn @@ -404,25 +420,31 @@ Thank you for your help in stamping out bugs. (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) ;; Global value (set (make-local-variable 'mml-buffer-list) mbl1);; Local value - ;; LOCAL argument of add-hook differs between GNU Emacs - ;; and XEmacs. make-local-hook makes sure they are local. - (make-local-hook 'kill-buffer-hook) - (make-local-hook 'change-major-mode-hook) + (gnus-make-local-hook 'kill-buffer-hook) + (gnus-make-local-hook 'change-major-mode-hook) (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)) (mml-destroy-buffers) (setq mml-buffer-list mbl))) + (message-hide-headers) (gnus-add-buffer) (gnus-configure-windows ,config t) (run-hooks 'post-command-hook) (set-buffer-modified-p nil)))) -(defun gnus-inews-make-draft-meta-information (group article) +(defun gnus-inews-make-draft-meta-information (group articles) + (when (numberp articles) + (setq articles (list articles))) (concat "(\"" group "\" " - (if article (number-to-string - (if (listp article) - (car article) - article)) "\"\"") + (if articles + (mapconcat + (lambda (elem) + (number-to-string + (if (consp elem) + (car elem) + elem))) + articles " ") + "") ")")) ;;;###autoload @@ -480,7 +502,7 @@ Gcc: header for archiving purposes." (while (setq elem (pop alist)) (when (or (and (stringp (car elem)) (string-match (car elem) group)) - (and (gnus-functionp (car elem)) + (and (functionp (car elem)) (funcall (car elem) group)) (and (symbolp (car elem)) (symbol-value (car elem)))) @@ -488,27 +510,35 @@ Gcc: header for archiving purposes." (defun gnus-inews-add-send-actions (winconf buffer article &optional config yanked) - (make-local-hook 'message-sent-hook) + (gnus-make-local-hook 'message-sent-hook) (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc 'gnus-inews-do-gcc) nil t) (when gnus-agent - (make-local-hook 'message-header-hook) + (gnus-make-local-hook 'message-header-hook) (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t)) (setq message-post-method `(lambda (arg) (gnus-post-method arg ,gnus-newsgroup-name))) (setq message-newsreader (setq message-mailer (gnus-extended-version))) - (message-add-action - `(set-window-configuration ,winconf) 'exit 'postpone 'kill) (message-add-action `(when (gnus-buffer-exists-p ,buffer) - (save-excursion - (set-buffer ,buffer) - ,(when article - (if (eq config 'forward) - `(gnus-summary-mark-article-as-forwarded ',yanked) - `(gnus-summary-mark-article-as-replied ',yanked))))) - 'send)) + (set-window-configuration ,winconf)) + 'exit 'postpone 'kill) + (let ((to-be-marked (cond + (yanked + (mapcar + (lambda (x) (if (listp x) (car x) x)) yanked)) + (article (if (listp article) article (list article))) + (t nil)))) + (message-add-action + `(when (gnus-buffer-exists-p ,buffer) + (save-excursion + (set-buffer ,buffer) + ,(when to-be-marked + (if (eq config 'forward) + `(gnus-summary-mark-article-as-forwarded ',to-be-marked) + `(gnus-summary-mark-article-as-replied ',to-be-marked))))) + 'send))) (put 'gnus-setup-message 'lisp-indent-function 1) (put 'gnus-setup-message 'edebug-form-spec '(form body)) @@ -549,7 +579,7 @@ If ARG is 1, prompt for group name to post to. This function prepares a news even when using mail groups. This is useful for posting messages to mail groups without actually sending them over the -network. The corresponding backend must have a 'request-post method." +network. The corresponding back end must have a 'request-post method." (interactive "P") ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. @@ -628,7 +658,7 @@ If ARG, don't do that. If ARG is 1, prompt for group name to post to. This function prepares a news even when using mail groups. This is useful for posting messages to mail groups without actually sending them over the -network. The corresponding backend must have a 'request-post method." +network. The corresponding back end must have a 'request-post method." (interactive "P") ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. @@ -648,7 +678,12 @@ network. The corresponding backend must have a 'request-post method." gnus-newsgroup-name)) ;; #### see comment in gnus-setup-message -- drv (gnus-setup-message 'message - (message-news (gnus-group-real-name gnus-newsgroup-name)))) + (progn + (message-news (gnus-group-real-name gnus-newsgroup-name)) + (set (make-local-variable 'gnus-discouraged-post-methods) + (remove + (car (gnus-find-method-for-group gnus-newsgroup-name)) + gnus-discouraged-post-methods))))) (save-excursion (set-buffer buffer) (setq gnus-newsgroup-name group))))) @@ -677,8 +712,7 @@ a news." If prefix argument YANK is non-nil, the original article is yanked automatically. YANK is a list of elements, where the car of each element is the -article number, and the two following numbers is the region to be -yanked." +article number, and the cdr is the string to be yanked." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) @@ -698,7 +732,9 @@ yanked." (gnus-summary-handle-replysign))) (defun gnus-summary-followup-with-original (n &optional force-news) - "Compose a followup to an article and include the original article." + "Compose a followup to an article and include the original article. +The text in the region will be yanked. If the region isn't +active, the entire article will be yanked." (interactive "P") (gnus-summary-followup (gnus-summary-work-articles n) force-news)) @@ -827,7 +863,9 @@ header line with the old Message-ID." (forward-line 1)) (let ((mail-header-separator "")) (setq beg (point) - end (or (message-goto-body) beg))) + end (or (message-goto-body) + ;; There may be just a header. + (point-max)))) ;; Delete the headers from the displayed articles. (set-buffer gnus-article-copy) (let ((mail-header-separator "")) @@ -878,7 +916,9 @@ header line with the old Message-ID." (not to-address))) ;; This is news. (if post - (message-news (or to-group group)) + (message-news + (or to-group + (and (not (gnus-virtual-group-p pgroup)) group))) (set-buffer gnus-article-copy) (gnus-msg-treat-broken-reply-to) (message-followup (if (or newsgroup-p force-news) @@ -993,33 +1033,21 @@ If SILENT, don't prompt the user." -;; Dummies to avoid byte-compile warning. -(eval-when-compile - (defvar nnspool-rejected-article-hook) - (defvar xemacs-codename)) - (defun gnus-extended-version () - "Stringified Gnus version and Emacs version." + "Stringified Gnus version and Emacs version. +See the variable `gnus-user-agent'." (interactive) - (concat - "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t) - " (" gnus-version ")" - " " - (cond - ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) - (concat "Emacs/" (match-string 1 emacs-version) - " (" system-configuration ")")) - ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" - emacs-version) - (concat (match-string 1 emacs-version) - (format "/%d.%d" emacs-major-version emacs-minor-version) - (if (match-beginning 3) - (match-string 3 emacs-version) - "") - (if (boundp 'xemacs-codename) - (concat " (" xemacs-codename ", " system-configuration ")") - ""))) - (t emacs-version)))) + (let* ((float-output-format nil) + (gnus-v + (concat "Gnus/" + (prin1-to-string (gnus-continuum-version gnus-version) t) + " (" gnus-version ")")) + (emacs-v (gnus-emacs-version))) + (if (stringp gnus-user-agent) + gnus-user-agent + (concat gnus-v + (when emacs-v + (concat " " emacs-v)))))) ;;; @@ -1038,9 +1066,16 @@ If VERY-WIDE, make a very wide reply." (list (and current-prefix-arg (gnus-summary-work-articles 1)))) ;; Allow user to require confirmation before replying by mail to the - ;; author of a news article. - (when (or (not (gnus-news-group-p gnus-newsgroup-name)) - (not gnus-confirm-mail-reply-to-news) + ;; 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)) @@ -1128,7 +1163,8 @@ automatically." (defun gnus-summary-wide-reply-with-original (n) "Start composing a wide reply mail to the current message. -The original article will be yanked." +The original article will be yanked. +Uses the process/prefix convention." (interactive "P") (gnus-summary-reply-with-original n t)) @@ -1244,8 +1280,8 @@ composing a new message." (goto-char (point-max)) (insert mail-header-separator) (goto-char (point-min)) - (re-search-forward "^To:\\|^Newsgroups:" nil 'move) - (forward-char 1) + (when (re-search-forward "^To:\\|^Newsgroups:" nil 'move) + (forward-char 1)) (widen))))) (defun gnus-summary-post-forward (&optional arg) @@ -1341,7 +1377,7 @@ The current group name will be inserted at \"%s\".") ;; This mail group doesn't have a `to-list', so we add one ;; here. Magic! (when (gnus-y-or-n-p - (format "Do you want to add this as `to-list': %s " to-address)) + (format "Do you want to add this as `to-list': %s? " to-address)) (gnus-group-add-parameter group (cons 'to-list to-address)))))) (defun gnus-put-message () @@ -1354,7 +1390,7 @@ The current group name will be inserted at \"%s\".") (not (gnus-group-read-only-p group))) (setq group (read-string "Put in group: " nil (gnus-writable-groups)))) - (when (gnus-gethash group gnus-newsrc-hashtb) + (when (gnus-group-entry group) (error "No such group: %s" group)) (save-excursion (save-restriction @@ -1441,8 +1477,7 @@ If YANK is non-nil, include the original article." (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t) current-prefix-arg)) (gnus-summary-iterate n - (let ((gnus-display-mime-function nil) - (gnus-inhibit-treatment t)) + (let ((gnus-inhibit-treatment t)) (gnus-summary-select-article)) (save-excursion (set-buffer buffer) @@ -1486,14 +1521,14 @@ The source file has to be in the Emacs load path." (while olist (if (boundp (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))) + (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") @@ -1509,7 +1544,7 @@ The source file has to be in the Emacs load path." (defun gnus-summary-resend-bounced-mail (&optional fetch) "Re-mail the current message. -This only makes sense if the current message is a bounce message than +This only makes sense if the current message is a bounce message that contains some mail you have written which has been bounced back to you. If FETCH, try to fetch the article that this is a reply to, if indeed @@ -1606,14 +1641,21 @@ this is a reply." (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match "" t t )) - (unless (setq group-art - (gnus-request-accept-article group method t t)) + (when (or (not (gnus-check-backend-function + 'request-accept-article group)) + (not (setq group-art + (gnus-request-accept-article + group method t t)))) (gnus-message 1 "Couldn't store article in group %s: %s" - group (gnus-status-message method)) - (sit-for 2)) + group (gnus-status-message method))) (when (and group-art + ;; FIXME: Should gcc-mark-as-read work when + ;; Gnus is not running? + (gnus-alive-p) (or gnus-gcc-mark-as-read - gnus-inews-mark-gcc-as-read)) + (and + (boundp 'gnus-inews-mark-gcc-as-read) + (symbol-value 'gnus-inews-mark-gcc-as-read)))) (gnus-group-mark-article-read group (cdr group-art))) (kill-buffer (current-buffer))))))))) @@ -1624,7 +1666,7 @@ this is a reply." (message-narrow-to-headers) (let* ((group gnus-outgoing-message-group) (gcc (cond - ((gnus-functionp group) + ((functionp group) (funcall group)) ((or (stringp group) (list group)) group)))) @@ -1665,7 +1707,7 @@ this is a reply." ((and (listp var) (stringp (car var))) ;; A list of groups. var) - ((gnus-functionp var) + ((functionp var) ;; A function. (funcall var group)) (t @@ -1678,7 +1720,7 @@ this is a reply." ;; Regexp. (when (string-match (caar var) group) (cdar var))) - ((gnus-functionp (car var)) + ((functionp (car var)) ;; Function. (funcall (car var) group)) (t @@ -1702,14 +1744,17 @@ this is a reply." (if (string-match " " gcc-self-val) (concat "\"" gcc-self-val "\"") gcc-self-val) - (if (string-match " " group) - (concat "\"" group "\"") - group))) + ;; In nndoc groups, we use the parent group name + ;; instead of the current group. + (let ((group (or (gnus-group-find-parameter + gnus-newsgroup-name 'parent-group) + group))) + (if (string-match " " group) + (concat "\"" group "\"") + group)))) (if (not (eq gcc-self-val 'none)) (insert "\n") - (progn - (beginning-of-line) - (kill-line)))) + (gnus-delete-line))) ;; Use the list of groups. (while (setq name (pop groups)) (let ((str (if (string-match ":" name) @@ -1723,6 +1768,16 @@ this is a reply." (insert " "))) (insert "\n"))))))) +(defun gnus-mailing-list-followup-to () + "Look at the headers in the current buffer and return a Mail-Followup-To address." + (let ((x-been-there (gnus-fetch-original-field "x-beenthere")) + (list-post (gnus-fetch-original-field "list-post"))) + (when (and list-post + (string-match "mailto:\\([^>]+\\)" list-post)) + (setq list-post (match-string 1 list-post))) + (or list-post + x-been-there))) + ;;; Posting styles. (defun gnus-configure-posting-styles (&optional group-name) @@ -1730,7 +1785,7 @@ this is a reply." (unless gnus-inhibit-posting-styles (let ((group (or group-name gnus-newsgroup-name "")) (styles gnus-posting-styles) - style match variable attribute value v results + style match attribute value v results filep name address element) ;; If the group has a posting-style parameter, add it at the end with a ;; regexp matching everything, to be sure it takes precedence over all @@ -1755,9 +1810,9 @@ this is a reply." (and header (string-match (pop style) header)))))) ((or (symbolp match) - (gnus-functionp match)) + (functionp match)) (cond - ((gnus-functionp match) + ((functionp match) ;; Function to be called. (funcall match)) ((boundp match) @@ -1778,7 +1833,6 @@ this is a reply." ;; We have a match, so we set the variables. (dolist (attribute style) (setq element (pop attribute) - variable nil filep nil) (setq value (cond @@ -1795,8 +1849,8 @@ this is a reply." ((stringp value) value) ((or (symbolp value) - (gnus-functionp value)) - (cond ((gnus-functionp value) + (functionp value)) + (cond ((functionp value) (funcall value)) ((boundp value) (symbol-value value)))) @@ -1824,8 +1878,7 @@ this is a reply." (setq name (assq 'name results) address (assq 'address results)) (setq results (delq name (delq address results))) - ;; make-local-hook is not obsolete in Emacs 20 or XEmacs. - (make-local-hook 'message-setup-hook) + (gnus-make-local-hook 'message-setup-hook) (setq results (sort results (lambda (x y) (string-lessp (car x) (car y))))) (dolist (result results) @@ -1883,4 +1936,5 @@ this is a reply." (provide 'gnus-msg) +;;; arch-tag: 9f22b2f5-1c0a-49de-916e-4c88e984852b ;;; gnus-msg.el ends here