X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-msg.el;h=5f3c80ae6744f43de7770a0c961389b8dd5db585;hb=c8ea10f077d264fe9a5d86ca0836db23cb2eba3a;hp=ad7f8dd6c77c383fb9ef8f4494ecb297e1ae3a2b;hpb=97fd6c48e2095ee8da278e2f1360a7319a10eb99;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index ad7f8dd..5f3c80a 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -2,8 +2,9 @@ ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA -;; Lars Magne Ingebrigtsen -;; MORIOKA Tomohiko +;; Lars Magne Ingebrigtsen +;; MORIOKA Tomohiko +;; Shuhei KOBAYASHI ;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -34,18 +35,25 @@ (require 'message) (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. @@ -85,18 +93,41 @@ Thank you. The first %s will be replaced by the Newsgroups header; the second with the current group name.") -(defvar gnus-message-setup-hook nil +(defvar gnus-message-setup-hook '(message-maybe-setup-default-charset) "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-inhibit-posting-styles nil + "Inhibit the use of posting styles.") + (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. + (format "Sending a bug report to the Gnus Towers. +======================================== + +This gnus is the %s%s. +If you think the bug is a Semi-gnus bug, send a bug report to Semi-gnus +Developers. (the addresses below are mailing list addresses) + ======================================== The buffer below is a mail buffer. When you press `C-c C-c', it will @@ -113,7 +144,11 @@ 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. -") +" + gnus-product-name + (if (string= gnus-product-name "Semi-gnus") + "" + ", a modified version of Semi-gnus"))) (eval-and-compile (autoload 'gnus-uu-post-news "gnus-uu" nil t) @@ -144,8 +179,8 @@ Thank you for your help in stamping out bugs. "\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) + "Om" gnus-summary-mail-digest + "Op" gnus-summary-post-digest) (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map) "b" gnus-summary-resend-bounced-mail @@ -154,6 +189,52 @@ Thank you for your help in stamping out bugs. ;;; Internal functions. +(defun gnus-extended-version () + "Stringified gnus version." + (concat gnus-product-name "/" gnus-version-number " (based on " + gnus-original-product-name " " gnus-original-version-number ")")) + +(defun gnus-message-make-user-agent (&optional include-mime-info max-column) + "Return user-agent info. +INCLUDE-MIME-INFO the optional first argument if it is non-nil and the variable + `mime-edit-user-agent-value' is exists, the return value will include it. +MAX-COLUMN the optional second argument if it is specified, the return value + will be folded up in the proper way." + (let ((user-agent (if (and include-mime-info + (boundp 'mime-edit-user-agent-value)) + (concat (gnus-extended-version) + " " + mime-edit-user-agent-value) + (gnus-extended-version)))) + (if max-column + (let (boundary) + (unless (natnump max-column) (setq max-column 76)) + (with-temp-buffer + (insert " " user-agent) + (goto-char 13) + (while (re-search-forward "[\n\t ]+" nil t) + (replace-match " ")) + (goto-char 13) + (while (re-search-forward "[^ ()/]+\\(/[^ ()/]+\\)? ?" nil t) + (while (eq ?\( (char-after (point))) + (forward-list) + (skip-chars-forward " ")) + (skip-chars-backward " ") + (if (> (current-column) max-column) + (progn + (if (or (not boundary) (eq ?\n (char-after boundary))) + (progn + (setq boundary (point)) + (unless (eobp) + (delete-char 1) + (insert "\n "))) + (goto-char boundary) + (delete-char 1) + (insert "\n "))) + (setq boundary (point)))) + (buffer-substring 13 (point-max)))) + user-agent))) + (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) (let ((winconf (make-symbol "gnus-setup-message-winconf")) @@ -165,9 +246,15 @@ Thank you for your help in stamping out bugs. (,article (and gnus-article-reply (gnus-summary-article-number))) (,group gnus-newsgroup-name) (message-header-setup-hook - (copy-sequence message-header-setup-hook))) + (copy-sequence message-header-setup-hook)) + (message-mode-hook (copy-sequence message-mode-hook)) + (gnus-message-get-reply-buffer 'gnus-copy-article-buffer)) (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) + (add-hook 'message-mode-hook + (lambda () + (setq message-user-agent (gnus-extended-version)))) (unwind-protect (progn ,@forms) @@ -177,6 +264,7 @@ Thank you for your help in stamping out bugs. (cons ,group ,article)) (make-local-variable 'gnus-newsgroup-name) (gnus-run-hooks 'gnus-message-setup-hook)) + (gnus-add-buffer) (gnus-configure-windows ,config t) (set-buffer-modified-p nil)))) @@ -186,13 +274,12 @@ Thank you for your help in stamping out bugs. (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 (buffer-name (get-buffer ,buffer)) + `(when (gnus-buffer-exists-p ,buffer) (save-excursion - (set-buffer (get-buffer ,buffer)) + (set-buffer ,buffer) ,(when article `(gnus-summary-mark-article-as-replied ,article)))) 'send)) @@ -202,11 +289,20 @@ Thank you for your help in stamping out bugs. ;;; Post news commands of Gnus group mode and summary mode -(defun gnus-group-mail () - "Start composing a mail." - (interactive) - (gnus-setup-message 'message - (message-mail))) +(defun gnus-group-mail (&optional arg) + "Start composing a mail. +If ARG, use the group under the point to find a posting style. +If ARG is 1, prompt for a group name to find the posting style." + (interactive "P") + (let ((gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use posting style of group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + (gnus-group-group-name)) + ""))) + (gnus-setup-message 'message (message-mail)))) (defun gnus-group-post-news (&optional arg) "Start composing a news message. @@ -314,9 +410,9 @@ header line with the old Message-ID." (message-supersede) (push `((lambda () - (when (buffer-name (get-buffer ,gnus-summary-buffer)) + (when (gnus-buffer-exists-p ,gnus-summary-buffer) (save-excursion - (set-buffer (get-buffer ,gnus-summary-buffer)) + (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)))) @@ -328,14 +424,11 @@ header line with the old Message-ID." ;; this copy is in the buffer gnus-article-copy. ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used ;; this buffer should be passed to all mail/news reply/post routines. - (setq gnus-article-copy (get-buffer-create " *gnus article copy*")) - (buffer-disable-undo gnus-article-copy) - (or (memq gnus-article-copy gnus-buffer-list) - (push gnus-article-copy gnus-buffer-list)) + (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*")) (let ((article-buffer (or article-buffer gnus-article-buffer)) - end beg contents) + end beg) (if (not (and (get-buffer article-buffer) - (buffer-name (get-buffer article-buffer)))) + (gnus-buffer-exists-p article-buffer))) (error "Can't find any article buffer") (save-excursion (set-buffer article-buffer) @@ -365,7 +458,7 @@ header line with the old Message-ID." (or (search-forward "\n\n" nil t) (point))) ;; Insert the original article headers. (insert-buffer-substring gnus-original-article-buffer beg end) - (gnus-article-decode-rfc1522))) + (article-decode-encoded-words))) gnus-article-copy))) (defun gnus-post-news (post &optional group header article-buffer yank subject @@ -404,6 +497,7 @@ header line with the old Message-ID." (if post (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))) ;; The is mail. (if post @@ -417,12 +511,19 @@ header line with the old Message-ID." (push (list 'gnus-inews-add-to-address pgroup) message-send-actions))) (set-buffer gnus-article-copy) - (message-wide-reply to-address - (gnus-group-find-parameter - gnus-newsgroup-name 'broken-reply-to)))) + (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." @@ -431,30 +532,38 @@ If SILENT, don't prompt the user." ;; If the group-method is nil (which shouldn't happen) we use ;; the default method. ((null group-method) - (or gnus-post-method gnus-select-method message-post-method)) - ;; We want this group's 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) + (mapcar 'car gnus-opened-servers) (list gnus-select-method) (list group-method))) method-alist post-methods method) ;; Weed out all mail methods. (while methods (setq method (gnus-server-get-method "" (pop methods))) - (when (or (gnus-method-option-p method 'post) - (gnus-method-option-p method 'post-mail)) + (when (and (or (gnus-method-option-p method 'post) + (gnus-method-option-p method 'post-mail)) + (not (member method post-methods))) (push method post-methods))) ;; Create a name-method alist. (setq method-alist @@ -475,26 +584,17 @@ If SILENT, don't prompt the user." (cons (or gnus-last-posting-server "") 0)))) method-alist)))) ;; Override normal method. - (gnus-post-method + ((and (eq gnus-post-method 'current) + (not (eq (car group-method) 'nndraft)) + (not arg)) + group-method) + ((and gnus-post-method + (not (eq gnus-post-method 'current))) gnus-post-method) ;; Use the normal select method. (t gnus-select-method)))) - -;; 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" - (interactive) - gnus-version) - - ;;; ;;; Gnus Mail Functions ;;; @@ -515,8 +615,8 @@ automatically." (gnus-setup-message (if yank 'reply-yank 'reply) (gnus-summary-select-article) (set-buffer (gnus-copy-article-buffer)) - (message-reply nil wide (gnus-group-find-parameter - gnus-newsgroup-name 'broken-reply-to)) + (gnus-msg-treat-broken-reply-to) + (message-reply nil wide) (when yank (gnus-inews-yank-articles yank))))) @@ -556,6 +656,39 @@ If FULL-HEADERS (the prefix), include full headers when forwarding." (if full-headers "" message-included-forward-headers))) (message-forward post)))) +(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)) + +;;; XXX: generate Subject and ``Topics''? +(defun gnus-summary-mail-digest (&optional n post) + "Digests and forwards all articles in this series." + (interactive "P") + (let ((subject "Digested Articles") + (articles (gnus-summary-work-articles n)) + article) + (gnus-setup-message 'forward + (gnus-summary-select-article) + (if post (message-news nil subject) (message-mail nil subject)) + (message-goto-body) + (while (setq article (pop articles)) + (save-window-excursion + (set-buffer gnus-summary-buffer) + (gnus-summary-select-article nil nil nil article) + (gnus-summary-remove-process-mark article)) + (insert (mime-make-tag "message" "rfc822") "\n") + (insert-buffer-substring gnus-original-article-buffer)) + (push-mark) + (message-goto-body) + (mime-edit-enclose-digest-region (point)(mark t))))) + +(defun gnus-summary-post-digest (&optional n) + "Digest and forwards all articles in this series to a newsgroup." + (interactive "P") + (gnus-summary-mail-digest n t)) + (defun gnus-summary-resend-message (address n) "Resend the current article to ADDRESS." (interactive "sResend message(s) to: \nP") @@ -567,12 +700,6 @@ If FULL-HEADERS (the prefix), include full headers when forwarding." (set-buffer gnus-original-article-buffer) (message-resend address))))) -(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\n" "Format string to insert in nastygrams. @@ -604,7 +731,8 @@ The current group name will be inserted at \"%s\".") (gnus-summary-select-article) (set-buffer gnus-original-article-buffer) (if (and (<= (length (message-tokenize-header - (setq newsgroups (mail-fetch-field "newsgroups")) + (setq newsgroups + (mail-fetch-field "newsgroups")) ", ")) 1) (or (not (setq followup-to (mail-fetch-field "followup-to"))) @@ -725,18 +853,21 @@ If YANK is non-nil, include the original article." (error "Gnus has been shut down")) (gnus-setup-message 'bug (delete-other-windows) - (switch-to-buffer (get-buffer-create "*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) + (message-setup + `((To . ,gnus-maintainer) (Cc . ,semi-gnus-developers) (Subject . ""))) + (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) "\n") + (insert (gnus-version) "\n" + (emacs-version) "\n") (when (and (boundp 'nntp-server-type) (stringp nntp-server-type)) (insert nntp-server-type)) @@ -764,8 +895,7 @@ The source file has to be in the Emacs load path." (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)) + (set-buffer (gnus-get-buffer-create " *gnus bug info*")) (while files (erase-buffer) (when (and (setq file (locate-library (pop files))) @@ -878,7 +1008,7 @@ this is a reply." (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match "" t t )) - (unless (gnus-request-accept-article group method 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)) @@ -909,7 +1039,7 @@ this is a reply." (and gnus-newsgroup-name (gnus-group-find-parameter gnus-newsgroup-name 'gcc-self))) - result + result (groups (cond ((null gnus-message-archive-method) @@ -975,6 +1105,89 @@ this is a reply." (insert " "))) (insert "\n"))))))) +;;; Posting styles. + +(defvar gnus-message-style-insertions nil) + +(defun gnus-configure-posting-styles () + "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) + ;; 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 (eq 'body (car attribute))) + (not (setq variable + (cdr (assq (car attribute) + gnus-posting-style-alist))))) + (message "Couldn't find attribute %s" (car attribute)) + ;; We get the value. + (setq value-value + (cond ((stringp value) + value) + ((or (symbolp value) + (gnus-functionp value)) + (cond ((gnus-functionp value) + (funcall value)) + ((boundp value) + (symbol-value value)))) + ((listp value) + (eval value)))) + (if variable + ;; This is an ordinary variable. + (set (make-local-variable variable) value-value) + ;; This is either a body or a header to be inserted in the + ;; message. + (when value-value + (let ((attr (car attribute))) + (make-local-variable 'message-setup-hook) + (if (eq 'body attr) + (add-hook 'message-setup-hook + `(lambda () + (save-excursion + (message-goto-body) + (insert ,value-value)))) + (add-hook 'message-setup-hook + 'gnus-message-insert-stylings) + (push (cons (if (stringp attr) attr + (symbol-name attr)) + value-value) + gnus-message-style-insertions)))))))))))) + +(defun gnus-message-insert-stylings () + (let (val) + (save-excursion + (message-goto-eoh) + (while (setq val (pop gnus-message-style-insertions)) + (when (cdr val) + (insert (car val) ": " (cdr val) "\n")) + (gnus-pull (car val) gnus-message-style-insertions))))) + ;;; Allow redefinition of functions. (gnus-ems-redefine)