X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-msg.el;h=c4bf6bfc6389b738e9e0ce9737cc2a6f28d46e3f;hb=9b6c272d50c6896583a69d40d9e9b15cabaf4247;hp=33f3f256a02a4e8eef73dd7002ce750206118dc7;hpb=8a41b30f27a064550cea8d98fbc7dab6d8ae89c2;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 33f3f25..c4bf6bf 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -1,10 +1,12 @@ ;;; gnus-msg.el --- mail and post interface for Semi-gnus -;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ;; Shuhei KOBAYASHI +;; Katsumi Yamaoka +;; Kiyokazu SUTO ;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -93,7 +95,7 @@ Thank you. The first %s will be replaced by the Newsgroups header; the second with the current group name.") -(defvar gnus-message-setup-hook '(message-maybe-setup-default-charset) +(defvar gnus-message-setup-hook '(gnus-maybe-setup-default-charset) "Hook run after setting up a message buffer.") (defvar gnus-bug-create-help-buffer t @@ -110,6 +112,17 @@ the second with the current group name.") (name . user-full-name)) "*Mapping from style parameters to variables.") +(defcustom gnus-group-posting-charset-alist + '(("^no\\." iso-8859-1) + (".*" iso-8859-1) + (message-this-is-news iso-8859-1) + (message-this-is-mail nil) + ) + "Alist of regexps (to match group names) and default charsets to be unencoded when posting." + :type '(repeat (list (regexp :tag "Group") + (symbol :tag "Charset"))) + :group 'gnus-charset) + ;;; Internal variables. (defvar gnus-inhibit-posting-styles nil @@ -189,52 +202,6 @@ 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")) @@ -255,9 +222,6 @@ MAX-COLUMN the optional second argument if it is specified, the return value (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) @@ -265,20 +229,37 @@ MAX-COLUMN the optional second argument if it is specified, the return value (setq gnus-message-buffer (current-buffer)) (set (make-local-variable 'gnus-message-group-art) (cons ,group ,article)) - (make-local-variable 'gnus-newsgroup-name) + (set (make-local-variable 'gnus-newsgroup-name) ,group) + (set (make-local-variable 'message-posting-charset) + (gnus-setup-posting-charset ,group)) (gnus-run-hooks 'gnus-message-setup-hook)) (gnus-add-buffer) (gnus-configure-windows ,config t) (set-buffer-modified-p nil)))) +(defun gnus-setup-posting-charset (group) + (let ((alist gnus-group-posting-charset-alist) + elem) + (catch 'found + (while (setq elem (pop alist)) + (when (or (and (stringp (car elem)) + (string-match (car elem) group)) + (and (gnus-functionp (car elem)) + (funcall (car elem) group)) + (and (symbolp (car elem)) + (symbol-value (car elem)))) + (throw 'found (cadr elem))))))) + (defun gnus-inews-add-send-actions (winconf buffer article) (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))) - (message-add-action - `(set-window-configuration ,winconf) 'exit 'postpone 'kill) + (setq message-user-agent (gnus-extended-version)) + (when (not message-use-multi-frames) + (message-add-action + `(set-window-configuration ,winconf) 'exit 'postpone 'kill)) (message-add-action `(when (gnus-buffer-exists-p ,buffer) (save-excursion @@ -297,15 +278,24 @@ MAX-COLUMN the optional second argument if it is specified, the return value 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)))) + ;; We can't `let' gnus-newsgroup-name here, since that leads + ;; to local variables leaking. + (let ((group gnus-newsgroup-name) + (buffer (current-buffer))) + (unwind-protect + (progn + (setq gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use posting style of group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + (gnus-group-group-name)) + "")) + (gnus-setup-message 'message (message-mail))) + (save-excursion + (set-buffer buffer) + (setq gnus-newsgroup-name group))))) (defun gnus-group-post-news (&optional arg) "Start composing a news message. @@ -362,13 +352,26 @@ If prefix argument YANK is non-nil, original article is yanked automatically." (gnus-summary-followup (gnus-summary-work-articles arg) t)) (defun gnus-inews-yank-articles (articles) - (let (beg article) + (let* ((more-than-one (cdr articles)) + (frame (when (and message-use-multi-frames more-than-one) + (window-frame (get-buffer-window (current-buffer))))) + refs beg article) (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)) + (when frame + (select-frame frame)) + + ;; Gathering references. + (when more-than-one + (setq refs (message-list-references + refs + (mail-header-references gnus-current-headers) + (mail-header-message-id gnus-current-headers)))) + (gnus-copy-article-buffer) (let ((message-reply-buffer gnus-article-copy) (message-reply-headers gnus-current-headers)) @@ -377,6 +380,25 @@ If prefix argument YANK is non-nil, original article is yanked automatically." (when articles (insert "\n"))) (push-mark) + + ;; Replace with the gathered references. + (when refs + (push-mark beg) + (save-restriction + (message-narrow-to-headers) + (let ((case-fold-search t)) + (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t) + (replace-match "") + (goto-char (point-max)))) + (mail-header-format + (list (or (assq 'References message-header-format-alist) + '(References . message-shorten-references))) + (list (cons 'References + (mapconcat 'identity (nreverse refs) " ")))) + (backward-delete-char 1)) + (setq beg (mark t)) + (pop-mark)) + (goto-char beg))) (defun gnus-summary-cancel-article (&optional n symp) @@ -406,7 +428,8 @@ post using the current select method." This is done simply by taking the old article and adding a Supersedes header line with the old Message-ID." (interactive) - (let ((article (gnus-summary-article-number))) + (let ((article (gnus-summary-article-number)) + (gnus-message-setup-hook '(gnus-maybe-setup-default-charset))) (gnus-setup-message 'reply-yank (gnus-summary-select-article t) (set-buffer gnus-original-article-buffer) @@ -458,7 +481,7 @@ header line with the old Message-ID." ;; Delete the headers from the displayed articles. (set-buffer gnus-article-copy) (delete-region (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point))) + (or (search-forward "\n\n" nil t) (point-max))) ;; Insert the original article headers. (insert-buffer-substring gnus-original-article-buffer beg end) (article-decode-encoded-words))) @@ -598,6 +621,54 @@ If SILENT, don't prompt the user." (t gnus-select-method)))) + +(defun gnus-extended-version () + "Stringified gnus version." + (concat gnus-product-name "/" gnus-version-number " (based on " + gnus-original-product-name " v" 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' 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))) + + ;;; ;;; Gnus Mail Functions ;;; @@ -659,12 +730,6 @@ 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." @@ -691,7 +756,7 @@ If FULL-HEADERS (the prefix), include full headers when forwarding." "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") @@ -703,6 +768,12 @@ 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. @@ -957,14 +1028,15 @@ this is a reply." (interactive "P") (gnus-summary-select-article t) (set-buffer gnus-original-article-buffer) - (gnus-setup-message 'compose-bounce - (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. - (and fetch parent - (gnus-summary-refer-article parent) - (gnus-summary-show-all-headers))))) + (let ((gnus-message-setup-hook '(gnus-maybe-setup-default-charset))) + (gnus-setup-message 'compose-bounce + (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. + (and fetch parent + (gnus-summary-refer-article parent) + (gnus-summary-show-all-headers)))))) ;;; Gcc handling. @@ -1119,24 +1191,34 @@ this is a reply." (gnus-newsgroup-name (or gnus-newsgroup-name "")) style match variable attribute value value-value) (make-local-variable 'gnus-message-style-insertions) + ;; If the group has a posting-style parameter, add it at the end with a + ;; regexp matching everything, to be sure it takes precedence over all + ;; the others. + (unless (zerop (length gnus-newsgroup-name)) + (let ((tmp-style (gnus-group-find-parameter + gnus-newsgroup-name 'posting-style t))) + (when tmp-style + (setq styles (append styles (list (cons ".*" tmp-style))))))) ;; Go through all styles and look for matches. (while styles (setq style (pop styles) match (pop style)) - (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))) + (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) @@ -1151,36 +1233,36 @@ this is a reply." (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)))) + (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)))) + (let ((attr (car attribute))) + (make-local-variable 'message-setup-hook) + (if (eq 'body attr) (add-hook 'message-setup-hook - 'gnus-message-insert-stylings) - (push (cons (if (stringp attr) attr - (symbol-name attr)) - value-value) - gnus-message-style-insertions)))))))))))) + `(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) @@ -1189,7 +1271,25 @@ this is a reply." (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))))) + (gnus-pull (car val) gnus-message-style-insertions t))))) + + +;;; @ for MIME Edit mode +;;; + +(defun gnus-maybe-setup-default-charset () + (let ((charset + (and (boundp 'gnus-summary-buffer) + (buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)))) + (if charset + (progn + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + )))) + ;;; Allow redefinition of functions.