From 80da5d5be490f308f36327b705fc28cba15dd2d0 Mon Sep 17 00:00:00 2001 From: yamaoka Date: Tue, 17 Sep 2002 22:34:29 +0000 Subject: [PATCH] Synch with Oort Gnus. --- GNUS-NEWS | 16 +- lisp/ChangeLog | 36 +++++ lisp/message-utils.el | 375 -------------------------------------------- lisp/message.el | 415 ++++++++++++++++++++++++++++++++++++++++++++++++- lisp/nnimap.el | 39 ++--- 5 files changed, 471 insertions(+), 410 deletions(-) delete mode 100644 lisp/message-utils.el diff --git a/GNUS-NEWS b/GNUS-NEWS index 56649e9..8c95a6f 100644 --- a/GNUS-NEWS +++ b/GNUS-NEWS @@ -11,14 +11,14 @@ For older news, see Gnus info node "New Features". ** Group Carbon Copy (GCC) quoting To support groups that contains SPC and other weird characters, groups -are quoted before they are placed in the Gcc: header. While this -should not cause problems, errorenous local customization may cause -problems. In particular, if you have local customizations (e.g., -variables such as gnus-message-archive-group) that return the string -"nnml:foo, nnml:bar" (indicating Gcc into two groups) you must change -it to return the list ("nnml:foo" "nnml:bar"), otherwise the Gcc: line -will be quoted incorrectly. Note that returning the string "nnml:foo, -nnml:bar" was incorrect earlier, it just didn't generate any problems. +are quoted before they are placed in the Gcc: header. This means +variables such as `gnus-message-archive-group' should no longer +contain quote characters to make groups containing SPC work. Also, if +you are using the string "nnml:foo, nnml:bar" (indicating Gcc into two +groups) you must change it to return the list ("nnml:foo" "nnml:bar"), +otherwise the Gcc: line will be quoted incorrectly. Note that +returning the string "nnml:foo, nnml:bar" was incorrect earlier, it +just didn't generate any problems since it was inserted directly. ** gnus-agent diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7d6de42..bc1595a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,39 @@ +2002-09-17 Simon Josefsson + + * nnimap.el (nnimap-expiry-target): Don't search for which + articles exists here. + (nnimap-request-expire-articles): Do it here instead. Only expire + when articles are found. Suggested by Nevin Kapur + . + +2002-09-17 Kai Gro,A_(Bjohann + From Reiner Steib . + + * message.el (message-strip-subject-trailing-was) + (message-change-subject, message-add-archive-header) + (message-xpost-fup2-header, message-xpost-insert-note) + (message-xpost-fup2, message-reduce-to-to-cc): New functions + adopted from message-utils.el. Add functions to the keymap, mode + describtion and menu. + (message-change-subject,message-xpost-fup2): Signal error if + current header is empty. + (message-xpost-insert-note): Changed insert position. + (message-archive-note): Ensure to insert note in message body (not + in head). + (message-archive-header, message-archive-note) + (message-xpost-default, message-xpost-note, message-fup2-note) + (message-xpost-note-function): New variables adopted from + message-utils.el. Changed some doc-strings. + (message-mark-insert-{begin,end}): Rename from + message-{begin,end}-inserted-text-mark (message-utils.el), changed + values. + (message-subject-trailing-was-query) + (message-subject-trailing-was-ask-regexp) + (message-subject-trailing-was-regexp): New variables. + (message-to-list-only): Added doc-string and menu entry. + + * message-utils.el: Removed. Functions are now in message.el. + 2002-09-16 ShengHuo ZHU * gnus-art.el (gnus-article-reply-with-original, diff --git a/lisp/message-utils.el b/lisp/message-utils.el deleted file mode 100644 index a2d61d5..0000000 --- a/lisp/message-utils.el +++ /dev/null @@ -1,375 +0,0 @@ -;;; message-utils.el -- utils for message-mode - -;; Copyright (C) 2002 Free Software Foundation, Inc. - -;; Author: Holger Schauer -;; Keywords: utils message - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. -;; -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This file contains some small additions to message mode: -;; * inserting files in a message and explicit marking it -;; as something somebody else has created, -;; * change Subject: header and add (was: ) -;; * strip (was: ) from Subject: headers -;; * add a X-No-Archive: Yes header and a note in the body -;; * a function for cross-post and followup-to messages -;; * replace To: header with contents of Cc: or Bcc: header. -;; - -;; This file is adopt from the link below when the revision is 0.8. -;; http://www.coling.uni-freiburg.de/~schauer/resources/emacs/message-utils.el.gz - -;;; Installation: (TODO: merge into message.el) - -;; .. is easy as in most cases. Add -;; (autoload 'message-mark-inserted-region "message-utils" nil t) -;; (autoload 'message-mark-insert-file "message-utils" nil t) -;; (autoload 'message-strip-subject-was "message-utils" nil t) -;; (autoload 'message-change-subject "message-utils" nil t) -;; (autoload 'message-xpost-fup2 "message-utils" nil t) -;; (autoload 'message-add-archive-header "message-utils" nil t) -;; (autoload 'message-reduce-to-to-cc "message-utils" nil t) -;; as well as some keybindings like -;; (define-key message-mode-map '[(control c) m] 'message-mark-inserted-region) -;; (define-key message-mode-map '[(control c) f] 'message-mark-insert-file) -;; (define-key message-mode-map '[(control c) x] 'message-xpost-fup2) -;; (define-key message-mode-map '[(control c) s] 'message-change-subject) -;; (define-key message-mode-map '[(control c) a] 'message-add-archive-header) -;; (define-key message-mode-map '[(control c) t] 'message-reduce-to-to-cc) -;; (add-hook 'message-header-setup-hook 'message-strip-subject-was) -;; to your .gnus or to your .emacs. -;; You might also want to add something along the following lines: -;; (defun message-utils-setup () -;; "Add menu-entries for message-utils." -;; (easy-menu-add-item nil '("Message") -;; ["Insert Region Marked" message-mark-inserted-region t] "Spellcheck") -;; (easy-menu-add-item nil '("Message") -;; ["Insert File Marked" message-mark-insert-file t] "Spellcheck") -;; (easy-menu-add-item nil '("Field") -;; ["Crosspost / Followup" message-xpost-fup2 t] "----") -;; (easy-menu-add-item nil '("Field") -;; ["New Subject" message-change-subject t] "----") -;; (easy-menu-add-item nil '("Field") -;; ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----") -;; (easy-menu-add-item nil '("Field") -;; [ "X-No-Archive:" message-add-archive-header t ])) -;; (add-hook 'message-mode-hook 'message-utils-setup) - -;;; Code: - -(require 'message) - -;;; ************** -;;; Inserting and marking ... - -; We try to hook the vars into the message customize group - -(defcustom message-begin-inserted-text-mark -"--8<------------------------schnipp------------------------->8---\n" -"How to mark the beginning of some inserted text." - :type 'string - :group 'message-various) - -(defcustom message-end-inserted-text-mark -"--8<------------------------schnapp------------------------->8---\n" -"How to mark the end of some inserted text." - :type 'string - :group 'message-various) - -;;;###autoload -(defun message-mark-inserted-region (beg end) - "Mark some region in the current article with enclosing tags. -See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'." - (interactive "r") - (save-excursion - ; add to the end of the region first, otherwise end would be invalid - (goto-char end) - (insert message-end-inserted-text-mark) - (goto-char beg) - (insert message-begin-inserted-text-mark))) - -;;;###autoload -(defun message-mark-insert-file (file) - "Inserts FILE at point, marking it with enclosing tags. -See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'." - (interactive "fFile to insert: ") - ;; reverse insertion to get correct result. - (let ((p (point))) - (insert message-end-inserted-text-mark) - (goto-char p) - (insert-file-contents file) - (goto-char p) - (insert message-begin-inserted-text-mark))) - -;;; ************** -;;; Subject mangling - -(defcustom message-subject-was-regexp - "[ \t]*\\((*[Ww][Aa][SsRr]:[ \t]*.*)\\)" - "*Regexp matching \"(was: )\" in the subject line." - :group 'message-various - :type 'regexp) - -;;;###autoload -(defun message-strip-subject-was () - "Remove trailing \"(Was: )\" from subject lines." - (message-narrow-to-head) - (let* ((subject (message-fetch-field "Subject")) - (pos)) - (cond (subject - (setq pos (or (string-match message-subject-was-regexp subject) 0)) - (cond ((> pos 0) - (message-goto-subject) - (message-delete-line) - (insert (concat "Subject: " - (substring subject 0 pos) "\n"))))))) - (widen)) - -;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/ -;;;###autoload -(defun message-change-subject (new-subject) - "Ask for new Subject: header, append (was: )." - (interactive - (list - (read-from-minibuffer "New subject: "))) - (cond ((and (not (or (null new-subject) ; new subject not empty - (zerop (string-width new-subject)) - (string-match "^[ \t]*$" new-subject)))) - (save-excursion - (let ((old-subject (message-fetch-field "Subject"))) - (cond ((not (string-match - (concat "^[ \t]*" - (regexp-quote new-subject) - " \t]*$") - old-subject)) ; yes, it really is a new subject - ;; delete eventual Re: prefix - (setq old-subject - (message-strip-subject-re old-subject)) - (message-goto-subject) - (message-delete-line) - (insert (concat "Subject: " - new-subject - " (was: " - old-subject ")\n"))))))))) - - -;;; ************** -;;; X-Archive-Header: No - -(defcustom message-archive-header - "X-No-Archive: Yes\n" - "Header to insert when you don't want your article to be archived by deja.com." - :type 'string - :group 'message-various) - -(defcustom message-archive-note - "X-No-Archive: Yes - save http://deja.com/" - "Note to insert why you wouldn't want this posting archived." - :type 'string - :group 'message-various) - -(defun message-add-archive-header () - "Insert \"X-No-Archive: Yes\" in the header and a note in the body. -When called with a prefix argument, ask for a text to insert." - (interactive) - (if current-prefix-arg - (setq message-archive-note - (read-from-minibuffer "Reason for No-Archive: " - (cons message-archive-note 0)))) - (save-excursion - (insert message-archive-note) - (newline) - (message-add-header message-archive-header) - (message-sort-headers))) - -;;; ************** -;;; Crossposts and Followups - -; inspired by JoH-followup-to by Jochem Huhman -; new suggestions by R. Weikusat - -(defvar message-xpost-old-target nil - "Old target for cross-posts or follow-ups.") -(make-variable-buffer-local 'message-xpost-old-target) - -(defcustom message-xpost-default t - "When non-nil `message-xpost-fup2' will normally perform a crosspost. -If nil, `message-xpost-fup2' will only do a followup. Note that you -can explicitly override this setting by calling `message-xpost-fup2' -with a prefix." - :type 'boolean - :group 'message-various) - -(defun message-xpost-fup2-header (target-group) - "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP. -With prefix-argument just set Follow-Up, don't cross-post." - (interactive - (list ; Completion based on Gnus - (completing-read "Followup To: " - (if (boundp 'gnus-newsrc-alist) - gnus-newsrc-alist) - nil nil '("poster" . 0) - (if (boundp 'gnus-group-history) - 'gnus-group-history)))) - (message-remove-header "Follow[Uu]p-[Tt]o" t) - (message-goto-newsgroups) - (beginning-of-line) - ;; if we already did a crosspost before, kill old target - (if (and message-xpost-old-target - (re-search-forward - (regexp-quote (concat "," message-xpost-old-target)) - nil t)) - (replace-match "")) - ;; unless (followup is to poster or user explicitly asked not - ;; to cross-post, or target-group is already in Newsgroups) - ;; add target-group to Newsgroups line. - (cond ((and (or (and message-xpost-default (not current-prefix-arg)) ; def: xpost, req:no - (and (not message-xpost-default) current-prefix-arg)) ; def: no-xpost, req:yes - (not (string-match "poster" target-group)) - (not (string-match (regexp-quote target-group) - (message-fetch-field "Newsgroups")))) - (end-of-line) - (insert-string (concat "," target-group)))) - (end-of-line) ; ensure Followup: comes after Newsgroups: - ;; unless new followup would be identical to Newsgroups line - ;; make a new Followup-To line - (if (not (string-match (concat "^[ \t]*" - target-group - "[ \t]*$") - (message-fetch-field "Newsgroups"))) - (insert (concat "\nFollowup-To: " target-group))) - (setq message-xpost-old-target target-group)) - - -(defcustom message-xpost-note - "Crosspost & Followup-To: " - "Note to insert before signature to notify of xpost and follow-up." - :type 'string - :group 'message-various) - -(defcustom message-fup2-note - "Followup-To: " - "Note to insert before signature to notify of follow-up only." - :type 'string - :group 'message-various) - -(defun message-xpost-insert-note (target-group xpost in-old old-groups) - "Insert a in message body note about a set Followup or Crosspost. -If there have been previous notes, delete them. TARGET-GROUP specifies the -group to Followup-To. When XPOST is t, insert note about -crossposting. IN-OLD specifies whether TARGET-GROUP is a member of -OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have -been made to before the user asked for a Crosspost." - ;; start scanning body for previous uses - (message-goto-signature) - (let ((head (re-search-backward - (concat "^" mail-header-separator) - nil t))) ; just search in body - (message-goto-signature) - (while (re-search-backward - (concat "^" (regexp-quote message-xpost-note) ".*") - head t) - (message-delete-line)) - (message-goto-signature) - (while (re-search-backward - (concat "^" (regexp-quote message-fup2-note) ".*") - head t) - (message-delete-line)) - ;; insert new note - (message-goto-signature) - (previous-line 2) - (open-line 1) - (if (or in-old - (not xpost) - (string-match "^[ \t]*poster[ \t]*$" target-group)) - (insert (concat message-fup2-note target-group "\n")) - (insert (concat message-xpost-note target-group "\n"))))) - -(defcustom message-xpost-note-function - 'message-xpost-insert-note - "Function to use to insert note about Crosspost or Followup-To. -The function will be called with four arguments. The function should not -only insert a note, but also ensure old notes are deleted. See the -documentation for `message-xpost-insert-note'. " - :type 'function - :group 'message-various) - -;;;###autoload -(defun message-xpost-fup2 (target-group) - "Crossposts message and sets Followup-To to TARGET-GROUP. -With prefix-argument just set Follow-Up, don't cross-post." - (interactive - (list ; Completion based on Gnus - (completing-read "Followup To: " - (if (boundp 'gnus-newsrc-alist) - gnus-newsrc-alist) - nil nil '("poster" . 0) - (if (boundp 'gnus-group-history) - 'gnus-group-history)))) - (cond ((not (or (null target-group) ; new subject not empty - (zerop (string-width target-group)) - (string-match "^[ \t]*$" target-group))) - (save-excursion - (let* ((old-groups (message-fetch-field "Newsgroups")) - (in-old (string-match - (regexp-quote target-group) old-groups))) - ;; check whether target exactly matches old Newsgroups - (cond ((or (not in-old) - (not (string-match - (concat "^[ \t]*" - (regexp-quote target-group) - "[ \t]*$") - old-groups))) - ;; yes, Newsgroups line must change - (message-xpost-fup2-header target-group) - ;; insert note whether we do xpost or fup2 - (funcall message-xpost-note-function - target-group - (if (or (and message-xpost-default (not current-prefix-arg)) - (and (not message-xpost-default) current-prefix-arg)) - t) - in-old old-groups)))))))) - - -;;; ************** -;;; Reduce To: to Cc: or Bcc: header - -(defun message-reduce-to-to-cc () - "Replace contents of To: header with contents of Cc: or Bcc: header." - (interactive) - (let ((cc-content (message-fetch-field "cc")) - (bcc nil)) - (if (and (not cc-content) - (setq cc-content (message-fetch-field "bcc"))) - (setq bcc t)) - (cond (cc-content - (save-excursion - (message-goto-to) - (message-delete-line) - (insert (concat "To: " cc-content "\n")) - (message-remove-header (if bcc - "bcc" - "cc"))))))) - -;;; provide ourself -(provide 'message-utils) - -;;; message-utils.el ends here diff --git a/lisp/message.el b/lisp/message.el index 71c8fd6..728bfa4 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -187,6 +187,121 @@ If this variable is nil, no such courtesy message will be added." :group 'message-sending :type 'function) +;;; Start of variables adopted from `message-utils.el'. + +(defcustom message-subject-trailing-was-query 'ask + ;; should it default to nil or ask? + "*What to do with trailing \"(was: )\" in subject lines. +If nil, leave the subject unchanged. If it is the symbol `ask', query +the user what do do. In this case, the subject is matched against +`message-subject-trailing-was-ask-regexp'. If +`message-subject-trailing-was-query' is t, always strip the trailing +old subject. In this case, `message-subject-trailing-was-regexp' is +used." + :type '(choice (const :tag "never" nil) + (const :tag "always strip" t) + (const ask)) + :group 'message-various) + +(defcustom message-subject-trailing-was-ask-regexp + "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)" + "*Regexp matching \"(was: )\" in the subject line. + +The function `message-strip-subject-trailing-was' uses this regexp if +`message-subject-trailing-was-query' is set to the symbol `ask'. If +the variable is t instead of `ask', use +`message-subject-trailing-was-regexp' instead. + +It is okay to create some false positives here, as the user is asked." + :group 'message-various + :type 'regexp) + +(defcustom message-subject-trailing-was-regexp + "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" + "*Regexp matching \"(was: )\" in the subject line. + +If `message-subject-trailing-was-query' is set to t, the subject is +matched against `message-subject-trailing-was-regexp' in +`message-strip-subject-trailing-was'. You should use a regexp creating very +few false positives here." + :group 'message-various + :type 'regexp) + +;;; marking inserted text + +;;;###autoload +(defcustom message-mark-insert-begin + "--8<---------------cut here---------------start------------->8---\n" + "How to mark the beginning of some inserted text." + :type 'string + :group 'message-various) + +;;;###autoload +(defcustom message-mark-insert-end + "--8<---------------cut here---------------end--------------->8---\n" + "How to mark the end of some inserted text." + :type 'string + :group 'message-various) + +;;;###autoload +(defcustom message-archive-header + "X-No-Archive: Yes\n" + "Header to insert when you don't want your article to be archived. +Archives \(such as groups.googgle.com\) respect this header." + :type 'string + :group 'message-various) + +;;;###autoload +(defcustom message-archive-note + "X-No-Archive: Yes - save http://groups.google.com/" + "Note to insert why you wouldn't want this posting archived. +If nil, don't insert any text in the body." + :type 'string + :group 'message-various) + +;;; Crossposts and Followups +;; inspired by JoH-followup-to by Jochem Huhman +;; new suggestions by R. Weikusat + +(defvar message-xpost-old-target nil + "Old target for cross-posts or follow-ups.") +(make-variable-buffer-local 'message-xpost-old-target) + +;;;###autoload +(defcustom message-xpost-default t + "When non-nil `message-xpost-fup2' will normally perform a crosspost. +If nil, `message-xpost-fup2' will only do a followup. Note that you +can explicitly override this setting by calling `message-xpost-fup2' +with a prefix." + :type 'boolean + :group 'message-various) + +;;;###autoload +(defcustom message-xpost-note + "Crosspost & Followup-To: " + "Note to insert before signature to notify of xpost and follow-up." + :type 'string + :group 'message-various) + +;;;###autoload +(defcustom message-fup2-note + "Followup-To: " + "Note to insert before signature to notify of follow-up only." + :type 'string + :group 'message-various) + +;;;###autoload +(defcustom message-xpost-note-function + 'message-xpost-insert-note + "Function to use to insert note about Crosspost or Followup-To. +The function will be called with four arguments. The function should not only +insert a note, but also ensure old notes are deleted. See the documentation +for `message-xpost-insert-note'. " + :type 'function + :group 'message-various) + +;;; End of variables adopted from `message-utils.el'. + ;;;###autoload (defcustom message-from-style 'default "*Specifies how \"From\" headers look. @@ -1641,6 +1756,253 @@ is used by default." (substring subject (match-end 0)) subject)) +;;; Start of functions adopted from `message-utils.el'. + +(defun message-strip-subject-trailing-was (subject) + "Remove trailing \"(Was: )\" from subject lines. +Leading \"Re: \" is not stripped by this function. Use the function +`message-strip-subject-re' for this." + (let* ((query message-subject-trailing-was-query) + (new) (found)) + (setq found + (string-match + (if (eq query 'ask) + message-subject-trailing-was-ask-regexp + message-subject-trailing-was-regexp) + subject)) + (if found + (setq new (substring subject 0 (match-beginning 0)))) + (if (or (not found) (eq query nil)) + subject + (if (eq query 'ask) + (if (message-y-or-n-p + "Strip `(was: )' in subject? " t + (concat + "Strip `(was: )' in subject " + "and use the new one instead?\n\n" + "Current subject is: \"" + subject "\"\n\n" + "New subject would be: \"" + new "\"\n\n" + "See the variable `message-subject-trailing-was-query' " + "to get rid of this query." + )) + new subject) + new)))) + +;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/ + +;;;###autoload +(defun message-change-subject (new-subject) + "Ask for new Subject: header, append (was: )." + (interactive + (list + (read-from-minibuffer "New subject: "))) + (cond ((and (not (or (null new-subject) ; new subject not empty + (zerop (string-width new-subject)) + (string-match "^[ \t]*$" new-subject)))) + (save-excursion + (let ((old-subject (message-fetch-field "Subject"))) + (cond ((not old-subject) + (error "No current subject.")) + ((not (string-match + (concat "^[ \t]*" + (regexp-quote new-subject) + " \t]*$") + old-subject)) ; yes, it really is a new subject + ;; delete eventual Re: prefix + (setq old-subject + (message-strip-subject-re old-subject)) + (message-goto-subject) + (message-delete-line) + (insert (concat "Subject: " + new-subject + " (was: " + old-subject ")\n"))))))))) + +;;;###autoload +(defun message-mark-inserted-region (beg end) + "Mark some region in the current article with enclosing tags. +See `message-mark-insert-begin' and `message-mark-insert-end'." + (interactive "r") + (save-excursion + ; add to the end of the region first, otherwise end would be invalid + (goto-char end) + (insert message-mark-insert-end) + (goto-char beg) + (insert message-mark-insert-begin))) + +;;;###autoload +(defun message-mark-insert-file (file) + "Inserts FILE at point, marking it with enclosing tags. +See `message-mark-insert-begin' and `message-mark-insert-end'." + (interactive "fFile to insert: ") + ;; reverse insertion to get correct result. + (let ((p (point))) + (insert message-mark-insert-end) + (goto-char p) + (insert-file-contents file) + (goto-char p) + (insert message-mark-insert-begin))) + +;;;###autoload +(defun message-add-archive-header () + "Insert \"X-No-Archive: Yes\" in the header and a note in the body. +The note can be customized using `message-archive-note'. When called with a +prefix argument, ask for a text to insert. If you don't want the note in the +body, set `message-archive-note' to nil." + (interactive) + (if current-prefix-arg + (setq message-archive-note + (read-from-minibuffer "Reason for No-Archive: " + (cons message-archive-note 0)))) + (save-excursion + (if (message-goto-signature) + (re-search-backward message-signature-separator)) + (when message-archive-note + (insert message-archive-note) + (newline)) + (message-add-header message-archive-header) + (message-sort-headers))) + +;;;###autoload +(defun message-xpost-fup2-header (target-group) + "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP. +With prefix-argument just set Follow-Up, don't cross-post." + (interactive + (list ; Completion based on Gnus + (completing-read "Followup To: " + (if (boundp 'gnus-newsrc-alist) + gnus-newsrc-alist) + nil nil '("poster" . 0) + (if (boundp 'gnus-group-history) + 'gnus-group-history)))) + (message-remove-header "Follow[Uu]p-[Tt]o" t) + (message-goto-newsgroups) + (beginning-of-line) + ;; if we already did a crosspost before, kill old target + (if (and message-xpost-old-target + (re-search-forward + (regexp-quote (concat "," message-xpost-old-target)) + nil t)) + (replace-match "")) + ;; unless (followup is to poster or user explicitly asked not + ;; to cross-post, or target-group is already in Newsgroups) + ;; add target-group to Newsgroups line. + (cond ((and (or + ;; def: xpost, req:no + (and message-xpost-default (not current-prefix-arg)) + ;; def: no-xpost, req:yes + (and (not message-xpost-default) current-prefix-arg)) + (not (string-match "poster" target-group)) + (not (string-match (regexp-quote target-group) + (message-fetch-field "Newsgroups")))) + (end-of-line) + (insert-string (concat "," target-group)))) + (end-of-line) ; ensure Followup: comes after Newsgroups: + ;; unless new followup would be identical to Newsgroups line + ;; make a new Followup-To line + (if (not (string-match (concat "^[ \t]*" + target-group + "[ \t]*$") + (message-fetch-field "Newsgroups"))) + (insert (concat "\nFollowup-To: " target-group))) + (setq message-xpost-old-target target-group)) + +;;;###autoload +(defun message-xpost-insert-note (target-group xpost in-old old-groups) + "Insert a in message body note about a set Followup or Crosspost. +If there have been previous notes, delete them. TARGET-GROUP specifies the +group to Followup-To. When XPOST is t, insert note about +crossposting. IN-OLD specifies whether TARGET-GROUP is a member of +OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have +been made to before the user asked for a Crosspost." + ;; start scanning body for previous uses + (message-goto-signature) + (let ((head (re-search-backward + (concat "^" mail-header-separator) + nil t))) ; just search in body + (message-goto-signature) + (while (re-search-backward + (concat "^" (regexp-quote message-xpost-note) ".*") + head t) + (message-delete-line)) + (message-goto-signature) + (while (re-search-backward + (concat "^" (regexp-quote message-fup2-note) ".*") + head t) + (message-delete-line)) + ;; insert new note + (if (message-goto-signature) + (re-search-backward message-signature-separator)) + (if (or in-old + (not xpost) + (string-match "^[ \t]*poster[ \t]*$" target-group)) + (insert (concat message-fup2-note target-group "\n")) + (insert (concat message-xpost-note target-group "\n"))))) + +;;;###autoload +(defun message-xpost-fup2 (target-group) + "Crossposts message and sets Followup-To to TARGET-GROUP. +With prefix-argument just set Follow-Up, don't cross-post." + (interactive + (list ; Completion based on Gnus + (completing-read "Followup To: " + (if (boundp 'gnus-newsrc-alist) + gnus-newsrc-alist) + nil nil '("poster" . 0) + (if (boundp 'gnus-group-history) + 'gnus-group-history)))) + (cond ((not (or (null target-group) ; new subject not empty + (zerop (string-width target-group)) + (string-match "^[ \t]*$" target-group))) + (save-excursion + (let* ((old-groups (message-fetch-field "Newsgroups")) + (in-old (string-match + (regexp-quote target-group) + (or old-groups "")))) + ;; check whether target exactly matches old Newsgroups + (cond ((not old-groups) + (error "No current newsgroup.")) + ((or (not in-old) + (not (string-match + (concat "^[ \t]*" + (regexp-quote target-group) + "[ \t]*$") + old-groups))) + ;; yes, Newsgroups line must change + (message-xpost-fup2-header target-group) + ;; insert note whether we do xpost or fup2 + (funcall message-xpost-note-function + target-group + (if (or (and message-xpost-default + (not current-prefix-arg)) + (and (not message-xpost-default) + current-prefix-arg)) t) + in-old old-groups)))))))) + +;;; Reduce To: to Cc: or Bcc: header + +;;;###autoload +(defun message-reduce-to-to-cc () + "Replace contents of To: header with contents of Cc: or Bcc: header." + (interactive) + (let ((cc-content (message-fetch-field "cc")) + (bcc nil)) + (if (and (not cc-content) + (setq cc-content (message-fetch-field "bcc"))) + (setq bcc t)) + (cond (cc-content + (save-excursion + (message-goto-to) + (message-delete-line) + (insert (concat "To: " cc-content "\n")) + (message-remove-header (if bcc + "bcc" + "cc"))))))) + +;;; End of functions adopted from `message-utils.el'. + (defun message-remove-header (header &optional is-regexp first reverse) "Remove HEADER in the narrowed buffer. If IS-REGEXP, HEADER is a regular expression. @@ -1824,6 +2186,18 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) (define-key message-mode-map "\C-c\C-f\C-i" 'message-insert-or-toggle-importance) (define-key message-mode-map "\C-c\C-f\C-a" 'message-gen-unsubscribed-mft) + + ;; modify headers (and insert notes in body) + (define-key message-mode-map "\C-c\C-fs" 'message-change-subject) + ;; + (define-key message-mode-map "\C-c\C-fx" 'message-xpost-fup2) + ;; prefix+message-xpost-fup2 = same w/o xpost + (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc) + (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header) + ;; mark inserted text + (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region) + (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file) + (define-key message-mode-map "\C-c\C-b" 'message-goto-body) (define-key message-mode-map "\C-c\C-i" 'message-goto-signature) (define-key message-mode-map "\C-c\C-fc" 'message-goto-mail-copies-to) @@ -1893,6 +2267,13 @@ Point is left at the beginning of the narrowed-to region." ,@(if (featurep 'xemacs) '(t) '(:help "Attach a file at point"))] "----" + ["Insert Region Marked" message-mark-inserted-region + ,@(if (featurep 'xemacs) '(t) + '(:help "Mark region with enclosing tags"))] + ["Insert File Marked" message-mark-insert-file + ,@(if (featurep 'xemacs) '(t) + '(:help "Insert file at point marked with enclosing tags"))] + "----" ["Send Message" message-send-and-exit ,@(if (featurep 'xemacs) '(t) '(:help "Send this message"))] @@ -1915,17 +2296,29 @@ Point is left at the beginning of the narrowed-to region." ["To" message-goto-to t] ["From" message-goto-from t] ["Subject" message-goto-subject t] + ["Change subject" message-change-subject t] ["Cc" message-goto-cc t] + ["Bcc" message-goto-bcc t] + ["Fcc" message-goto-fcc t] ["Reply-To" message-goto-reply-to t] - ["Mail-Reply-To" message-goto-mail-reply-to t] - ["Mail-Followup-To" message-goto-mail-followup-to t] - ["Mail-Copies-To" message-goto-mail-copies-to t] + "----" + ;; (typical) news stuff ["Summary" message-goto-summary t] ["Keywords" message-goto-keywords t] ["Newsgroups" message-goto-newsgroups t] ["Followup-To" message-goto-followup-to t] - ["Mail-Followup-To" message-goto-mail-followup-to t] + ;; ["Followup-To (with note in body)" message-xpost-fup2 t] + ["Crosspost / Followup-To" message-xpost-fup2 t] ["Distribution" message-goto-distribution t] + ["X-No-Archive:" message-add-archive-header t ] + "----" + ;; (typical) mailing-lists stuff + ["Send to list only" message-to-list-only t] + ["Mail-Followup-To" message-goto-mail-followup-to t] + ["Mail-Reply-To" message-goto-mail-reply-to t] + ["Mail-Copies-To" message-goto-mail-copies-to t] + ["Reduce To: to Cc:" message-reduce-to-to-cc t] + "----" ["Body" message-goto-body t] ["Signature" message-goto-signature t])) @@ -2007,8 +2400,12 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-o move to From (\"Originator\") C-c C-f C-f move to Followup-To C-c C-f C-m move to Mail-Followup-To - C-c C-f C-i cycle through Importance values C-c C-f c move to Mail-Copies-To + C-c C-f C-i cycle through Importance values + C-c C-f s change subject and append \"(was: )\" + C-c C-f x crossposting with FollowUp-To header and note in body + C-c C-f t replace To: header with contents of Cc: or Bcc: + C-c C-f a Insert X-No-Archive: header and a note in the body C-c C-t `message-insert-to' (add a To header to a news followup) C-c C-l `message-to-list-only' (removes all but list address in to/cc) C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) @@ -2023,6 +2420,8 @@ C-c C-z `message-kill-to-signature' (kill the text up to the signature). C-c C-r `message-caesar-buffer-body' (rot13 the message body). C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance). C-c M-n `message-insert-disposition-notification-to' (request receipt). +C-c M-m `message-mark-inserted-region' (mark region with enclosing tags). +C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags). M-RET `message-newline-and-reformat' (break the line and reformat)." (setq local-abbrev-table text-mode-abbrev-table) (set (make-local-variable 'message-reply-buffer) nil) @@ -4595,6 +4994,8 @@ give as trustworthy answer as possible." (message-make-fqdn))) (defun message-to-list-only () + "Send a message to the list only. +Remove all addresses but the list address from To and Cc headers." (interactive) (let ((listaddr (message-make-mft t))) (when listaddr @@ -5448,6 +5849,8 @@ responses here are directed to other addresses."))) (when gnus-list-identifiers (setq subject (message-strip-list-identifiers subject))) (setq subject (message-make-followup-subject subject)) + (when message-subject-trailing-was-query + (setq subject (message-strip-subject-trailing-was subject))) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) @@ -5532,6 +5935,8 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (if gnus-list-identifiers (setq subject (message-strip-list-identifiers subject))) (setq subject (message-make-followup-subject subject)) + (when message-subject-trailing-was-query + (setq subject (message-strip-subject-trailing-was subject))) (widen)) ;; Handle special values of Mail-Copies-To. diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 12baf9c..37afe96 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1301,10 +1301,7 @@ function is generally only called when Gnus is shutting down." (defun nnimap-expiry-target (arts group server) (unless (eq nnmail-expiry-target 'delete) (with-temp-buffer - (dolist (art (imap-search (concat "UID " - (imap-range-to-message-set - (gnus-uncompress-sequence arts))) - nnimap-server-buffer)) + (dolist (art arts) (nnimap-request-article art group server (current-buffer)) ;; hints for optimization in `nnimap-request-accept-article' (let ((nnimap-current-move-article art) @@ -1323,16 +1320,16 @@ function is generally only called when Gnus is shutting down." (let ((days (or (and nnmail-expiry-wait-function (funcall nnmail-expiry-wait-function group)) nnmail-expiry-wait))) - (cond (force - (nnimap-expiry-target artseq group server) - (when (imap-message-flags-add - (imap-range-to-message-set artseq) "\\Deleted") - (setq articles nil))) - ((eq days 'immediate) - (nnimap-expiry-target artseq group server) - (when (imap-message-flags-add - (imap-range-to-message-set artseq) "\\Deleted") - (setq articles nil))) + (cond ((or force (eq days 'immediate)) + (let ((oldarts (imap-search + (concat "UID " + (imap-range-to-message-set artseq))))) + (when oldarts + (nnimap-expiry-target oldarts group server)) + (when (imap-message-flags-add + (imap-range-to-message-set oldarts) "\\Deleted") + (setq articles (gnus-set-difference + articles oldarts))))) ((numberp days) (let ((oldarts (imap-search (format nnimap-expunge-search-string @@ -1340,14 +1337,12 @@ function is generally only called when Gnus is shutting down." (nnimap-date-days-ago days)))) (imap-fetch-data-hook '(nnimap-request-expire-articles-progress))) - (nnimap-expiry-target oldarts group server) - (and oldarts - (imap-message-flags-add - (imap-range-to-message-set - (gnus-compress-sequence oldarts)) - "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts)))))))))) + (when oldarts + (nnimap-expiry-target oldarts group server)) + (when (imap-message-flags-add + (imap-range-to-message-set oldarts) "\\Deleted") + (setq articles (gnus-set-difference + articles oldarts)))))))))) ;; return articles not deleted articles) -- 1.7.10.4