1 ;;; message-utils.el -- utils for message-mode
3 ;; Copyright (C) 2002 Free Software Foundation, Inc.
5 ;; Author: Holger Schauer <Holger.Schauer@gmx.de>
6 ;; Keywords: utils message
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 ;; This file contains some small additions to message mode:
28 ;; * inserting files in a message and explicit marking it
29 ;; as something somebody else has created,
30 ;; * change Subject: header and add (was: <old subject>)
31 ;; * strip (was: <old subject>) from Subject: headers
32 ;; * add a X-No-Archieve: Yes header and a note in the body
33 ;; * a function for cross-post and followup-to messages
34 ;; * replace To: header with contents of Cc: or Bcc: header.
37 ;; This file is adopt from the link below when the revision is 0.8.
38 ;; http://www.coling.uni-freiburg.de/~schauer/resources/emacs/message-utils.el.gz
40 ;;; Installation: (TODO: merge into message.el)
42 ;; .. is easy as in most cases. Add
43 ;; (autoload 'message-mark-inserted-region "message-utils" nil t)
44 ;; (autoload 'message-mark-insert-file "message-utils" nil t)
45 ;; (autoload 'message-strip-subject-was "message-utils" nil t)
46 ;; (autoload 'message-change-subject "message-utils" nil t)
47 ;; (autoload 'message-xpost-fup2 "message-utils" nil t)
48 ;; (autoload 'message-add-archive-header "message-utils" nil t)
49 ;; (autoload 'message-reduce-to-to-cc "message-utils" nil t)
50 ;; as well as some keybindings like
51 ;; (define-key message-mode-map '[(control c) m] 'message-mark-inserted-region)
52 ;; (define-key message-mode-map '[(control c) f] 'message-mark-insert-file)
53 ;; (define-key message-mode-map '[(control c) x] 'message-xpost-fup2)
54 ;; (define-key message-mode-map '[(control c) s] 'message-change-subject)
55 ;; (define-key message-mode-map '[(control c) a] 'message-add-archive-header)
56 ;; (define-key message-mode-map '[(control c) t] 'message-reduce-to-to-cc)
57 ;; (add-hook 'message-header-setup-hook 'message-strip-subject-was)
58 ;; to your .gnus or to your .emacs.
59 ;; You might also want to add something along the following lines:
60 ;; (defun message-utils-setup ()
61 ;; "Add menu-entries for message-utils."
62 ;; (easy-menu-add-item nil '("Message")
63 ;; ["Insert Region Marked" message-mark-inserted-region t] "Spellcheck")
64 ;; (easy-menu-add-item nil '("Message")
65 ;; ["Insert File Marked" message-mark-insert-file t] "Spellcheck")
66 ;; (easy-menu-add-item nil '("Field")
67 ;; ["Crosspost / Followup" message-xpost-fup2 t] "----")
68 ;; (easy-menu-add-item nil '("Field")
69 ;; ["New Subject" message-change-subject t] "----")
70 ;; (easy-menu-add-item nil '("Field")
71 ;; ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----")
72 ;; (easy-menu-add-item nil '("Field")
73 ;; [ "X-No-Archive:" message-add-archive-header t ]))
74 ;; (add-hook 'message-mode-hook 'message-utils-setup)
81 ;;; Inserting and marking ...
83 ; We try to hook the vars into the message customize group
85 (defcustom message-begin-inserted-text-mark
86 "--8<------------------------schnipp------------------------->8---\n"
87 "How to mark the beginning of some inserted text."
89 :group 'message-various)
91 (defcustom message-end-inserted-text-mark
92 "--8<------------------------schnapp------------------------->8---\n"
93 "How to mark the end of some inserted text."
95 :group 'message-various)
98 (defun message-mark-inserted-region (beg end)
99 "Mark some region in the current article with enclosing tags.
100 See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'."
103 ; add to the end of the region first, otherwise end would be invalid
105 (insert message-end-inserted-text-mark)
107 (insert message-begin-inserted-text-mark)))
110 (defun message-mark-insert-file (file)
111 "Inserts FILE at point, marking it with enclosing tags.
112 See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'."
113 (interactive "fFile to insert: ")
114 ;; reverse insertion to get correct result.
116 (insert message-end-inserted-text-mark)
118 (insert-file-contents file)
120 (insert message-begin-inserted-text-mark)))
125 (defcustom message-subject-was-regexp
126 "[ \t]*\\((*[Ww][Aa][SsRr]:[ \t]*.*)\\)"
127 "*Regexp matching \"(was: <old subject>)\" in the subject line."
128 :group 'message-various
132 (defun message-strip-subject-was ()
133 "Remove trailing \"(Was: <old subject>)\" from subject lines."
134 (message-narrow-to-head)
135 (let* ((subject (message-fetch-field "Subject"))
138 (setq pos (or (string-match message-subject-was-regexp subject) 0))
140 (message-goto-subject)
141 (message-delete-line)
142 (insert (concat "Subject: "
143 (substring subject 0 pos) "\n")))))))
146 ;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/
148 (defun message-change-subject (new-subject)
149 "Ask for new Subject: header, append (was: <Old Subject>)."
152 (read-from-minibuffer "New subject: ")))
153 (cond ((and (not (or (null new-subject) ; new subject not empty
154 (zerop (string-width new-subject))
155 (string-match "^[ \t]*$" new-subject))))
157 (let ((old-subject (message-fetch-field "Subject")))
158 (cond ((not (string-match
160 (regexp-quote new-subject)
162 old-subject)) ; yes, it really is a new subject
163 ;; delete eventual Re: prefix
165 (message-strip-subject-re old-subject))
166 (message-goto-subject)
167 (message-delete-line)
168 (insert (concat "Subject: "
171 old-subject ")\n")))))))))
175 ;;; X-Archive-Header: No
177 (defcustom message-archive-header
178 "X-No-Archive: Yes\n"
179 "Header to insert when you don't want your article to be archived by deja.com."
181 :group 'message-various)
183 (defcustom message-archive-note
184 "X-No-Archive: Yes - save http://deja.com/"
185 "Note to insert why you wouldn't want this posting archived."
187 :group 'message-various)
189 (defun message-add-archive-header ()
190 "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
191 When called with a prefix argument, ask for a text to insert."
193 (if current-prefix-arg
194 (setq message-archive-note
195 (read-from-minibuffer "Reason for No-Archive: "
196 (cons message-archive-note 0))))
198 (insert message-archive-note)
200 (message-add-header message-archive-header)
201 (message-sort-headers)))
204 ;;; Crossposts and Followups
206 ; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de>
207 ; new suggestions by R. Weikusat <rw at another.de>
209 (defvar message-xpost-old-target nil
210 "Old target for cross-posts or follow-ups.")
211 (make-variable-buffer-local 'message-xpost-old-target)
213 (defcustom message-xpost-default t
214 "When non-nil `mesage-xpost-fup2' will normally perform a crosspost.
215 If nil, `message-xpost-fup2' will only do a followup. Note that you
216 can explicitly override this setting by calling `message-xpost-fup2'
219 :group 'message-various)
221 (defun message-xpost-fup2-header (target-group)
222 "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
223 With prefix-argument just set Follow-Up, don't cross-post."
225 (list ; Completion based on Gnus
226 (completing-read "Follwup To: "
227 (if (boundp 'gnus-newsrc-alist)
229 nil nil '("poster" . 0)
230 (if (boundp 'gnus-group-history)
231 'gnus-group-history))))
232 (message-remove-header "Follow[Uu]p-[Tt]o" t)
233 (message-goto-newsgroups)
235 ;; if we already did a crosspost before, kill old target
236 (if (and message-xpost-old-target
238 (regexp-quote (concat "," message-xpost-old-target))
241 ;; unless (followup is to poster or user explicitly asked not
242 ;; to cross-post, or target-group is already in Newsgroups)
243 ;; add target-group to Newsgroups line.
244 (cond ((and (or (and message-xpost-default (not current-prefix-arg)) ; def: xpost, req:no
245 (and (not message-xpost-default) current-prefix-arg)) ; def: no-xpost, req:yes
246 (not (string-match "poster" target-group))
247 (not (string-match (regexp-quote target-group)
248 (message-fetch-field "Newsgroups"))))
250 (insert-string (concat "," target-group))))
251 (end-of-line) ; ensure Followup: comes after Newsgroups:
252 ;; unless new followup would be identical to Newsgroups line
253 ;; make a new Followup-To line
254 (if (not (string-match (concat "^[ \t]*"
257 (message-fetch-field "Newsgroups")))
258 (insert (concat "\nFollowup-To: " target-group)))
259 (setq message-xpost-old-target target-group))
262 (defcustom message-xpost-note
263 "Crosspost & Followup-To: "
264 "Note to insert before signature to notify of xpost and follow-up."
266 :group 'message-various)
268 (defcustom message-fup2-note
270 "Note to insert before signature to notify of follow-up only."
272 :group 'message-various)
274 (defun message-xpost-insert-note (target-group xpost in-old old-groups)
275 "Insert a in message body note about a set Followup or Crosspost.
276 If there have been previous notes, delete them. TARGET-GROUP specifies the
277 group to Followup-To. When XPOST is t, insert note about
278 crossposting. IN-OLD specifies whether TARGET-GROUP is a member of
279 OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have
280 been made to before the user asked for a Crosspost."
281 ;; start scanning body for previous uses
282 (message-goto-signature)
283 (let ((head (re-search-backward
284 (concat "^" mail-header-separator)
285 nil t))) ; just search in body
286 (message-goto-signature)
287 (while (re-search-backward
288 (concat "^" (regexp-quote message-xpost-note) ".*")
290 (message-delete-line))
291 (message-goto-signature)
292 (while (re-search-backward
293 (concat "^" (regexp-quote message-fup2-note) ".*")
295 (message-delete-line))
297 (message-goto-signature)
302 (string-match "^[ \t]*poster[ \t]*$" target-group))
303 (insert (concat message-fup2-note target-group "\n"))
304 (insert (concat message-xpost-note target-group "\n")))))
306 (defcustom message-xpost-note-function
307 'message-xpost-insert-note
308 "Function to use to insert note about Crosspost or Followup-To.
309 The function will be called with four arguments. The function should not
310 only insert a note, but also ensure old notes are deleted. See the
311 documentation for `message-xpost-insert-note'. "
313 :group 'message-various)
316 (defun message-xpost-fup2 (target-group)
317 "Crossposts message and sets Followup-To to TARGET-GROUP.
318 With prefix-argument just set Follow-Up, don't cross-post."
320 (list ; Completion based on Gnus
321 (completing-read "Follwup To: "
322 (if (boundp 'gnus-newsrc-alist)
324 nil nil '("poster" . 0)
325 (if (boundp 'gnus-group-history)
326 'gnus-group-history))))
327 (cond ((not (or (null target-group) ; new subject not empty
328 (zerop (string-width target-group))
329 (string-match "^[ \t]*$" target-group)))
331 (let* ((old-groups (message-fetch-field "Newsgroups"))
332 (in-old (string-match
333 (regexp-quote target-group) old-groups)))
334 ;; check whether target exactly matches old Newsgroups
335 (cond ((or (not in-old)
338 (regexp-quote target-group)
341 ;; yes, Newsgroups line must change
342 (message-xpost-fup2-header target-group)
343 ;; insert note whether we do xpost or fup2
344 (funcall message-xpost-note-function
346 (if (or (and message-xpost-default (not current-prefix-arg))
347 (and (not message-xpost-default) current-prefix-arg))
349 in-old old-groups))))))))
353 ;;; Reduce To: to Cc: or Bcc: header
355 (defun message-reduce-to-to-cc ()
356 "Replace contents of To: header with contents of Cc: or Bcc: header."
358 (let ((cc-content (message-fetch-field "cc"))
360 (if (and (not cc-content)
361 (setq cc-content (message-fetch-field "bcc")))
366 (message-delete-line)
367 (insert (concat "To: " cc-content "\n"))
368 (message-remove-header (if bcc
373 (provide 'message-utils)
375 ;;; message-utils.el ends here