X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-msg.el;h=a80230e0ecd910a7eb443a9b6d7b486d772ebdfa;hb=9954729d205c97242f0787c79dc23e7b051a6201;hp=98b9175378b7c070e2f32633a95b12c409c83f87;hpb=0971c51f0ef1bab83646e8dc37581e251c604ce9;p=gnus diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 98b917537..a80230e0e 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -1,8 +1,8 @@ ;;; gnus-msg.el --- mail and post interface for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA -;; Lars Magne Ingebrigtsen +;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. @@ -26,61 +26,114 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-ems) (require 'message) -(eval-when-compile (require 'cl)) +(require 'gnus-art) -;; Added by Sudish Joseph . -(defvar gnus-post-method nil +(defcustom gnus-post-method nil "*Preferred method for posting USENET news. -If this variable is nil, Gnus will use the current method to decide -which method to use when posting. If it is non-nil, it will override -the current method. This method will not be used in mail groups and -the like, only in \"real\" newsgroups. -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.") +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. + +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 +method to use when posting." + :group 'gnus-group-foreign + :type `(choice (const nil) + (const current) + (const native) + (sexp :tag "Methods" ,gnus-select-method))) (defvar 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 -can also be a list of group names. +\"nnml:archive\", you set this variable to that value. This variable +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).") -(defvar gnus-message-archive-group - '((if (message-news-p) "misc-news" "misc-mail")) - "*Name of the group in which to save the messages you've written. -This can either be a string, a list of strings; or an alist -of regexps/functions/forms to be evaluated to return a string (or a list -of strings). The functions are called with the name of the current -group (or nil) as a parameter.") - (defvar 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.") -(defvar gnus-sent-message-ids-file - (nnheader-concat gnus-directory "Sent-Message-IDs") - "File where Gnus saves a cache of sent message ids.") +(defvar gnus-add-to-list nil + "*If non-nil, add a `to-list' parameter automatically.") + +(defvar gnus-crosspost-complaint + "Hi, + +You posted the article below with the following Newsgroups header: + +Newsgroups: %s -(defvar gnus-sent-message-ids-length 1000 - "The number of sent Message-IDs to save.") +The %s group, at least, was an inappropriate recipient +of this message. Please trim your Newsgroups header to exclude this +group before posting in the future. + +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.") ;;; Internal variables. (defvar gnus-message-buffer "*Mail Gnus*") (defvar gnus-article-copy nil) (defvar gnus-last-posting-server nil) +(defvar gnus-message-group-art nil) + +(defconst gnus-bug-message + "Sending a bug report to the Gnus Towers. +======================================== + +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. + +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') +and include the backtrace in your bug report. + +Please describe the bug in annoying, painstaking detail. + +Thank you for your help in stamping out bugs. +") (eval-and-compile (autoload 'gnus-uu-post-news "gnus-uu" nil t) @@ -94,50 +147,63 @@ the group.") ;;; Gnus Posting Functions ;;; -(gnus-define-keys - (gnus-summary-send-map "S" gnus-summary-mode-map) - "p" gnus-summary-post-news - "f" gnus-summary-followup - "F" gnus-summary-followup-with-original - "c" gnus-summary-cancel-article - "s" gnus-summary-supersede-article - "r" gnus-summary-reply - "R" gnus-summary-reply-with-original - "m" gnus-summary-mail-other-window - "u" gnus-uu-post-news - "om" gnus-summary-mail-forward - "op" gnus-summary-post-forward - "Om" gnus-uu-digest-mail-forward - "Op" gnus-uu-digest-post-forward) - -(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) +(gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map) + "p" gnus-summary-post-news + "f" gnus-summary-followup + "F" gnus-summary-followup-with-original + "c" gnus-summary-cancel-article + "s" gnus-summary-supersede-article + "r" gnus-summary-reply + "R" gnus-summary-reply-with-original + "w" gnus-summary-wide-reply + "W" gnus-summary-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 + "om" gnus-summary-mail-forward + "op" gnus-summary-post-forward + "Om" gnus-uu-digest-mail-forward + "Op" gnus-uu-digest-post-forward) + +(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) ;;; Internal functions. (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) - (let ((winconf (make-symbol "winconf")) - (buffer (make-symbol "buffer")) - (article (make-symbol "article"))) + (let ((winconf (make-symbol "gnus-setup-message-winconf")) + (buffer (make-symbol "gnus-setup-message-buffer")) + (article (make-symbol "gnus-setup-message-article")) + (group (make-symbol "gnus-setup-message-group"))) `(let ((,winconf (current-window-configuration)) - (,buffer (current-buffer)) + (,buffer (buffer-name (current-buffer))) (,article (and gnus-article-reply (gnus-summary-article-number))) + (,group gnus-newsgroup-name) (message-header-setup-hook (copy-sequence message-header-setup-hook))) (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) - ,@forms - (gnus-inews-add-send-actions ,winconf ,buffer ,article) - (setq gnus-message-buffer (current-buffer)) - (gnus-configure-windows ,config t)))) - + (add-hook 'message-mode-hook 'gnus-configure-posting-styles) + (unwind-protect + (progn + ,@forms) + (gnus-inews-add-send-actions ,winconf ,buffer ,article) + (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)) + (gnus-configure-windows ,config t) + (set-buffer-modified-p nil)))) + (defun gnus-inews-add-send-actions (winconf buffer article) - (gnus-make-local-hook 'message-sent-hook) - (gnus-add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) + (make-local-hook 'message-sent-hook) + (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) (setq message-post-method `(lambda (arg) (gnus-post-method arg ,gnus-newsgroup-name))) @@ -145,7 +211,7 @@ the group.") (message-add-action `(set-window-configuration ,winconf) 'exit 'postpone 'kill) (message-add-action - `(when (buffer-name ,buffer) + `(when (gnus-buffer-exists-p ,buffer) (save-excursion (set-buffer ,buffer) ,(when article @@ -153,7 +219,6 @@ the group.") 'send)) (put 'gnus-setup-message 'lisp-indent-function 1) -(put 'gnus-setup-message 'lisp-indent-hook 1) (put 'gnus-setup-message 'edebug-form-spec '(form body)) ;;; Post news commands of Gnus group mode and summary mode @@ -169,8 +234,7 @@ the group.") If ARG, post to the group under point. If ARG is 1, prompt for a group name." (interactive "P") - ;; Bind this variable here to make message mode hooks - ;; work ok. + ;; Bind this variable here to make message mode hooks work ok. (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) @@ -183,16 +247,14 @@ If ARG is 1, prompt for a group name." (defun gnus-summary-post-news () "Start composing a news message." (interactive) - (gnus-set-global-variables) (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." - (interactive - (list (and current-prefix-arg + (interactive + (list (and current-prefix-arg (gnus-summary-work-articles 1)))) - (gnus-set-global-variables) (when yank (gnus-summary-goto-subject (car yank))) (save-window-excursion @@ -201,7 +263,7 @@ If prefix argument YANK is non-nil, original article is yanked automatically." (gnus-newsgroup-name gnus-newsgroup-name)) ;; Send a followup. (gnus-post-news nil gnus-newsgroup-name - headers gnus-article-buffer + headers gnus-article-buffer yank nil force-news))) (defun gnus-summary-followup-with-original (n &optional force-news) @@ -209,8 +271,21 @@ If prefix argument YANK is non-nil, original article is yanked automatically." (interactive "P") (gnus-summary-followup (gnus-summary-work-articles n) force-news)) +(defun gnus-summary-followup-to-mail (&optional arg) + "Followup to the current mail message via news." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-summary-followup arg t)) + +(defun gnus-summary-followup-to-mail-with-original (&optional arg) + "Followup to the current mail message via news." + (interactive "P") + (gnus-summary-followup (gnus-summary-work-articles arg) t)) + (defun gnus-inews-yank-articles (articles) (let (beg article) + (message-goto-body) (while (setq article (pop articles)) (save-window-excursion (set-buffer gnus-summary-buffer) @@ -221,24 +296,26 @@ If prefix argument YANK is non-nil, original article is yanked automatically." (message-reply-headers gnus-current-headers)) (message-yank-original) (setq beg (or beg (mark t)))) - (when articles (insert "\n"))) - + (when articles + (insert "\n"))) (push-mark) (goto-char beg))) -(defun gnus-summary-cancel-article (n) - "Cancel an article you posted." - (interactive "P") - (gnus-set-global-variables) +(defun gnus-summary-cancel-article (&optional n symp) + "Cancel an article you posted. +Uses the process-prefix convention. If given the symbolic +prefix `a', cancel using the standard posting method; if not +post using the current select method." + (interactive (gnus-interactive "P\ny")) (let ((articles (gnus-summary-work-articles n)) (message-post-method `(lambda (arg) - (gnus-post-method nil ,gnus-newsgroup-name))) + (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name))) article) (while (setq article (pop articles)) (when (gnus-summary-select-article t nil nil article) - (when (gnus-eval-in-buffer-window - gnus-original-article-buffer (message-cancel-news)) + (when (gnus-eval-in-buffer-window gnus-original-article-buffer + (message-cancel-news)) (gnus-summary-mark-as-read article gnus-canceled-mark) (gnus-cache-remove-article 1)) (gnus-article-hide-headers-if-wanted)) @@ -249,7 +326,6 @@ If prefix argument YANK is non-nil, original article is yanked automatically." This is done simply by taking the old article and adding a Supersedes header line with the old Message-ID." (interactive) - (gnus-set-global-variables) (let ((article (gnus-summary-article-number))) (gnus-setup-message 'reply-yank (gnus-summary-select-article t) @@ -257,7 +333,11 @@ header line with the old Message-ID." (message-supersede) (push `((lambda () - (gnus-cache-possibly-remove-article ,article nil nil nil t))) + (when (gnus-buffer-exists-p ,gnus-summary-buffer) + (save-excursion + (set-buffer ,gnus-summary-buffer) + (gnus-cache-possibly-remove-article ,article nil nil nil t) + (gnus-summary-mark-as-read ,article gnus-canceled-mark))))) message-send-actions)))) @@ -270,48 +350,69 @@ header line with the old Message-ID." (setq gnus-article-copy (get-buffer-create " *gnus article copy*")) (buffer-disable-undo gnus-article-copy) (or (memq gnus-article-copy gnus-buffer-list) - (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list))) + (push gnus-article-copy gnus-buffer-list)) (let ((article-buffer (or article-buffer gnus-article-buffer)) - end) - (when (and (get-buffer article-buffer) - (buffer-name (get-buffer article-buffer))) + end beg contents) + (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) - (gnus-set-text-properties (point-min) (point-max) nil) (delete-region (goto-char (point-min)) (or (search-forward "\n\n" nil t) (point))) - (insert-buffer-substring gnus-original-article-buffer 1 end))) + ;; Insert the original article headers. + (insert-buffer-substring gnus-original-article-buffer beg end) + (gnus-article-decode-rfc1522))) 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 article-buffer) + (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)) (pgroup group) - to-address to-group mailing-list to-list) + to-address to-group mailing-list to-list + newsgroup-p) (when group - (setq to-address (gnus-group-get-parameter group 'to-address) - to-group (gnus-group-get-parameter group 'to-group) - to-list (gnus-group-get-parameter group 'to-list) + (setq to-address (gnus-group-find-parameter group 'to-address) + to-group (gnus-group-find-parameter group 'to-group) + to-list (gnus-group-find-parameter group 'to-list) + 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))) (if (or (and to-group (gnus-news-group-p to-group)) + newsgroup-p force-news - (and (gnus-news-group-p + (and (gnus-news-group-p (or pgroup gnus-newsgroup-name) (if header (mail-header-number header) gnus-current-article)) @@ -322,44 +423,63 @@ header line with the old Message-ID." (if post (message-news (or to-group group)) (set-buffer gnus-article-copy) - (message-followup)) + (gnus-msg-treat-broken-reply-to) + (message-followup (if (or newsgroup-p force-news) nil to-group))) ;; The is mail. (if post (progn (message-mail (or to-address to-list)) ;; Arrange for mail groups that have no `to-address' to ;; get that when the user sends off the mail. - (push (list 'gnus-inews-add-to-address group) - message-send-actions)) + (when (and (not to-list) + (not to-address) + add-to-list) + (push (list 'gnus-inews-add-to-address pgroup) + message-send-actions))) (set-buffer gnus-article-copy) + (gnus-msg-treat-broken-reply-to) (message-wide-reply to-address))) (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) + (save-restriction + (message-narrow-to-head) + (message-remove-header "reply-to")))) + (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))) - (cond - ;; If the group-method is nil (which shouldn't happen) we use + (cond + ;; If the group-method is nil (which shouldn't happen) we use ;; the default method. - ((null arg) - (or gnus-post-method gnus-select-method message-post-method)) - ;; We want this group's method. + ((null group-method) + (or (and (null (eq gnus-post-method 'active)) gnus-post-method) + gnus-select-method message-post-method)) + ;; We want the inverse of the default ((and arg (not (eq arg 0))) - group-method) + (if (eq gnus-post-method 'active) + 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)) (listp (car gnus-post-method)))) (let* ((methods ;; Collect all methods we know about. (append - (when gnus-post-method + (when (and gnus-post-method + (not (eq gnus-post-method 'current))) (if (listp (car gnus-post-method)) gnus-post-method (list gnus-post-method))) gnus-secondary-select-methods + (mapcar 'cdr gnus-server-alist) (list gnus-select-method) (list group-method))) method-alist post-methods method) @@ -371,7 +491,7 @@ If SILENT, don't prompt the user." (push method post-methods))) ;; Create a name-method alist. (setq method-alist - (mapcar + (mapcar (lambda (m) (list (concat (cadr m) " (" (symbol-name (car m)) ")") m)) post-methods)) @@ -388,69 +508,25 @@ If SILENT, don't prompt the user." (cons (or gnus-last-posting-server "") 0)))) method-alist)))) ;; Override normal method. - ((and gnus-post-method - (or (gnus-method-option-p group-method 'post) - (gnus-method-option-p group-method 'post-mail))) + ((and (eq gnus-post-method 'current) + (not arg)) + group-method) + (gnus-post-method gnus-post-method) - ;; Perhaps this is a mail group? - ((and (not (gnus-member-of-valid 'post group)) - (not (gnus-method-option-p group-method 'post-mail))) - group-method) ;; Use the normal select method. (t gnus-select-method)))) -(defun gnus-inews-narrow-to-headers () - (widen) - (narrow-to-region - (goto-char (point-min)) - (or (and (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") nil t) - (match-beginning 0)) - (point-max))) - (goto-char (point-min))) - -;;; -;;; Check whether the message has been sent already. -;;; - -(defvar gnus-inews-sent-ids nil) - -(defun gnus-inews-reject-message () - "Check whether this message has already been sent." - (when gnus-sent-message-ids-file - (let ((message-id (save-restriction (gnus-inews-narrow-to-headers) - (mail-fetch-field "message-id"))) - end) - (when message-id - (unless gnus-inews-sent-ids - (condition-case () - (load t t t) - (error nil))) - (if (member message-id gnus-inews-sent-ids) - ;; Reject this message. - (not (gnus-yes-or-no-p - (format "Message %s already sent. Send anyway? " - message-id))) - (push message-id gnus-inews-sent-ids) - ;; Chop off the last Message-IDs. - (when (setq end (nthcdr gnus-sent-message-ids-length - gnus-inews-sent-ids)) - (setcdr end nil)) - (nnheader-temp-write gnus-sent-message-ids-file - (prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids) - (current-buffer))) - nil))))) - ;; Dummy to avoid byte-compile warning. (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" + "Stringified Gnus version and Emacs version." (interactive) (concat gnus-version @@ -460,18 +536,28 @@ If SILENT, don't prompt the user." (concat "Emacs " (substring emacs-version (match-beginning 1) (match-end 1)))) - ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)" emacs-version) + ((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))) + (format " %d.%d" emacs-major-version emacs-minor-version) + (if (match-beginning 3) + (substring emacs-version + (match-beginning 3) + (match-end 3)) + "") + (if (boundp 'xemacs-codename) + (concat " - \"" xemacs-codename "\"")))) (t emacs-version)))) -;; Written by "Mr. Per Persson" . +;; 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 + (let ((mail-header-separator + (progn (goto-char (point-min)) (if (and (search-forward (concat "\n" mail-header-separator "\n") nil t) @@ -483,7 +569,7 @@ If SILENT, don't prompt the user." (cond ((save-restriction (widen) (goto-char (point-min)) - (re-search-forward "[\200-\377]" nil t)) + (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") @@ -493,76 +579,134 @@ If SILENT, don't prompt the user." (or (mail-position-on-field "Content-Transfer-Encoding") (insert "7bit"))))))) +(custom-add-option 'message-header-hook 'gnus-inews-insert-mime-headers) + ;;; -;;; Gnus Mail Functions +;;; Gnus Mail Functions ;;; ;;; Mail reply commands of Gnus summary mode -(defun gnus-summary-reply (&optional yank) - "Reply mail to news author. -If prefix argument YANK is non-nil, original article is yanked automatically." - (interactive - (list (and current-prefix-arg +(defun gnus-summary-reply (&optional yank wide) + "Start composing a 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)))) - ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells) ;; Stripping headers should be specified with mail-yank-ignored-headers. - (gnus-set-global-variables) - (when yank + (when yank (gnus-summary-goto-subject (car yank))) (let ((gnus-article-reply t)) (gnus-setup-message (if yank 'reply-yank 'reply) (gnus-summary-select-article) (set-buffer (gnus-copy-article-buffer)) - (message-reply nil nil (gnus-group-get-parameter - gnus-newsgroup-name 'broken-reply-to)) + (gnus-msg-treat-broken-reply-to) + (message-reply nil wide) (when yank (gnus-inews-yank-articles yank))))) -(defun gnus-summary-reply-with-original (n) - "Reply mail to news author with original article." +(defun gnus-summary-reply-with-original (n &optional wide) + "Start composing a reply mail to the current message. +The original article will be yanked." (interactive "P") - (gnus-summary-reply (gnus-summary-work-articles n))) + (gnus-summary-reply (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 +automatically." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-summary-reply yank t)) + +(defun gnus-summary-wide-reply-with-original (n) + "Start composing a wide reply mail to the current message. +The original article will be yanked." + (interactive "P") + (gnus-summary-reply-with-original n t)) -(defun gnus-summary-mail-forward (&optional post) - "Forward the current message to another user." +(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." (interactive "P") - (gnus-set-global-variables) (gnus-setup-message 'forward (gnus-summary-select-article) (set-buffer gnus-original-article-buffer) - (message-forward post))) + (let ((message-included-forward-headers + (if full-headers "" message-included-forward-headers))) + (message-forward post)))) -(defun gnus-summary-resend-message (address) +(defun gnus-summary-resend-message (address n) "Resend the current article to ADDRESS." - (interactive "sResend message to: ") - (gnus-summary-select-article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (message-resend address))) + (interactive "sResend message(s) to: \nP") + (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))))) -(defun gnus-summary-post-forward () - "Forward the current article to a newsgroup." - (interactive) - (gnus-summary-mail-forward t)) +(defun gnus-summary-post-forward (&optional full-headers) + "Forward the current article to a newsgroup. +If FULL-HEADERS (the prefix), include full headers when forwarding." + (interactive "P") + (gnus-summary-mail-forward full-headers t)) -(defvar gnus-nastygram-message - "The following article was inappropriately posted to %s.\n" +(defvar gnus-nastygram-message + "The following article was inappropriately posted to %s.\n\n" "Format string to insert in nastygrams. The current group name will be inserted at \"%s\".") (defun gnus-summary-mail-nastygram (n) "Send a nastygram to the author of the current article." (interactive "P") - (if (or gnus-expert-user - (gnus-y-or-n-p - "Really send a nastygram to the author of the current article? ")) - (let ((group gnus-newsgroup-name)) - (gnus-summary-reply-with-original n) - (set-buffer gnus-message-buffer) - (insert (format gnus-nastygram-message group)) - (message-send-and-exit)))) + (when (or gnus-expert-user + (gnus-y-or-n-p + "Really send a nastygram to the author of the current article? ")) + (let ((group gnus-newsgroup-name)) + (gnus-summary-reply-with-original n) + (set-buffer gnus-message-buffer) + (message-goto-body) + (insert (format gnus-nastygram-message group)) + (message-send-and-exit)))) + +(defun gnus-summary-mail-crosspost-complaint (n) + "Send a complaint about crossposting to the current article(s)." + (interactive "P") + (let ((articles (gnus-summary-work-articles n)) + article) + (while (setq article (pop articles)) + (set-buffer gnus-summary-buffer) + (gnus-summary-goto-subject article) + (let ((group (gnus-group-real-name gnus-newsgroup-name)) + newsgroups followup-to) + (gnus-summary-select-article) + (set-buffer gnus-original-article-buffer) + (if (and (<= (length (message-tokenize-header + (setq newsgroups (mail-fetch-field "newsgroups")) + ", ")) + 1) + (or (not (setq followup-to (mail-fetch-field "followup-to"))) + (not (member group (message-tokenize-header + followup-to ", "))))) + (if followup-to + (gnus-message 1 "Followup-to restricted") + (gnus-message 1 "Not a crossposted article")) + (set-buffer gnus-summary-buffer) + (gnus-summary-reply-with-original 1) + (set-buffer gnus-message-buffer) + (message-goto-body) + (insert (format gnus-crosspost-complaint newsgroups group)) + (message-goto-subject) + (re-search-forward " *$") + (replace-match " (crosspost notification)" t t) + (gnus-deactivate-mark) + (when (gnus-y-or-n-p "Send this complaint? ") + (message-send-and-exit))))))) (defun gnus-summary-mail-other-window () "Compose mail in other window." @@ -578,7 +722,7 @@ The current group name will be inserted at \"%s\".") (setq beg (point)) (skip-chars-forward "^,") (while (zerop - (save-excursion + (save-excursion (save-restriction (let ((i 0)) (narrow-to-region beg (point)) @@ -586,31 +730,26 @@ The current group name will be inserted at \"%s\".") (logand (progn (while (search-forward "\"" nil t) (incf i)) - (if (zerop i) 2 i)) 2))))) + (if (zerop i) 2 i)) + 2))))) (skip-chars-forward ",") (skip-chars-forward "^,")) (skip-chars-backward " ") - (setq accumulated - (cons (buffer-substring beg (point)) - accumulated)) + (push (buffer-substring beg (point)) + accumulated) (skip-chars-forward "^,") (skip-chars-forward ", ")) accumulated)) -(defun gnus-mail-yank-original () - (interactive) - (save-excursion - (mail-yank-original nil)) - (or mail-yank-hooks mail-citation-hook - (run-hooks 'news-reply-header-hook))) - (defun gnus-inews-add-to-address (group) (let ((to-address (mail-fetch-field "to"))) (when (and to-address (gnus-alive-p)) ;; This mail group doesn't have a `to-list', so we add one - ;; here. Magic! - (gnus-group-add-parameter group (cons 'to-list to-address))))) + ;; here. Magic! + (when (gnus-y-or-n-p + (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 () "Put the current message in some group and return to Gnus." @@ -618,17 +757,17 @@ The current group name will be inserted at \"%s\".") (let ((reply gnus-article-reply) (winconf gnus-prev-winconf) (group gnus-newsgroup-name)) - + (or (and group (not (gnus-group-read-only-p group))) (setq group (read-string "Put in group: " nil (gnus-writable-groups)))) - (and (gnus-gethash group gnus-newsrc-hashtb) - (error "No such group: %s" group)) + (when (gnus-gethash group gnus-newsrc-hashtb) + (error "No such group: %s" group)) (save-excursion (save-restriction (widen) - (gnus-inews-narrow-to-headers) + (message-narrow-to-headers) (let (gnus-deletable-headers) (if (message-news-p) (message-generate-headers message-required-news-headers) @@ -639,47 +778,53 @@ The current group name will be inserted at \"%s\".") (gnus-inews-do-gcc) - (if (get-buffer gnus-group-buffer) - (progn - (if (gnus-buffer-exists-p (car-safe reply)) - (progn - (set-buffer (car reply)) - (and (cdr reply) - (gnus-summary-mark-article-as-replied - (cdr reply))))) - (and winconf (set-window-configuration winconf)))))) + (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))))) (defun gnus-article-mail (yank) "Send a reply to the address near point. If YANK is non-nil, include the original article." (interactive "P") - (let ((address + (let ((address (buffer-substring (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point))) (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point)))))) (when address - (switch-to-buffer gnus-summary-buffer) (message-reply address) (when yank - (gnus-inews-yank-articles yank))))) + (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) +(defvar nntp-server-type) (defun gnus-bug () "Send a bug report to the Gnus maintainers." (interactive) + (unless (gnus-alive-p) + (error "Gnus has been shut down")) (gnus-setup-message 'bug (delete-other-windows) - (switch-to-buffer "*Gnus Help Bug*") - (erase-buffer) - (insert gnus-bug-message) - (goto-char (point-min)) + (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 . ""))) - (push `(gnus-bug-kill-buffer) message-send-actions) + (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) - (insert (gnus-version) "\n") - (insert (emacs-version)) + (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") (gnus-debug) (goto-char (point-min)) @@ -687,49 +832,44 @@ If YANK is non-nil, include the original article." (message ""))) (defun gnus-bug-kill-buffer () - (and (get-buffer "*Gnus Help Bug*") - (kill-buffer "*Gnus Help Bug*"))) + (when (get-buffer "*Gnus Help Bug*") + (kill-buffer "*Gnus Help Bug*"))) (defun gnus-debug () - "Attemps to go through the Gnus source file and report what variables have been changed. + "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-msg.el" "gnus-score.el" "nnmail.el" - "message.el")) - file dirs expr olist sym) + (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")) + (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. (save-excursion (set-buffer (get-buffer-create " *gnus bug info*")) (buffer-disable-undo (current-buffer)) (while files (erase-buffer) - (setq dirs load-path) - (while dirs - (if (or (not (car dirs)) - (not (stringp (car dirs))) - (not (file-exists-p - (setq file (concat (file-name-as-directory - (car dirs)) (car files)))))) - (setq dirs (cdr dirs)) - (setq dirs nil) - (insert-file-contents file) + (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)) - (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 (condition-case () - (read (current-buffer)) (error nil))) - (condition-case () - (and (eq (car expr) 'defvar) - (stringp (nth 3 expr)) - (or (not (boundp (nth 1 expr))) - (not (equal (eval (nth 2 expr)) - (symbol-value (nth 1 expr))))) - (setq olist (cons (nth 1 expr) olist))) - (error nil)))))) - (setq files (cdr files))) + (while (setq expr (ignore-errors (read (current-buffer)))) + (ignore-errors + (and (or (eq (car expr) 'defvar) + (eq (car expr) 'defcustom)) + (stringp (nth 3 expr)) + (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")) @@ -749,11 +889,12 @@ The source file has to be in the Emacs load path." (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) (setq olist (cdr olist))) (insert "\n\n") - ;; Remove any null chars - they seem to cause trouble for some - ;; mailers. (Byte-compiled output from the stuff above.) - (goto-char (point-min)) - (while (re-search-forward "[\000\200]" nil t) - (replace-match "" t t)))) + ;; Remove any control chars - they seem to cause trouble for some + ;; mailers. (Byte-compiled output from the stuff above.) + (goto-char point) + (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t) + (replace-match (format "\\%03o" (string-to-char (match-string 0))) + t t)))) ;;; Treatment of rejected articles. ;;; Bounced mail. @@ -772,15 +913,16 @@ this is a reply." (let* ((references (mail-fetch-field "references")) (parent (and references (gnus-parent-id references)))) (message-bounce) - ;; If there are references, we fetch the article we answered to. + ;; If there are references, we fetch the article we answered to. (and fetch parent (gnus-summary-refer-article parent) (gnus-summary-show-all-headers))))) ;;; Gcc handling. -;; Do Gcc handling, which copied the message over to some 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 @@ -794,11 +936,11 @@ this is a reply." (setq groups (message-tokenize-header gcc " ,")) ;; Copy the article over to some group(s). (while (setq group (pop groups)) - (gnus-check-server + (gnus-check-server (setq method (cond ((and (null (gnus-get-info group)) (eq (car gnus-message-archive-method) - (car + (car (gnus-server-to-method (gnus-group-method group))))) ;; If the group doesn't exist, we assume @@ -816,12 +958,12 @@ this is a reply." (nnheader-set-temp-buffer " *acc*") (insert-buffer-substring cur) (goto-char (point-min)) - (when (re-search-forward + (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" + (gnus-message 1 "Couldn't store article in group %s: %s" group (gnus-status-message method)) (sit-for 2)) (kill-buffer (current-buffer)))))))))) @@ -830,9 +972,9 @@ this is a reply." "Insert Gcc headers based on `gnus-outgoing-message-group'." (save-excursion (save-restriction - (gnus-inews-narrow-to-headers) + (message-narrow-to-headers) (let* ((group gnus-outgoing-message-group) - (gcc (cond + (gcc (cond ((gnus-functionp group) (funcall group)) ((or (stringp group) (list group)) @@ -847,9 +989,13 @@ this is a reply." "Insert the Gcc to say where the article is to be archived." (let* ((var gnus-message-archive-group) (group (or group gnus-newsgroup-name "")) - result + (gcc-self-val + (and gnus-newsgroup-name + (gnus-group-find-parameter + gnus-newsgroup-name 'gcc-self))) + result (groups - (cond + (cond ((null gnus-message-archive-method) ;; Ignore. nil) @@ -870,7 +1016,7 @@ this is a reply." (while (and var (not (setq result - (cond + (cond ((stringp (caar var)) ;; Regexp. (when (string-match (caar var) group) @@ -881,47 +1027,100 @@ this is a reply." (t (eval (car var))))))) (setq var (cdr var))) - result)))) - (when groups + result))) + name) + (when (or groups gcc-self-val) (when (stringp groups) (setq groups (list groups))) (save-excursion (save-restriction - (gnus-inews-narrow-to-headers) + (message-narrow-to-headers) (goto-char (point-max)) (insert "Gcc: ") - (while groups - (insert (gnus-group-prefixed-name - (pop groups) gnus-message-archive-method)) - (insert " ")) - (insert "\n")))))) - -(defun gnus-summary-send-draft () - "Enter a mail/post buffer to edit and send the draft." - (interactive) - (gnus-set-global-variables) - (let (buf) - (if (not (setq buf (gnus-request-restore-buffer - (gnus-summary-article-number) gnus-newsgroup-name))) - (error "Couldn't restore the article") - (switch-to-buffer buf) - (when (eq major-mode 'news-reply-mode) - (local-set-key "\C-c\C-c" 'gnus-inews-news)) - ;; Insert the separator. - (goto-char (point-min)) - (search-forward "\n\n") - (forward-char -1) - (insert mail-header-separator) - ;; Configure windows. - (let ((gnus-draft-buffer (current-buffer))) - (gnus-configure-windows 'draft t) - (goto-char (point)))))) - -(gnus-add-shutdown 'gnus-inews-close 'gnus) - -(defun gnus-inews-close () - (setq gnus-inews-sent-ids nil)) - + (if gcc-self-val + ;; Use the `gcc-self' param value instead. + (progn + (insert + (if (stringp gcc-self-val) + gcc-self-val + group)) + (if (not (eq gcc-self-val 'none)) + (insert "\n") + (progn + (beginning-of-line) + (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))) + (when groups + (insert " "))) + (insert "\n"))))))) + +;;; Posting styles. + +(defun gnus-configure-posting-styles () + "Configure posting styles according to `gnus-posting-styles'." + (let ((styles gnus-posting-styles) + (gnus-newsgroup-name (or gnus-newsgroup-name "")) + style match variable attribute value value-value) + ;; 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))) + ;; 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 (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 + (progn + ;; This is an ordinary variable. + (make-local-variable variable) + (set variable value-value)) + ;; This is a header to be added to the headers when + ;; posting. + (when value-value + (make-local-variable 'message-required-mail-headers) + (make-local-variable 'message-required-news-headers) + (push (cons (car attribute) value-value) + message-required-mail-headers) + (push (cons (car attribute) value-value) + message-required-news-headers))))))))) + ;;; Allow redefinition of functions. (gnus-ems-redefine)