Readd missing el
[emacs.git] / .emacs.d / elisp / local / message-utils.el
1 ;;; -*- Mode: Emacs-Lisp -*-
2 ;;; message-utils.el -- Utils for message-mode
3 ;;; Revision: 0.8
4 ;;; $Id: message-utils.el,v 1.17 2000/06/19 10:29:25 schauer Exp $
5
6 ;; Author: Holger Schauer <Holger.Schauer@gmx.de>
7 ;; Keywords: utils message
8
9 ;;; This program is free software; you can redistribute it and/or modify
10 ;;; it under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 2 of the License, or
12 ;;; (at your option) any later version.
13 ;;;
14 ;;; This program is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with this program; if not, write to the Free Software
21 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
22
23 ;;; Summary:
24
25 ;; This file contains some small additions to message mode:
26 ;; * inserting files in a message and explicit marking it
27 ;; as something somebody else has created,
28 ;; * change Subject: header and add (was: <old subject>)
29 ;; * strip (was: <old subject>) from Subject: headers
30 ;; * add a X-No-Archieve: Yes header and a note in the body
31 ;; * a function for cross-post and followup-to messages
32 ;; * replace To: header with contents of Cc: or Bcc: header.
33 ;;
34 ;; Where to get this file:
35 ;; http://www.coling.uni-freiburg.de/~schauer/resources/emacs/message-utils.el.gz
36
37 ;;; Installation:
38
39 ;; .. is easy as in most cases. Add this file to where your
40 ;; Emacs can find it and add
41 ;; (autoload 'message-mark-inserted-region "message-utils" nil t)
42 ;; (autoload 'message-mark-insert-file "message-utils" nil t)
43 ;; (autoload 'message-strip-subject-was "message-utils" nil t)
44 ;; (autoload 'message-change-subject "message-utils" nil t)
45 ;; (autoload 'message-xpost-fup2 "message-utils" nil t)
46 ;; (autoload 'message-add-archive-header "message-utils" nil t)
47 ;; (autoload 'message-reduce-to-to-cc "message-utils" nil t)
48 ;; as well as some keybindings like
49 ;; (define-key message-mode-map '[(control c) m] 'message-mark-inserted-region)
50 ;; (define-key message-mode-map '[(control c) f] 'message-mark-insert-file)
51 ;; (define-key message-mode-map '[(control c) x] 'message-xpost-fup2)
52 ;; (define-key message-mode-map '[(control c) s] 'message-change-subject)
53 ;; (define-key message-mode-map '[(control c) a] 'message-add-archive-header)
54 ;; (define-key message-mode-map '[(control c) t] 'message-reduce-to-to-cc)
55 ;; (add-hook 'message-header-setup-hook 'message-strip-subject-was)
56 ;; to your .gnus or to your .emacs.
57 ;; You might also want to add something along the following lines:
58 ;; (defun message-utils-setup ()
59 ;; "Add menu-entries for message-utils."
60 ;; (easy-menu-add-item nil '("Message")
61 ;; ["Insert Region Marked" message-mark-inserted-region t] "Spellcheck")
62 ;; (easy-menu-add-item nil '("Message")
63 ;; ["Insert File Marked" message-mark-insert-file t] "Spellcheck")
64 ;; (easy-menu-add-item nil '("Field")
65 ;; ["Crosspost / Followup" message-xpost-fup2 t] "----")
66 ;; (easy-menu-add-item nil '("Field")
67 ;; ["New Subject" message-change-subject t] "----")
68 ;; (easy-menu-add-item nil '("Field")
69 ;; ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----")
70 ;; (easy-menu-add-item nil '("Field")
71 ;; [ "X-No-Archive:" message-add-archive-header t ]))
72 ;;
73 ;; You may then use it like this:
74 ;; (add-hook 'message-mode-hook 'message-utils-setup)
75
76
77
78 (require 'message)
79
80 ;;; **************
81 ;;; Preliminaries
82
83 ;; Incantations to make custom stuff work without customize, e.g. on
84 ;; XEmacs 19.14 or GNU Emacs 19.34. Stolen from htmlize.el by Hrovje Niksic.
85 (eval-and-compile
86 (condition-case ()
87 (require 'custom)
88 (error nil))
89 (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
90 nil ;; We've got what we needed
91 ;; We have the old custom-library, hack around it!
92 (defmacro defgroup (&rest args)
93 nil)
94 (defmacro defcustom (var value doc &rest args)
95 (` (defvar (, var) (, value) (, doc))))
96 (defmacro defface (face value doc &rest stuff)
97 `(make-face ,face))))
98
99 ;;; **************
100 ;;; Inserting and marking ...
101
102 ; We try to hook the vars into the message customize group
103
104 (defcustom message-begin-inserted-text-mark
105 "--8<------------------------schnipp------------------------->8---\n"
106 "How to mark the beginning of some inserted text."
107 :type 'string
108 :group 'message-various)
109
110 (defcustom message-end-inserted-text-mark
111 "--8<------------------------schnapp------------------------->8---\n"
112 "How to mark the end of some inserted text."
113 :type 'string
114 :group 'message-various)
115
116 ;;;###autoload
117 (defun message-mark-inserted-region (beg end)
118 "Mark some region in the current article with enclosing tags.
119 See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'."
120 (interactive "r")
121 (save-excursion
122 ; add to the end of the region first, otherwise end would be invalid
123 (goto-char end)
124 (insert message-end-inserted-text-mark)
125 (goto-char beg)
126 (insert message-begin-inserted-text-mark)))
127
128 ;;;###autoload
129 (defun message-mark-insert-file (file)
130 "Inserts FILE at point, marking it with enclosing tags.
131 See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'."
132 (interactive "fFile to insert: ")
133 ;; reverse insertion to get correct result.
134 (let ((p (point)))
135 (insert message-end-inserted-text-mark)
136 (goto-char p)
137 (insert-file-contents file)
138 (goto-char p)
139 (insert message-begin-inserted-text-mark)))
140
141 ;;; **************
142 ;;; Subject mangling
143
144 (defcustom message-subject-was-regexp
145 "[ \t]*\\((*[Ww][Aa][SsRr]:[ \t]*.*)\\)"
146 "*Regexp matching \"(was: <old subject>)\" in the subject line."
147 :group 'message-various
148 :type 'regexp)
149
150 ;;;###autoload
151 (defun message-strip-subject-was ()
152 "Remove trailing \"(Was: <old subject>)\" from subject lines."
153 (message-narrow-to-head)
154 (let* ((subject (message-fetch-field "Subject"))
155 (pos))
156 (cond (subject
157 (setq pos (or (string-match message-subject-was-regexp subject) 0))
158 (cond ((> pos 0)
159 (message-goto-subject)
160 (message-delete-line)
161 (insert (concat "Subject: "
162 (substring subject 0 pos) "\n")))))))
163 (widen))
164
165 ;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/
166 ;;;###autoload
167 (defun message-change-subject (new-subject)
168 "Ask for new Subject: header, append (was: <Old Subject>)."
169 (interactive
170 (list
171 (read-from-minibuffer "New subject: ")))
172 (cond ((and (not (or (null new-subject) ; new subject not empty
173 (zerop (string-width new-subject))
174 (string-match "^[ \t]*$" new-subject))))
175 (save-excursion
176 (let ((old-subject (message-fetch-field "Subject")))
177 (cond ((not (string-match
178 (concat "^[ \t]*"
179 (regexp-quote new-subject)
180 " \t]*$")
181 old-subject)) ; yes, it really is a new subject
182 ;; delete eventual Re: prefix
183 (setq old-subject
184 (message-strip-subject-re old-subject))
185 (message-goto-subject)
186 (message-delete-line)
187 (insert (concat "Subject: "
188 new-subject
189 " (was: "
190 old-subject ")\n")))))))))
191
192
193 ;;; **************
194 ;;; X-Archive-Header: No
195
196 (defcustom message-archive-header
197 "X-No-Archive: Yes\n"
198 "Header to insert when you don't want your article to be archived by deja.com."
199 :type 'string
200 :group 'message-various)
201
202 (defcustom message-archive-note
203 "X-No-Archive: Yes - save http://deja.com/"
204 "Note to insert why you wouldn't want this posting archived."
205 :type 'string
206 :group 'message-various)
207
208 (defun message-add-archive-header ()
209 "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
210 When called with a prefix argument, ask for a text to insert."
211 (interactive)
212 (if current-prefix-arg
213 (setq message-archive-note
214 (read-from-minibuffer "Reason for No-Archive: "
215 (cons message-archive-note 0))))
216 (save-excursion
217 (insert message-archive-note)
218 (newline)
219 (message-add-header message-archive-header)
220 (message-sort-headers)))
221
222 ;;; **************
223 ;;; Crossposts and Followups
224
225 ; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de>
226 ; new suggestions by R. Weikusat <rw at another.de>
227
228 (defvar message-xpost-old-target nil
229 "Old target for cross-posts or follow-ups.")
230 (make-variable-buffer-local 'message-xpost-old-target)
231
232 (defcustom message-xpost-default t
233 "When non-nil `mesage-xpost-fup2' will normally perform a crosspost.
234 If nil, `message-xpost-fup2' will only do a followup. Note that you
235 can explicitly override this setting by calling `message-xpost-fup2'
236 with a prefix."
237 :type 'boolean
238 :group 'message-various)
239
240 (defun message-xpost-fup2-header (target-group)
241 "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
242 With prefix-argument just set Follow-Up, don't cross-post."
243 (interactive
244 (list ; Completion based on Gnus
245 (completing-read "Follwup To: "
246 (if (boundp 'gnus-newsrc-alist)
247 gnus-newsrc-alist)
248 nil nil '("poster" . 0)
249 (if (boundp 'gnus-group-history)
250 'gnus-group-history))))
251 (message-remove-header "Follow[Uu]p-[Tt]o" t)
252 (message-goto-newsgroups)
253 (beginning-of-line)
254 ;; if we already did a crosspost before, kill old target
255 (if (and message-xpost-old-target
256 (re-search-forward
257 (regexp-quote (concat "," message-xpost-old-target))
258 nil t))
259 (replace-match ""))
260 ;; unless (followup is to poster or user explicitly asked not
261 ;; to cross-post, or target-group is already in Newsgroups)
262 ;; add target-group to Newsgroups line.
263 (cond ((and (or (and message-xpost-default (not current-prefix-arg)) ; def: xpost, req:no
264 (and (not message-xpost-default) current-prefix-arg)) ; def: no-xpost, req:yes
265 (not (string-match "poster" target-group))
266 (not (string-match (regexp-quote target-group)
267 (message-fetch-field "Newsgroups"))))
268 (end-of-line)
269 (insert-string (concat "," target-group))))
270 (end-of-line) ; ensure Followup: comes after Newsgroups:
271 ;; unless new followup would be identical to Newsgroups line
272 ;; make a new Followup-To line
273 (if (not (string-match (concat "^[ \t]*"
274 target-group
275 "[ \t]*$")
276 (message-fetch-field "Newsgroups")))
277 (insert (concat "\nFollowup-To: " target-group)))
278 (setq message-xpost-old-target target-group))
279
280
281 (defcustom message-xpost-note
282 "Crosspost & Followup-To: "
283 "Note to insert before signature to notify of xpost and follow-up."
284 :type 'string
285 :group 'message-various)
286
287 (defcustom message-fup2-note
288 "Followup-To: "
289 "Note to insert before signature to notify of follow-up only."
290 :type 'string
291 :group 'message-various)
292
293 (defun message-xpost-insert-note (target-group xpost in-old old-groups)
294 "Insert a in message body note about a set Followup or Crosspost.
295 If there have been previous notes, delete them. TARGET-GROUP specifies the
296 group to Followup-To. When XPOST is t, insert note about
297 crossposting. IN-OLD specifies whether TARGET-GROUP is a member of
298 OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have
299 been made to before the user asked for a Crosspost."
300 ;; start scanning body for previous uses
301 (message-goto-signature)
302 (let ((head (re-search-backward
303 (concat "^" mail-header-separator)
304 nil t))) ; just search in body
305 (message-goto-signature)
306 (while (re-search-backward
307 (concat "^" (regexp-quote message-xpost-note) ".*")
308 head t)
309 (message-delete-line))
310 (message-goto-signature)
311 (while (re-search-backward
312 (concat "^" (regexp-quote message-fup2-note) ".*")
313 head t)
314 (message-delete-line))
315 ;; insert new note
316 (message-goto-signature)
317 (previous-line 2)
318 (open-line 1)
319 (if (or in-old
320 (not xpost)
321 (string-match "^[ \t]*poster[ \t]*$" target-group))
322 (insert (concat message-fup2-note target-group "\n"))
323 (insert (concat message-xpost-note target-group "\n")))))
324
325 (defcustom message-xpost-note-function
326 'message-xpost-insert-note
327 "Function to use to insert note about Crosspost or Followup-To.
328 The function will be called with four arguments. The function should not
329 only insert a note, but also ensure old notes are deleted. See the
330 documentation for `message-xpost-insert-note'. "
331 :type 'function
332 :group 'message-various)
333
334 ;;;###autoload
335 (defun message-xpost-fup2 (target-group)
336 "Crossposts message and sets Followup-To to TARGET-GROUP.
337 With prefix-argument just set Follow-Up, don't cross-post."
338 (interactive
339 (list ; Completion based on Gnus
340 (completing-read "Follwup To: "
341 (if (boundp 'gnus-newsrc-alist)
342 gnus-newsrc-alist)
343 nil nil '("poster" . 0)
344 (if (boundp 'gnus-group-history)
345 'gnus-group-history))))
346 (cond ((not (or (null target-group) ; new subject not empty
347 (zerop (string-width target-group))
348 (string-match "^[ \t]*$" target-group)))
349 (save-excursion
350 (let* ((old-groups (message-fetch-field "Newsgroups"))
351 (in-old (string-match
352 (regexp-quote target-group) old-groups)))
353 ;; check whether target exactly matches old Newsgroups
354 (cond ((or (not in-old)
355 (not (string-match
356 (concat "^[ \t]*"
357 (regexp-quote target-group)
358 "[ \t]*$")
359 old-groups)))
360 ;; yes, Newsgroups line must change
361 (message-xpost-fup2-header target-group)
362 ;; insert note whether we do xpost or fup2
363 (funcall message-xpost-note-function
364 target-group
365 (if (or (and message-xpost-default (not current-prefix-arg))
366 (and (not message-xpost-default) current-prefix-arg))
367 t)
368 in-old old-groups))))))))
369
370
371 ;;; **************
372 ;;; Reduce To: to Cc: or Bcc: header
373
374 (defun message-reduce-to-to-cc ()
375 "Replace contents of To: header with contents of Cc: or Bcc: header."
376 (interactive)
377 (let ((cc-content (message-fetch-field "cc"))
378 (bcc nil))
379 (if (and (not cc-content)
380 (setq cc-content (message-fetch-field "bcc")))
381 (setq bcc t))
382 (cond (cc-content
383 (save-excursion
384 (message-goto-to)
385 (message-delete-line)
386 (insert (concat "To: " cc-content "\n"))
387 (message-remove-header (if bcc
388 "bcc"
389 "cc")))))))
390
391 ;;; provide ourself
392 (provide 'message-utils)
393