comment
[bpt/emacs.git] / lisp / gnus / gnus-msg.el
1 ;;; gnus-msg.el --- mail and post interface for Gnus
2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
3 ;; Free Software Foundation, Inc.
4
5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Keywords: news
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Commentary:
27
28 ;;; Code:
29
30 (eval-when-compile (require 'cl))
31
32 (require 'gnus)
33 (require 'gnus-ems)
34 (require 'message)
35 (require 'gnus-art)
36
37 (defcustom gnus-post-method 'current
38 "*Preferred method for posting USENET news.
39
40 If this variable is `current', Gnus will use the \"current\" select
41 method when posting. If it is nil (which is the default), Gnus will
42 use the native select method when posting.
43
44 This method will not be used in mail groups and the like, only in
45 \"real\" newsgroups.
46
47 If not nil nor `native', the value must be a valid method as discussed
48 in the documentation of `gnus-select-method'. It can also be a list of
49 methods. If that is the case, the user will be queried for what select
50 method to use when posting."
51 :group 'gnus-group-foreign
52 :type `(choice (const nil)
53 (const current)
54 (const native)
55 (sexp :tag "Methods" ,gnus-select-method)))
56
57 (defvar gnus-outgoing-message-group nil
58 "*All outgoing messages will be put in this group.
59 If you want to store all your outgoing mail and articles in the group
60 \"nnml:archive\", you set this variable to that value. This variable
61 can also be a list of group names.
62
63 If you want to have greater control over what group to put each
64 message in, you can set this variable to a function that checks the
65 current newsgroup name and then returns a suitable group name (or list
66 of names).")
67
68 (defvar gnus-mailing-list-groups nil
69 "*Regexp matching groups that are really mailing lists.
70 This is useful when you're reading a mailing list that has been
71 gatewayed to a newsgroup, and you want to followup to an article in
72 the group.")
73
74 (defvar gnus-add-to-list nil
75 "*If non-nil, add a `to-list' parameter automatically.")
76
77 (defvar gnus-crosspost-complaint
78 "Hi,
79
80 You posted the article below with the following Newsgroups header:
81
82 Newsgroups: %s
83
84 The %s group, at least, was an inappropriate recipient
85 of this message. Please trim your Newsgroups header to exclude this
86 group before posting in the future.
87
88 Thank you.
89
90 "
91 "Format string to be inserted when complaining about crossposts.
92 The first %s will be replaced by the Newsgroups header;
93 the second with the current group name.")
94
95 (defvar gnus-message-setup-hook nil
96 "Hook run after setting up a message buffer.")
97
98 (defvar gnus-bug-create-help-buffer t
99 "*Should we create the *Gnus Help Bug* buffer?")
100
101 (defvar gnus-posting-styles nil
102 "*Alist of styles to use when posting.")
103
104 (defcustom gnus-group-posting-charset-alist
105 '(("^\\(no\\|fr\\|dk\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\|dk\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
106 ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
107 (message-this-is-mail nil nil)
108 (message-this-is-news nil t))
109 "Alist of regexps and permitted unencoded charsets for posting.
110 Each element of the alist has the form (TEST HEADER BODY-LIST), where
111 TEST is either a regular expression matching the newsgroup header or a
112 variable to query,
113 HEADER is the charset which may be left unencoded in the header (nil
114 means encode all charsets),
115 BODY-LIST is a list of charsets which may be encoded using 8bit
116 content-transfer encoding in the body, or one of the special values
117 nil (always encode using quoted-printable) or t (always use 8bit).
118
119 Note that any value other than nil for HEADER infringes some RFCs, so
120 use this option with care."
121 :type '(repeat (list :tag "Permitted unencoded charsets"
122 (choice :tag "Where"
123 (regexp :tag "Group")
124 (const :tag "Mail message" :value message-this-is-mail)
125 (const :tag "News article" :value message-this-is-news))
126 (choice :tag "Header"
127 (const :tag "None" nil)
128 (symbol :tag "Charset"))
129 (choice :tag "Body"
130 (const :tag "Any" :value t)
131 (const :tag "None" :value nil)
132 (repeat :tag "Charsets"
133 (symbol :tag "Charset")))))
134 :group 'gnus-charset)
135
136 ;;; Internal variables.
137
138 (defvar gnus-inhibit-posting-styles nil
139 "Inhibit the use of posting styles.")
140
141 (defvar gnus-message-buffer "*Mail Gnus*")
142 (defvar gnus-article-copy nil)
143 (defvar gnus-last-posting-server nil)
144 (defvar gnus-message-group-art nil)
145
146 (defconst gnus-bug-message
147 "Sending a bug report to the Gnus Towers.
148 ========================================
149
150 The buffer below is a mail buffer. When you press `C-c C-c', it will
151 be sent to the Gnus Bug Exterminators.
152
153 The thing near the bottom of the buffer is how the environment
154 settings will be included in the mail. Please do not delete that.
155 They will tell the Bug People what your environment is, so that it
156 will be easier to locate the bugs.
157
158 If you have found a bug that makes Emacs go \"beep\", set
159 debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
160 and include the backtrace in your bug report.
161
162 Please describe the bug in annoying, painstaking detail.
163
164 Thank you for your help in stamping out bugs.
165 ")
166
167 (eval-and-compile
168 (autoload 'gnus-uu-post-news "gnus-uu" nil t)
169 (autoload 'news-setup "rnewspost")
170 (autoload 'news-reply-mode "rnewspost")
171 (autoload 'rmail-dont-reply-to "mail-utils")
172 (autoload 'rmail-output "rmailout"))
173
174 \f
175 ;;;
176 ;;; Gnus Posting Functions
177 ;;;
178
179 (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map)
180 "p" gnus-summary-post-news
181 "f" gnus-summary-followup
182 "F" gnus-summary-followup-with-original
183 "c" gnus-summary-cancel-article
184 "s" gnus-summary-supersede-article
185 "r" gnus-summary-reply
186 "y" gnus-summary-yank-message
187 "R" gnus-summary-reply-with-original
188 "w" gnus-summary-wide-reply
189 "W" gnus-summary-wide-reply-with-original
190 "n" gnus-summary-followup-to-mail
191 "N" gnus-summary-followup-to-mail-with-original
192 "m" gnus-summary-mail-other-window
193 "u" gnus-uu-post-news
194 "\M-c" gnus-summary-mail-crosspost-complaint
195 "om" gnus-summary-mail-forward
196 "op" gnus-summary-post-forward
197 "Om" gnus-uu-digest-mail-forward
198 "Op" gnus-uu-digest-post-forward)
199
200 (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
201 "b" gnus-summary-resend-bounced-mail
202 ;; "c" gnus-summary-send-draft
203 "r" gnus-summary-resend-message)
204
205 ;;;###autoload
206 (define-mail-user-agent 'gnus-user-agent
207 'gnus-msg-mail 'message-send-and-exit
208 'message-kill-buffer 'message-send-hook)
209
210 ;;; Internal functions.
211
212 (defvar gnus-article-reply nil)
213 (defmacro gnus-setup-message (config &rest forms)
214 (let ((winconf (make-symbol "gnus-setup-message-winconf"))
215 (buffer (make-symbol "gnus-setup-message-buffer"))
216 (article (make-symbol "gnus-setup-message-article"))
217 (group (make-symbol "gnus-setup-message-group")))
218 `(let ((,winconf (current-window-configuration))
219 (,buffer (buffer-name (current-buffer)))
220 (,article (and gnus-article-reply (gnus-summary-article-number)))
221 (,group gnus-newsgroup-name)
222 (message-header-setup-hook
223 (copy-sequence message-header-setup-hook))
224 (mbl mml-buffer-list)
225 (message-mode-hook (copy-sequence message-mode-hook)))
226 (setq mml-buffer-list nil)
227 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
228 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
229 (add-hook 'message-mode-hook 'gnus-configure-posting-styles)
230 (unwind-protect
231 (progn
232 ,@forms)
233 (gnus-inews-add-send-actions ,winconf ,buffer ,article)
234 (setq gnus-message-buffer (current-buffer))
235 (set (make-local-variable 'gnus-message-group-art)
236 (cons ,group ,article))
237 (set (make-local-variable 'gnus-newsgroup-name) ,group)
238 (gnus-run-hooks 'gnus-message-setup-hook)
239 (if (eq major-mode 'message-mode)
240 ;; Make mml-buffer-list local.
241 ;; Restore global mml-buffer-list value as mbl.
242 ;; What a hack! -- Shenghuo
243 (let ((mml-buffer-list mml-buffer-list))
244 (setq mml-buffer-list mbl)
245 (make-local-variable 'mml-buffer-list)
246 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
247 (mml-destroy-buffers)
248 (setq mml-buffer-list mbl)))
249 (gnus-add-buffer)
250 (gnus-configure-windows ,config t)
251 (set-buffer-modified-p nil))))
252
253 (defun gnus-setup-posting-charset (group)
254 (let ((alist gnus-group-posting-charset-alist)
255 (group (or group ""))
256 elem)
257 (when group
258 (catch 'found
259 (while (setq elem (pop alist))
260 (when (or (and (stringp (car elem))
261 (string-match (car elem) group))
262 (and (gnus-functionp (car elem))
263 (funcall (car elem) group))
264 (and (symbolp (car elem))
265 (symbol-value (car elem))))
266 (throw 'found (cons (cadr elem) (caddr elem)))))))))
267
268 (defun gnus-inews-add-send-actions (winconf buffer article)
269 (make-local-hook 'message-sent-hook)
270 (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc
271 'gnus-inews-do-gcc) nil t)
272 (when gnus-agent
273 (make-local-hook 'message-header-hook)
274 (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))
275 (setq message-post-method
276 `(lambda (arg)
277 (gnus-post-method arg ,gnus-newsgroup-name)))
278 (setq message-newsreader (setq message-mailer (gnus-extended-version)))
279 (message-add-action
280 `(set-window-configuration ,winconf) 'exit 'postpone 'kill)
281 (message-add-action
282 `(when (gnus-buffer-exists-p ,buffer)
283 (save-excursion
284 (set-buffer ,buffer)
285 ,(when article
286 `(gnus-summary-mark-article-as-replied ,article))))
287 'send))
288
289 (put 'gnus-setup-message 'lisp-indent-function 1)
290 (put 'gnus-setup-message 'edebug-form-spec '(form body))
291
292 ;;; Post news commands of Gnus group mode and summary mode
293
294 (defun gnus-group-mail (&optional arg)
295 "Start composing a mail.
296 If ARG, use the group under the point to find a posting style.
297 If ARG is 1, prompt for a group name to find the posting style."
298 (interactive "P")
299 ;; We can't `let' gnus-newsgroup-name here, since that leads
300 ;; to local variables leaking.
301 (let ((group gnus-newsgroup-name)
302 (buffer (current-buffer)))
303 (unwind-protect
304 (progn
305 (setq gnus-newsgroup-name
306 (if arg
307 (if (= 1 (prefix-numeric-value arg))
308 (completing-read "Use posting style of group: "
309 gnus-active-hashtb nil
310 (gnus-read-active-file-p))
311 (gnus-group-group-name))
312 ""))
313 (gnus-setup-message 'message (message-mail)))
314 (save-excursion
315 (set-buffer buffer)
316 (setq gnus-newsgroup-name group)))))
317
318 (defun gnus-group-post-news (&optional arg)
319 "Start composing a news message.
320 If ARG, post to the group under point.
321 If ARG is 1, prompt for a group name."
322 (interactive "P")
323 ;; Bind this variable here to make message mode hooks work ok.
324 (let ((gnus-newsgroup-name
325 (if arg
326 (if (= 1 (prefix-numeric-value arg))
327 (completing-read "Newsgroup: " gnus-active-hashtb nil
328 (gnus-read-active-file-p))
329 (gnus-group-group-name))
330 "")))
331 (gnus-post-news 'post gnus-newsgroup-name)))
332
333 (defun gnus-summary-post-news ()
334 "Start composing a news message."
335 (interactive)
336 (gnus-post-news 'post gnus-newsgroup-name))
337
338 (defun gnus-summary-followup (yank &optional force-news)
339 "Compose a followup to an article.
340 If prefix argument YANK is non-nil, original article is yanked automatically."
341 (interactive
342 (list (and current-prefix-arg
343 (gnus-summary-work-articles 1))))
344 (when yank
345 (gnus-summary-goto-subject (car yank)))
346 (save-window-excursion
347 (gnus-summary-select-article))
348 (let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
349 (gnus-newsgroup-name gnus-newsgroup-name))
350 ;; Send a followup.
351 (gnus-post-news nil gnus-newsgroup-name
352 headers gnus-article-buffer
353 yank nil force-news)))
354
355 (defun gnus-summary-followup-with-original (n &optional force-news)
356 "Compose a followup to an article and include the original article."
357 (interactive "P")
358 (gnus-summary-followup (gnus-summary-work-articles n) force-news))
359
360 (defun gnus-summary-followup-to-mail (&optional arg)
361 "Followup to the current mail message via news."
362 (interactive
363 (list (and current-prefix-arg
364 (gnus-summary-work-articles 1))))
365 (gnus-summary-followup arg t))
366
367 (defun gnus-summary-followup-to-mail-with-original (&optional arg)
368 "Followup to the current mail message via news."
369 (interactive "P")
370 (gnus-summary-followup (gnus-summary-work-articles arg) t))
371
372 (defun gnus-inews-yank-articles (articles)
373 (let (beg article)
374 (message-goto-body)
375 (while (setq article (pop articles))
376 (save-window-excursion
377 (set-buffer gnus-summary-buffer)
378 (gnus-summary-select-article nil nil nil article)
379 (gnus-summary-remove-process-mark article))
380 (gnus-copy-article-buffer)
381 (let ((message-reply-buffer gnus-article-copy)
382 (message-reply-headers gnus-current-headers))
383 (message-yank-original)
384 (setq beg (or beg (mark t))))
385 (when articles
386 (insert "\n")))
387 (push-mark)
388 (goto-char beg)))
389
390 (defun gnus-summary-cancel-article (&optional n symp)
391 "Cancel an article you posted.
392 Uses the process-prefix convention. If given the symbolic
393 prefix `a', cancel using the standard posting method; if not
394 post using the current select method."
395 (interactive (gnus-interactive "P\ny"))
396 (let ((articles (gnus-summary-work-articles n))
397 (message-post-method
398 `(lambda (arg)
399 (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name)))
400 article)
401 (while (setq article (pop articles))
402 (when (gnus-summary-select-article t nil nil article)
403 (when (gnus-eval-in-buffer-window gnus-original-article-buffer
404 (message-cancel-news))
405 (gnus-summary-mark-as-read article gnus-canceled-mark)
406 (gnus-cache-remove-article 1))
407 (gnus-article-hide-headers-if-wanted))
408 (gnus-summary-remove-process-mark article))))
409
410 (defun gnus-summary-supersede-article ()
411 "Compose an article that will supersede a previous article.
412 This is done simply by taking the old article and adding a Supersedes
413 header line with the old Message-ID."
414 (interactive)
415 (let ((article (gnus-summary-article-number)))
416 (gnus-setup-message 'reply-yank
417 (gnus-summary-select-article t)
418 (set-buffer gnus-original-article-buffer)
419 (message-supersede)
420 (push
421 `((lambda ()
422 (when (gnus-buffer-exists-p ,gnus-summary-buffer)
423 (save-excursion
424 (set-buffer ,gnus-summary-buffer)
425 (gnus-cache-possibly-remove-article ,article nil nil nil t)
426 (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
427 message-send-actions))))
428 \f
429 ;;;###autoload
430 (defun gnus-msg-mail (&rest args)
431 "Start editing a mail message to be sent.
432 Like `message-mail', but with Gnus paraphernalia, particularly the
433 the Gcc: header for archiving purposes."
434 (interactive)
435 (gnus-setup-message 'message
436 (apply 'message-mail args)))
437 \f
438
439 (defun gnus-copy-article-buffer (&optional article-buffer)
440 ;; make a copy of the article buffer with all text properties removed
441 ;; this copy is in the buffer gnus-article-copy.
442 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
443 ;; this buffer should be passed to all mail/news reply/post routines.
444 (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
445 (save-excursion
446 (set-buffer gnus-article-copy)
447 (mm-enable-multibyte))
448 (let ((article-buffer (or article-buffer gnus-article-buffer))
449 end beg)
450 (if (not (and (get-buffer article-buffer)
451 (gnus-buffer-exists-p article-buffer)))
452 (error "Can't find any article buffer")
453 (save-excursion
454 (set-buffer article-buffer)
455 (save-restriction
456 ;; Copy over the (displayed) article buffer, delete
457 ;; hidden text and remove text properties.
458 (widen)
459 (copy-to-buffer gnus-article-copy (point-min) (point-max))
460 (set-buffer gnus-article-copy)
461 (gnus-article-delete-text-of-type 'annotation)
462 (gnus-remove-text-with-property 'gnus-prev)
463 (gnus-remove-text-with-property 'gnus-next)
464 (insert
465 (prog1
466 (buffer-substring-no-properties (point-min) (point-max))
467 (erase-buffer)))
468 ;; Find the original headers.
469 (set-buffer gnus-original-article-buffer)
470 (goto-char (point-min))
471 (while (looking-at message-unix-mail-delimiter)
472 (forward-line 1))
473 (setq beg (point))
474 (setq end (or (search-forward "\n\n" nil t) (point)))
475 ;; Delete the headers from the displayed articles.
476 (set-buffer gnus-article-copy)
477 (delete-region (goto-char (point-min))
478 (or (search-forward "\n\n" nil t) (point-max)))
479 ;; Insert the original article headers.
480 (insert-buffer-substring gnus-original-article-buffer beg end)
481 (article-decode-encoded-words)))
482 gnus-article-copy)))
483
484 (defun gnus-post-news (post &optional group header article-buffer yank subject
485 force-news)
486 (when article-buffer
487 (gnus-copy-article-buffer))
488 (let ((gnus-article-reply article-buffer)
489 (add-to-list gnus-add-to-list))
490 (gnus-setup-message (cond (yank 'reply-yank)
491 (article-buffer 'reply)
492 (t 'message))
493 (let* ((group (or group gnus-newsgroup-name))
494 (charset (gnus-group-name-charset nil group))
495 (pgroup group)
496 to-address to-group mailing-list to-list
497 newsgroup-p)
498 (when group
499 (setq to-address (gnus-group-find-parameter group 'to-address)
500 to-group (gnus-group-find-parameter group 'to-group)
501 to-list (gnus-group-find-parameter group 'to-list)
502 newsgroup-p (gnus-group-find-parameter group 'newsgroup)
503 mailing-list (when gnus-mailing-list-groups
504 (string-match gnus-mailing-list-groups group))
505 group (gnus-group-name-decode (gnus-group-real-name group)
506 charset)))
507 (if (or (and to-group
508 (gnus-news-group-p to-group))
509 newsgroup-p
510 force-news
511 (and (gnus-news-group-p
512 (or pgroup gnus-newsgroup-name)
513 (if header (mail-header-number header)
514 gnus-current-article))
515 (not mailing-list)
516 (not to-list)
517 (not to-address)))
518 ;; This is news.
519 (if post
520 (message-news (or to-group group))
521 (set-buffer gnus-article-copy)
522 (gnus-msg-treat-broken-reply-to)
523 (message-followup (if (or newsgroup-p force-news) nil to-group)))
524 ;; The is mail.
525 (if post
526 (progn
527 (message-mail (or to-address to-list))
528 ;; Arrange for mail groups that have no `to-address' to
529 ;; get that when the user sends off the mail.
530 (when (and (not to-list)
531 (not to-address)
532 add-to-list)
533 (push (list 'gnus-inews-add-to-address pgroup)
534 message-send-actions)))
535 (set-buffer gnus-article-copy)
536 (gnus-msg-treat-broken-reply-to)
537 (message-wide-reply to-address)))
538 (when yank
539 (gnus-inews-yank-articles yank))))))
540
541 (defun gnus-msg-treat-broken-reply-to ()
542 "Remove the Reply-to header iff broken-reply-to."
543 (when (gnus-group-find-parameter
544 gnus-newsgroup-name 'broken-reply-to)
545 (save-restriction
546 (message-narrow-to-head)
547 (message-remove-header "reply-to"))))
548
549 (defun gnus-post-method (arg group &optional silent)
550 "Return the posting method based on GROUP and ARG.
551 If SILENT, don't prompt the user."
552 (let ((group-method (gnus-find-method-for-group group)))
553 (cond
554 ;; If the group-method is nil (which shouldn't happen) we use
555 ;; the default method.
556 ((null group-method)
557 (or (and (null (eq gnus-post-method 'active)) gnus-post-method)
558 gnus-select-method message-post-method))
559 ;; We want the inverse of the default
560 ((and arg (not (eq arg 0)))
561 (if (eq gnus-post-method 'active)
562 gnus-select-method
563 group-method))
564 ;; We query the user for a post method.
565 ((or arg
566 (and gnus-post-method
567 (not (eq gnus-post-method 'current))
568 (listp (car gnus-post-method))))
569 (let* ((methods
570 ;; Collect all methods we know about.
571 (append
572 (when (and gnus-post-method
573 (not (eq gnus-post-method 'current)))
574 (if (listp (car gnus-post-method))
575 gnus-post-method
576 (list gnus-post-method)))
577 gnus-secondary-select-methods
578 (mapcar 'cdr gnus-server-alist)
579 (mapcar 'car gnus-opened-servers)
580 (list gnus-select-method)
581 (list group-method)))
582 method-alist post-methods method)
583 ;; Weed out all mail methods.
584 (while methods
585 (setq method (gnus-server-get-method "" (pop methods)))
586 (when (and (or (gnus-method-option-p method 'post)
587 (gnus-method-option-p method 'post-mail))
588 (not (member method post-methods)))
589 (push method post-methods)))
590 ;; Create a name-method alist.
591 (setq method-alist
592 (mapcar
593 (lambda (m)
594 (list (concat (cadr m) " (" (symbol-name (car m)) ")") m))
595 post-methods))
596 ;; Query the user.
597 (cadr
598 (assoc
599 (setq gnus-last-posting-server
600 (if (and silent
601 gnus-last-posting-server)
602 ;; Just use the last value.
603 gnus-last-posting-server
604 (completing-read
605 "Posting method: " method-alist nil t
606 (cons (or gnus-last-posting-server "") 0))))
607 method-alist))))
608 ;; Override normal method.
609 ((and (eq gnus-post-method 'current)
610 (not (eq (car group-method) 'nndraft))
611 (gnus-get-function group-method 'request-post t)
612 (not arg))
613 group-method)
614 ((and gnus-post-method
615 (not (eq gnus-post-method 'current)))
616 gnus-post-method)
617 ;; Use the normal select method.
618 (t gnus-select-method))))
619
620 \f
621
622 ;; Dummies to avoid byte-compile warning.
623 (eval-when-compile
624 (defvar nnspool-rejected-article-hook)
625 (defvar xemacs-codename))
626
627 (defun gnus-extended-version ()
628 "Stringified Gnus version and Emacs version."
629 (interactive)
630 (concat
631 "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t)
632 " (" gnus-version ")"
633 " "
634 (cond
635 ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
636 (concat "Emacs/" (match-string 1 emacs-version)))
637 ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
638 emacs-version)
639 (concat (match-string 1 emacs-version)
640 (format "/%d.%d" emacs-major-version emacs-minor-version)
641 (if (match-beginning 3)
642 (match-string 3 emacs-version)
643 "")
644 (if (boundp 'xemacs-codename)
645 (concat " (" xemacs-codename ")")
646 "")))
647 (t emacs-version))))
648
649 \f
650 ;;;
651 ;;; Gnus Mail Functions
652 ;;;
653
654 ;;; Mail reply commands of Gnus summary mode
655
656 (defun gnus-summary-reply (&optional yank wide)
657 "Start composing a reply mail to the current message.
658 If prefix argument YANK is non-nil, the original article is yanked
659 automatically."
660 (interactive
661 (list (and current-prefix-arg
662 (gnus-summary-work-articles 1))))
663 ;; Stripping headers should be specified with mail-yank-ignored-headers.
664 (when yank
665 (gnus-summary-goto-subject (car yank)))
666 (let ((gnus-article-reply t))
667 (gnus-setup-message (if yank 'reply-yank 'reply)
668 (gnus-summary-select-article)
669 (set-buffer (gnus-copy-article-buffer))
670 (gnus-msg-treat-broken-reply-to)
671 (save-restriction
672 (message-narrow-to-head)
673 (goto-char (point-max)))
674 (mml-quote-region (point) (point-max))
675 (message-reply nil wide)
676 (when yank
677 (gnus-inews-yank-articles yank)))))
678
679 (defun gnus-summary-reply-with-original (n &optional wide)
680 "Start composing a reply mail to the current message.
681 The original article will be yanked."
682 (interactive "P")
683 (gnus-summary-reply (gnus-summary-work-articles n) wide))
684
685 (defun gnus-summary-wide-reply (&optional yank)
686 "Start composing a wide reply mail to the current message.
687 If prefix argument YANK is non-nil, the original article is yanked
688 automatically."
689 (interactive
690 (list (and current-prefix-arg
691 (gnus-summary-work-articles 1))))
692 (gnus-summary-reply yank t))
693
694 (defun gnus-summary-wide-reply-with-original (n)
695 "Start composing a wide reply mail to the current message.
696 The original article will be yanked."
697 (interactive "P")
698 (gnus-summary-reply-with-original n t))
699
700 (defun gnus-summary-mail-forward (&optional arg post)
701 "Forward the current message to another user.
702 If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
703 if ARG is 1, decode the message and forward directly inline;
704 if ARG is 2, foward message as an rfc822 MIME section;
705 if ARG is 3, decode message and forward as an rfc822 MIME section;
706 if ARG is 4, foward message directly inline;
707 otherwise, use flipped `message-forward-as-mime'.
708 If POST, post instead of mail."
709 (interactive "P")
710 (let ((message-forward-as-mime message-forward-as-mime)
711 (message-forward-show-mml message-forward-show-mml))
712 (cond
713 ((null arg))
714 ((eq arg 1) (setq message-forward-as-mime nil
715 message-forward-show-mml t))
716 ((eq arg 2) (setq message-forward-as-mime t
717 message-forward-show-mml nil))
718 ((eq arg 3) (setq message-forward-as-mime t
719 message-forward-show-mml t))
720 ((eq arg 4) (setq message-forward-as-mime nil
721 message-forward-show-mml nil))
722 (t (setq message-forward-as-mime (not message-forward-as-mime))))
723 (gnus-setup-message 'forward
724 (gnus-summary-select-article)
725 (let ((mail-parse-charset gnus-newsgroup-charset)
726 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
727 text)
728 (save-excursion
729 (set-buffer gnus-original-article-buffer)
730 (setq text (buffer-string)))
731 (set-buffer
732 (gnus-get-buffer-create
733 (generate-new-buffer-name " *Gnus forward*")))
734 (erase-buffer)
735 (unless message-forward-show-mml
736 (mm-disable-multibyte))
737 (insert text)
738 (goto-char (point-min))
739 (when (looking-at "From ")
740 (replace-match "X-From-Line: ") )
741 (when message-forward-show-mml
742 (mime-to-mml))
743 (message-forward post)))))
744
745 (defun gnus-summary-resend-message (address n)
746 "Resend the current article to ADDRESS."
747 (interactive "sResend message(s) to: \nP")
748 (let ((articles (gnus-summary-work-articles n))
749 article)
750 (while (setq article (pop articles))
751 (gnus-summary-select-article nil nil nil article)
752 (save-excursion
753 (set-buffer gnus-original-article-buffer)
754 (message-resend address)))))
755
756 (defun gnus-summary-post-forward (&optional arg)
757 "Forward the current article to a newsgroup.
758 See `gnus-summary-mail-forward' for ARG."
759 (interactive "P")
760 (gnus-summary-mail-forward arg t))
761
762 (defvar gnus-nastygram-message
763 "The following article was inappropriately posted to %s.\n\n"
764 "Format string to insert in nastygrams.
765 The current group name will be inserted at \"%s\".")
766
767 (defun gnus-summary-mail-nastygram (n)
768 "Send a nastygram to the author of the current article."
769 (interactive "P")
770 (when (or gnus-expert-user
771 (gnus-y-or-n-p
772 "Really send a nastygram to the author of the current article? "))
773 (let ((group gnus-newsgroup-name))
774 (gnus-summary-reply-with-original n)
775 (set-buffer gnus-message-buffer)
776 (message-goto-body)
777 (insert (format gnus-nastygram-message group))
778 (message-send-and-exit))))
779
780 (defun gnus-summary-mail-crosspost-complaint (n)
781 "Send a complaint about crossposting to the current article(s)."
782 (interactive "P")
783 (let ((articles (gnus-summary-work-articles n))
784 article)
785 (while (setq article (pop articles))
786 (set-buffer gnus-summary-buffer)
787 (gnus-summary-goto-subject article)
788 (let ((group (gnus-group-real-name gnus-newsgroup-name))
789 newsgroups followup-to)
790 (gnus-summary-select-article)
791 (set-buffer gnus-original-article-buffer)
792 (if (and (<= (length (message-tokenize-header
793 (setq newsgroups
794 (mail-fetch-field "newsgroups"))
795 ", "))
796 1)
797 (or (not (setq followup-to (mail-fetch-field "followup-to")))
798 (not (member group (message-tokenize-header
799 followup-to ", ")))))
800 (if followup-to
801 (gnus-message 1 "Followup-to restricted")
802 (gnus-message 1 "Not a crossposted article"))
803 (set-buffer gnus-summary-buffer)
804 (gnus-summary-reply-with-original 1)
805 (set-buffer gnus-message-buffer)
806 (message-goto-body)
807 (insert (format gnus-crosspost-complaint newsgroups group))
808 (message-goto-subject)
809 (re-search-forward " *$")
810 (replace-match " (crosspost notification)" t t)
811 (gnus-deactivate-mark)
812 (when (gnus-y-or-n-p "Send this complaint? ")
813 (message-send-and-exit)))))))
814
815 (defun gnus-summary-mail-other-window ()
816 "Compose mail in other window."
817 (interactive)
818 (gnus-setup-message 'message
819 (message-mail)))
820
821 (defun gnus-mail-parse-comma-list ()
822 (let (accumulated
823 beg)
824 (skip-chars-forward " ")
825 (while (not (eobp))
826 (setq beg (point))
827 (skip-chars-forward "^,")
828 (while (zerop
829 (save-excursion
830 (save-restriction
831 (let ((i 0))
832 (narrow-to-region beg (point))
833 (goto-char beg)
834 (logand (progn
835 (while (search-forward "\"" nil t)
836 (incf i))
837 (if (zerop i) 2 i))
838 2)))))
839 (skip-chars-forward ",")
840 (skip-chars-forward "^,"))
841 (skip-chars-backward " ")
842 (push (buffer-substring beg (point))
843 accumulated)
844 (skip-chars-forward "^,")
845 (skip-chars-forward ", "))
846 accumulated))
847
848 (defun gnus-inews-add-to-address (group)
849 (let ((to-address (mail-fetch-field "to")))
850 (when (and to-address
851 (gnus-alive-p))
852 ;; This mail group doesn't have a `to-list', so we add one
853 ;; here. Magic!
854 (when (gnus-y-or-n-p
855 (format "Do you want to add this as `to-list': %s " to-address))
856 (gnus-group-add-parameter group (cons 'to-list to-address))))))
857
858 (defun gnus-put-message ()
859 "Put the current message in some group and return to Gnus."
860 (interactive)
861 (let ((reply gnus-article-reply)
862 (winconf gnus-prev-winconf)
863 (group gnus-newsgroup-name))
864
865 (or (and group (not (gnus-group-read-only-p group)))
866 (setq group (read-string "Put in group: " nil
867 (gnus-writable-groups))))
868 (when (gnus-gethash group gnus-newsrc-hashtb)
869 (error "No such group: %s" group))
870
871 (save-excursion
872 (save-restriction
873 (widen)
874 (message-narrow-to-headers)
875 (let (gnus-deletable-headers)
876 (if (message-news-p)
877 (message-generate-headers message-required-news-headers)
878 (message-generate-headers message-required-mail-headers)))
879 (goto-char (point-max))
880 (insert "Gcc: " group "\n")
881 (widen)))
882
883 (gnus-inews-do-gcc)
884
885 (when (get-buffer gnus-group-buffer)
886 (when (gnus-buffer-exists-p (car-safe reply))
887 (set-buffer (car reply))
888 (and (cdr reply)
889 (gnus-summary-mark-article-as-replied
890 (cdr reply))))
891 (when winconf
892 (set-window-configuration winconf)))))
893
894 (defun gnus-article-mail (yank)
895 "Send a reply to the address near point.
896 If YANK is non-nil, include the original article."
897 (interactive "P")
898 (let ((address
899 (buffer-substring
900 (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
901 (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
902 (when address
903 (message-reply address)
904 (when yank
905 (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
906
907 (defvar nntp-server-type)
908 (defun gnus-bug ()
909 "Send a bug report to the Gnus maintainers."
910 (interactive)
911 (unless (gnus-alive-p)
912 (error "Gnus has been shut down"))
913 (gnus-setup-message 'bug
914 (delete-other-windows)
915 (when gnus-bug-create-help-buffer
916 (switch-to-buffer "*Gnus Help Bug*")
917 (erase-buffer)
918 (insert gnus-bug-message)
919 (goto-char (point-min)))
920 (message-pop-to-buffer "*Gnus Bug*")
921 (message-setup `((To . ,gnus-maintainer) (Subject . "")))
922 (when gnus-bug-create-help-buffer
923 (push `(gnus-bug-kill-buffer) message-send-actions))
924 (goto-char (point-min))
925 (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
926 (forward-line 1)
927 (insert (gnus-version) "\n"
928 (emacs-version) "\n")
929 (when (and (boundp 'nntp-server-type)
930 (stringp nntp-server-type))
931 (insert nntp-server-type))
932 (insert "\n\n\n\n\n")
933 (let (text)
934 (save-excursion
935 (set-buffer (gnus-get-buffer-create " *gnus environment info*"))
936 (gnus-debug)
937 (setq text (buffer-string)))
938 (insert "<#part type=application/x-emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>"))
939 (goto-char (point-min))
940 (search-forward "Subject: " nil t)
941 (message "")))
942
943 (defun gnus-bug-kill-buffer ()
944 (when (get-buffer "*Gnus Help Bug*")
945 (kill-buffer "*Gnus Help Bug*")))
946
947 (defun gnus-summary-yank-message (buffer n)
948 "Yank the current article into a composed message."
949 (interactive
950 (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
951 current-prefix-arg))
952 (gnus-summary-iterate n
953 (let ((gnus-display-mime-function nil)
954 (gnus-inhibit-treatment t))
955 (gnus-summary-select-article))
956 (save-excursion
957 (set-buffer buffer)
958 (message-yank-buffer gnus-article-buffer))))
959
960 (defun gnus-debug ()
961 "Attempts to go through the Gnus source file and report what variables have been changed.
962 The source file has to be in the Emacs load path."
963 (interactive)
964 (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el"
965 "gnus-art.el" "gnus-start.el" "gnus-async.el"
966 "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el"
967 "nnmail.el" "message.el"))
968 (point (point))
969 file expr olist sym)
970 (gnus-message 4 "Please wait while we snoop your variables...")
971 (sit-for 0)
972 ;; Go through all the files looking for non-default values for variables.
973 (save-excursion
974 (set-buffer (gnus-get-buffer-create " *gnus bug info*"))
975 (while files
976 (erase-buffer)
977 (when (and (setq file (locate-library (pop files)))
978 (file-exists-p file))
979 (insert-file-contents file)
980 (goto-char (point-min))
981 (if (not (re-search-forward "^;;* *Internal variables" nil t))
982 (gnus-message 4 "Malformed sources in file %s" file)
983 (narrow-to-region (point-min) (point))
984 (goto-char (point-min))
985 (while (setq expr (ignore-errors (read (current-buffer))))
986 (ignore-errors
987 (and (or (eq (car expr) 'defvar)
988 (eq (car expr) 'defcustom))
989 (stringp (nth 3 expr))
990 (or (not (boundp (nth 1 expr)))
991 (not (equal (eval (nth 2 expr))
992 (symbol-value (nth 1 expr)))))
993 (push (nth 1 expr) olist)))))))
994 (kill-buffer (current-buffer)))
995 (when (setq olist (nreverse olist))
996 (insert "------------------ Environment follows ------------------\n\n"))
997 (while olist
998 (if (boundp (car olist))
999 (condition-case ()
1000 (pp `(setq ,(car olist)
1001 ,(if (or (consp (setq sym (symbol-value (car olist))))
1002 (and (symbolp sym)
1003 (not (or (eq sym nil)
1004 (eq sym t)))))
1005 (list 'quote (symbol-value (car olist)))
1006 (symbol-value (car olist))))
1007 (current-buffer))
1008 (error
1009 (format "(setq %s 'whatever)\n" (car olist))))
1010 (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
1011 (setq olist (cdr olist)))
1012 (insert "\n\n")
1013 ;; Remove any control chars - they seem to cause trouble for some
1014 ;; mailers. (Byte-compiled output from the stuff above.)
1015 (goto-char point)
1016 (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t)
1017 (replace-match (format "\\%03o" (string-to-char (match-string 0)))
1018 t t))))
1019
1020 ;;; Treatment of rejected articles.
1021 ;;; Bounced mail.
1022
1023 (defun gnus-summary-resend-bounced-mail (&optional fetch)
1024 "Re-mail the current message.
1025 This only makes sense if the current message is a bounce message than
1026 contains some mail you have written which has been bounced back to
1027 you.
1028 If FETCH, try to fetch the article that this is a reply to, if indeed
1029 this is a reply."
1030 (interactive "P")
1031 (gnus-summary-select-article t)
1032 (set-buffer gnus-original-article-buffer)
1033 (gnus-setup-message 'compose-bounce
1034 (let* ((references (mail-fetch-field "references"))
1035 (parent (and references (gnus-parent-id references))))
1036 (message-bounce)
1037 ;; If there are references, we fetch the article we answered to.
1038 (and fetch parent
1039 (gnus-summary-refer-article parent)
1040 (gnus-summary-show-all-headers)))))
1041
1042 ;;; Gcc handling.
1043
1044 (defun gnus-inews-group-method (group)
1045 (cond ((and (null (gnus-get-info group))
1046 (eq (car gnus-message-archive-method)
1047 (car
1048 (gnus-server-to-method
1049 (gnus-group-method group)))))
1050 ;; If the group doesn't exist, we assume
1051 ;; it's an archive group...
1052 gnus-message-archive-method)
1053 ;; Use the method.
1054 ((gnus-info-method (gnus-get-info group))
1055 (gnus-info-method (gnus-get-info group)))
1056 ;; Find the method.
1057 (t (gnus-group-method group))))
1058
1059 ;; Do Gcc handling, which copied the message over to some group.
1060 (defun gnus-inews-do-gcc (&optional gcc)
1061 (interactive)
1062 (when (gnus-alive-p)
1063 (save-excursion
1064 (save-restriction
1065 (message-narrow-to-headers)
1066 (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
1067 (cur (current-buffer))
1068 groups group method)
1069 (when gcc
1070 (message-remove-header "gcc")
1071 (widen)
1072 (setq groups (message-unquote-tokens
1073 (message-tokenize-header gcc " ,")))
1074 ;; Copy the article over to some group(s).
1075 (while (setq group (pop groups))
1076 (gnus-check-server
1077 (setq method (gnus-inews-group-method group)))
1078 (unless (gnus-request-group group t method)
1079 (gnus-request-create-group group method))
1080 (save-excursion
1081 (nnheader-set-temp-buffer " *acc*")
1082 (insert-buffer-substring cur)
1083 (message-encode-message-body)
1084 (save-restriction
1085 (message-narrow-to-headers)
1086 (let ((mail-parse-charset message-default-charset)
1087 (rfc2047-header-encoding-alist
1088 (cons '("Newsgroups" . default)
1089 rfc2047-header-encoding-alist)))
1090 (mail-encode-encoded-word-buffer)))
1091 (goto-char (point-min))
1092 (when (re-search-forward
1093 (concat "^" (regexp-quote mail-header-separator) "$")
1094 nil t)
1095 (replace-match "" t t ))
1096 (unless (gnus-request-accept-article group method t t)
1097 (gnus-message 1 "Couldn't store article in group %s: %s"
1098 group (gnus-status-message method))
1099 (sit-for 2))
1100 (kill-buffer (current-buffer))))))))))
1101
1102 (defun gnus-inews-insert-gcc ()
1103 "Insert Gcc headers based on `gnus-outgoing-message-group'."
1104 (save-excursion
1105 (save-restriction
1106 (message-narrow-to-headers)
1107 (let* ((group gnus-outgoing-message-group)
1108 (gcc (cond
1109 ((gnus-functionp group)
1110 (funcall group))
1111 ((or (stringp group) (list group))
1112 group))))
1113 (when gcc
1114 (insert "Gcc: "
1115 (if (stringp gcc) gcc
1116 (mapconcat 'identity gcc " "))
1117 "\n"))))))
1118
1119 (defun gnus-inews-insert-archive-gcc (&optional group)
1120 "Insert the Gcc to say where the article is to be archived."
1121 (let* ((var gnus-message-archive-group)
1122 (group (or group gnus-newsgroup-name ""))
1123 (gcc-self-val
1124 (and gnus-newsgroup-name
1125 (not (equal gnus-newsgroup-name ""))
1126 (gnus-group-find-parameter
1127 gnus-newsgroup-name 'gcc-self)))
1128 result
1129 (groups
1130 (cond
1131 ((null gnus-message-archive-method)
1132 ;; Ignore.
1133 nil)
1134 ((stringp var)
1135 ;; Just a single group.
1136 (list var))
1137 ((null var)
1138 ;; We don't want this.
1139 nil)
1140 ((and (listp var) (stringp (car var)))
1141 ;; A list of groups.
1142 var)
1143 ((gnus-functionp var)
1144 ;; A function.
1145 (funcall var group))
1146 (t
1147 ;; An alist of regexps/functions/forms.
1148 (while (and var
1149 (not
1150 (setq result
1151 (cond
1152 ((stringp (caar var))
1153 ;; Regexp.
1154 (when (string-match (caar var) group)
1155 (cdar var)))
1156 ((gnus-functionp (car var))
1157 ;; Function.
1158 (funcall (car var) group))
1159 (t
1160 (eval (car var)))))))
1161 (setq var (cdr var)))
1162 result)))
1163 name)
1164 (when (or groups gcc-self-val)
1165 (when (stringp groups)
1166 (setq groups (list groups)))
1167 (save-excursion
1168 (save-restriction
1169 (message-narrow-to-headers)
1170 (goto-char (point-max))
1171 (insert "Gcc: ")
1172 (if gcc-self-val
1173 ;; Use the `gcc-self' param value instead.
1174 (progn
1175 (insert
1176 (if (stringp gcc-self-val)
1177 gcc-self-val
1178 group))
1179 (if (not (eq gcc-self-val 'none))
1180 (insert "\n")
1181 (progn
1182 (beginning-of-line)
1183 (kill-line))))
1184 ;; Use the list of groups.
1185 (while (setq name (pop groups))
1186 (insert (if (string-match ":" name)
1187 name
1188 (gnus-group-prefixed-name
1189 name gnus-message-archive-method)))
1190 (when groups
1191 (insert " ")))
1192 (insert "\n")))))))
1193
1194 ;;; Posting styles.
1195
1196 (defun gnus-configure-posting-styles ()
1197 "Configure posting styles according to `gnus-posting-styles'."
1198 (unless gnus-inhibit-posting-styles
1199 (let ((group (or gnus-newsgroup-name ""))
1200 (styles gnus-posting-styles)
1201 style match variable attribute value v results
1202 filep name address element)
1203 ;; If the group has a posting-style parameter, add it at the end with a
1204 ;; regexp matching everything, to be sure it takes precedence over all
1205 ;; the others.
1206 (when gnus-newsgroup-name
1207 (let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
1208 (when tmp-style
1209 (setq styles (append styles (list (cons ".*" tmp-style)))))))
1210 ;; Go through all styles and look for matches.
1211 (dolist (style styles)
1212 (setq match (pop style))
1213 (goto-char (point-min))
1214 (when (cond
1215 ((stringp match)
1216 ;; Regexp string match on the group name.
1217 (string-match match group))
1218 ((eq match 'header)
1219 (let ((header (message-fetch-field (pop style))))
1220 (and header
1221 (string-match (pop style) header))))
1222 ((or (symbolp match)
1223 (gnus-functionp match))
1224 (cond
1225 ((gnus-functionp match)
1226 ;; Function to be called.
1227 (funcall match))
1228 ((boundp match)
1229 ;; Variable to be checked.
1230 (symbol-value match))))
1231 ((listp match)
1232 ;; This is a form to be evaled.
1233 (eval match)))
1234 ;; We have a match, so we set the variables.
1235 (dolist (attribute style)
1236 (setq element (pop attribute)
1237 variable nil
1238 filep nil)
1239 (setq value
1240 (cond
1241 ((eq (car attribute) :file)
1242 (setq filep t)
1243 (cadr attribute))
1244 ((eq (car attribute) :value)
1245 (cadr attribute))
1246 (t
1247 (car attribute))))
1248 ;; We get the value.
1249 (setq v
1250 (cond
1251 ((stringp value)
1252 value)
1253 ((or (symbolp value)
1254 (gnus-functionp value))
1255 (cond ((gnus-functionp value)
1256 (funcall value))
1257 ((boundp value)
1258 (symbol-value value))))
1259 ((listp value)
1260 (eval value))))
1261 ;; Translate obsolescent value.
1262 (when (eq element 'signature-file)
1263 (setq element 'signature
1264 filep t))
1265 ;; Get the contents of file elems.
1266 (when (and filep v)
1267 (setq v (with-temp-buffer
1268 (insert-file-contents v)
1269 (buffer-string))))
1270 (setq results (delq (assoc element results) results))
1271 (push (cons element v) results))))
1272 ;; Now we have all the styles, so we insert them.
1273 (setq name (assq 'name results)
1274 address (assq 'address results))
1275 (setq results (delq name (delq address results)))
1276 (make-local-variable 'message-setup-hook)
1277 (dolist (result results)
1278 (add-hook 'message-setup-hook
1279 (cond
1280 ((eq 'eval (car result))
1281 'ignore)
1282 ((eq 'body (car result))
1283 `(lambda ()
1284 (save-excursion
1285 (message-goto-body)
1286 (insert ,(cdr result)))))
1287 ((eq 'signature (car result))
1288 (set (make-local-variable 'message-signature) nil)
1289 (set (make-local-variable 'message-signature-file) nil)
1290 (if (not (cdr result))
1291 'ignore
1292 `(lambda ()
1293 (save-excursion
1294 (let ((message-signature ,(cdr result)))
1295 (when message-signature
1296 (message-insert-signature)))))))
1297 (t
1298 (let ((header
1299 (if (symbolp (car result))
1300 (capitalize (symbol-name (car result)))
1301 (car result))))
1302 `(lambda ()
1303 (save-excursion
1304 (message-remove-header ,header)
1305 (let ((value ,(cdr result)))
1306 (when value
1307 (message-goto-eoh)
1308 (insert ,header ": " value "\n"))))))))))
1309 (when (or name address)
1310 (add-hook 'message-setup-hook
1311 `(lambda ()
1312 (set (make-local-variable 'user-mail-address)
1313 ,(or (cdr address) user-mail-address))
1314 (let ((user-full-name ,(or (cdr name) (user-full-name)))
1315 (user-mail-address
1316 ,(or (cdr address) user-mail-address)))
1317 (save-excursion
1318 (message-remove-header "From")
1319 (message-goto-eoh)
1320 (insert "From: " (message-make-from) "\n")))))))))
1321
1322 ;;; Allow redefinition of functions.
1323
1324 (gnus-ems-redefine)
1325
1326 (provide 'gnus-msg)
1327
1328 ;;; gnus-msg.el ends here