Merge changes from emacs-23
[bpt/emacs.git] / lisp / gnus / message.el
1 ;;; message.el --- composing mail and news messages
2
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
5
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Keywords: mail, 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 3 of the License, or
14 ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
23
24 ;;; Commentary:
25
26 ;; This mode provides mail-sending facilities from within Emacs. It
27 ;; consists mainly of large chunks of code from the sendmail.el,
28 ;; gnus-msg.el and rnewspost.el files.
29
30 ;;; Code:
31
32 ;; For Emacs <22.2 and XEmacs.
33 (eval-and-compile
34 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
35 (eval-when-compile
36 (require 'cl))
37
38 (require 'mailheader)
39 (require 'gmm-utils)
40 (require 'mail-utils)
41 ;; Only for the trivial macros mail-header-from, mail-header-date
42 ;; mail-header-references, mail-header-subject, mail-header-id
43 (eval-when-compile (require 'nnheader))
44 ;; This is apparently necessary even though things are autoloaded.
45 ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better
46 ;; require mailabbrev here.
47 (if (featurep 'xemacs)
48 (require 'mail-abbrevs)
49 (require 'mailabbrev))
50 (require 'mail-parse)
51 (require 'mml)
52 (require 'rfc822)
53
54 (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
55
56 (defvar gnus-message-group-art)
57 (defvar gnus-list-identifiers) ; gnus-sum is required where necessary
58 (defvar rmail-enable-mime-composing)
59
60 (defgroup message '((user-mail-address custom-variable)
61 (user-full-name custom-variable))
62 "Mail and news message composing."
63 :link '(custom-manual "(message)Top")
64 :group 'mail
65 :group 'news)
66
67 (put 'user-mail-address 'custom-type 'string)
68 (put 'user-full-name 'custom-type 'string)
69
70 (defgroup message-various nil
71 "Various Message Variables."
72 :link '(custom-manual "(message)Various Message Variables")
73 :group 'message)
74
75 (defgroup message-buffers nil
76 "Message Buffers."
77 :link '(custom-manual "(message)Message Buffers")
78 :group 'message)
79
80 (defgroup message-sending nil
81 "Message Sending."
82 :link '(custom-manual "(message)Sending Variables")
83 :group 'message)
84
85 (defgroup message-interface nil
86 "Message Interface."
87 :link '(custom-manual "(message)Interface")
88 :group 'message)
89
90 (defgroup message-forwarding nil
91 "Message Forwarding."
92 :link '(custom-manual "(message)Forwarding")
93 :group 'message-interface)
94
95 (defgroup message-insertion nil
96 "Message Insertion."
97 :link '(custom-manual "(message)Insertion")
98 :group 'message)
99
100 (defgroup message-headers nil
101 "Message Headers."
102 :link '(custom-manual "(message)Message Headers")
103 :group 'message)
104
105 (defgroup message-news nil
106 "Composing News Messages."
107 :group 'message)
108
109 (defgroup message-mail nil
110 "Composing Mail Messages."
111 :group 'message)
112
113 (defgroup message-faces nil
114 "Faces used for message composing."
115 :group 'message
116 :group 'faces)
117
118 (defcustom message-directory "~/Mail/"
119 "*Directory from which all other mail file variables are derived."
120 :group 'message-various
121 :type 'directory)
122
123 (defcustom message-max-buffers 10
124 "*How many buffers to keep before starting to kill them off."
125 :group 'message-buffers
126 :type 'integer)
127
128 (defcustom message-send-rename-function nil
129 "Function called to rename the buffer after sending it."
130 :group 'message-buffers
131 :type '(choice function (const nil)))
132
133 (defcustom message-fcc-handler-function 'message-output
134 "*A function called to save outgoing articles.
135 This function will be called with the name of the file to store the
136 article in. The default function is `message-output' which saves in Unix
137 mailbox format."
138 :type '(radio (function-item message-output)
139 (function :tag "Other"))
140 :group 'message-sending)
141
142 (defcustom message-fcc-externalize-attachments nil
143 "If non-nil, attachments are included as external parts in Fcc copies."
144 :version "22.1"
145 :type 'boolean
146 :group 'message-sending)
147
148 (defcustom message-courtesy-message
149 "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"
150 "*This is inserted at the start of a mailed copy of a posted message.
151 If the string contains the format spec \"%s\", the Newsgroups
152 the article has been posted to will be inserted there.
153 If this variable is nil, no such courtesy message will be added."
154 :group 'message-sending
155 :type '(radio string (const nil)))
156
157 (defcustom message-ignored-bounced-headers
158 "^\\(Received\\|Return-Path\\|Delivered-To\\):"
159 "*Regexp that matches headers to be removed in resent bounced mail."
160 :group 'message-interface
161 :type 'regexp)
162
163 (defcustom message-from-style mail-from-style
164 "*Specifies how \"From\" headers look.
165
166 If nil, they contain just the return address like:
167 king@grassland.com
168 If `parens', they look like:
169 king@grassland.com (Elvis Parsley)
170 If `angles', they look like:
171 Elvis Parsley <king@grassland.com>
172
173 Otherwise, most addresses look like `angles', but they look like
174 `parens' if `angles' would need quoting and `parens' would not."
175 :version "23.2"
176 :type '(choice (const :tag "simple" nil)
177 (const parens)
178 (const angles)
179 (const default))
180 :group 'message-headers)
181
182 (defcustom message-insert-canlock t
183 "Whether to insert a Cancel-Lock header in news postings."
184 :version "22.1"
185 :group 'message-headers
186 :type 'boolean)
187
188 (defcustom message-syntax-checks
189 (if message-insert-canlock '((sender . disabled)) nil)
190 ;; Guess this one shouldn't be easy to customize...
191 "*Controls what syntax checks should not be performed on outgoing posts.
192 To disable checking of long signatures, for instance, add
193 `(signature . disabled)' to this list.
194
195 Don't touch this variable unless you really know what you're doing.
196
197 Checks include `approved', `bogus-recipient', `continuation-headers',
198 `control-chars', `empty', `existing-newsgroups', `from', `illegible-text',
199 `invisible-text', `long-header-lines', `long-lines', `message-id',
200 `multiple-headers', `new-text', `newsgroups', `quoting-style',
201 `repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot',
202 `shorten-followup-to', `signature', `size', `subject', `subject-cmsg'
203 and `valid-newsgroups'."
204 :group 'message-news
205 :type '(repeat sexp)) ; Fixme: improve this
206
207 (defcustom message-required-headers '((optional . References)
208 From)
209 "*Headers to be generated or prompted for when sending a message.
210 Also see `message-required-news-headers' and
211 `message-required-mail-headers'."
212 :version "22.1"
213 :group 'message-news
214 :group 'message-headers
215 :link '(custom-manual "(message)Message Headers")
216 :type '(repeat sexp))
217
218 (defcustom message-draft-headers '(References From Date)
219 "*Headers to be generated when saving a draft message."
220 :version "22.1"
221 :group 'message-news
222 :group 'message-headers
223 :link '(custom-manual "(message)Message Headers")
224 :type '(repeat sexp))
225
226 (defcustom message-required-news-headers
227 '(From Newsgroups Subject Date Message-ID
228 (optional . Organization)
229 (optional . User-Agent))
230 "*Headers to be generated or prompted for when posting an article.
231 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
232 Message-ID. Organization, Lines, In-Reply-To, Expires, and
233 User-Agent are optional. If you don't want message to insert some
234 header, remove it from this list."
235 :group 'message-news
236 :group 'message-headers
237 :link '(custom-manual "(message)Message Headers")
238 :type '(repeat sexp))
239
240 (defcustom message-required-mail-headers
241 '(From Subject Date (optional . In-Reply-To) Message-ID
242 (optional . User-Agent))
243 "*Headers to be generated or prompted for when mailing a message.
244 It is recommended that From, Date, To, Subject and Message-ID be
245 included. Organization and User-Agent are optional."
246 :group 'message-mail
247 :group 'message-headers
248 :link '(custom-manual "(message)Message Headers")
249 :type '(repeat sexp))
250
251 (defcustom message-prune-recipient-rules nil
252 "Rules for how to prune the list of recipients when doing wide replies.
253 This is a list of regexps and regexp matches."
254 :version "24.1"
255 :group 'message-mail
256 :group 'message-headers
257 :link '(custom-manual "(message)Wide Reply")
258 :type '(repeat regexp))
259
260 (defcustom message-deletable-headers '(Message-ID Date Lines)
261 "Headers to be deleted if they already exist and were generated by message previously."
262 :group 'message-headers
263 :link '(custom-manual "(message)Message Headers")
264 :type 'sexp)
265
266 (defcustom message-ignored-news-headers
267 "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
268 "*Regexp of headers to be removed unconditionally before posting."
269 :group 'message-news
270 :group 'message-headers
271 :link '(custom-manual "(message)Message Headers")
272 :type '(repeat :value-to-internal (lambda (widget value)
273 (custom-split-regexp-maybe value))
274 :match (lambda (widget value)
275 (or (stringp value)
276 (widget-editable-list-match widget value)))
277 regexp))
278
279 (defcustom message-ignored-mail-headers
280 "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
281 "*Regexp of headers to be removed unconditionally before mailing."
282 :group 'message-mail
283 :group 'message-headers
284 :link '(custom-manual "(message)Mail Headers")
285 :type 'regexp)
286
287 (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:\\|^Injection-Date:\\|^Injection-Info:"
288 "*Header lines matching this regexp will be deleted before posting.
289 It's best to delete old Path and Date headers before posting to avoid
290 any confusion."
291 :group 'message-interface
292 :link '(custom-manual "(message)Superseding")
293 :type '(repeat :value-to-internal (lambda (widget value)
294 (custom-split-regexp-maybe value))
295 :match (lambda (widget value)
296 (or (stringp value)
297 (widget-editable-list-match widget value)))
298 regexp))
299
300 (defcustom message-subject-re-regexp
301 "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
302 "*Regexp matching \"Re: \" in the subject line."
303 :group 'message-various
304 :link '(custom-manual "(message)Message Headers")
305 :type 'regexp)
306
307 ;;; Start of variables adopted from `message-utils.el'.
308
309 (defcustom message-subject-trailing-was-query 'ask
310 "*What to do with trailing \"(was: <old subject>)\" in subject lines.
311 If nil, leave the subject unchanged. If it is the symbol `ask', query
312 the user what do do. In this case, the subject is matched against
313 `message-subject-trailing-was-ask-regexp'. If
314 `message-subject-trailing-was-query' is t, always strip the trailing
315 old subject. In this case, `message-subject-trailing-was-regexp' is
316 used."
317 :version "22.1"
318 :type '(choice (const :tag "never" nil)
319 (const :tag "always strip" t)
320 (const ask))
321 :link '(custom-manual "(message)Message Headers")
322 :group 'message-various)
323
324 (defcustom message-subject-trailing-was-ask-regexp
325 "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)"
326 "*Regexp matching \"(was: <old subject>)\" in the subject line.
327
328 The function `message-strip-subject-trailing-was' uses this regexp if
329 `message-subject-trailing-was-query' is set to the symbol `ask'. If
330 the variable is t instead of `ask', use
331 `message-subject-trailing-was-regexp' instead.
332
333 It is okay to create some false positives here, as the user is asked."
334 :version "22.1"
335 :group 'message-various
336 :link '(custom-manual "(message)Message Headers")
337 :type 'regexp)
338
339 (defcustom message-subject-trailing-was-regexp
340 "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)"
341 "*Regexp matching \"(was: <old subject>)\" in the subject line.
342
343 If `message-subject-trailing-was-query' is set to t, the subject is
344 matched against `message-subject-trailing-was-regexp' in
345 `message-strip-subject-trailing-was'. You should use a regexp creating very
346 few false positives here."
347 :version "22.1"
348 :group 'message-various
349 :link '(custom-manual "(message)Message Headers")
350 :type 'regexp)
351
352 ;;; marking inserted text
353
354 (defcustom message-mark-insert-begin
355 "--8<---------------cut here---------------start------------->8---\n"
356 "How to mark the beginning of some inserted text."
357 :version "22.1"
358 :type 'string
359 :link '(custom-manual "(message)Insertion Variables")
360 :group 'message-various)
361
362 (defcustom message-mark-insert-end
363 "--8<---------------cut here---------------end--------------->8---\n"
364 "How to mark the end of some inserted text."
365 :version "22.1"
366 :type 'string
367 :link '(custom-manual "(message)Insertion Variables")
368 :group 'message-various)
369
370 (defcustom message-archive-header "X-No-Archive: Yes\n"
371 "Header to insert when you don't want your article to be archived.
372 Archives \(such as groups.google.com\) respect this header."
373 :version "22.1"
374 :type 'string
375 :link '(custom-manual "(message)Header Commands")
376 :group 'message-various)
377
378 (defcustom message-archive-note
379 "X-No-Archive: Yes - save http://groups.google.com/"
380 "Note to insert why you wouldn't want this posting archived.
381 If nil, don't insert any text in the body."
382 :version "22.1"
383 :type '(radio string (const nil))
384 :link '(custom-manual "(message)Header Commands")
385 :group 'message-various)
386
387 ;;; Crossposts and Followups
388 ;; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de>
389 ;; new suggestions by R. Weikusat <rw at another.de>
390
391 (defvar message-cross-post-old-target nil
392 "Old target for cross-posts or follow-ups.")
393 (make-variable-buffer-local 'message-cross-post-old-target)
394
395 (defcustom message-cross-post-default t
396 "When non-nil `message-cross-post-followup-to' will perform a crosspost.
397 If nil, `message-cross-post-followup-to' will only do a followup. Note that
398 you can explicitly override this setting by calling
399 `message-cross-post-followup-to' with a prefix."
400 :version "22.1"
401 :type 'boolean
402 :group 'message-various)
403
404 (defcustom message-cross-post-note "Crosspost & Followup-To: "
405 "Note to insert before signature to notify of cross-post and follow-up."
406 :version "22.1"
407 :type 'string
408 :group 'message-various)
409
410 (defcustom message-followup-to-note "Followup-To: "
411 "Note to insert before signature to notify of follow-up only."
412 :version "22.1"
413 :type 'string
414 :group 'message-various)
415
416 (defcustom message-cross-post-note-function 'message-cross-post-insert-note
417 "Function to use to insert note about Crosspost or Followup-To.
418 The function will be called with four arguments. The function should not only
419 insert a note, but also ensure old notes are deleted. See the documentation
420 for `message-cross-post-insert-note'."
421 :version "22.1"
422 :type 'function
423 :group 'message-various)
424
425 ;;; End of variables adopted from `message-utils.el'.
426
427 (defcustom message-signature-separator "^-- $"
428 "Regexp matching the signature separator.
429 This variable is used to strip off the signature from quoted text
430 when `message-cite-function' is
431 `message-cite-original-without-signature'. Most useful values
432 are \"^-- $\" (strict) and \"^-- *$\" (loose; allow missing
433 whitespace)."
434 :type '(choice (const :tag "strict" "^-- $")
435 (const :tag "loose" "^-- *$")
436 regexp)
437 :version "22.3" ;; Gnus 5.10.12 (changed default)
438 :link '(custom-manual "(message)Various Message Variables")
439 :group 'message-various)
440
441 (defcustom message-elide-ellipsis "\n[...]\n\n"
442 "*The string which is inserted for elided text."
443 :type 'string
444 :link '(custom-manual "(message)Various Commands")
445 :group 'message-various)
446
447 (defcustom message-interactive mail-interactive
448 "Non-nil means when sending a message wait for and display errors.
449 A value of nil means let mailer mail back a message to report errors."
450 :version "23.2"
451 :group 'message-sending
452 :group 'message-mail
453 :link '(custom-manual "(message)Sending Variables")
454 :type 'boolean)
455
456 (defcustom message-confirm-send nil
457 "When non-nil, ask for confirmation when sending a message."
458 :group 'message-sending
459 :group 'message-mail
460 :version "23.1" ;; No Gnus
461 :link '(custom-manual "(message)Sending Variables")
462 :type 'boolean)
463
464 (defcustom message-generate-new-buffers 'unsent
465 "*Say whether to create a new message buffer to compose a message.
466 Valid values include:
467
468 nil
469 Generate the buffer name in the Message way (e.g., *mail*, *news*,
470 *mail to whom*, *news on group*, etc.) and continue editing in the
471 existing buffer of that name. If there is no such buffer, it will
472 be newly created.
473
474 `unique' or t
475 Create the new buffer with the name generated in the Message way.
476
477 `unsent'
478 Similar to `unique' but the buffer name begins with \"*unsent \".
479
480 `standard'
481 Similar to nil but the buffer name is simpler like *mail message*.
482
483 function
484 If this is a function, call that function with three parameters:
485 The type, the To address and the group name (any of these may be nil).
486 The function should return the new buffer name."
487 :version "24.1"
488 :group 'message-buffers
489 :link '(custom-manual "(message)Message Buffers")
490 :type '(choice (const nil)
491 (sexp :tag "unique" :format "unique\n" :value unique
492 :match (lambda (widget value) (memq value '(unique t))))
493 (const unsent)
494 (const standard)
495 (function :format "\n %{%t%}: %v")))
496
497 (defcustom message-kill-buffer-on-exit nil
498 "*Non-nil means that the message buffer will be killed after sending a message."
499 :group 'message-buffers
500 :link '(custom-manual "(message)Message Buffers")
501 :type 'boolean)
502
503 (defcustom message-kill-buffer-query t
504 "*Non-nil means that killing a modified message buffer has to be confirmed.
505 This is used by `message-kill-buffer'."
506 :version "23.1" ;; No Gnus
507 :group 'message-buffers
508 :type 'boolean)
509
510 (defvar gnus-local-organization)
511 (defcustom message-user-organization
512 (or (and (boundp 'gnus-local-organization)
513 (stringp gnus-local-organization)
514 gnus-local-organization)
515 (getenv "ORGANIZATION")
516 t)
517 "*String to be used as an Organization header.
518 If t, use `message-user-organization-file'."
519 :group 'message-headers
520 :type '(choice string
521 (const :tag "consult file" t)))
522
523 (defcustom message-user-organization-file
524 (let (orgfile)
525 (dolist (f (list "/etc/organization"
526 "/etc/news/organization"
527 "/usr/lib/news/organization"))
528 (when (file-readable-p f)
529 (setq orgfile f)))
530 orgfile)
531 "*Local news organization file."
532 :type 'file
533 :link '(custom-manual "(message)News Headers")
534 :group 'message-headers)
535
536 (defcustom message-make-forward-subject-function
537 #'message-forward-subject-name-subject
538 "*List of functions called to generate subject headers for forwarded messages.
539 The subject generated by the previous function is passed into each
540 successive function.
541
542 The provided functions are:
543
544 * `message-forward-subject-author-subject' Source of article (author or
545 newsgroup), in brackets followed by the subject
546 * `message-forward-subject-name-subject' Source of article (name of author
547 or newsgroup), in brackets followed by the subject
548 * `message-forward-subject-fwd' Subject of article with 'Fwd:' prepended
549 to it."
550 :group 'message-forwarding
551 :link '(custom-manual "(message)Forwarding")
552 :type '(radio (function-item message-forward-subject-author-subject)
553 (function-item message-forward-subject-fwd)
554 (function-item message-forward-subject-name-subject)
555 (repeat :tag "List of functions" function)))
556
557 (defcustom message-forward-as-mime t
558 "*Non-nil means forward messages as an inline/rfc822 MIME section.
559 Otherwise, directly inline the old message in the forwarded message."
560 :version "21.1"
561 :group 'message-forwarding
562 :link '(custom-manual "(message)Forwarding")
563 :type 'boolean)
564
565 (defcustom message-forward-show-mml 'best
566 "*Non-nil means show forwarded messages as MML (decoded from MIME).
567 Otherwise, forwarded messages are unchanged.
568 Can also be the symbol `best' to indicate that MML should be
569 used, except when it is a bad idea to use MML. One example where
570 it is a bad idea is when forwarding a signed or encrypted
571 message, because converting MIME to MML would invalidate the
572 digital signature."
573 :version "21.1"
574 :group 'message-forwarding
575 :type '(choice (const :tag "use MML" t)
576 (const :tag "don't use MML " nil)
577 (const :tag "use MML when appropriate" best)))
578
579 (defcustom message-forward-before-signature t
580 "*Non-nil means put forwarded message before signature, else after."
581 :group 'message-forwarding
582 :type 'boolean)
583
584 (defcustom message-wash-forwarded-subjects nil
585 "*Non-nil means try to remove as much cruft as possible from the subject.
586 Done before generating the new subject of a forward."
587 :group 'message-forwarding
588 :link '(custom-manual "(message)Forwarding")
589 :type 'boolean)
590
591 (defcustom message-ignored-resent-headers
592 ;; `Delivered-To' needs to be removed because some mailers use it to
593 ;; detect loops, so if you resend a message to an address that ultimately
594 ;; comes back to you (e.g. a mailing-list to which you subscribe, in which
595 ;; case you may be removed from the list on the grounds that mail to you
596 ;; bounced with a "mailing loop" error).
597 "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From \\|^Delivered-To:"
598 "*All headers that match this regexp will be deleted when resending a message."
599 :group 'message-interface
600 :link '(custom-manual "(message)Resending")
601 :type '(repeat :value-to-internal (lambda (widget value)
602 (custom-split-regexp-maybe value))
603 :match (lambda (widget value)
604 (or (stringp value)
605 (widget-editable-list-match widget value)))
606 regexp))
607
608 (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
609 "*All headers that match this regexp will be deleted when forwarding a message."
610 :version "21.1"
611 :group 'message-forwarding
612 :type '(repeat :value-to-internal (lambda (widget value)
613 (custom-split-regexp-maybe value))
614 :match (lambda (widget value)
615 (or (stringp value)
616 (widget-editable-list-match widget value)))
617 regexp))
618
619 (defcustom message-ignored-cited-headers "."
620 "*Delete these headers from the messages you yank."
621 :group 'message-insertion
622 :link '(custom-manual "(message)Insertion Variables")
623 :type 'regexp)
624
625 (defcustom message-cite-prefix-regexp mail-citation-prefix-regexp
626 "*Regexp matching the longest possible citation prefix on a line."
627 :version "24.1"
628 :group 'message-insertion
629 :link '(custom-manual "(message)Insertion Variables")
630 :type 'regexp
631 :set (lambda (symbol value)
632 (prog1
633 (custom-set-default symbol value)
634 (if (boundp 'gnus-message-cite-prefix-regexp)
635 (setq gnus-message-cite-prefix-regexp
636 (concat "^\\(?:" value "\\)"))))))
637
638 (defcustom message-cancel-message "I am canceling my own article.\n"
639 "Message to be inserted in the cancel message."
640 :group 'message-interface
641 :link '(custom-manual "(message)Canceling News")
642 :type 'string)
643
644 (defun message-send-mail-function ()
645 "Return suitable value for the variable `message-send-mail-function'."
646 (cond ((and (require 'sendmail)
647 (boundp 'sendmail-program)
648 sendmail-program
649 (executable-find sendmail-program))
650 'message-send-mail-with-sendmail)
651 ((and (locate-library "smtpmail")
652 (boundp 'smtpmail-default-smtp-server)
653 smtpmail-default-smtp-server)
654 'message-smtpmail-send-it)
655 ((locate-library "mailclient")
656 'message-send-mail-with-mailclient)
657 (t
658 (error "Don't know how to send mail. Please customize `message-send-mail-function'"))))
659
660 ;; Useful to set in site-init.el
661 (defcustom message-send-mail-function
662 (cond ((eq send-mail-function 'smtpmail-send-it) 'message-smtpmail-send-it)
663 ((eq send-mail-function 'feedmail-send-it) 'feedmail-send-it)
664 ((eq send-mail-function 'mailclient-send-it)
665 'message-send-mail-with-mailclient)
666 (t (message-send-mail-function)))
667 "Function to call to send the current buffer as mail.
668 The headers should be delimited by a line whose contents match the
669 variable `mail-header-separator'.
670
671 Valid values include `message-send-mail-with-sendmail'
672 `message-send-mail-with-mh', `message-send-mail-with-qmail',
673 `message-smtpmail-send-it', `smtpmail-send-it',
674 `feedmail-send-it' and `message-send-mail-with-mailclient'. The
675 default is system dependent and determined by the function
676 `message-send-mail-function'.
677
678 See also `send-mail-function'."
679 :type '(radio (function-item message-send-mail-with-sendmail)
680 (function-item message-send-mail-with-mh)
681 (function-item message-send-mail-with-qmail)
682 (function-item message-smtpmail-send-it)
683 (function-item smtpmail-send-it)
684 (function-item feedmail-send-it)
685 (function-item message-send-mail-with-mailclient
686 :tag "Use Mailclient package")
687 (function :tag "Other"))
688 :group 'message-sending
689 :version "23.2"
690 :initialize 'custom-initialize-default
691 :link '(custom-manual "(message)Mail Variables")
692 :group 'message-mail)
693
694 (defcustom message-send-news-function 'message-send-news
695 "Function to call to send the current buffer as news.
696 The headers should be delimited by a line whose contents match the
697 variable `mail-header-separator'."
698 :group 'message-sending
699 :group 'message-news
700 :link '(custom-manual "(message)News Variables")
701 :type 'function)
702
703 (defcustom message-reply-to-function nil
704 "If non-nil, function that should return a list of headers.
705 This function should pick out addresses from the To, Cc, and From headers
706 and respond with new To and Cc headers."
707 :group 'message-interface
708 :link '(custom-manual "(message)Reply")
709 :type '(choice function (const nil)))
710
711 (defcustom message-wide-reply-to-function nil
712 "If non-nil, function that should return a list of headers.
713 This function should pick out addresses from the To, Cc, and From headers
714 and respond with new To and Cc headers."
715 :group 'message-interface
716 :link '(custom-manual "(message)Wide Reply")
717 :type '(choice function (const nil)))
718
719 (defcustom message-followup-to-function nil
720 "If non-nil, function that should return a list of headers.
721 This function should pick out addresses from the To, Cc, and From headers
722 and respond with new To and Cc headers."
723 :group 'message-interface
724 :link '(custom-manual "(message)Followup")
725 :type '(choice function (const nil)))
726
727 (defcustom message-extra-wide-headers nil
728 "If non-nil, a list of additional address headers.
729 These are used when composing a wide reply."
730 :group 'message-sending
731 :type '(repeat string))
732
733 (defcustom message-use-followup-to 'ask
734 "*Specifies what to do with Followup-To header.
735 If nil, always ignore the header. If it is t, use its value, but
736 query before using the \"poster\" value. If it is the symbol `ask',
737 always query the user whether to use the value. If it is the symbol
738 `use', always use the value."
739 :group 'message-interface
740 :link '(custom-manual "(message)Followup")
741 :type '(choice (const :tag "ignore" nil)
742 (const :tag "use & query" t)
743 (const use)
744 (const ask)))
745
746 (defcustom message-use-mail-followup-to 'use
747 "*Specifies what to do with Mail-Followup-To header.
748 If nil, always ignore the header. If it is the symbol `ask', always
749 query the user whether to use the value. If it is the symbol `use',
750 always use the value."
751 :version "22.1"
752 :group 'message-interface
753 :link '(custom-manual "(message)Mailing Lists")
754 :type '(choice (const :tag "ignore" nil)
755 (const use)
756 (const ask)))
757
758 (defcustom message-subscribed-address-functions nil
759 "*Specifies functions for determining list subscription.
760 If nil, do not attempt to determine list subscription with functions.
761 If non-nil, this variable contains a list of functions which return
762 regular expressions to match lists. These functions can be used in
763 conjunction with `message-subscribed-regexps' and
764 `message-subscribed-addresses'."
765 :version "22.1"
766 :group 'message-interface
767 :link '(custom-manual "(message)Mailing Lists")
768 :type '(repeat sexp))
769
770 (defcustom message-subscribed-address-file nil
771 "*A file containing addresses the user is subscribed to.
772 If nil, do not look at any files to determine list subscriptions. If
773 non-nil, each line of this file should be a mailing list address."
774 :version "22.1"
775 :group 'message-interface
776 :link '(custom-manual "(message)Mailing Lists")
777 :type '(radio file (const nil)))
778
779 (defcustom message-subscribed-addresses nil
780 "*Specifies a list of addresses the user is subscribed to.
781 If nil, do not use any predefined list subscriptions. This list of
782 addresses can be used in conjunction with
783 `message-subscribed-address-functions' and `message-subscribed-regexps'."
784 :version "22.1"
785 :group 'message-interface
786 :link '(custom-manual "(message)Mailing Lists")
787 :type '(repeat string))
788
789 (defcustom message-subscribed-regexps nil
790 "*Specifies a list of addresses the user is subscribed to.
791 If nil, do not use any predefined list subscriptions. This list of
792 regular expressions can be used in conjunction with
793 `message-subscribed-address-functions' and `message-subscribed-addresses'."
794 :version "22.1"
795 :group 'message-interface
796 :link '(custom-manual "(message)Mailing Lists")
797 :type '(repeat regexp))
798
799 (defcustom message-allow-no-recipients 'ask
800 "Specifies what to do when there are no recipients other than Gcc/Fcc.
801 If it is the symbol `always', the posting is allowed. If it is the
802 symbol `never', the posting is not allowed. If it is the symbol
803 `ask', you are prompted."
804 :version "22.1"
805 :group 'message-interface
806 :link '(custom-manual "(message)Message Headers")
807 :type '(choice (const always)
808 (const never)
809 (const ask)))
810
811 (defcustom message-sendmail-f-is-evil nil
812 "*Non-nil means don't add \"-f username\" to the sendmail command line.
813 Doing so would be even more evil than leaving it out."
814 :group 'message-sending
815 :link '(custom-manual "(message)Mail Variables")
816 :type 'boolean)
817
818 (defcustom message-sendmail-envelope-from
819 ;; `mail-envelope-from' is unavailable unless sendmail.el is loaded.
820 (if (boundp 'mail-envelope-from) mail-envelope-from)
821 "*Envelope-from when sending mail with sendmail.
822 If this is nil, use `user-mail-address'. If it is the symbol
823 `header', use the From: header of the message."
824 :version "23.2"
825 :type '(choice (string :tag "From name")
826 (const :tag "Use From: header from message" header)
827 (const :tag "Use `user-mail-address'" nil))
828 :link '(custom-manual "(message)Mail Variables")
829 :group 'message-sending)
830
831 (defcustom message-sendmail-extra-arguments nil
832 "Additional arguments to `sendmail-program'."
833 ;; E.g. '("-a" "account") for msmtp
834 :version "23.1" ;; No Gnus
835 :type '(repeat string)
836 ;; :link '(custom-manual "(message)Mail Variables")
837 :group 'message-sending)
838
839 ;; qmail-related stuff
840 (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
841 "Location of the qmail-inject program."
842 :group 'message-sending
843 :link '(custom-manual "(message)Mail Variables")
844 :type 'file)
845
846 (defcustom message-qmail-inject-args nil
847 "Arguments passed to qmail-inject programs.
848 This should be a list of strings, one string for each argument.
849 It may also be a function.
850
851 For e.g., if you wish to set the envelope sender address so that bounces
852 go to the right place or to deal with listserv's usage of that address, you
853 might set this variable to '(\"-f\" \"you@some.where\")."
854 :group 'message-sending
855 :link '(custom-manual "(message)Mail Variables")
856 :type '(choice (function)
857 (repeat string)))
858
859 (defvar gnus-post-method)
860 (defvar gnus-select-method)
861 (defcustom message-post-method
862 (cond ((and (boundp 'gnus-post-method)
863 (listp gnus-post-method)
864 gnus-post-method)
865 gnus-post-method)
866 ((boundp 'gnus-select-method)
867 gnus-select-method)
868 (t '(nnspool "")))
869 "*Method used to post news.
870 Note that when posting from inside Gnus, for instance, this
871 variable isn't used."
872 :group 'message-news
873 :group 'message-sending
874 ;; This should be the `gnus-select-method' widget, but that might
875 ;; create a dependence to `gnus.el'.
876 :type 'sexp)
877
878 ;; FIXME: This should be a temporary workaround until someone implements a
879 ;; proper solution. If a crash happens while replying, the auto-save file
880 ;; will *not* have a `References:' header if `message-generate-headers-first'
881 ;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138
882 (defcustom message-generate-headers-first '(references)
883 "Which headers should be generated before starting to compose a message.
884 If t, generate all required headers. This can also be a list of headers to
885 generate. The variables `message-required-news-headers' and
886 `message-required-mail-headers' specify which headers to generate.
887
888 Note that the variable `message-deletable-headers' specifies headers which
889 are to be deleted and then re-generated before sending, so this variable
890 will not have a visible effect for those headers."
891 :group 'message-headers
892 :link '(custom-manual "(message)Message Headers")
893 :type '(choice (const :tag "None" nil)
894 (const :tag "References" '(references))
895 (const :tag "All" t)
896 (repeat (sexp :tag "Header"))))
897
898 (defcustom message-fill-column 72
899 "Column beyond which automatic line-wrapping should happen.
900 Local value for message buffers. If non-nil, also turn on
901 auto-fill in message buffers."
902 :group 'message-various
903 ;; :link '(custom-manual "(message)Message Headers")
904 :type '(choice (const :tag "Don't turn on auto fill" nil)
905 (integer)))
906
907 (defcustom message-setup-hook nil
908 "Normal hook, run each time a new outgoing message is initialized.
909 The function `message-setup' runs this hook."
910 :group 'message-various
911 :link '(custom-manual "(message)Various Message Variables")
912 :type 'hook)
913
914 (defcustom message-cancel-hook nil
915 "Hook run when cancelling articles."
916 :group 'message-various
917 :link '(custom-manual "(message)Various Message Variables")
918 :type 'hook)
919
920 (defcustom message-signature-setup-hook nil
921 "Normal hook, run each time a new outgoing message is initialized.
922 It is run after the headers have been inserted and before
923 the signature is inserted."
924 :group 'message-various
925 :link '(custom-manual "(message)Various Message Variables")
926 :type 'hook)
927
928 (defcustom message-mode-hook nil
929 "Hook run in message mode buffers."
930 :group 'message-various
931 :type 'hook)
932
933 (defcustom message-header-hook nil
934 "Hook run in a message mode buffer narrowed to the headers."
935 :group 'message-various
936 :type 'hook)
937
938 (defcustom message-header-setup-hook nil
939 "Hook called narrowed to the headers when setting up a message buffer."
940 :group 'message-various
941 :link '(custom-manual "(message)Various Message Variables")
942 :type 'hook)
943
944 (defcustom message-minibuffer-local-map
945 (let ((map (make-sparse-keymap 'message-minibuffer-local-map)))
946 (set-keymap-parent map minibuffer-local-map)
947 map)
948 "Keymap for `message-read-from-minibuffer'."
949 :version "22.1"
950 :group 'message-various)
951
952 (defcustom message-citation-line-function 'message-insert-citation-line
953 "*Function called to insert the \"Whomever writes:\" line.
954
955 Predefined functions include `message-insert-citation-line' and
956 `message-insert-formatted-citation-line' (see the variable
957 `message-citation-line-format').
958
959 Note that Gnus provides a feature where the reader can click on
960 `writes:' to hide the cited text. If you change this line too much,
961 people who read your message will have to change their Gnus
962 configuration. See the variable `gnus-cite-attribution-suffix'."
963 :type '(choice
964 (function-item :tag "plain" message-insert-citation-line)
965 (function-item :tag "formatted" message-insert-formatted-citation-line)
966 (function :tag "Other"))
967 :link '(custom-manual "(message)Insertion Variables")
968 :group 'message-insertion)
969
970 (defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n"
971 "Format of the \"Whomever writes:\" line.
972
973 The string is formatted using `format-spec'. The following
974 constructs are replaced:
975
976 %f The full From, e.g. \"John Doe <john.doe@example.invalid>\".
977 %n The mail address, e.g. \"john.doe@example.invalid\".
978 %N The real name if present, e.g.: \"John Doe\", else fall
979 back to the mail address.
980 %F The first name if present, e.g.: \"John\".
981 %L The last name if present, e.g.: \"Doe\".
982
983 All other format specifiers are passed to `format-time-string'
984 which is called using the date from the article your replying to.
985 Extracting the first (%F) and last name (%L) is done
986 heuristically, so you should always check it yourself.
987
988 Please also read the note in the documentation of
989 `message-citation-line-function'."
990 :type '(choice (const :tag "Plain" "%f writes:")
991 (const :tag "Include date" "On %a, %b %d %Y, %n wrote:")
992 string)
993 :link '(custom-manual "(message)Insertion Variables")
994 :version "23.1" ;; No Gnus
995 :group 'message-insertion)
996
997 (defcustom message-yank-prefix mail-yank-prefix
998 "*Prefix inserted on the lines of yanked messages.
999 Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
1000 See also `message-yank-cited-prefix' and `message-yank-empty-prefix'."
1001 :version "23.2"
1002 :type 'string
1003 :link '(custom-manual "(message)Insertion Variables")
1004 :group 'message-insertion)
1005
1006 (defcustom message-yank-cited-prefix ">"
1007 "*Prefix inserted on cited lines of yanked messages.
1008 Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
1009 See also `message-yank-prefix' and `message-yank-empty-prefix'."
1010 :version "22.1"
1011 :type 'string
1012 :link '(custom-manual "(message)Insertion Variables")
1013 :group 'message-insertion)
1014
1015 (defcustom message-yank-empty-prefix ">"
1016 "*Prefix inserted on empty lines of yanked messages.
1017 See also `message-yank-prefix' and `message-yank-cited-prefix'."
1018 :version "22.1"
1019 :type 'string
1020 :link '(custom-manual "(message)Insertion Variables")
1021 :group 'message-insertion)
1022
1023 (defcustom message-indentation-spaces mail-indentation-spaces
1024 "*Number of spaces to insert at the beginning of each cited line.
1025 Used by `message-yank-original' via `message-yank-cite'."
1026 :version "23.2"
1027 :group 'message-insertion
1028 :link '(custom-manual "(message)Insertion Variables")
1029 :type 'integer)
1030
1031 (defcustom message-cite-function 'message-cite-original-without-signature
1032 "*Function for citing an original message.
1033 Predefined functions include `message-cite-original' and
1034 `message-cite-original-without-signature'.
1035 Note that these functions use `mail-citation-hook' if that is non-nil."
1036 :type '(radio (function-item message-cite-original)
1037 (function-item message-cite-original-without-signature)
1038 (function-item sc-cite-original)
1039 (function :tag "Other"))
1040 :link '(custom-manual "(message)Insertion Variables")
1041 :version "22.3" ;; Gnus 5.10.12 (changed default)
1042 :group 'message-insertion)
1043
1044 (defcustom message-indent-citation-function 'message-indent-citation
1045 "*Function for modifying a citation just inserted in the mail buffer.
1046 This can also be a list of functions. Each function can find the
1047 citation between (point) and (mark t). And each function should leave
1048 point and mark around the citation text as modified."
1049 :type 'function
1050 :link '(custom-manual "(message)Insertion Variables")
1051 :group 'message-insertion)
1052
1053 (defcustom message-signature mail-signature
1054 "*String to be inserted at the end of the message buffer.
1055 If t, the `message-signature-file' file will be inserted instead.
1056 If a function, the result from the function will be used instead.
1057 If a form, the result from the form will be used instead."
1058 :version "23.2"
1059 :type 'sexp
1060 :link '(custom-manual "(message)Insertion Variables")
1061 :group 'message-insertion)
1062
1063 (defcustom message-signature-file mail-signature-file
1064 "*Name of file containing the text inserted at end of message buffer.
1065 Ignored if the named file doesn't exist.
1066 If nil, don't insert a signature.
1067 If a path is specified, the value of `message-signature-directory' is ignored,
1068 even if set."
1069 :version "23.2"
1070 :type '(choice file (const :tags "None" nil))
1071 :link '(custom-manual "(message)Insertion Variables")
1072 :group 'message-insertion)
1073
1074 (defcustom message-signature-directory nil
1075 "*Name of directory containing signature files.
1076 Comes in handy if you have many such files, handled via posting styles for
1077 instance.
1078 If nil, `message-signature-file' is expected to specify the directory if
1079 needed."
1080 :type '(choice string (const :tags "None" nil))
1081 :link '(custom-manual "(message)Insertion Variables")
1082 :group 'message-insertion)
1083
1084 (defcustom message-signature-insert-empty-line t
1085 "*If non-nil, insert an empty line before the signature separator."
1086 :version "22.1"
1087 :type 'boolean
1088 :link '(custom-manual "(message)Insertion Variables")
1089 :group 'message-insertion)
1090
1091 (defcustom message-distribution-function nil
1092 "*Function called to return a Distribution header."
1093 :group 'message-news
1094 :group 'message-headers
1095 :link '(custom-manual "(message)News Headers")
1096 :type '(choice function (const nil)))
1097
1098 (defcustom message-expires 14
1099 "Number of days before your article expires."
1100 :group 'message-news
1101 :group 'message-headers
1102 :link '(custom-manual "(message)News Headers")
1103 :type 'integer)
1104
1105 (defcustom message-user-path nil
1106 "If nil, use the NNTP server name in the Path header.
1107 If stringp, use this; if non-nil, use no host name (user name only)."
1108 :group 'message-news
1109 :group 'message-headers
1110 :link '(custom-manual "(message)News Headers")
1111 :type '(choice (const :tag "nntp" nil)
1112 (string :tag "name")
1113 (sexp :tag "none" :format "%t" t)))
1114
1115 ;; This can be the name of a buffer, or a cons cell (FUNCTION . ARGS)
1116 ;; for yanking the original buffer.
1117 (defvar message-reply-buffer nil)
1118 (defvar message-reply-headers nil
1119 "The headers of the current replied article.
1120 It is a vector of the following headers:
1121 \[number subject from date id references chars lines xref extra].")
1122 (defvar message-newsreader nil)
1123 (defvar message-mailer nil)
1124 (defvar message-sent-message-via nil)
1125 (defvar message-checksum nil)
1126 (defvar message-send-actions nil
1127 "A list of actions to be performed upon successful sending of a message.")
1128 (defvar message-exit-actions nil
1129 "A list of actions to be performed upon exiting after sending a message.")
1130 (defvar message-kill-actions nil
1131 "A list of actions to be performed before killing a message buffer.")
1132 (defvar message-postpone-actions nil
1133 "A list of actions to be performed after postponing a message.")
1134
1135 (define-widget 'message-header-lines 'text
1136 "All header lines must be LFD terminated."
1137 :format "%{%t%}:%n%v"
1138 :valid-regexp "^\\'"
1139 :error "All header lines must be newline terminated")
1140
1141 (defcustom message-default-headers ""
1142 "A string containing header lines to be inserted in outgoing messages.
1143 It is inserted before you edit the message, so you can edit or
1144 delete these lines. If set to a function, it is called and its
1145 result is inserted."
1146 :version "23.2"
1147 :group 'message-headers
1148 :link '(custom-manual "(message)Message Headers")
1149 :type 'message-header-lines)
1150
1151 (defcustom message-default-mail-headers
1152 ;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555.
1153 (concat (if (and (boundp 'mail-default-reply-to)
1154 (stringp mail-default-reply-to))
1155 (format "Reply-to: %s\n" mail-default-reply-to))
1156 (if (and (boundp 'mail-self-blind)
1157 mail-self-blind)
1158 (format "BCC: %s\n" user-mail-address))
1159 (if (and (boundp 'mail-archive-file-name)
1160 (stringp mail-archive-file-name))
1161 (format "FCC: %s\n" mail-archive-file-name))
1162 ;; Use the value of `mail-default-headers' if available.
1163 ;; Note: as for XEmacs 21.4 and 21.5, it is unavailable
1164 ;; unless sendmail.el is loaded.
1165 (if (boundp 'mail-default-headers)
1166 mail-default-headers))
1167 "*A string of header lines to be inserted in outgoing mails."
1168 :version "23.2"
1169 :group 'message-headers
1170 :group 'message-mail
1171 :link '(custom-manual "(message)Mail Headers")
1172 :type 'message-header-lines)
1173
1174 (defcustom message-default-news-headers ""
1175 "*A string of header lines to be inserted in outgoing news articles."
1176 :group 'message-headers
1177 :group 'message-news
1178 :link '(custom-manual "(message)News Headers")
1179 :type 'message-header-lines)
1180
1181 ;; Note: could use /usr/ucb/mail instead of sendmail;
1182 ;; options -t, and -v if not interactive.
1183 (defcustom message-mailer-swallows-blank-line
1184 (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
1185 system-configuration)
1186 (file-readable-p "/etc/sendmail.cf")
1187 (let ((buffer (get-buffer-create " *temp*")))
1188 (unwind-protect
1189 (with-current-buffer buffer
1190 (insert-file-contents "/etc/sendmail.cf")
1191 (goto-char (point-min))
1192 (let ((case-fold-search nil))
1193 (re-search-forward "^OR\\>" nil t)))
1194 (kill-buffer buffer))))
1195 ;; According to RFC822, "The field-name must be composed of printable
1196 ;; ASCII characters (i. e., characters that have decimal values between
1197 ;; 33 and 126, except colon)", i. e., any chars except ctl chars,
1198 ;; space, or colon.
1199 '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
1200 "*Set this non-nil if the system's mailer runs the header and body together.
1201 \(This problem exists on Sunos 4 when sendmail is run in remote mode.)
1202 The value should be an expression to test whether the problem will
1203 actually occur."
1204 :group 'message-sending
1205 :link '(custom-manual "(message)Mail Variables")
1206 :type 'sexp)
1207
1208 ;;;###autoload
1209 (define-mail-user-agent 'message-user-agent
1210 'message-mail 'message-send-and-exit
1211 'message-kill-buffer 'message-send-hook)
1212
1213 (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
1214 "If non-nil, delete the deletable headers before feeding to mh.")
1215
1216 (defvar message-send-method-alist
1217 '((news message-news-p message-send-via-news)
1218 (mail message-mail-p message-send-via-mail))
1219 "Alist of ways to send outgoing messages.
1220 Each element has the form
1221
1222 \(TYPE PREDICATE FUNCTION)
1223
1224 where TYPE is a symbol that names the method; PREDICATE is a function
1225 called without any parameters to determine whether the message is
1226 a message of type TYPE; and FUNCTION is a function to be called if
1227 PREDICATE returns non-nil. FUNCTION is called with one parameter --
1228 the prefix.")
1229
1230 (defcustom message-mail-alias-type 'abbrev
1231 "*What alias expansion type to use in Message buffers.
1232 The default is `abbrev', which uses mailabbrev. `ecomplete' uses
1233 an electric completion mode. nil switches mail aliases off.
1234 This can also be a list of values."
1235 :group 'message
1236 :link '(custom-manual "(message)Mail Aliases")
1237 :type '(choice (const :tag "Use Mailabbrev" abbrev)
1238 (const :tag "Use ecomplete" ecomplete)
1239 (const :tag "No expansion" nil)))
1240
1241 (defcustom message-self-insert-commands '(self-insert-command)
1242 "List of `self-insert-command's used to trigger ecomplete.
1243 When one of those commands is invoked to enter a character in To or Cc
1244 header, ecomplete will suggest the candidates of recipients (see also
1245 `message-mail-alias-type'). If you use some tool to enter non-ASCII
1246 text and it replaces `self-insert-command' with the other command, e.g.
1247 `egg-self-insert-command', you may want to add it to this list."
1248 :group 'message-various
1249 :type '(repeat function))
1250
1251 (defcustom message-auto-save-directory
1252 (file-name-as-directory (expand-file-name "drafts" message-directory))
1253 "*Directory where Message auto-saves buffers if Gnus isn't running.
1254 If nil, Message won't auto-save."
1255 :group 'message-buffers
1256 :link '(custom-manual "(message)Various Message Variables")
1257 :type '(choice directory (const :tag "Don't auto-save" nil)))
1258
1259 (defcustom message-default-charset
1260 (and (not (mm-multibyte-p)) 'iso-8859-1)
1261 "Default charset used in non-MULE Emacsen.
1262 If nil, you might be asked to input the charset."
1263 :version "21.1"
1264 :group 'message
1265 :link '(custom-manual "(message)Various Message Variables")
1266 :type 'symbol)
1267
1268 (defcustom message-dont-reply-to-names
1269 (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
1270 "*Addresses to prune when doing wide replies.
1271 This can be a regexp or a list of regexps. Also, a value of nil means
1272 exclude your own user name only."
1273 :version "21.1"
1274 :group 'message
1275 :link '(custom-manual "(message)Wide Reply")
1276 :type '(choice (const :tag "Yourself" nil)
1277 regexp
1278 (repeat :tag "Regexp List" regexp)))
1279
1280 (defsubst message-dont-reply-to-names ()
1281 (gmm-regexp-concat message-dont-reply-to-names))
1282
1283 (defvar message-shoot-gnksa-feet nil
1284 "*A list of GNKSA feet you are allowed to shoot.
1285 Gnus gives you all the opportunity you could possibly want for
1286 shooting yourself in the foot. Also, Gnus allows you to shoot the
1287 feet of Good Net-Keeping Seal of Approval. The following are foot
1288 candidates:
1289 `empty-article' Allow you to post an empty article;
1290 `quoted-text-only' Allow you to post quoted text only;
1291 `multiple-copies' Allow you to post multiple copies;
1292 `cancel-messages' Allow you to cancel or supersede messages from
1293 your other email addresses.")
1294
1295 (defsubst message-gnksa-enable-p (feature)
1296 (or (not (listp message-shoot-gnksa-feet))
1297 (memq feature message-shoot-gnksa-feet)))
1298
1299 (defcustom message-hidden-headers '("^References:" "^Face:" "^X-Face:"
1300 "^X-Draft-From:")
1301 "Regexp of headers to be hidden when composing new messages.
1302 This can also be a list of regexps to match headers. Or a list
1303 starting with `not' and followed by regexps."
1304 :version "22.1"
1305 :group 'message
1306 :link '(custom-manual "(message)Message Headers")
1307 :type '(choice
1308 :format "%{%t%}: %[Value Type%] %v"
1309 (regexp :menu-tag "regexp" :format "regexp\n%t: %v")
1310 (repeat :menu-tag "(regexp ...)" :format "(regexp ...)\n%v%i"
1311 (regexp :format "%t: %v"))
1312 (cons :menu-tag "(not regexp ...)" :format "(not regexp ...)\n%v"
1313 (const not)
1314 (repeat :format "%v%i"
1315 (regexp :format "%t: %v")))))
1316
1317 (defcustom message-cite-articles-with-x-no-archive t
1318 "If non-nil, cite text from articles that has X-No-Archive set."
1319 :group 'message
1320 :type 'boolean)
1321
1322 ;;; Internal variables.
1323 ;;; Well, not really internal.
1324
1325 (defvar message-mode-syntax-table
1326 (let ((table (copy-syntax-table text-mode-syntax-table)))
1327 (modify-syntax-entry ?% ". " table)
1328 (modify-syntax-entry ?> ". " table)
1329 (modify-syntax-entry ?< ". " table)
1330 table)
1331 "Syntax table used while in Message mode.")
1332
1333 (defface message-header-to
1334 '((((class color)
1335 (background dark))
1336 (:foreground "DarkOliveGreen1" :bold t))
1337 (((class color)
1338 (background light))
1339 (:foreground "MidnightBlue" :bold t))
1340 (t
1341 (:bold t :italic t)))
1342 "Face used for displaying From headers."
1343 :group 'message-faces)
1344 ;; backward-compatibility alias
1345 (put 'message-header-to-face 'face-alias 'message-header-to)
1346 (put 'message-header-to-face 'obsolete-face "22.1")
1347
1348 (defface message-header-cc
1349 '((((class color)
1350 (background dark))
1351 (:foreground "chartreuse1" :bold t))
1352 (((class color)
1353 (background light))
1354 (:foreground "MidnightBlue"))
1355 (t
1356 (:bold t)))
1357 "Face used for displaying Cc headers."
1358 :group 'message-faces)
1359 ;; backward-compatibility alias
1360 (put 'message-header-cc-face 'face-alias 'message-header-cc)
1361 (put 'message-header-cc-face 'obsolete-face "22.1")
1362
1363 (defface message-header-subject
1364 '((((class color)
1365 (background dark))
1366 (:foreground "OliveDrab1"))
1367 (((class color)
1368 (background light))
1369 (:foreground "navy blue" :bold t))
1370 (t
1371 (:bold t)))
1372 "Face used for displaying subject headers."
1373 :group 'message-faces)
1374 ;; backward-compatibility alias
1375 (put 'message-header-subject-face 'face-alias 'message-header-subject)
1376 (put 'message-header-subject-face 'obsolete-face "22.1")
1377
1378 (defface message-header-newsgroups
1379 '((((class color)
1380 (background dark))
1381 (:foreground "yellow" :bold t :italic t))
1382 (((class color)
1383 (background light))
1384 (:foreground "blue4" :bold t :italic t))
1385 (t
1386 (:bold t :italic t)))
1387 "Face used for displaying newsgroups headers."
1388 :group 'message-faces)
1389 ;; backward-compatibility alias
1390 (put 'message-header-newsgroups-face 'face-alias 'message-header-newsgroups)
1391 (put 'message-header-newsgroups-face 'obsolete-face "22.1")
1392
1393 (defface message-header-other
1394 '((((class color)
1395 (background dark))
1396 (:foreground "VioletRed1"))
1397 (((class color)
1398 (background light))
1399 (:foreground "steel blue"))
1400 (t
1401 (:bold t :italic t)))
1402 "Face used for displaying newsgroups headers."
1403 :group 'message-faces)
1404 ;; backward-compatibility alias
1405 (put 'message-header-other-face 'face-alias 'message-header-other)
1406 (put 'message-header-other-face 'obsolete-face "22.1")
1407
1408 (defface message-header-name
1409 '((((class color)
1410 (background dark))
1411 (:foreground "green"))
1412 (((class color)
1413 (background light))
1414 (:foreground "cornflower blue"))
1415 (t
1416 (:bold t)))
1417 "Face used for displaying header names."
1418 :group 'message-faces)
1419 ;; backward-compatibility alias
1420 (put 'message-header-name-face 'face-alias 'message-header-name)
1421 (put 'message-header-name-face 'obsolete-face "22.1")
1422
1423 (defface message-header-xheader
1424 '((((class color)
1425 (background dark))
1426 (:foreground "DeepSkyBlue1"))
1427 (((class color)
1428 (background light))
1429 (:foreground "blue"))
1430 (t
1431 (:bold t)))
1432 "Face used for displaying X-Header headers."
1433 :group 'message-faces)
1434 ;; backward-compatibility alias
1435 (put 'message-header-xheader-face 'face-alias 'message-header-xheader)
1436 (put 'message-header-xheader-face 'obsolete-face "22.1")
1437
1438 (defface message-separator
1439 '((((class color)
1440 (background dark))
1441 (:foreground "LightSkyBlue1"))
1442 (((class color)
1443 (background light))
1444 (:foreground "brown"))
1445 (t
1446 (:bold t)))
1447 "Face used for displaying the separator."
1448 :group 'message-faces)
1449 ;; backward-compatibility alias
1450 (put 'message-separator-face 'face-alias 'message-separator)
1451 (put 'message-separator-face 'obsolete-face "22.1")
1452
1453 (defface message-cited-text
1454 '((((class color)
1455 (background dark))
1456 (:foreground "LightPink1"))
1457 (((class color)
1458 (background light))
1459 (:foreground "red"))
1460 (t
1461 (:bold t)))
1462 "Face used for displaying cited text names."
1463 :group 'message-faces)
1464 ;; backward-compatibility alias
1465 (put 'message-cited-text-face 'face-alias 'message-cited-text)
1466 (put 'message-cited-text-face 'obsolete-face "22.1")
1467
1468 (defface message-mml
1469 '((((class color)
1470 (background dark))
1471 (:foreground "MediumSpringGreen"))
1472 (((class color)
1473 (background light))
1474 (:foreground "ForestGreen"))
1475 (t
1476 (:bold t)))
1477 "Face used for displaying MML."
1478 :group 'message-faces)
1479 ;; backward-compatibility alias
1480 (put 'message-mml-face 'face-alias 'message-mml)
1481 (put 'message-mml-face 'obsolete-face "22.1")
1482
1483 (defun message-font-lock-make-header-matcher (regexp)
1484 (let ((form
1485 `(lambda (limit)
1486 (let ((start (point)))
1487 (save-restriction
1488 (widen)
1489 (goto-char (point-min))
1490 (if (re-search-forward
1491 (concat "^" (regexp-quote mail-header-separator) "$")
1492 nil t)
1493 (setq limit (min limit (match-beginning 0))))
1494 (goto-char start))
1495 (and (< start limit)
1496 (re-search-forward ,regexp limit t))))))
1497 (if (featurep 'bytecomp)
1498 (byte-compile form)
1499 form)))
1500
1501 (defvar message-font-lock-keywords
1502 (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
1503 `((,(message-font-lock-make-header-matcher
1504 (concat "^\\([Tt]o:\\)" content))
1505 (1 'message-header-name)
1506 (2 'message-header-to nil t))
1507 (,(message-font-lock-make-header-matcher
1508 (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content))
1509 (1 'message-header-name)
1510 (2 'message-header-cc nil t))
1511 (,(message-font-lock-make-header-matcher
1512 (concat "^\\([Ss]ubject:\\)" content))
1513 (1 'message-header-name)
1514 (2 'message-header-subject nil t))
1515 (,(message-font-lock-make-header-matcher
1516 (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
1517 (1 'message-header-name)
1518 (2 'message-header-newsgroups nil t))
1519 (,(message-font-lock-make-header-matcher
1520 (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
1521 (1 'message-header-name)
1522 (2 'message-header-xheader))
1523 (,(message-font-lock-make-header-matcher
1524 (concat "^\\([A-Z][^: \n\t]+:\\)" content))
1525 (1 'message-header-name)
1526 (2 'message-header-other nil t))
1527 ,@(if (and mail-header-separator
1528 (not (equal mail-header-separator "")))
1529 `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1530 1 'message-separator))
1531 nil)
1532 ((lambda (limit)
1533 (re-search-forward (concat "^\\("
1534 message-cite-prefix-regexp
1535 "\\).*")
1536 limit t))
1537 (0 'message-cited-text))
1538 ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>"
1539 (0 'message-mml))))
1540 "Additional expressions to highlight in Message mode.")
1541
1542
1543 ;; XEmacs does it like this. For Emacs, we have to set the
1544 ;; `font-lock-defaults' buffer-local variable.
1545 (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
1546
1547 (defvar message-face-alist
1548 '((bold . message-bold-region)
1549 (underline . underline-region)
1550 (default . (lambda (b e)
1551 (message-unbold-region b e)
1552 (ununderline-region b e))))
1553 "Alist of mail and news faces for facemenu.
1554 The cdr of each entry is a function for applying the face to a region.")
1555
1556 (defcustom message-send-hook nil
1557 "Hook run before sending messages.
1558 This hook is run quite early when sending."
1559 :group 'message-various
1560 :options '(ispell-message)
1561 :link '(custom-manual "(message)Various Message Variables")
1562 :type 'hook)
1563
1564 (defcustom message-send-mail-hook nil
1565 "Hook run before sending mail messages.
1566 This hook is run very late -- just before the message is sent as
1567 mail."
1568 :group 'message-various
1569 :link '(custom-manual "(message)Various Message Variables")
1570 :type 'hook)
1571
1572 (defcustom message-send-news-hook nil
1573 "Hook run before sending news messages.
1574 This hook is run very late -- just before the message is sent as
1575 news."
1576 :group 'message-various
1577 :link '(custom-manual "(message)Various Message Variables")
1578 :type 'hook)
1579
1580 (defcustom message-sent-hook nil
1581 "Hook run after sending messages."
1582 :group 'message-various
1583 :type 'hook)
1584
1585 (defvar message-send-coding-system 'binary
1586 "Coding system to encode outgoing mail.")
1587
1588 (defvar message-draft-coding-system
1589 mm-auto-save-coding-system
1590 "*Coding system to compose mail.
1591 If you'd like to make it possible to share draft files between XEmacs
1592 and Emacs, you may use `iso-2022-7bit' for this value at your own risk.
1593 Note that the coding-system `iso-2022-7bit' isn't suitable to all data.")
1594
1595 (defcustom message-send-mail-partially-limit nil
1596 "The limitation of messages sent as message/partial.
1597 The lower bound of message size in characters, beyond which the message
1598 should be sent in several parts. If it is nil, the size is unlimited."
1599 :version "24.1"
1600 :group 'message-buffers
1601 :link '(custom-manual "(message)Mail Variables")
1602 :type '(choice (const :tag "unlimited" nil)
1603 (integer 1000000)))
1604
1605 (defcustom message-alternative-emails nil
1606 "*Regexp matching alternative email addresses.
1607 The first address in the To, Cc or From headers of the original
1608 article matching this variable is used as the From field of
1609 outgoing messages.
1610
1611 This variable has precedence over posting styles and anything that runs
1612 off `message-setup-hook'."
1613 :group 'message-headers
1614 :link '(custom-manual "(message)Message Headers")
1615 :type '(choice (const :tag "Always use primary" nil)
1616 regexp))
1617
1618 (defcustom message-hierarchical-addresses nil
1619 "A list of hierarchical mail address definitions.
1620
1621 Inside each entry, the first address is the \"top\" address, and
1622 subsequent addresses are subaddresses; this is used to indicate that
1623 mail sent to the first address will automatically be delivered to the
1624 subaddresses. So if the first address appears in the recipient list
1625 for a message, the subaddresses will be removed (if present) before
1626 the mail is sent. All addresses in this structure should be
1627 downcased."
1628 :version "22.1"
1629 :group 'message-headers
1630 :type '(repeat (repeat string)))
1631
1632 (defcustom message-mail-user-agent nil
1633 "Like `mail-user-agent'.
1634 Except if it is nil, use Gnus native MUA; if it is t, use
1635 `mail-user-agent'."
1636 :version "22.1"
1637 :type '(radio (const :tag "Gnus native"
1638 :format "%t\n"
1639 nil)
1640 (const :tag "`mail-user-agent'"
1641 :format "%t\n"
1642 t)
1643 (function-item :tag "Default Emacs mail"
1644 :format "%t\n"
1645 sendmail-user-agent)
1646 (function-item :tag "Emacs interface to MH"
1647 :format "%t\n"
1648 mh-e-user-agent)
1649 (function :tag "Other"))
1650 :version "21.1"
1651 :group 'message)
1652
1653 (defcustom message-wide-reply-confirm-recipients nil
1654 "Whether to confirm a wide reply to multiple email recipients.
1655 If this variable is nil, don't ask whether to reply to all recipients.
1656 If this variable is non-nil, pose the question \"Reply to all
1657 recipients?\" before a wide reply to multiple recipients. If the user
1658 answers yes, reply to all recipients as usual. If the user answers
1659 no, only reply back to the author."
1660 :version "22.1"
1661 :group 'message-headers
1662 :link '(custom-manual "(message)Wide Reply")
1663 :type 'boolean)
1664
1665 (defcustom message-user-fqdn nil
1666 "*Domain part of Message-Ids."
1667 :version "22.1"
1668 :group 'message-headers
1669 :link '(custom-manual "(message)News Headers")
1670 :type '(radio (const :format "%v " nil)
1671 (string :format "FQDN: %v")))
1672
1673 (defcustom message-use-idna (and (condition-case nil (require 'idna)
1674 (file-error))
1675 (mm-coding-system-p 'utf-8)
1676 (executable-find idna-program)
1677 (string= (idna-to-ascii "räksmörgås")
1678 "xn--rksmrgs-5wao1o")
1679 t)
1680 "Whether to encode non-ASCII in domain names into ASCII according to IDNA.
1681 GNU Libidn, and in particular the elisp package \"idna.el\" and
1682 the external program \"idn\", must be installed for this
1683 functionality to work."
1684 :version "22.1"
1685 :group 'message-headers
1686 :link '(custom-manual "(message)IDNA")
1687 :type '(choice (const :tag "Ask" ask)
1688 (const :tag "Never" nil)
1689 (const :tag "Always" t)))
1690
1691 (defcustom message-generate-hashcash (if (executable-find "hashcash") 'opportunistic)
1692 "*Whether to generate X-Hashcash: headers.
1693 If t, always generate hashcash headers. If `opportunistic',
1694 only generate hashcash headers if it can be done without the user
1695 waiting (i.e., only asynchronously).
1696
1697 You must have the \"hashcash\" binary installed, see `hashcash-path'."
1698 :version "24.1"
1699 :group 'message-headers
1700 :link '(custom-manual "(message)Mail Headers")
1701 :type '(choice (const :tag "Always" t)
1702 (const :tag "Never" nil)
1703 (const :tag "Opportunistic" opportunistic)))
1704
1705 ;;; Internal variables.
1706
1707 (defvar message-sending-message "Sending...")
1708 (defvar message-buffer-list nil)
1709 (defvar message-this-is-news nil)
1710 (defvar message-this-is-mail nil)
1711 (defvar message-draft-article nil)
1712 (defvar message-mime-part nil)
1713 (defvar message-posting-charset nil)
1714 (defvar message-inserted-headers nil)
1715 (defvar message-inhibit-ecomplete nil)
1716
1717 ;; Byte-compiler warning
1718 (defvar gnus-active-hashtb)
1719 (defvar gnus-read-active-file)
1720
1721 ;;; Regexp matching the delimiter of messages in UNIX mail format
1722 ;;; (UNIX From lines), minus the initial ^. It should be a copy
1723 ;;; of rmail.el's rmail-unix-mail-delimiter.
1724 (defvar message-unix-mail-delimiter
1725 (let ((time-zone-regexp
1726 (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
1727 "\\|[-+]?[0-9][0-9][0-9][0-9]"
1728 "\\|"
1729 "\\) *")))
1730 (concat
1731 "From "
1732
1733 ;; Many things can happen to an RFC 822 mailbox before it is put into
1734 ;; a `From' line. The leading phrase can be stripped, e.g.
1735 ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g.
1736 ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF
1737 ;; can be removed, e.g.
1738 ;; From: joe@y.z (Joe K
1739 ;; User)
1740 ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and
1741 ;; From: Joe User
1742 ;; <joe@y.z>
1743 ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.
1744 ;; The mailbox can be removed or be replaced by white space, e.g.
1745 ;; From: "Joe User"{space}{tab}
1746 ;; <joe@y.z>
1747 ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996',
1748 ;; where {space} and {tab} represent the Ascii space and tab characters.
1749 ;; We want to match the results of any of these manglings.
1750 ;; The following regexp rejects names whose first characters are
1751 ;; obviously bogus, but after that anything goes.
1752 "\\([^\0-\b\n-\r\^?].*\\)?"
1753
1754 ;; The time the message was sent.
1755 "\\([^\0-\r \^?]+\\) +" ; day of the week
1756 "\\([^\0-\r \^?]+\\) +" ; month
1757 "\\([0-3]?[0-9]\\) +" ; day of month
1758 "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
1759
1760 ;; Perhaps a time zone, specified by an abbreviation, or by a
1761 ;; numeric offset.
1762 time-zone-regexp
1763
1764 ;; The year.
1765 " \\([0-9][0-9]+\\) *"
1766
1767 ;; On some systems the time zone can appear after the year, too.
1768 time-zone-regexp
1769
1770 ;; Old uucp cruft.
1771 "\\(remote from .*\\)?"
1772
1773 "\n"))
1774 "Regexp matching the delimiter of messages in UNIX mail format.")
1775
1776 (defvar message-unsent-separator
1777 (concat "^ *---+ +Unsent message follows +---+ *$\\|"
1778 "^ *---+ +Returned message +---+ *$\\|"
1779 "^Start of returned message$\\|"
1780 "^ *---+ +Original message +---+ *$\\|"
1781 "^ *--+ +begin message +--+ *$\\|"
1782 "^ *---+ +Original message follows +---+ *$\\|"
1783 "^ *---+ +Undelivered message follows +---+ *$\\|"
1784 "^------ This is a copy of the message, including all the headers. ------ *$\\|"
1785 "^|? *---+ +Message text follows: +---+ *|?$")
1786 "A regexp that matches the separator before the text of a failed message.")
1787
1788 (defvar message-field-fillers
1789 '((To message-fill-field-address)
1790 (Cc message-fill-field-address)
1791 (From message-fill-field-address))
1792 "Alist of header names/filler functions.")
1793
1794 (defvar message-header-format-alist
1795 `((From)
1796 (Newsgroups)
1797 (To)
1798 (Cc)
1799 (Subject)
1800 (In-Reply-To)
1801 (Fcc)
1802 (Bcc)
1803 (Date)
1804 (Organization)
1805 (Distribution)
1806 (Lines)
1807 (Expires)
1808 (Message-ID)
1809 (References . message-shorten-references)
1810 (User-Agent))
1811 "Alist used for formatting headers.")
1812
1813 (defvar message-options nil
1814 "Some saved answers when sending message.")
1815
1816 (defvar message-send-mail-real-function nil
1817 "Internal send mail function.")
1818
1819 (defvar message-bogus-system-names "^localhost\\.\\|\\.local$"
1820 "The regexp of bogus system names.")
1821
1822 (defcustom message-valid-fqdn-regexp
1823 (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
1824 ;; valid TLDs:
1825 "\\([a-z][a-z]\\|" ;; two letter country TDLs
1826 "aero\\|arpa\\|bitnet\\|biz\\|bofh\\|"
1827 "cat\\|com\\|coop\\|edu\\|gov\\|"
1828 "info\\|int\\|jobs\\|"
1829 "mil\\|mobi\\|museum\\|name\\|net\\|"
1830 "org\\|pro\\|travel\\|uucp\\)")
1831 ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
1832 ;; http://en.wikipedia.org/wiki/GTLD
1833 ;; `in the process of being approved': .asia .post .tel .sex
1834 ;; "dead" nato bitnet uucp
1835 "Regular expression that matches a valid FQDN."
1836 ;; see also: gnus-button-valid-fqdn-regexp
1837 :version "22.1"
1838 :group 'message-headers
1839 :type 'regexp)
1840
1841 (autoload 'gnus-alive-p "gnus-util")
1842 (autoload 'gnus-delay-article "gnus-delay")
1843 (autoload 'gnus-extract-address-components "gnus-util")
1844 (autoload 'gnus-find-method-for-group "gnus")
1845 (autoload 'gnus-group-decoded-name "gnus-group")
1846 (autoload 'gnus-group-name-charset "gnus-group")
1847 (autoload 'gnus-group-name-decode "gnus-group")
1848 (autoload 'gnus-groups-from-server "gnus")
1849 (autoload 'gnus-make-local-hook "gnus-util")
1850 (autoload 'gnus-open-server "gnus-int")
1851 (autoload 'gnus-output-to-mail "gnus-util")
1852 (autoload 'gnus-output-to-rmail "gnus-util")
1853 (autoload 'gnus-request-post "gnus-int")
1854 (autoload 'gnus-select-frame-set-input-focus "gnus-util")
1855 (autoload 'gnus-server-string "gnus")
1856 (autoload 'idna-to-ascii "idna")
1857 (autoload 'message-setup-toolbar "messagexmas")
1858 (autoload 'mh-new-draft-name "mh-comp")
1859 (autoload 'mh-send-letter "mh-comp")
1860 (autoload 'nndraft-request-associate-buffer "nndraft")
1861 (autoload 'nndraft-request-expire-articles "nndraft")
1862 (autoload 'nnvirtual-find-group-art "nnvirtual")
1863 (autoload 'rmail-dont-reply-to "mail-utils")
1864 (autoload 'rmail-msg-is-pruned "rmail")
1865 (autoload 'rmail-output "rmailout")
1866
1867 \f
1868
1869 ;;;
1870 ;;; Utility functions.
1871 ;;;
1872
1873 (defmacro message-y-or-n-p (question show &rest text)
1874 "Ask QUESTION, displaying remaining args in a temporary buffer if SHOW."
1875 `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
1876
1877 (defmacro message-delete-line (&optional n)
1878 "Delete the current line (and the next N lines)."
1879 `(delete-region (progn (beginning-of-line) (point))
1880 (progn (forward-line ,(or n 1)) (point))))
1881
1882 (defun message-mark-active-p ()
1883 "Non-nil means the mark and region are currently active in this buffer."
1884 mark-active)
1885
1886 (defun message-unquote-tokens (elems)
1887 "Remove double quotes (\") from strings in list ELEMS."
1888 (mapcar (lambda (item)
1889 (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)
1890 (setq item (concat (match-string 1 item)
1891 (match-string 2 item))))
1892 item)
1893 elems))
1894
1895 (defun message-tokenize-header (header &optional separator)
1896 "Split HEADER into a list of header elements.
1897 SEPARATOR is a string of characters to be used as separators. \",\"
1898 is used by default."
1899 (if (not header)
1900 nil
1901 (let ((regexp (format "[%s]+" (or separator ",")))
1902 (first t)
1903 beg quoted elems paren)
1904 (with-temp-buffer
1905 (mm-enable-multibyte)
1906 (setq beg (point-min))
1907 (insert header)
1908 (goto-char (point-min))
1909 (while (not (eobp))
1910 (if first
1911 (setq first nil)
1912 (forward-char 1))
1913 (cond ((and (> (point) beg)
1914 (or (eobp)
1915 (and (looking-at regexp)
1916 (not quoted)
1917 (not paren))))
1918 (push (buffer-substring beg (point)) elems)
1919 (setq beg (match-end 0)))
1920 ((eq (char-after) ?\")
1921 (setq quoted (not quoted)))
1922 ((and (eq (char-after) ?\()
1923 (not quoted))
1924 (setq paren t))
1925 ((and (eq (char-after) ?\))
1926 (not quoted))
1927 (setq paren nil))))
1928 (nreverse elems)))))
1929
1930 (autoload 'nnheader-insert-file-contents "nnheader")
1931
1932 (defun message-mail-file-mbox-p (file)
1933 "Say whether FILE looks like a Unix mbox file."
1934 (when (and (file-exists-p file)
1935 (file-readable-p file)
1936 (file-regular-p file))
1937 (with-temp-buffer
1938 (nnheader-insert-file-contents file)
1939 (goto-char (point-min))
1940 (looking-at message-unix-mail-delimiter))))
1941
1942 (defun message-fetch-field (header &optional not-all)
1943 "The same as `mail-fetch-field', only remove all newlines.
1944 The buffer is expected to be narrowed to just the header of the message;
1945 see `message-narrow-to-headers-or-head'."
1946 (let* ((inhibit-point-motion-hooks t)
1947 (value (mail-fetch-field header nil (not not-all))))
1948 (when value
1949 (while (string-match "\n[\t ]+" value)
1950 (setq value (replace-match " " t t value)))
1951 value)))
1952
1953 (defun message-field-value (header &optional not-all)
1954 "The same as `message-fetch-field', only narrow to the headers first."
1955 (save-excursion
1956 (save-restriction
1957 (message-narrow-to-headers-or-head)
1958 (message-fetch-field header not-all))))
1959
1960 (defun message-narrow-to-field ()
1961 "Narrow the buffer to the header on the current line."
1962 (beginning-of-line)
1963 (while (looking-at "[ \t]")
1964 (forward-line -1))
1965 (narrow-to-region
1966 (point)
1967 (progn
1968 (forward-line 1)
1969 (if (re-search-forward "^[^ \n\t]" nil t)
1970 (point-at-bol)
1971 (point-max))))
1972 (goto-char (point-min)))
1973
1974 (defun message-add-header (&rest headers)
1975 "Add the HEADERS to the message header, skipping those already present."
1976 (while headers
1977 (let (hclean)
1978 (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers))
1979 (error "Invalid header `%s'" (car headers)))
1980 (setq hclean (match-string 1 (car headers)))
1981 (save-restriction
1982 (message-narrow-to-headers)
1983 (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
1984 (goto-char (point-max))
1985 (if (string-match "\n$" (car headers))
1986 (insert (car headers))
1987 (insert (car headers) ?\n)))))
1988 (setq headers (cdr headers))))
1989
1990 (defmacro message-with-reply-buffer (&rest forms)
1991 "Evaluate FORMS in the reply buffer, if it exists."
1992 `(when (and (bufferp message-reply-buffer)
1993 (buffer-name message-reply-buffer))
1994 (with-current-buffer message-reply-buffer
1995 ,@forms)))
1996
1997 (put 'message-with-reply-buffer 'lisp-indent-function 0)
1998 (put 'message-with-reply-buffer 'edebug-form-spec '(body))
1999
2000 (defun message-fetch-reply-field (header)
2001 "Fetch field HEADER from the message we're replying to."
2002 (message-with-reply-buffer
2003 (save-restriction
2004 (mail-narrow-to-head)
2005 (message-fetch-field header))))
2006
2007 (defun message-strip-list-identifiers (subject)
2008 "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT."
2009 (require 'gnus-sum) ; for gnus-list-identifiers
2010 (let ((regexp (if (stringp gnus-list-identifiers)
2011 gnus-list-identifiers
2012 (mapconcat 'identity gnus-list-identifiers " *\\|"))))
2013 (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
2014 " *\\)\\)+\\(Re: +\\)?\\)") subject)
2015 (concat (substring subject 0 (match-beginning 1))
2016 (or (match-string 3 subject)
2017 (match-string 5 subject))
2018 (substring subject
2019 (match-end 1)))
2020 subject)))
2021
2022 (defun message-strip-subject-re (subject)
2023 "Remove \"Re:\" from subject lines in string SUBJECT."
2024 (if (string-match message-subject-re-regexp subject)
2025 (substring subject (match-end 0))
2026 subject))
2027
2028 (defcustom message-replacement-char "."
2029 "Replacement character used instead of unprintable or not decodable chars."
2030 :group 'message-various
2031 :version "22.1" ;; Gnus 5.10.9
2032 :type '(choice string
2033 (const ".")
2034 (const "?")))
2035
2036 ;; FIXME: We also should call `message-strip-subject-encoded-words'
2037 ;; when forwarding. Probably in `message-make-forward-subject' and
2038 ;; `message-forward-make-body'.
2039
2040 (defun message-strip-subject-encoded-words (subject)
2041 "Fix non-decodable words in SUBJECT."
2042 ;; Cf. `gnus-simplify-subject-fully'.
2043 (let* ((case-fold-search t)
2044 (replacement-chars (format "[%s%s%s]"
2045 message-replacement-char
2046 message-replacement-char
2047 message-replacement-char))
2048 (enc-word-re "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?\\([^?]+\\)\\(\\?=\\)")
2049 cs-string
2050 (have-marker
2051 (with-temp-buffer
2052 (insert subject)
2053 (goto-char (point-min))
2054 (when (re-search-forward enc-word-re nil t)
2055 (setq cs-string (match-string 1)))))
2056 cs-coding q-or-b word-beg word-end)
2057 (if (or (not have-marker) ;; No encoded word found...
2058 ;; ... or double encoding was correct:
2059 (and (stringp cs-string)
2060 (setq cs-string (downcase cs-string))
2061 (mm-coding-system-p (intern cs-string))
2062 (not (prog1
2063 (y-or-n-p
2064 (format "\
2065 Decoded Subject \"%s\"
2066 contains a valid encoded word. Decode again? "
2067 subject))
2068 (setq cs-coding (intern cs-string))))))
2069 subject
2070 (with-temp-buffer
2071 (insert subject)
2072 (goto-char (point-min))
2073 (while (re-search-forward enc-word-re nil t)
2074 (setq cs-string (downcase (match-string 1))
2075 q-or-b (match-string 2)
2076 word-beg (match-beginning 0)
2077 word-end (match-end 0))
2078 (setq cs-coding
2079 (if (mm-coding-system-p (intern cs-string))
2080 (setq cs-coding (intern cs-string))
2081 nil))
2082 ;; No double encoded subject? => bogus charset.
2083 (unless cs-coding
2084 (setq cs-coding
2085 (mm-read-coding-system
2086 (format "\
2087 Decoded Subject \"%s\"
2088 contains an encoded word. The charset `%s' is unknown or invalid.
2089 Hit RET to replace non-decodable characters with \"%s\" or enter replacement
2090 charset: "
2091 subject cs-string message-replacement-char)))
2092 (if cs-coding
2093 (replace-match (concat "=?" (symbol-name cs-coding)
2094 "?\\2?\\3\\4\\5"))
2095 (save-excursion
2096 (goto-char word-beg)
2097 (re-search-forward "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?" word-end t)
2098 (replace-match "")
2099 ;; QP or base64
2100 (if (string-match "\\`Q\\'" q-or-b)
2101 ;; QP
2102 (progn
2103 (message "Replacing non-decodable characters with \"%s\"."
2104 message-replacement-char)
2105 (while (re-search-forward "\\(=[A-F0-9][A-F0-9]\\)+"
2106 word-end t)
2107 (replace-match message-replacement-char)))
2108 ;; base64
2109 (message "Replacing non-decodable characters with \"%s\"."
2110 replacement-chars)
2111 (re-search-forward "[^?]+" word-end t)
2112 (replace-match replacement-chars))
2113 (re-search-forward "\\?=")
2114 (replace-match "")))))
2115 (rfc2047-decode-region (point-min) (point-max))
2116 (buffer-string)))))
2117
2118 ;;; Start of functions adopted from `message-utils.el'.
2119
2120 (defun message-strip-subject-trailing-was (subject)
2121 "Remove trailing \"(was: <old subject>)\" from SUBJECT lines.
2122 Leading \"Re: \" is not stripped by this function. Use the function
2123 `message-strip-subject-re' for this."
2124 (let* ((query message-subject-trailing-was-query)
2125 (new) (found))
2126 (setq found
2127 (string-match
2128 (if (eq query 'ask)
2129 message-subject-trailing-was-ask-regexp
2130 message-subject-trailing-was-regexp)
2131 subject))
2132 (if found
2133 (setq new (substring subject 0 (match-beginning 0))))
2134 (if (or (not found) (eq query nil))
2135 subject
2136 (if (eq query 'ask)
2137 (if (message-y-or-n-p
2138 "Strip `(was: <old subject>)' in subject? " t
2139 (concat
2140 "Strip `(was: <old subject>)' in subject "
2141 "and use the new one instead?\n\n"
2142 "Current subject is: \""
2143 subject "\"\n\n"
2144 "New subject would be: \""
2145 new "\"\n\n"
2146 "See the variable `message-subject-trailing-was-query' "
2147 "to get rid of this query."
2148 ))
2149 new subject)
2150 new))))
2151
2152 ;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/
2153
2154 (defun message-change-subject (new-subject)
2155 "Ask for NEW-SUBJECT header, append (was: <Old Subject>)."
2156 (interactive
2157 (list
2158 (read-from-minibuffer "New subject: ")))
2159 (cond ((and (not (or (null new-subject) ; new subject not empty
2160 (zerop (string-width new-subject))
2161 (string-match "^[ \t]*$" new-subject))))
2162 (save-excursion
2163 (let ((old-subject
2164 (save-restriction
2165 (message-narrow-to-headers)
2166 (message-fetch-field "Subject"))))
2167 (cond ((not old-subject)
2168 (error "No current subject"))
2169 ((not (string-match
2170 (concat "^[ \t]*"
2171 (regexp-quote new-subject)
2172 " \t]*$")
2173 old-subject)) ; yes, it really is a new subject
2174 ;; delete eventual Re: prefix
2175 (setq old-subject
2176 (message-strip-subject-re old-subject))
2177 (message-goto-subject)
2178 (message-delete-line)
2179 (insert (concat "Subject: "
2180 new-subject
2181 " (was: "
2182 old-subject ")\n")))))))))
2183
2184 (defun message-mark-inserted-region (beg end &optional verbatim)
2185 "Mark some region in the current article with enclosing tags.
2186 See `message-mark-insert-begin' and `message-mark-insert-end'.
2187 If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")."
2188 (interactive "r\nP")
2189 (save-excursion
2190 ;; add to the end of the region first, otherwise end would be invalid
2191 (goto-char end)
2192 (insert (if verbatim "#v-\n" message-mark-insert-end))
2193 (goto-char beg)
2194 (insert (if verbatim "#v+\n" message-mark-insert-begin))))
2195
2196 (defun message-mark-insert-file (file &optional verbatim)
2197 "Insert FILE at point, marking it with enclosing tags.
2198 See `message-mark-insert-begin' and `message-mark-insert-end'.
2199 If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")."
2200 (interactive "fFile to insert: \nP")
2201 ;; reverse insertion to get correct result.
2202 (let ((p (point)))
2203 (insert (if verbatim "#v-\n" message-mark-insert-end))
2204 (goto-char p)
2205 (insert-file-contents file)
2206 (goto-char p)
2207 (insert (if verbatim "#v+\n" message-mark-insert-begin))))
2208
2209 (defun message-add-archive-header ()
2210 "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
2211 The note can be customized using `message-archive-note'. When called with a
2212 prefix argument, ask for a text to insert. If you don't want the note in the
2213 body, set `message-archive-note' to nil."
2214 (interactive)
2215 (if current-prefix-arg
2216 (setq message-archive-note
2217 (read-from-minibuffer "Reason for No-Archive: "
2218 (cons message-archive-note 0))))
2219 (save-excursion
2220 (if (message-goto-signature)
2221 (re-search-backward message-signature-separator))
2222 (when message-archive-note
2223 (insert message-archive-note)
2224 (newline))
2225 (message-add-header message-archive-header)
2226 (message-sort-headers)))
2227
2228 (defun message-cross-post-followup-to-header (target-group)
2229 "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
2230 With prefix-argument just set Follow-Up, don't cross-post."
2231 (interactive
2232 (list ; Completion based on Gnus
2233 (completing-read "Followup To: "
2234 (if (boundp 'gnus-newsrc-alist)
2235 gnus-newsrc-alist)
2236 nil nil '("poster" . 0)
2237 (if (boundp 'gnus-group-history)
2238 'gnus-group-history))))
2239 (message-remove-header "Follow[Uu]p-[Tt]o" t)
2240 (message-goto-newsgroups)
2241 (beginning-of-line)
2242 ;; if we already did a crosspost before, kill old target
2243 (if (and message-cross-post-old-target
2244 (re-search-forward
2245 (regexp-quote (concat "," message-cross-post-old-target))
2246 nil t))
2247 (replace-match ""))
2248 ;; unless (followup is to poster or user explicitly asked not
2249 ;; to cross-post, or target-group is already in Newsgroups)
2250 ;; add target-group to Newsgroups line.
2251 (cond ((and (or
2252 ;; def: cross-post, req:no
2253 (and message-cross-post-default (not current-prefix-arg))
2254 ;; def: no-cross-post, req:yes
2255 (and (not message-cross-post-default) current-prefix-arg))
2256 (not (string-match "poster" target-group))
2257 (not (string-match (regexp-quote target-group)
2258 (message-fetch-field "Newsgroups"))))
2259 (end-of-line)
2260 (insert (concat "," target-group))))
2261 (end-of-line) ; ensure Followup: comes after Newsgroups:
2262 ;; unless new followup would be identical to Newsgroups line
2263 ;; make a new Followup-To line
2264 (if (not (string-match (concat "^[ \t]*"
2265 target-group
2266 "[ \t]*$")
2267 (message-fetch-field "Newsgroups")))
2268 (insert (concat "\nFollowup-To: " target-group)))
2269 (setq message-cross-post-old-target target-group))
2270
2271 (defun message-cross-post-insert-note (target-group cross-post in-old
2272 old-groups)
2273 "Insert a in message body note about a set Followup or Crosspost.
2274 If there have been previous notes, delete them. TARGET-GROUP specifies the
2275 group to Followup-To. When CROSS-POST is t, insert note about
2276 crossposting. IN-OLD specifies whether TARGET-GROUP is a member of
2277 OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have
2278 been made to before the user asked for a Crosspost."
2279 ;; start scanning body for previous uses
2280 (message-goto-signature)
2281 (let ((head (re-search-backward
2282 (concat "^" mail-header-separator)
2283 nil t))) ; just search in body
2284 (message-goto-signature)
2285 (while (re-search-backward
2286 (concat "^" (regexp-quote message-cross-post-note) ".*")
2287 head t)
2288 (message-delete-line))
2289 (message-goto-signature)
2290 (while (re-search-backward
2291 (concat "^" (regexp-quote message-followup-to-note) ".*")
2292 head t)
2293 (message-delete-line))
2294 ;; insert new note
2295 (if (message-goto-signature)
2296 (re-search-backward message-signature-separator))
2297 (if (or in-old
2298 (not cross-post)
2299 (string-match "^[ \t]*poster[ \t]*$" target-group))
2300 (insert (concat message-followup-to-note target-group "\n"))
2301 (insert (concat message-cross-post-note target-group "\n")))))
2302
2303 (defun message-cross-post-followup-to (target-group)
2304 "Crossposts message and set Followup-To to TARGET-GROUP.
2305 With prefix-argument just set Follow-Up, don't cross-post."
2306 (interactive
2307 (list ; Completion based on Gnus
2308 (completing-read "Followup To: "
2309 (if (boundp 'gnus-newsrc-alist)
2310 gnus-newsrc-alist)
2311 nil nil '("poster" . 0)
2312 (if (boundp 'gnus-group-history)
2313 'gnus-group-history))))
2314 (cond ((not (or (null target-group) ; new subject not empty
2315 (zerop (string-width target-group))
2316 (string-match "^[ \t]*$" target-group)))
2317 (save-excursion
2318 (let* ((old-groups (message-fetch-field "Newsgroups"))
2319 (in-old (string-match
2320 (regexp-quote target-group)
2321 (or old-groups ""))))
2322 ;; check whether target exactly matches old Newsgroups
2323 (cond ((not old-groups)
2324 (error "No current newsgroup"))
2325 ((or (not in-old)
2326 (not (string-match
2327 (concat "^[ \t]*"
2328 (regexp-quote target-group)
2329 "[ \t]*$")
2330 old-groups)))
2331 ;; yes, Newsgroups line must change
2332 (message-cross-post-followup-to-header target-group)
2333 ;; insert note whether we do cross-post or followup-to
2334 (funcall message-cross-post-note-function
2335 target-group
2336 (if (or (and message-cross-post-default
2337 (not current-prefix-arg))
2338 (and (not message-cross-post-default)
2339 current-prefix-arg)) t)
2340 in-old old-groups))))))))
2341
2342 ;;; Reduce To: to Cc: or Bcc: header
2343
2344 (defun message-reduce-to-to-cc ()
2345 "Replace contents of To: header with contents of Cc: or Bcc: header."
2346 (interactive)
2347 (let ((cc-content
2348 (save-restriction (message-narrow-to-headers)
2349 (message-fetch-field "cc")))
2350 (bcc nil))
2351 (if (and (not cc-content)
2352 (setq cc-content
2353 (save-restriction
2354 (message-narrow-to-headers)
2355 (message-fetch-field "bcc"))))
2356 (setq bcc t))
2357 (cond (cc-content
2358 (save-excursion
2359 (message-goto-to)
2360 (message-delete-line)
2361 (insert (concat "To: " cc-content "\n"))
2362 (save-restriction
2363 (message-narrow-to-headers)
2364 (message-remove-header (if bcc
2365 "bcc"
2366 "cc"))))))))
2367
2368 ;;; End of functions adopted from `message-utils.el'.
2369
2370 (defun message-remove-header (header &optional is-regexp first reverse)
2371 "Remove HEADER in the narrowed buffer.
2372 If IS-REGEXP, HEADER is a regular expression.
2373 If FIRST, only remove the first instance of the header.
2374 Return the number of headers removed."
2375 (goto-char (point-min))
2376 (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":")))
2377 (number 0)
2378 (case-fold-search t)
2379 last)
2380 (while (and (not (eobp))
2381 (not last))
2382 (if (if reverse
2383 (not (looking-at regexp))
2384 (looking-at regexp))
2385 (progn
2386 (incf number)
2387 (when first
2388 (setq last t))
2389 (delete-region
2390 (point)
2391 ;; There might be a continuation header, so we have to search
2392 ;; until we find a new non-continuation line.
2393 (progn
2394 (forward-line 1)
2395 (if (re-search-forward "^[^ \t]" nil t)
2396 (goto-char (match-beginning 0))
2397 (point-max)))))
2398 (forward-line 1)
2399 (if (re-search-forward "^[^ \t]" nil t)
2400 (goto-char (match-beginning 0))
2401 (goto-char (point-max)))))
2402 number))
2403
2404 (defun message-remove-first-header (header)
2405 "Remove the first instance of HEADER if there is more than one."
2406 (let ((count 0)
2407 (regexp (concat "^" (regexp-quote header) ":")))
2408 (save-excursion
2409 (goto-char (point-min))
2410 (while (re-search-forward regexp nil t)
2411 (incf count)))
2412 (while (> count 1)
2413 (message-remove-header header nil t)
2414 (decf count))))
2415
2416 (defun message-narrow-to-headers ()
2417 "Narrow the buffer to the head of the message."
2418 (widen)
2419 (narrow-to-region
2420 (goto-char (point-min))
2421 (if (re-search-forward
2422 (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
2423 (match-beginning 0)
2424 (point-max)))
2425 (goto-char (point-min)))
2426
2427 (defun message-narrow-to-head-1 ()
2428 "Like `message-narrow-to-head'. Don't widen."
2429 (narrow-to-region
2430 (goto-char (point-min))
2431 (if (search-forward "\n\n" nil 1)
2432 (1- (point))
2433 (point-max)))
2434 (goto-char (point-min)))
2435
2436 ;; FIXME: clarify diffference: message-narrow-to-head,
2437 ;; message-narrow-to-headers-or-head, message-narrow-to-headers
2438 (defun message-narrow-to-head ()
2439 "Narrow the buffer to the head of the message.
2440 Point is left at the beginning of the narrowed-to region."
2441 (widen)
2442 (message-narrow-to-head-1))
2443
2444 (defun message-narrow-to-headers-or-head ()
2445 "Narrow the buffer to the head of the message."
2446 (widen)
2447 (narrow-to-region
2448 (goto-char (point-min))
2449 (if (re-search-forward (concat "\\(\n\\)\n\\|^\\("
2450 (regexp-quote mail-header-separator)
2451 "\n\\)")
2452 nil t)
2453 (or (match-end 1) (match-beginning 2))
2454 (point-max)))
2455 (goto-char (point-min)))
2456
2457 (defun message-news-p ()
2458 "Say whether the current buffer contains a news message."
2459 (and (not message-this-is-mail)
2460 (or message-this-is-news
2461 (save-excursion
2462 (save-restriction
2463 (message-narrow-to-headers)
2464 (and (message-fetch-field "newsgroups")
2465 (not (message-fetch-field "posted-to"))))))))
2466
2467 (defun message-mail-p ()
2468 "Say whether the current buffer contains a mail message."
2469 (and (not message-this-is-news)
2470 (or message-this-is-mail
2471 (save-excursion
2472 (save-restriction
2473 (message-narrow-to-headers)
2474 (or (message-fetch-field "to")
2475 (message-fetch-field "cc")
2476 (message-fetch-field "bcc")))))))
2477
2478 (defun message-subscribed-p ()
2479 "Say whether we need to insert a MFT header."
2480 (or message-subscribed-regexps
2481 message-subscribed-addresses
2482 message-subscribed-address-file
2483 message-subscribed-address-functions))
2484
2485 (defun message-next-header ()
2486 "Go to the beginning of the next header."
2487 (beginning-of-line)
2488 (or (eobp) (forward-char 1))
2489 (not (if (re-search-forward "^[^ \t]" nil t)
2490 (beginning-of-line)
2491 (goto-char (point-max)))))
2492
2493 (defun message-sort-headers-1 ()
2494 "Sort the buffer as headers using `message-rank' text props."
2495 (goto-char (point-min))
2496 (require 'sort)
2497 (sort-subr
2498 nil 'message-next-header
2499 (lambda ()
2500 (message-next-header)
2501 (unless (bobp)
2502 (forward-char -1)))
2503 (lambda ()
2504 (or (get-text-property (point) 'message-rank)
2505 10000))))
2506
2507 (defun message-sort-headers ()
2508 "Sort the headers of the current message according to `message-header-format-alist'."
2509 (interactive)
2510 (save-excursion
2511 (save-restriction
2512 (let ((max (1+ (length message-header-format-alist)))
2513 rank)
2514 (message-narrow-to-headers)
2515 (while (re-search-forward "^[^ \n]+:" nil t)
2516 (put-text-property
2517 (match-beginning 0) (1+ (match-beginning 0))
2518 'message-rank
2519 (if (setq rank (length (memq (assq (intern (buffer-substring
2520 (match-beginning 0)
2521 (1- (match-end 0))))
2522 message-header-format-alist)
2523 message-header-format-alist)))
2524 (- max rank)
2525 (1+ max)))))
2526 (message-sort-headers-1))))
2527
2528 (defun message-kill-address ()
2529 "Kill the address under point."
2530 (interactive)
2531 (let ((start (point)))
2532 (message-skip-to-next-address)
2533 (kill-region start (point))))
2534
2535
2536 (autoload 'Info-goto-node "info")
2537 (defvar mml2015-use)
2538
2539 (defun message-info (&optional arg)
2540 "Display the Message manual.
2541
2542 Prefixed with one \\[universal-argument], display the Emacs MIME
2543 manual. With two \\[universal-argument]'s, display the EasyPG or
2544 PGG manual, depending on the value of `mml2015-use'."
2545 (interactive "p")
2546 ;; Don't use `info' because support for `(filename)nodename' is not
2547 ;; available in XEmacs < 21.5.12.
2548 (Info-goto-node (format "(%s)Top"
2549 (cond ((eq arg 16)
2550 (require 'mml2015)
2551 mml2015-use)
2552 ((eq arg 4) 'emacs-mime)
2553 ;; `booleanp' only available in Emacs 22+
2554 ((and (not (memq arg '(nil t)))
2555 (symbolp arg))
2556 arg)
2557 (t
2558 'message)))))
2559
2560 \f
2561
2562 ;;;
2563 ;;; Message mode
2564 ;;;
2565
2566 ;;; Set up keymap.
2567
2568 (defvar message-mode-map nil)
2569
2570 (unless message-mode-map
2571 (setq message-mode-map (make-keymap))
2572 (set-keymap-parent message-mode-map text-mode-map)
2573 (define-key message-mode-map "\C-c?" 'describe-mode)
2574
2575 (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
2576 (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from)
2577 (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
2578 (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
2579 (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
2580 (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
2581 (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
2582 (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
2583 (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
2584 (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
2585 (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
2586 (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
2587 (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
2588 (define-key message-mode-map "\C-c\C-f\C-i"
2589 'message-insert-or-toggle-importance)
2590 (define-key message-mode-map "\C-c\C-f\C-a"
2591 'message-generate-unsubscribed-mail-followup-to)
2592
2593 ;; modify headers (and insert notes in body)
2594 (define-key message-mode-map "\C-c\C-fs" 'message-change-subject)
2595 ;;
2596 (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to)
2597 ;; prefix+message-cross-post-followup-to = same w/o cross-post
2598 (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc)
2599 (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header)
2600 ;; mark inserted text
2601 (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region)
2602 (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file)
2603
2604 (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
2605 (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
2606
2607 (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
2608 (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
2609 (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
2610 (define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
2611 (define-key message-mode-map "\C-c\C-f\C-e" 'message-insert-expires)
2612
2613 (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance)
2614 (define-key message-mode-map "\C-c\M-n"
2615 'message-insert-disposition-notification-to)
2616
2617 (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
2618 (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)
2619 (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
2620 (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
2621 (define-key message-mode-map "\C-c\M-h" 'message-insert-headers)
2622 (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
2623 (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
2624 (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
2625
2626 (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
2627 (define-key message-mode-map "\C-c\C-s" 'message-send)
2628 (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
2629 (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
2630 (define-key message-mode-map "\C-c\n" 'gnus-delay-article)
2631
2632 (define-key message-mode-map "\C-c\M-k" 'message-kill-address)
2633 (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
2634 (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
2635 (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
2636 (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
2637 (define-key message-mode-map [remap split-line] 'message-split-line)
2638
2639 (define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
2640
2641 (define-key message-mode-map "\C-a" 'message-beginning-of-line)
2642 (define-key message-mode-map "\t" 'message-tab)
2643
2644 (define-key message-mode-map "\M-n" 'message-display-abbrev))
2645
2646 (easy-menu-define
2647 message-mode-menu message-mode-map "Message Menu."
2648 `("Message"
2649 ["Yank Original" message-yank-original message-reply-buffer]
2650 ["Fill Yanked Message" message-fill-yanked-message t]
2651 ["Insert Signature" message-insert-signature t]
2652 ["Caesar (rot13) Message" message-caesar-buffer-body t]
2653 ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)]
2654 ["Elide Region" message-elide-region
2655 :active (message-mark-active-p)
2656 ,@(if (featurep 'xemacs) nil
2657 '(:help "Replace text in region with an ellipsis"))]
2658 ["Delete Outside Region" message-delete-not-region
2659 :active (message-mark-active-p)
2660 ,@(if (featurep 'xemacs) nil
2661 '(:help "Delete all quoted text outside region"))]
2662 ["Kill To Signature" message-kill-to-signature t]
2663 ["Newline and Reformat" message-newline-and-reformat t]
2664 ["Rename buffer" message-rename-buffer t]
2665 ["Spellcheck" ispell-message
2666 ,@(if (featurep 'xemacs) '(t)
2667 '(:help "Spellcheck this message"))]
2668 "----"
2669 ["Insert Region Marked" message-mark-inserted-region
2670 :active (message-mark-active-p)
2671 ,@(if (featurep 'xemacs) nil
2672 '(:help "Mark region with enclosing tags"))]
2673 ["Insert File Marked..." message-mark-insert-file
2674 ,@(if (featurep 'xemacs) '(t)
2675 '(:help "Insert file at point marked with enclosing tags"))]
2676 "----"
2677 ["Send Message" message-send-and-exit
2678 ,@(if (featurep 'xemacs) '(t)
2679 '(:help "Send this message"))]
2680 ["Postpone Message" message-dont-send
2681 ,@(if (featurep 'xemacs) '(t)
2682 '(:help "File this draft message and exit"))]
2683 ["Send at Specific Time..." gnus-delay-article
2684 ,@(if (featurep 'xemacs) '(t)
2685 '(:help "Ask, then arrange to send message at that time"))]
2686 ["Kill Message" message-kill-buffer
2687 ,@(if (featurep 'xemacs) '(t)
2688 '(:help "Delete this message without sending"))]
2689 "----"
2690 ["Message manual" message-info
2691 ,@(if (featurep 'xemacs) '(t)
2692 '(:help "Display the Message manual"))]))
2693
2694 (easy-menu-define
2695 message-mode-field-menu message-mode-map ""
2696 `("Field"
2697 ["To" message-goto-to t]
2698 ["From" message-goto-from t]
2699 ["Subject" message-goto-subject t]
2700 ["Change subject..." message-change-subject t]
2701 ["Cc" message-goto-cc t]
2702 ["Bcc" message-goto-bcc t]
2703 ["Fcc" message-goto-fcc t]
2704 ["Reply-To" message-goto-reply-to t]
2705 ["Flag As Important" message-insert-importance-high
2706 ,@(if (featurep 'xemacs) '(t)
2707 '(:help "Mark this message as important"))]
2708 ["Flag As Unimportant" message-insert-importance-low
2709 ,@(if (featurep 'xemacs) '(t)
2710 '(:help "Mark this message as unimportant"))]
2711 ["Request Receipt"
2712 message-insert-disposition-notification-to
2713 ,@(if (featurep 'xemacs) '(t)
2714 '(:help "Request a receipt notification"))]
2715 "----"
2716 ;; (typical) news stuff
2717 ["Summary" message-goto-summary t]
2718 ["Keywords" message-goto-keywords t]
2719 ["Newsgroups" message-goto-newsgroups t]
2720 ["Fetch Newsgroups" message-insert-newsgroups t]
2721 ["Followup-To" message-goto-followup-to t]
2722 ;; ["Followup-To (with note in body)" message-cross-post-followup-to t]
2723 ["Crosspost / Followup-To..." message-cross-post-followup-to t]
2724 ["Distribution" message-goto-distribution t]
2725 ["Expires" message-insert-expires t ]
2726 ["X-No-Archive" message-add-archive-header t ]
2727 "----"
2728 ;; (typical) mailing-lists stuff
2729 ["Fetch To" message-insert-to
2730 ,@(if (featurep 'xemacs) '(t)
2731 '(:help "Insert a To header that points to the author."))]
2732 ["Fetch To and Cc" message-insert-wide-reply
2733 ,@(if (featurep 'xemacs) '(t)
2734 '(:help
2735 "Insert To and Cc headers as if you were doing a wide reply."))]
2736 "----"
2737 ["Send to list only" message-to-list-only t]
2738 ["Mail-Followup-To" message-goto-mail-followup-to t]
2739 ["Unsubscribed list post" message-generate-unsubscribed-mail-followup-to
2740 ,@(if (featurep 'xemacs) '(t)
2741 '(:help "Insert a reasonable `Mail-Followup-To:' header."))]
2742 ["Reduce To: to Cc:" message-reduce-to-to-cc t]
2743 "----"
2744 ["Sort Headers" message-sort-headers t]
2745 ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t]
2746 ;; We hide `message-hidden-headers' by narrowing the buffer.
2747 ["Show Hidden Headers" widen t]
2748 ["Goto Body" message-goto-body t]
2749 ["Goto Signature" message-goto-signature t]))
2750
2751 (defvar message-tool-bar-map nil)
2752
2753 (defvar facemenu-add-face-function)
2754 (defvar facemenu-remove-face-function)
2755
2756 ;;; Forbidden properties
2757 ;;
2758 ;; We use `after-change-functions' to keep special text properties
2759 ;; that interfere with the normal function of message mode out of the
2760 ;; buffer.
2761
2762 (defcustom message-strip-special-text-properties t
2763 "Strip special properties from the message buffer.
2764
2765 Emacs has a number of special text properties which can break message
2766 composing in various ways. If this option is set, message will strip
2767 these properties from the message composition buffer. However, some
2768 packages requires these properties to be present in order to work.
2769 If you use one of these packages, turn this option off, and hope the
2770 message composition doesn't break too bad."
2771 :version "22.1"
2772 :group 'message-various
2773 :link '(custom-manual "(message)Various Message Variables")
2774 :type 'boolean)
2775
2776 (defconst message-forbidden-properties
2777 ;; No reason this should be clutter up customize. We make it a
2778 ;; property list (rather than a list of property symbols), to be
2779 ;; directly useful for `remove-text-properties'.
2780 '(field nil read-only nil invisible nil intangible nil
2781 mouse-face nil modification-hooks nil insert-in-front-hooks nil
2782 insert-behind-hooks nil point-entered nil point-left nil)
2783 ;; Other special properties:
2784 ;; category, face, display: probably doesn't do any harm.
2785 ;; fontified: is used by font-lock.
2786 ;; syntax-table, local-map: I dunno.
2787 ;; We need to add XEmacs names to the list.
2788 "Property list of with properties forbidden in message buffers.
2789 The values of the properties are ignored, only the property names are used.")
2790
2791 (defun message-tamago-not-in-use-p (pos)
2792 "Return t when tamago version 4 is not in use at the cursor position.
2793 Tamago version 4 is a popular input method for writing Japanese text.
2794 It uses the properties `intangible', `invisible', `modification-hooks'
2795 and `read-only' when translating ascii or kana text to kanji text.
2796 These properties are essential to work, so we should never strip them."
2797 (not (and (boundp 'egg-modefull-mode)
2798 (symbol-value 'egg-modefull-mode)
2799 (or (memq (get-text-property pos 'intangible)
2800 '(its-part-1 its-part-2))
2801 (get-text-property pos 'egg-end)
2802 (get-text-property pos 'egg-lang)
2803 (get-text-property pos 'egg-start)))))
2804
2805 (defsubst message-mail-alias-type-p (type)
2806 (if (atom message-mail-alias-type)
2807 (eq message-mail-alias-type type)
2808 (memq type message-mail-alias-type)))
2809
2810 (defun message-strip-forbidden-properties (begin end &optional old-length)
2811 "Strip forbidden properties between BEGIN and END, ignoring the third arg.
2812 This function is intended to be called from `after-change-functions'.
2813 See also `message-forbidden-properties'."
2814 (when (and (message-mail-alias-type-p 'ecomplete)
2815 (memq this-command message-self-insert-commands))
2816 (message-display-abbrev))
2817 (when (and message-strip-special-text-properties
2818 (message-tamago-not-in-use-p begin))
2819 (let ((buffer-read-only nil)
2820 (inhibit-read-only t))
2821 (remove-text-properties begin end message-forbidden-properties))))
2822
2823 (autoload 'ecomplete-setup "ecomplete") ;; for Emacs <23.
2824
2825 ;;;###autoload
2826 (define-derived-mode message-mode text-mode "Message"
2827 "Major mode for editing mail and news to be sent.
2828 Like Text Mode but with these additional commands:\\<message-mode-map>
2829 C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit'
2830 C-c C-d Postpone sending the message C-c C-k Kill the message
2831 C-c C-f move to a header field (and create it if there isn't):
2832 C-c C-f C-t move to To C-c C-f C-s move to Subject
2833 C-c C-f C-c move to Cc C-c C-f C-b move to Bcc
2834 C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To
2835 C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups
2836 C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution
2837 C-c C-f C-o move to From (\"Originator\")
2838 C-c C-f C-f move to Followup-To
2839 C-c C-f C-m move to Mail-Followup-To
2840 C-c C-f C-e move to Expires
2841 C-c C-f C-i cycle through Importance values
2842 C-c C-f s change subject and append \"(was: <Old Subject>)\"
2843 C-c C-f x crossposting with FollowUp-To header and note in body
2844 C-c C-f t replace To: header with contents of Cc: or Bcc:
2845 C-c C-f a Insert X-No-Archive: header and a note in the body
2846 C-c C-t `message-insert-to' (add a To header to a news followup)
2847 C-c C-l `message-to-list-only' (removes all but list address in to/cc)
2848 C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply)
2849 C-c C-b `message-goto-body' (move to beginning of message text).
2850 C-c C-i `message-goto-signature' (move to the beginning of the signature).
2851 C-c C-w `message-insert-signature' (insert `message-signature-file' file).
2852 C-c C-y `message-yank-original' (insert current message, if any).
2853 C-c C-q `message-fill-yanked-message' (fill what was yanked).
2854 C-c C-e `message-elide-region' (elide the text between point and mark).
2855 C-c C-v `message-delete-not-region' (remove the text outside the region).
2856 C-c C-z `message-kill-to-signature' (kill the text up to the signature).
2857 C-c C-r `message-caesar-buffer-body' (rot13 the message body).
2858 C-c C-a `mml-attach-file' (attach a file as MIME).
2859 C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance).
2860 C-c M-n `message-insert-disposition-notification-to' (request receipt).
2861 C-c M-m `message-mark-inserted-region' (mark region with enclosing tags).
2862 C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags).
2863 M-RET `message-newline-and-reformat' (break the line and reformat)."
2864 (setq local-abbrev-table text-mode-abbrev-table)
2865 (set (make-local-variable 'message-reply-buffer) nil)
2866 (set (make-local-variable 'message-inserted-headers) nil)
2867 (set (make-local-variable 'message-send-actions) nil)
2868 (set (make-local-variable 'message-exit-actions) nil)
2869 (set (make-local-variable 'message-kill-actions) nil)
2870 (set (make-local-variable 'message-postpone-actions) nil)
2871 (set (make-local-variable 'message-draft-article) nil)
2872 (setq buffer-offer-save t)
2873 (set (make-local-variable 'facemenu-add-face-function)
2874 (lambda (face end)
2875 (let ((face-fun (cdr (assq face message-face-alist))))
2876 (if face-fun
2877 (funcall face-fun (point) end)
2878 (error "Face %s not configured for %s mode" face mode-name)))
2879 ""))
2880 (set (make-local-variable 'facemenu-remove-face-function) t)
2881 (set (make-local-variable 'message-reply-headers) nil)
2882 (make-local-variable 'message-newsreader)
2883 (make-local-variable 'message-mailer)
2884 (make-local-variable 'message-post-method)
2885 (set (make-local-variable 'message-sent-message-via) nil)
2886 (set (make-local-variable 'message-checksum) nil)
2887 (set (make-local-variable 'message-mime-part) 0)
2888 (message-setup-fill-variables)
2889 (when message-fill-column
2890 (setq fill-column message-fill-column)
2891 (turn-on-auto-fill))
2892 ;; Allow using comment commands to add/remove quoting.
2893 ;; (set (make-local-variable 'comment-start) message-yank-prefix)
2894 (when message-yank-prefix
2895 (set (make-local-variable 'comment-start) message-yank-prefix)
2896 (set (make-local-variable 'comment-start-skip)
2897 (concat "^" (regexp-quote message-yank-prefix) "[ \t]*")))
2898 (if (featurep 'xemacs)
2899 (message-setup-toolbar)
2900 (set (make-local-variable 'font-lock-defaults)
2901 '(message-font-lock-keywords t))
2902 (if (boundp 'tool-bar-map)
2903 (set (make-local-variable 'tool-bar-map) (message-make-tool-bar))))
2904 (easy-menu-add message-mode-menu message-mode-map)
2905 (easy-menu-add message-mode-field-menu message-mode-map)
2906 (gnus-make-local-hook 'after-change-functions)
2907 ;; Mmmm... Forbidden properties...
2908 (add-hook 'after-change-functions 'message-strip-forbidden-properties
2909 nil 'local)
2910 ;; Allow mail alias things.
2911 (cond
2912 ((message-mail-alias-type-p 'abbrev)
2913 (if (fboundp 'mail-abbrevs-setup)
2914 (mail-abbrevs-setup)
2915 (if (fboundp 'mail-aliases-setup) ; warning avoidance
2916 (mail-aliases-setup))))
2917 ((message-mail-alias-type-p 'ecomplete)
2918 (ecomplete-setup)))
2919 (unless buffer-file-name
2920 (message-set-auto-save-file-name))
2921 (unless (buffer-base-buffer)
2922 ;; Don't enable multibyte on an indirect buffer. Maybe enabling
2923 ;; multibyte is not necessary at all. -- zsh
2924 (mm-enable-multibyte))
2925 (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation.
2926 (mml-mode))
2927
2928 (defun message-setup-fill-variables ()
2929 "Setup message fill variables."
2930 (set (make-local-variable 'fill-paragraph-function)
2931 'message-fill-paragraph)
2932 (make-local-variable 'paragraph-separate)
2933 (make-local-variable 'paragraph-start)
2934 (make-local-variable 'adaptive-fill-regexp)
2935 (unless (boundp 'adaptive-fill-first-line-regexp)
2936 (setq adaptive-fill-first-line-regexp nil))
2937 (make-local-variable 'adaptive-fill-first-line-regexp)
2938 (let ((quote-prefix-regexp
2939 ;; User should change message-cite-prefix-regexp if
2940 ;; message-yank-prefix is set to an abnormal value.
2941 (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
2942 (setq paragraph-start
2943 (concat
2944 (regexp-quote mail-header-separator) "$\\|"
2945 "[ \t]*$\\|" ; blank lines
2946 "-- $\\|" ; signature delimiter
2947 "---+$\\|" ; delimiters for forwarded messages
2948 page-delimiter "$\\|" ; spoiler warnings
2949 ".*wrote:$\\|" ; attribution lines
2950 quote-prefix-regexp "$\\|" ; empty lines in quoted text
2951 ; mml tags
2952 "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
2953 (setq paragraph-separate paragraph-start)
2954 (setq adaptive-fill-regexp
2955 (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
2956 (setq adaptive-fill-first-line-regexp
2957 (concat quote-prefix-regexp "\\|"
2958 adaptive-fill-first-line-regexp)))
2959 (make-local-variable 'auto-fill-inhibit-regexp)
2960 ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
2961 (setq auto-fill-inhibit-regexp nil)
2962 (make-local-variable 'normal-auto-fill-function)
2963 (setq normal-auto-fill-function 'message-do-auto-fill)
2964 ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'.
2965 ;; In that case, ensure that it uses the right function. The real
2966 ;; solution would be not to use `define-derived-mode', and run
2967 ;; `text-mode-hook' ourself at the end of the mode.
2968 ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19.
2969 ;; This kludge is unneeded in Emacs>=21 since define-derived-mode is
2970 ;; now careful to run parent hooks after the body. --Stef
2971 (when auto-fill-function
2972 (setq auto-fill-function normal-auto-fill-function)))
2973
2974 \f
2975
2976 ;;;
2977 ;;; Message mode commands
2978 ;;;
2979
2980 ;;; Movement commands
2981
2982 (defun message-goto-to ()
2983 "Move point to the To header."
2984 (interactive)
2985 (message-position-on-field "To"))
2986
2987 (defun message-goto-from ()
2988 "Move point to the From header."
2989 (interactive)
2990 (message-position-on-field "From"))
2991
2992 (defun message-goto-subject ()
2993 "Move point to the Subject header."
2994 (interactive)
2995 (message-position-on-field "Subject"))
2996
2997 (defun message-goto-cc ()
2998 "Move point to the Cc header."
2999 (interactive)
3000 (message-position-on-field "Cc" "To"))
3001
3002 (defun message-goto-bcc ()
3003 "Move point to the Bcc header."
3004 (interactive)
3005 (message-position-on-field "Bcc" "Cc" "To"))
3006
3007 (defun message-goto-fcc ()
3008 "Move point to the Fcc header."
3009 (interactive)
3010 (message-position-on-field "Fcc" "To" "Newsgroups"))
3011
3012 (defun message-goto-reply-to ()
3013 "Move point to the Reply-To header."
3014 (interactive)
3015 (message-position-on-field "Reply-To" "Subject"))
3016
3017 (defun message-goto-newsgroups ()
3018 "Move point to the Newsgroups header."
3019 (interactive)
3020 (message-position-on-field "Newsgroups"))
3021
3022 (defun message-goto-distribution ()
3023 "Move point to the Distribution header."
3024 (interactive)
3025 (message-position-on-field "Distribution"))
3026
3027 (defun message-goto-followup-to ()
3028 "Move point to the Followup-To header."
3029 (interactive)
3030 (message-position-on-field "Followup-To" "Newsgroups"))
3031
3032 (defun message-goto-mail-followup-to ()
3033 "Move point to the Mail-Followup-To header."
3034 (interactive)
3035 (message-position-on-field "Mail-Followup-To" "To"))
3036
3037 (defun message-goto-keywords ()
3038 "Move point to the Keywords header."
3039 (interactive)
3040 (message-position-on-field "Keywords" "Subject"))
3041
3042 (defun message-goto-summary ()
3043 "Move point to the Summary header."
3044 (interactive)
3045 (message-position-on-field "Summary" "Subject"))
3046
3047 (defun message-goto-body (&optional interactivep)
3048 "Move point to the beginning of the message body."
3049 (interactive (list t))
3050 (when (and interactivep
3051 (looking-at "[ \t]*\n"))
3052 (expand-abbrev))
3053 (goto-char (point-min))
3054 (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
3055 (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
3056
3057 (defun message-in-body-p ()
3058 "Return t if point is in the message body."
3059 (let ((body (save-excursion (message-goto-body) (point))))
3060 (>= (point) body)))
3061
3062 (defun message-goto-eoh ()
3063 "Move point to the end of the headers."
3064 (interactive)
3065 (message-goto-body)
3066 (forward-line -1))
3067
3068 (defun message-goto-signature ()
3069 "Move point to the beginning of the message signature.
3070 If there is no signature in the article, go to the end and
3071 return nil."
3072 (interactive)
3073 (goto-char (point-min))
3074 (if (re-search-forward message-signature-separator nil t)
3075 (forward-line 1)
3076 (goto-char (point-max))
3077 nil))
3078
3079 (defun message-generate-unsubscribed-mail-followup-to (&optional include-cc)
3080 "Insert a reasonable MFT header in a post to an unsubscribed list.
3081 When making original posts to a mailing list you are not subscribed to,
3082 you have to type in a MFT header by hand. The contents, usually, are
3083 the addresses of the list and your own address. This function inserts
3084 such a header automatically. It fetches the contents of the To: header
3085 in the current mail buffer, and appends the current `user-mail-address'.
3086
3087 If the optional argument INCLUDE-CC is non-nil, the addresses in the
3088 Cc: header are also put into the MFT."
3089
3090 (interactive "P")
3091 (let* (cc tos)
3092 (save-restriction
3093 (message-narrow-to-headers)
3094 (message-remove-header "Mail-Followup-To")
3095 (setq cc (and include-cc (message-fetch-field "Cc")))
3096 (setq tos (if cc
3097 (concat (message-fetch-field "To") "," cc)
3098 (message-fetch-field "To"))))
3099 (message-goto-mail-followup-to)
3100 (insert (concat tos ", " user-mail-address))))
3101
3102 \f
3103
3104 (defun message-insert-to (&optional force)
3105 "Insert a To header that points to the author of the article being replied to.
3106 If the original author requested not to be sent mail, don't insert unless the
3107 prefix FORCE is given."
3108 (interactive "P")
3109 (let* ((mct (message-fetch-reply-field "mail-copies-to"))
3110 (dont (and mct (or (equal (downcase mct) "never")
3111 (equal (downcase mct) "nobody"))))
3112 (to (or (message-fetch-reply-field "mail-reply-to")
3113 (message-fetch-reply-field "reply-to")
3114 (message-fetch-reply-field "from"))))
3115 (when (and dont to)
3116 (message
3117 (if force
3118 "Ignoring the user request not to have copies sent via mail"
3119 "Complying with the user request not to have copies sent via mail")))
3120 (when (and force (not to))
3121 (error "No mail address in the article"))
3122 (when (and to (or force (not dont)))
3123 (message-carefully-insert-headers (list (cons 'To to))))))
3124
3125 (defun message-insert-wide-reply ()
3126 "Insert To and Cc headers as if you were doing a wide reply."
3127 (interactive)
3128 (let ((headers (message-with-reply-buffer
3129 (message-get-reply-headers t))))
3130 (message-carefully-insert-headers headers)))
3131
3132 (defcustom message-header-synonyms
3133 '((To Cc Bcc)
3134 (Original-To))
3135 "List of lists of header synonyms.
3136 E.g., if this list contains a member list with elements `Cc' and `To',
3137 then `message-carefully-insert-headers' will not insert a `To' header
3138 when the message is already `Cc'ed to the recipient."
3139 :version "22.1"
3140 :group 'message-headers
3141 :link '(custom-manual "(message)Message Headers")
3142 :type '(repeat sexp))
3143
3144 (defun message-carefully-insert-headers (headers)
3145 "Insert the HEADERS, an alist, into the message buffer.
3146 Does not insert the headers when they are already present there
3147 or in the synonym headers, defined by `message-header-synonyms'."
3148 ;; FIXME: Should compare only the address and not the full name. Comparison
3149 ;; should be done case-folded (and with `string=' rather than
3150 ;; `string-match').
3151 ;; (mail-strip-quoted-names "Foo Bar <foo@bar>, bla@fasel (Bla Fasel)")
3152 (dolist (header headers)
3153 (let* ((header-name (symbol-name (car header)))
3154 (new-header (cdr header))
3155 (synonyms (loop for synonym in message-header-synonyms
3156 when (memq (car header) synonym) return synonym))
3157 (old-header
3158 (loop for synonym in synonyms
3159 for old-header = (mail-fetch-field (symbol-name synonym))
3160 when (and old-header (string-match new-header old-header))
3161 return synonym)))
3162 (if old-header
3163 (message "already have `%s' in `%s'" new-header old-header)
3164 (when (and (message-position-on-field header-name)
3165 (setq old-header (mail-fetch-field header-name))
3166 (not (string-match "\\` *\\'" old-header)))
3167 (insert ", "))
3168 (insert new-header)))))
3169
3170 (defun message-widen-reply ()
3171 "Widen the reply to include maximum recipients."
3172 (interactive)
3173 (let ((follow-to
3174 (and (bufferp message-reply-buffer)
3175 (buffer-name message-reply-buffer)
3176 (with-current-buffer message-reply-buffer
3177 (message-get-reply-headers t)))))
3178 (save-excursion
3179 (save-restriction
3180 (message-narrow-to-headers)
3181 (dolist (elem follow-to)
3182 (message-remove-header (symbol-name (car elem)))
3183 (goto-char (point-min))
3184 (insert (symbol-name (car elem)) ": "
3185 (cdr elem) "\n"))))))
3186
3187 (defun message-insert-newsgroups ()
3188 "Insert the Newsgroups header from the article being replied to."
3189 (interactive)
3190 (when (and (message-position-on-field "Newsgroups")
3191 (mail-fetch-field "newsgroups")
3192 (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
3193 (insert ","))
3194 (insert (or (message-fetch-reply-field "newsgroups") "")))
3195
3196 \f
3197
3198 ;;; Various commands
3199
3200 (defun message-delete-not-region (beg end)
3201 "Delete everything in the body of the current message outside of the region."
3202 (interactive "r")
3203 (let (citeprefix)
3204 (save-excursion
3205 (goto-char beg)
3206 ;; snarf citation prefix, if appropriate
3207 (unless (eq (point) (progn (beginning-of-line) (point)))
3208 (when (looking-at message-cite-prefix-regexp)
3209 (setq citeprefix (match-string 0))))
3210 (goto-char end)
3211 (delete-region (point) (if (not (message-goto-signature))
3212 (point)
3213 (forward-line -2)
3214 (point)))
3215 (insert "\n")
3216 (goto-char beg)
3217 (delete-region beg (progn (message-goto-body)
3218 (forward-line 2)
3219 (point)))
3220 (when citeprefix
3221 (insert citeprefix))))
3222 (when (message-goto-signature)
3223 (forward-line -2)))
3224
3225 (defun message-kill-to-signature (&optional arg)
3226 "Kill all text up to the signature.
3227 If a numeric argument or prefix arg is given, leave that number
3228 of lines before the signature intact."
3229 (interactive "P")
3230 (save-excursion
3231 (save-restriction
3232 (let ((point (point)))
3233 (narrow-to-region point (point-max))
3234 (message-goto-signature)
3235 (unless (eobp)
3236 (if (and arg (numberp arg))
3237 (forward-line (- -1 arg))
3238 (end-of-line -1)))
3239 (unless (= point (point))
3240 (kill-region point (point))
3241 (unless (bolp)
3242 (insert "\n")))))))
3243
3244 (defun message-newline-and-reformat (&optional arg not-break)
3245 "Insert four newlines, and then reformat if inside quoted text.
3246 Prefix arg means justify as well."
3247 (interactive (list (if current-prefix-arg 'full)))
3248 (let (quoted point beg end leading-space bolp fill-paragraph-function)
3249 (setq point (point))
3250 (beginning-of-line)
3251 (setq beg (point))
3252 (setq bolp (= beg point))
3253 ;; Find first line of the paragraph.
3254 (if not-break
3255 (while (and (not (eobp))
3256 (not (looking-at message-cite-prefix-regexp))
3257 (looking-at paragraph-start))
3258 (forward-line 1)))
3259 ;; Find the prefix
3260 (when (looking-at message-cite-prefix-regexp)
3261 (setq quoted (match-string 0))
3262 (goto-char (match-end 0))
3263 (looking-at "[ \t]*")
3264 (setq leading-space (match-string 0)))
3265 (if (and quoted
3266 (not not-break)
3267 (not bolp)
3268 (< (- point beg) (length quoted)))
3269 ;; break inside the cite prefix.
3270 (setq quoted nil
3271 end nil))
3272 (if quoted
3273 (progn
3274 (forward-line 1)
3275 (while (and (not (eobp))
3276 (not (looking-at paragraph-separate))
3277 (looking-at message-cite-prefix-regexp)
3278 (equal quoted (match-string 0)))
3279 (goto-char (match-end 0))
3280 (looking-at "[ \t]*")
3281 (if (> (length leading-space) (length (match-string 0)))
3282 (setq leading-space (match-string 0)))
3283 (forward-line 1))
3284 (setq end (point))
3285 (goto-char beg)
3286 (while (and (if (bobp) nil (forward-line -1) t)
3287 (not (looking-at paragraph-start))
3288 (looking-at message-cite-prefix-regexp)
3289 (equal quoted (match-string 0)))
3290 (setq beg (point))
3291 (goto-char (match-end 0))
3292 (looking-at "[ \t]*")
3293 (if (> (length leading-space) (length (match-string 0)))
3294 (setq leading-space (match-string 0)))))
3295 (while (and (not (eobp))
3296 (not (looking-at paragraph-separate))
3297 (not (looking-at message-cite-prefix-regexp)))
3298 (forward-line 1))
3299 (setq end (point))
3300 (goto-char beg)
3301 (while (and (if (bobp) nil (forward-line -1) t)
3302 (not (looking-at paragraph-start))
3303 (not (looking-at message-cite-prefix-regexp)))
3304 (setq beg (point))))
3305 (goto-char point)
3306 (save-restriction
3307 (narrow-to-region beg end)
3308 (if not-break
3309 (setq point nil)
3310 (if bolp
3311 (newline)
3312 (newline)
3313 (newline))
3314 (setq point (point))
3315 ;; (newline 2) doesn't mark both newline's as hard, so call
3316 ;; newline twice. -jas
3317 (newline)
3318 (newline)
3319 (delete-region (point) (re-search-forward "[ \t]*"))
3320 (when (and quoted (not bolp))
3321 (insert quoted leading-space)))
3322 (undo-boundary)
3323 (if quoted
3324 (let* ((adaptive-fill-regexp
3325 (regexp-quote (concat quoted leading-space)))
3326 (adaptive-fill-first-line-regexp
3327 adaptive-fill-regexp ))
3328 (fill-paragraph arg))
3329 (fill-paragraph arg))
3330 (if point (goto-char point)))))
3331
3332 (defun message-fill-paragraph (&optional arg)
3333 "Message specific function to fill a paragraph.
3334 This function is used as the value of `fill-paragraph-function' in
3335 Message buffers and is not meant to be called directly."
3336 (interactive (list (if current-prefix-arg 'full)))
3337 (if (if (boundp 'filladapt-mode) filladapt-mode)
3338 nil
3339 (if (message-point-in-header-p)
3340 (message-fill-field)
3341 (message-newline-and-reformat arg t))
3342 t))
3343
3344 (defun message-point-in-header-p ()
3345 "Return t if point is in the header."
3346 (save-excursion
3347 (not (re-search-backward
3348 (concat "^" (regexp-quote mail-header-separator) "\n") nil t))))
3349
3350 (defun message-do-auto-fill ()
3351 "Like `do-auto-fill', but don't fill in message header."
3352 (unless (message-point-in-header-p)
3353 (do-auto-fill)))
3354
3355 (defun message-insert-signature (&optional force)
3356 "Insert a signature. See documentation for variable `message-signature'."
3357 (interactive (list 0))
3358 (let* ((signature
3359 (cond
3360 ((and (null message-signature)
3361 (eq force 0))
3362 (save-excursion
3363 (goto-char (point-max))
3364 (not (re-search-backward message-signature-separator nil t))))
3365 ((and (null message-signature)
3366 force)
3367 t)
3368 ((functionp message-signature)
3369 (funcall message-signature))
3370 ((listp message-signature)
3371 (eval message-signature))
3372 (t message-signature)))
3373 signature-file)
3374 (setq signature
3375 (cond ((stringp signature)
3376 signature)
3377 ((and (eq t signature) message-signature-file)
3378 (setq signature-file
3379 (if (and message-signature-directory
3380 ;; don't actually use the signature directory
3381 ;; if message-signature-file contains a path.
3382 (not (file-name-directory
3383 message-signature-file)))
3384 (expand-file-name message-signature-file
3385 message-signature-directory)
3386 message-signature-file))
3387 (file-exists-p signature-file))))
3388 (when signature
3389 (goto-char (point-max))
3390 ;; Insert the signature.
3391 (unless (bolp)
3392 (insert "\n"))
3393 (when message-signature-insert-empty-line
3394 (insert "\n"))
3395 (insert "-- \n")
3396 (if (eq signature t)
3397 (insert-file-contents signature-file)
3398 (insert signature))
3399 (goto-char (point-max))
3400 (or (bolp) (insert "\n")))))
3401
3402 (defun message-insert-importance-high ()
3403 "Insert header to mark message as important."
3404 (interactive)
3405 (save-excursion
3406 (save-restriction
3407 (message-narrow-to-headers)
3408 (message-remove-header "Importance"))
3409 (message-goto-eoh)
3410 (insert "Importance: high\n")))
3411
3412 (defun message-insert-importance-low ()
3413 "Insert header to mark message as unimportant."
3414 (interactive)
3415 (save-excursion
3416 (save-restriction
3417 (message-narrow-to-headers)
3418 (message-remove-header "Importance"))
3419 (message-goto-eoh)
3420 (insert "Importance: low\n")))
3421
3422 (defun message-insert-or-toggle-importance ()
3423 "Insert a \"Importance: high\" header, or cycle through the header values.
3424 The three allowed values according to RFC 1327 are `high', `normal'
3425 and `low'."
3426 (interactive)
3427 (save-excursion
3428 (let ((new "high")
3429 cur)
3430 (save-restriction
3431 (message-narrow-to-headers)
3432 (when (setq cur (message-fetch-field "Importance"))
3433 (message-remove-header "Importance")
3434 (setq new (cond ((string= cur "high")
3435 "low")
3436 ((string= cur "low")
3437 "normal")
3438 (t
3439 "high")))))
3440 (message-goto-eoh)
3441 (insert (format "Importance: %s\n" new)))))
3442
3443 (defun message-insert-disposition-notification-to ()
3444 "Request a disposition notification (return receipt) to this message.
3445 Note that this should not be used in newsgroups."
3446 (interactive)
3447 (save-excursion
3448 (save-restriction
3449 (message-narrow-to-headers)
3450 (message-remove-header "Disposition-Notification-To"))
3451 (message-goto-eoh)
3452 (insert (format "Disposition-Notification-To: %s\n"
3453 (or (message-field-value "Reply-to")
3454 (message-field-value "From")
3455 (message-make-from))))))
3456
3457 (defun message-elide-region (b e)
3458 "Elide the text in the region.
3459 An ellipsis (from `message-elide-ellipsis') will be inserted where the
3460 text was killed."
3461 (interactive "r")
3462 (kill-region b e)
3463 (insert message-elide-ellipsis))
3464
3465 (defvar message-caesar-translation-table nil)
3466
3467 (defun message-caesar-region (b e &optional n)
3468 "Caesar rotate region B to E by N, default 13, for decrypting netnews."
3469 (interactive
3470 (list
3471 (min (point) (or (mark t) (point)))
3472 (max (point) (or (mark t) (point)))
3473 (when current-prefix-arg
3474 (prefix-numeric-value current-prefix-arg))))
3475
3476 (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
3477 (unless (or (zerop n) ; no action needed for a rot of 0
3478 (= b e)) ; no region to rotate
3479 ;; We build the table, if necessary.
3480 (when (or (not message-caesar-translation-table)
3481 (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
3482 (setq message-caesar-translation-table
3483 (message-make-caesar-translation-table n)))
3484 (translate-region b e message-caesar-translation-table)))
3485
3486 (defun message-make-caesar-translation-table (n)
3487 "Create a rot table with offset N."
3488 (let ((i -1)
3489 (table (make-string 256 0)))
3490 (while (< (incf i) 256)
3491 (aset table i i))
3492 (concat
3493 (substring table 0 ?A)
3494 (substring table (+ ?A n) (+ ?A n (- 26 n)))
3495 (substring table ?A (+ ?A n))
3496 (substring table (+ ?A 26) ?a)
3497 (substring table (+ ?a n) (+ ?a n (- 26 n)))
3498 (substring table ?a (+ ?a n))
3499 (substring table (+ ?a 26) 255))))
3500
3501 (defun message-caesar-buffer-body (&optional rotnum wide)
3502 "Caesar rotate all letters in the current buffer by 13 places.
3503 Used to encode/decode possibly offensive messages (commonly in rec.humor).
3504 With prefix arg, specifies the number of places to rotate each letter forward.
3505 Mail and USENET news headers are not rotated unless WIDE is non-nil."
3506 (interactive (if current-prefix-arg
3507 (list (prefix-numeric-value current-prefix-arg))
3508 (list nil)))
3509 (save-excursion
3510 (save-restriction
3511 (when (and (not wide) (message-goto-body))
3512 (narrow-to-region (point) (point-max)))
3513 (message-caesar-region (point-min) (point-max) rotnum))))
3514
3515 (defun message-pipe-buffer-body (program)
3516 "Pipe the message body in the current buffer through PROGRAM."
3517 (save-excursion
3518 (save-restriction
3519 (when (message-goto-body)
3520 (narrow-to-region (point) (point-max)))
3521 (shell-command-on-region
3522 (point-min) (point-max) program nil t))))
3523
3524 (defun message-rename-buffer (&optional enter-string)
3525 "Rename the *message* buffer to \"*message* RECIPIENT\".
3526 If the function is run with a prefix, it will ask for a new buffer
3527 name, rather than giving an automatic name."
3528 (interactive "Pbuffer name: ")
3529 (save-excursion
3530 (save-restriction
3531 (goto-char (point-min))
3532 (narrow-to-region (point)
3533 (search-forward mail-header-separator nil 'end))
3534 (let* ((mail-to (or
3535 (if (message-news-p) (message-fetch-field "Newsgroups")
3536 (message-fetch-field "To"))
3537 ""))
3538 (mail-trimmed-to
3539 (if (string-match "," mail-to)
3540 (concat (substring mail-to 0 (match-beginning 0)) ", ...")
3541 mail-to))
3542 (name-default (concat "*message* " mail-trimmed-to))
3543 (name (if enter-string
3544 (read-string "New buffer name: " name-default)
3545 name-default)))
3546 (rename-buffer name t)))))
3547
3548 (defun message-fill-yanked-message (&optional justifyp)
3549 "Fill the paragraphs of a message yanked into this one.
3550 Numeric argument means justify as well."
3551 (interactive "P")
3552 (save-excursion
3553 (goto-char (point-min))
3554 (search-forward (concat "\n" mail-header-separator "\n") nil t)
3555 (let ((fill-prefix message-yank-prefix))
3556 (fill-individual-paragraphs (point) (point-max) justifyp))))
3557
3558 (defun message-indent-citation (&optional start end yank-only)
3559 "Modify text just inserted from a message to be cited.
3560 The inserted text should be the region.
3561 When this function returns, the region is again around the modified text.
3562
3563 Normally, indent each nonblank line `message-indentation-spaces' spaces.
3564 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
3565 (unless start (setq start (point)))
3566 (unless yank-only
3567 ;; Remove unwanted headers.
3568 (when message-ignored-cited-headers
3569 (let (all-removed)
3570 (save-restriction
3571 (narrow-to-region
3572 (goto-char start)
3573 (if (search-forward "\n\n" nil t)
3574 (1- (point))
3575 (point)))
3576 (message-remove-header message-ignored-cited-headers t)
3577 (when (= (point-min) (point-max))
3578 (setq all-removed t))
3579 (goto-char (point-max)))
3580 (if all-removed
3581 (goto-char start)
3582 (forward-line 1))))
3583 ;; Delete blank lines at the start of the buffer.
3584 (while (and (point-min)
3585 (eolp)
3586 (not (eobp)))
3587 (message-delete-line))
3588 ;; Delete blank lines at the end of the buffer.
3589 (goto-char (point-max))
3590 (unless (eolp)
3591 (insert "\n"))
3592 (while (and (zerop (forward-line -1))
3593 (looking-at "$"))
3594 (message-delete-line)))
3595 ;; Do the indentation.
3596 (if (null message-yank-prefix)
3597 (indent-rigidly start (or end (mark t)) message-indentation-spaces)
3598 (save-excursion
3599 (goto-char start)
3600 (while (< (point) (or end (mark t)))
3601 (cond ((looking-at ">")
3602 (insert message-yank-cited-prefix))
3603 ((looking-at "^$")
3604 (insert message-yank-empty-prefix))
3605 (t
3606 (insert message-yank-prefix)))
3607 (forward-line 1))))
3608 (goto-char start))
3609
3610 (defun message-remove-blank-cited-lines (&optional remove)
3611 "Remove cited lines containing only blanks.
3612 If REMOVE is non-nil, remove newlines, too.
3613
3614 To use this automatically, you may add this function to
3615 `gnus-message-setup-hook'."
3616 (interactive "P")
3617 (let ((citexp
3618 (concat
3619 "^\\("
3620 (when (boundp 'message-yank-cited-prefix)
3621 (concat message-yank-cited-prefix "\\|"))
3622 message-yank-prefix
3623 "\\)+ *\n"
3624 )))
3625 (gnus-message 8 "removing `%s'" citexp)
3626 (save-excursion
3627 (message-goto-body)
3628 (while (re-search-forward citexp nil t)
3629 (replace-match (if remove "" "\n"))))))
3630
3631 (defvar message-cite-reply-above nil
3632 "If non-nil, start own text above the quote.
3633
3634 Note: Top posting is bad netiquette. Don't use it unless you
3635 really must. You probably want to set variable only for specific
3636 groups, e.g. using `gnus-posting-styles':
3637
3638 (eval (set (make-local-variable 'message-cite-reply-above) t))
3639
3640 This variable has no effect in news postings.")
3641
3642 (defun message-yank-original (&optional arg)
3643 "Insert the message being replied to, if any.
3644 Puts point before the text and mark after.
3645 Normally indents each nonblank line ARG spaces (default 3). However,
3646 if `message-yank-prefix' is non-nil, insert that prefix on each line.
3647
3648 This function uses `message-cite-function' to do the actual citing.
3649
3650 Just \\[universal-argument] as argument means don't indent, insert no
3651 prefix, and don't delete any headers."
3652 (interactive "P")
3653 (let ((modified (buffer-modified-p))
3654 body-text)
3655 (when (and message-reply-buffer
3656 message-cite-function)
3657 (when message-cite-reply-above
3658 (if (and (not (message-news-p))
3659 (or (eq message-cite-reply-above 'is-evil)
3660 (y-or-n-p "\
3661 Top posting is bad netiquette. Please don't top post unless you really must.
3662 Really top post? ")))
3663 (save-excursion
3664 (setq body-text
3665 (buffer-substring (message-goto-body)
3666 (point-max)))
3667 (delete-region (message-goto-body) (point-max)))
3668 (set (make-local-variable 'message-cite-reply-above) nil)))
3669 (if (bufferp message-reply-buffer)
3670 (delete-windows-on message-reply-buffer t))
3671 (push-mark (save-excursion
3672 (cond
3673 ((bufferp message-reply-buffer)
3674 (insert-buffer-substring message-reply-buffer))
3675 ((and (consp message-reply-buffer)
3676 (functionp (car message-reply-buffer)))
3677 (apply (car message-reply-buffer)
3678 (cdr message-reply-buffer))))
3679 (unless (bolp)
3680 (insert ?\n))
3681 (point)))
3682 (unless arg
3683 (funcall message-cite-function)
3684 (unless (eq (char-before (mark t)) ?\n)
3685 (let ((pt (point)))
3686 (goto-char (mark t))
3687 (insert-before-markers ?\n)
3688 (goto-char pt))))
3689 (when message-cite-reply-above
3690 (message-goto-body)
3691 (insert body-text)
3692 (insert (if (bolp) "\n" "\n\n"))
3693 (message-goto-body))
3694 ;; Add a `message-setup-very-last-hook' here?
3695 ;; Add `gnus-article-highlight-citation' here?
3696 (unless modified
3697 (setq message-checksum (message-checksum))))))
3698
3699 (defun message-yank-buffer (buffer)
3700 "Insert BUFFER into the current buffer and quote it."
3701 (interactive "bYank buffer: ")
3702 (let ((message-reply-buffer (get-buffer buffer)))
3703 (save-window-excursion
3704 (message-yank-original))))
3705
3706 (defun message-buffers ()
3707 "Return a list of active message buffers."
3708 (let (buffers)
3709 (save-current-buffer
3710 (dolist (buffer (buffer-list t))
3711 (set-buffer buffer)
3712 (when (and (eq major-mode 'message-mode)
3713 (null message-sent-message-via))
3714 (push (buffer-name buffer) buffers))))
3715 (nreverse buffers)))
3716
3717 (defun message-cite-original-1 (strip-signature)
3718 "Cite an original message.
3719 If STRIP-SIGNATURE is non-nil, strips off the signature from the
3720 original message.
3721
3722 This function uses `mail-citation-hook' if that is non-nil."
3723 (if (and (boundp 'mail-citation-hook)
3724 mail-citation-hook)
3725 (run-hooks 'mail-citation-hook)
3726 (let* ((start (point))
3727 (end (mark t))
3728 (x-no-archive nil)
3729 (functions
3730 (when message-indent-citation-function
3731 (if (listp message-indent-citation-function)
3732 message-indent-citation-function
3733 (list message-indent-citation-function))))
3734 ;; This function may be called by `gnus-summary-yank-message' and
3735 ;; may insert a different article from the original. So, we will
3736 ;; modify the value of `message-reply-headers' with that article.
3737 (message-reply-headers
3738 (save-restriction
3739 (narrow-to-region start end)
3740 (message-narrow-to-head-1)
3741 (setq x-no-archive (message-fetch-field "x-no-archive"))
3742 (vector 0
3743 (or (message-fetch-field "subject") "none")
3744 (or (message-fetch-field "from") "nobody")
3745 (message-fetch-field "date")
3746 (message-fetch-field "message-id" t)
3747 (message-fetch-field "references")
3748 0 0 ""))))
3749 (mml-quote-region start end)
3750 (when strip-signature
3751 ;; Allow undoing.
3752 (undo-boundary)
3753 (goto-char end)
3754 (when (re-search-backward message-signature-separator start t)
3755 ;; Also peel off any blank lines before the signature.
3756 (forward-line -1)
3757 (while (looking-at "^[ \t]*$")
3758 (forward-line -1))
3759 (forward-line 1)
3760 (delete-region (point) end)
3761 (unless (search-backward "\n\n" start t)
3762 ;; Insert a blank line if it is peeled off.
3763 (insert "\n"))))
3764 (goto-char start)
3765 (mapc 'funcall functions)
3766 (when message-citation-line-function
3767 (unless (bolp)
3768 (insert "\n"))
3769 (funcall message-citation-line-function))
3770 (when (and x-no-archive
3771 (not message-cite-articles-with-x-no-archive)
3772 (string-match "yes" x-no-archive))
3773 (undo-boundary)
3774 (delete-region (point) (mark t))
3775 (insert "> [Quoted text removed due to X-No-Archive]\n")
3776 (push-mark)
3777 (forward-line -1)))))
3778
3779 (defun message-cite-original ()
3780 "Cite function in the standard Message manner."
3781 (message-cite-original-1 nil))
3782
3783 (defvar gnus-extract-address-components)
3784
3785 (autoload 'format-spec "format-spec")
3786
3787 (defun message-insert-formatted-citation-line (&optional from date)
3788 "Function that inserts a formatted citation line.
3789
3790 See `message-citation-line-format'."
3791 ;; The optional args are for testing/debugging. They will disappear later.
3792 ;; Example:
3793 ;; (with-temp-buffer
3794 ;; (message-insert-formatted-citation-line
3795 ;; "John Doe <john.doe@example.invalid>"
3796 ;; (current-time))
3797 ;; (buffer-string))
3798 (when (or message-reply-headers (and from date))
3799 (unless from
3800 (setq from (mail-header-from message-reply-headers)))
3801 (let* ((data (condition-case ()
3802 (funcall (if (boundp gnus-extract-address-components)
3803 gnus-extract-address-components
3804 'mail-extract-address-components)
3805 from)
3806 (error nil)))
3807 (name (car data))
3808 (fname name)
3809 (lname name)
3810 (net (car (cdr data)))
3811 (name-or-net (or (car data)
3812 (car (cdr data)) from))
3813 (replydate
3814 (or
3815 date
3816 ;; We need Gnus functionality if the user wants date or time from
3817 ;; the original article:
3818 (when (string-match "%[^fnNFL]" message-citation-line-format)
3819 (autoload 'gnus-date-get-time "gnus-util")
3820 (gnus-date-get-time (mail-header-date message-reply-headers)))))
3821 (flist
3822 (let ((i ?A) lst)
3823 (when (stringp name)
3824 ;; Guess first name and last name:
3825 (cond ((string-match
3826 "\\`\\(\\w\\|[-.]\\)+ \\(\\w\\|[-.]\\)+\\'" name)
3827 (setq fname (nth 0 (split-string name "[ \t]+"))
3828 lname (nth 1 (split-string name "[ \t]+"))))
3829 ((string-match
3830 "\\`\\(\\w\\|[-.]\\)+, \\(\\w\\|[-.]\\)+\\'" name)
3831 (setq fname (nth 1 (split-string name "[ \t,]+"))
3832 lname (nth 0 (split-string name "[ \t,]+"))))
3833 ((string-match
3834 "\\`\\(\\w\\|[-.]\\)+\\'" name)
3835 (setq fname name
3836 lname ""))))
3837 ;; The following letters are not used in `format-time-string':
3838 (push ?E lst) (push "<E>" lst)
3839 (push ?F lst) (push fname lst)
3840 ;; We might want to use "" instead of "<X>" later.
3841 (push ?J lst) (push "<J>" lst)
3842 (push ?K lst) (push "<K>" lst)
3843 (push ?L lst) (push lname lst)
3844 (push ?N lst) (push name-or-net lst)
3845 (push ?O lst) (push "<O>" lst)
3846 (push ?P lst) (push "<P>" lst)
3847 (push ?Q lst) (push "<Q>" lst)
3848 (push ?f lst) (push from lst)
3849 (push ?i lst) (push "<i>" lst)
3850 (push ?n lst) (push net lst)
3851 (push ?o lst) (push "<o>" lst)
3852 (push ?q lst) (push "<q>" lst)
3853 (push ?t lst) (push "<t>" lst)
3854 (push ?v lst) (push "<v>" lst)
3855 ;; Delegate the rest to `format-time-string':
3856 (while (<= i ?z)
3857 (when (and (not (memq i lst))
3858 ;; Skip (Z,a)
3859 (or (<= i ?Z)
3860 (>= i ?a)))
3861 (push i lst)
3862 (push (condition-case nil
3863 (format-time-string (format "%%%c" i) replydate)
3864 (error (format ">%c<" i)))
3865 lst))
3866 (setq i (1+ i)))
3867 (reverse lst)))
3868 (spec (apply 'format-spec-make flist)))
3869 (insert (format-spec message-citation-line-format spec)))
3870 (newline)))
3871
3872 (defun message-cite-original-without-signature ()
3873 "Cite function in the standard Message manner.
3874 This function strips off the signature from the original message."
3875 (message-cite-original-1 t))
3876
3877 (defun message-insert-citation-line ()
3878 "Insert a simple citation line."
3879 (when message-reply-headers
3880 (insert (mail-header-from message-reply-headers) " writes:")
3881 (newline)
3882 (newline)))
3883
3884 (defun message-position-on-field (header &rest afters)
3885 (let ((case-fold-search t))
3886 (save-restriction
3887 (narrow-to-region
3888 (goto-char (point-min))
3889 (progn
3890 (re-search-forward
3891 (concat "^" (regexp-quote mail-header-separator) "$"))
3892 (match-beginning 0)))
3893 (goto-char (point-min))
3894 (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
3895 (progn
3896 (re-search-forward "^[^ \t]" nil 'move)
3897 (beginning-of-line)
3898 (skip-chars-backward "\n")
3899 t)
3900 (while (and afters
3901 (not (re-search-forward
3902 (concat "^" (regexp-quote (car afters)) ":")
3903 nil t)))
3904 (pop afters))
3905 (when afters
3906 (re-search-forward "^[^ \t]" nil 'move)
3907 (beginning-of-line))
3908 (insert header ": \n")
3909 (forward-char -1)
3910 nil))))
3911
3912 (defun message-remove-signature ()
3913 "Remove the signature from the text between point and mark.
3914 The text will also be indented the normal way."
3915 (save-excursion
3916 (let ((start (point))
3917 mark)
3918 (if (not (re-search-forward message-signature-separator (mark t) t))
3919 ;; No signature here, so we just indent the cited text.
3920 (message-indent-citation)
3921 ;; Find the last non-empty line.
3922 (forward-line -1)
3923 (while (looking-at "[ \t]*$")
3924 (forward-line -1))
3925 (forward-line 1)
3926 (setq mark (set-marker (make-marker) (point)))
3927 (goto-char start)
3928 (message-indent-citation)
3929 ;; Enable undoing the deletion.
3930 (undo-boundary)
3931 (delete-region mark (mark t))
3932 (set-marker mark nil)))))
3933
3934 \f
3935
3936 ;;;
3937 ;;; Sending messages
3938 ;;;
3939
3940 (defun message-send-and-exit (&optional arg)
3941 "Send message like `message-send', then, if no errors, exit from mail buffer."
3942 (interactive "P")
3943 (let ((buf (current-buffer))
3944 (actions message-exit-actions))
3945 (when (and (message-send arg)
3946 (buffer-name buf))
3947 (if message-kill-buffer-on-exit
3948 (kill-buffer buf)
3949 (bury-buffer buf)
3950 (when (eq buf (current-buffer))
3951 (message-bury buf)))
3952 (message-do-actions actions)
3953 t)))
3954
3955 (defun message-dont-send ()
3956 "Don't send the message you have been editing.
3957 Instead, just auto-save the buffer and then bury it."
3958 (interactive)
3959 (set-buffer-modified-p t)
3960 (save-buffer)
3961 (let ((actions message-postpone-actions))
3962 (message-bury (current-buffer))
3963 (message-do-actions actions)))
3964
3965 (defun message-kill-buffer ()
3966 "Kill the current buffer."
3967 (interactive)
3968 (when (or (not (buffer-modified-p))
3969 (not message-kill-buffer-query)
3970 (yes-or-no-p "Message modified; kill anyway? "))
3971 (let ((actions message-kill-actions)
3972 (draft-article message-draft-article)
3973 (auto-save-file-name buffer-auto-save-file-name)
3974 (file-name buffer-file-name)
3975 (modified (buffer-modified-p)))
3976 (setq buffer-file-name nil)
3977 (kill-buffer (current-buffer))
3978 (when (and (or (and auto-save-file-name
3979 (file-exists-p auto-save-file-name))
3980 (and file-name
3981 (file-exists-p file-name)))
3982 (progn
3983 ;; If the message buffer has lived in a dedicated window,
3984 ;; `kill-buffer' has killed the frame. Thus the
3985 ;; `yes-or-no-p' may show up in a lowered frame. Make sure
3986 ;; that the user can see the question by raising the
3987 ;; current frame:
3988 (raise-frame)
3989 (yes-or-no-p (format "Remove the backup file%s? "
3990 (if modified " too" "")))))
3991 (ignore-errors
3992 (delete-file auto-save-file-name))
3993 (let ((message-draft-article draft-article))
3994 (message-disassociate-draft)))
3995 (message-do-actions actions))))
3996
3997 (defun message-bury (buffer)
3998 "Bury this mail BUFFER."
3999 (let ((newbuf (other-buffer buffer)))
4000 (bury-buffer buffer)
4001 (if (and (window-dedicated-p (selected-window))
4002 (not (null (delq (selected-frame) (visible-frame-list)))))
4003 (delete-frame (selected-frame))
4004 (switch-to-buffer newbuf))))
4005
4006 (defun message-send (&optional arg)
4007 "Send the message in the current buffer.
4008 If `message-interactive' is non-nil, wait for success indication or
4009 error messages, and inform user.
4010 Otherwise any failure is reported in a message back to the user from
4011 the mailer.
4012 The usage of ARG is defined by the instance that called Message.
4013 It should typically alter the sending method in some way or other."
4014 (interactive "P")
4015 ;; Make it possible to undo the coming changes.
4016 (undo-boundary)
4017 (let ((inhibit-read-only t))
4018 (put-text-property (point-min) (point-max) 'read-only nil))
4019 (message-fix-before-sending)
4020 (run-hooks 'message-send-hook)
4021 (when message-confirm-send
4022 (or (y-or-n-p "Send message? ")
4023 (keyboard-quit)))
4024 (message message-sending-message)
4025 (let ((alist message-send-method-alist)
4026 (success t)
4027 elem sent dont-barf-on-no-method
4028 (message-options message-options))
4029 (message-options-set-recipient)
4030 (while (and success
4031 (setq elem (pop alist)))
4032 (when (funcall (cadr elem))
4033 (when (and (or (not (memq (car elem)
4034 message-sent-message-via))
4035 (message-fetch-field "supersedes")
4036 (if (or (message-gnksa-enable-p 'multiple-copies)
4037 (not (eq (car elem) 'news)))
4038 (y-or-n-p
4039 (format
4040 "Already sent message via %s; resend? "
4041 (car elem)))
4042 (error "Denied posting -- multiple copies")))
4043 (setq success (funcall (caddr elem) arg)))
4044 (setq sent t))))
4045 (unless (or sent
4046 (not success)
4047 (let ((fcc (message-fetch-field "Fcc"))
4048 (gcc (message-fetch-field "Gcc")))
4049 (when (or fcc gcc)
4050 (or (eq message-allow-no-recipients 'always)
4051 (and (not (eq message-allow-no-recipients 'never))
4052 (setq dont-barf-on-no-method
4053 (gnus-y-or-n-p
4054 (format "No receiver, perform %s anyway? "
4055 (cond ((and fcc gcc) "Fcc and Gcc")
4056 (fcc "Fcc")
4057 (t "Gcc"))))))))))
4058 (error "No methods specified to send by"))
4059 (when (or dont-barf-on-no-method
4060 (and success sent))
4061 (message-do-fcc)
4062 (save-excursion
4063 (run-hooks 'message-sent-hook))
4064 (message "Sending...done")
4065 ;; Do ecomplete address snarfing.
4066 (when (and (message-mail-alias-type-p 'ecomplete)
4067 (not message-inhibit-ecomplete))
4068 (message-put-addresses-in-ecomplete))
4069 ;; Mark the buffer as unmodified and delete auto-save.
4070 (set-buffer-modified-p nil)
4071 (delete-auto-save-file-if-necessary t)
4072 (message-disassociate-draft)
4073 ;; Delete other mail buffers and stuff.
4074 (message-do-send-housekeeping)
4075 (message-do-actions message-send-actions)
4076 ;; Return success.
4077 t)))
4078
4079 (defun message-send-via-mail (arg)
4080 "Send the current message via mail."
4081 (message-send-mail arg))
4082
4083 (defun message-send-via-news (arg)
4084 "Send the current message via news."
4085 (funcall message-send-news-function arg))
4086
4087 (defmacro message-check (type &rest forms)
4088 "Eval FORMS if TYPE is to be checked."
4089 `(or (message-check-element ,type)
4090 (save-excursion
4091 ,@forms)))
4092
4093 (put 'message-check 'lisp-indent-function 1)
4094 (put 'message-check 'edebug-form-spec '(form body))
4095
4096 (defun message-text-with-property (prop &optional start end reverse)
4097 "Return a list of start and end positions where the text has PROP.
4098 START and END bound the search, they default to `point-min' and
4099 `point-max' respectively. If REVERSE is non-nil, find text which does
4100 not have PROP."
4101 (unless start
4102 (setq start (point-min)))
4103 (unless end
4104 (setq end (point-max)))
4105 (let (next regions)
4106 (if reverse
4107 (while (and start
4108 (setq start (text-property-any start end prop nil)))
4109 (setq next (next-single-property-change start prop nil end))
4110 (push (cons start (or next end)) regions)
4111 (setq start next))
4112 (while (and start
4113 (or (get-text-property start prop)
4114 (and (setq start (next-single-property-change
4115 start prop nil end))
4116 (get-text-property start prop))))
4117 (setq next (text-property-any start end prop nil))
4118 (push (cons start (or next end)) regions)
4119 (setq start next)))
4120 (nreverse regions)))
4121
4122 (defcustom message-bogus-addresses
4123 ;; '("noreply" "nospam" "invalid")
4124 '("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]")
4125 "List of regexps of potentially bogus mail addresses.
4126 See `message-check-recipients' how to setup checking.
4127
4128 This list should make it possible to catch typos or warn about
4129 spam-trap addresses. It doesn't aim to verify strict RFC
4130 conformance."
4131 :version "23.1" ;; No Gnus
4132 :group 'message-headers
4133 :type '(choice
4134 (const :tag "None" nil)
4135 (list
4136 (set :inline t
4137 (const "noreply")
4138 (const "nospam")
4139 (const "invalid")
4140 (const :tag "duplicate @" "@@")
4141 (const :tag "non-ascii local part" "[^[:ascii:]].*@")
4142 ;; Already caught by `message-valid-fqdn-regexp'
4143 ;; (const :tag "`_' in domain part" "@.*_")
4144 (const :tag "whitespace" "[ \t]"))
4145 (repeat :inline t
4146 :tag "Other"
4147 (regexp)))))
4148
4149 (defun message-fix-before-sending ()
4150 "Do various things to make the message nice before sending it."
4151 ;; Make sure there's a newline at the end of the message.
4152 (goto-char (point-max))
4153 (unless (bolp)
4154 (insert "\n"))
4155 ;; Make the hidden headers visible.
4156 (widen)
4157 ;; Sort headers before sending the message.
4158 (message-sort-headers)
4159 ;; Make invisible text visible.
4160 ;; It doesn't seem as if this is useful, since the invisible property
4161 ;; is clobbered by an after-change hook anyhow.
4162 (message-check 'invisible-text
4163 (let ((regions (message-text-with-property 'invisible))
4164 from to)
4165 (when regions
4166 (while regions
4167 (setq from (caar regions)
4168 to (cdar regions)
4169 regions (cdr regions))
4170 (put-text-property from to 'invisible nil)
4171 (message-overlay-put (message-make-overlay from to)
4172 'face 'highlight))
4173 (unless (yes-or-no-p
4174 "Invisible text found and made visible; continue sending? ")
4175 (error "Invisible text found and made visible")))))
4176 (message-check 'illegible-text
4177 (let (char found choice)
4178 (message-goto-body)
4179 (while (progn
4180 (skip-chars-forward mm-7bit-chars)
4181 (when (get-text-property (point) 'no-illegible-text)
4182 ;; There is a signed or encrypted raw message part
4183 ;; that is considered to be safe.
4184 (goto-char (or (next-single-property-change
4185 (point) 'no-illegible-text)
4186 (point-max))))
4187 (setq char (char-after)))
4188 (when (or (< (mm-char-int char) 128)
4189 (and (mm-multibyte-p)
4190 (memq (char-charset char)
4191 '(eight-bit-control eight-bit-graphic
4192 ;; Emacs 23, Bug#1770:
4193 eight-bit
4194 control-1))
4195 (not (get-text-property
4196 (point) 'untranslated-utf-8))))
4197 (message-overlay-put (message-make-overlay (point) (1+ (point)))
4198 'face 'highlight)
4199 (setq found t))
4200 (forward-char))
4201 (when found
4202 (setq choice
4203 (gnus-multiple-choice
4204 "Non-printable characters found. Continue sending?"
4205 `((?d "Remove non-printable characters and send")
4206 (?r ,(format
4207 "Replace non-printable characters with \"%s\" and send"
4208 message-replacement-char))
4209 (?s "Send as is without removing anything")
4210 (?e "Continue editing"))))
4211 (if (eq choice ?e)
4212 (error "Non-printable characters"))
4213 (message-goto-body)
4214 (skip-chars-forward mm-7bit-chars)
4215 (while (not (eobp))
4216 (when (let ((char (char-after)))
4217 (or (< (mm-char-int char) 128)
4218 (and (mm-multibyte-p)
4219 ;; FIXME: Wrong for Emacs 23 (unicode) and for
4220 ;; things like undecodable utf-8 (in Emacs 21?).
4221 ;; Should at least use find-coding-systems-region.
4222 ;; -- fx
4223 (memq (char-charset char)
4224 '(eight-bit-control eight-bit-graphic
4225 ;; Emacs 23, Bug#1770:
4226 eight-bit
4227 control-1))
4228 (not (get-text-property
4229 (point) 'untranslated-utf-8)))))
4230 (if (eq choice ?i)
4231 (message-kill-all-overlays)
4232 (delete-char 1)
4233 (when (eq choice ?r)
4234 (insert message-replacement-char))))
4235 (forward-char)
4236 (skip-chars-forward mm-7bit-chars)))))
4237 (message-check 'bogus-recipient
4238 ;; Warn before sending a mail to an invalid address.
4239 (message-check-recipients)))
4240
4241 (defun message-bogus-recipient-p (recipients)
4242 "Check if a mail address in RECIPIENTS looks bogus.
4243
4244 RECIPIENTS is a mail header. Return a list of potentially bogus
4245 addresses. If none is found, return nil.
4246
4247 An address might be bogus if the domain part is not fully
4248 qualified, see `message-valid-fqdn-regexp', or if there's a
4249 matching entry in `message-bogus-addresses'."
4250 ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"?
4251 (let (found)
4252 (mapc (lambda (address)
4253 (setq address (cadr address))
4254 (when
4255 (or (not
4256 (or
4257 (not (string-match "@" address))
4258 (string-match
4259 (concat ".@.*\\("
4260 message-valid-fqdn-regexp "\\)\\'") address)))
4261 (and message-bogus-addresses
4262 (let ((re
4263 (if (listp message-bogus-addresses)
4264 (mapconcat 'identity
4265 message-bogus-addresses
4266 "\\|")
4267 message-bogus-addresses)))
4268 (string-match re address))))
4269 (push address found)))
4270 ;;
4271 (mail-extract-address-components recipients t))
4272 found))
4273
4274 (defun message-check-recipients ()
4275 "Warn before composing or sending a mail to an invalid address.
4276
4277 This function could be useful in `message-setup-hook'."
4278 (interactive)
4279 (save-restriction
4280 (message-narrow-to-headers)
4281 (dolist (hdr '("To" "Cc" "Bcc"))
4282 (let ((addr (message-fetch-field hdr)))
4283 (when (stringp addr)
4284 (dolist (bog (message-bogus-recipient-p addr))
4285 (and bog
4286 (not (y-or-n-p
4287 (format
4288 "Address `%s' might be bogus. Continue? " bog)))
4289 (error "Bogus address"))))))))
4290
4291 (custom-add-option 'message-setup-hook 'message-check-recipients)
4292
4293 (defun message-add-action (action &rest types)
4294 "Add ACTION to be performed when doing an exit of type TYPES."
4295 (while types
4296 (add-to-list (intern (format "message-%s-actions" (pop types)))
4297 action)))
4298
4299 (defun message-delete-action (action &rest types)
4300 "Delete ACTION from lists of actions performed when doing an exit of type TYPES."
4301 (let (var)
4302 (while types
4303 (set (setq var (intern (format "message-%s-actions" (pop types))))
4304 (delq action (symbol-value var))))))
4305
4306 (defun message-do-actions (actions)
4307 "Perform all actions in ACTIONS."
4308 ;; Now perform actions on successful sending.
4309 (dolist (action actions)
4310 (ignore-errors
4311 (cond
4312 ;; A simple function.
4313 ((functionp action)
4314 (funcall action))
4315 ;; Something to be evaled.
4316 (t
4317 (eval action))))))
4318
4319 (defun message-send-mail-partially ()
4320 "Send mail as message/partial."
4321 ;; replace the header delimiter with a blank line
4322 (goto-char (point-min))
4323 (re-search-forward
4324 (concat "^" (regexp-quote mail-header-separator) "\n"))
4325 (replace-match "\n")
4326 (run-hooks 'message-send-mail-hook)
4327 (let ((p (goto-char (point-min)))
4328 (tembuf (message-generate-new-buffer-clone-locals " message temp"))
4329 (curbuf (current-buffer))
4330 (id (message-make-message-id)) (n 1)
4331 plist total header required-mail-headers)
4332 (while (not (eobp))
4333 (if (< (point-max) (+ p message-send-mail-partially-limit))
4334 (goto-char (point-max))
4335 (goto-char (+ p message-send-mail-partially-limit))
4336 (beginning-of-line)
4337 (if (<= (point) p) (forward-line 1))) ;; In case of bad message.
4338 (push p plist)
4339 (setq p (point)))
4340 (setq total (length plist))
4341 (push (point-max) plist)
4342 (setq plist (nreverse plist))
4343 (unwind-protect
4344 (save-excursion
4345 (setq p (pop plist))
4346 (while plist
4347 (set-buffer curbuf)
4348 (copy-to-buffer tembuf p (car plist))
4349 (set-buffer tembuf)
4350 (goto-char (point-min))
4351 (if header
4352 (progn
4353 (goto-char (point-min))
4354 (narrow-to-region (point) (point))
4355 (insert header))
4356 (message-goto-eoh)
4357 (setq header (buffer-substring (point-min) (point)))
4358 (goto-char (point-min))
4359 (narrow-to-region (point) (point))
4360 (insert header)
4361 (message-remove-header "Mime-Version")
4362 (message-remove-header "Content-Type")
4363 (message-remove-header "Content-Transfer-Encoding")
4364 (message-remove-header "Message-ID")
4365 (message-remove-header "Lines")
4366 (goto-char (point-max))
4367 (insert "Mime-Version: 1.0\n")
4368 (setq header (buffer-string)))
4369 (goto-char (point-max))
4370 (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
4371 id n total))
4372 (forward-char -1)
4373 (let ((mail-header-separator ""))
4374 (when (memq 'Message-ID message-required-mail-headers)
4375 (insert "Message-ID: " (message-make-message-id) "\n"))
4376 (when (memq 'Lines message-required-mail-headers)
4377 (insert "Lines: " (message-make-lines) "\n"))
4378 (message-goto-subject)
4379 (end-of-line)
4380 (insert (format " (%d/%d)" n total))
4381 (widen)
4382 (funcall (or message-send-mail-real-function
4383 message-send-mail-function)))
4384 (setq n (+ n 1))
4385 (setq p (pop plist))
4386 (erase-buffer)))
4387 (kill-buffer tembuf))))
4388
4389 (declare-function hashcash-wait-async "hashcash" (&optional buffer))
4390
4391 (defun message-send-mail (&optional arg)
4392 (require 'mail-utils)
4393 (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
4394 (case-fold-search nil)
4395 (news (message-news-p))
4396 (mailbuf (current-buffer))
4397 (message-this-is-mail t)
4398 ;; gnus-setup-posting-charset is autoloaded in mml.el (FIXME
4399 ;; maybe it should not be), which this file requires. Hence
4400 ;; the fboundp test is always true. Loading it from gnus-msg
4401 ;; loads many Gnus files (Bug#5642). If
4402 ;; gnus-group-posting-charset-alist hasn't been customized,
4403 ;; this is just going to return nil anyway. FIXME it would
4404 ;; be good to improve this further, because even if g-g-p-c-a
4405 ;; has been customized, that is likely to just be for news.
4406 ;; Eg either move the definition from gnus-msg, or separate out
4407 ;; the mail and news parts.
4408 (message-posting-charset
4409 (if (and (fboundp 'gnus-setup-posting-charset)
4410 (boundp 'gnus-group-posting-charset-alist))
4411 (gnus-setup-posting-charset nil)
4412 message-posting-charset))
4413 (headers message-required-mail-headers))
4414 (when (and message-generate-hashcash
4415 (not (eq message-generate-hashcash 'opportunistic)))
4416 (message "Generating hashcash...")
4417 (require 'hashcash)
4418 ;; Wait for calculations already started to finish...
4419 (hashcash-wait-async)
4420 ;; ...and do calculations not already done. mail-add-payment
4421 ;; will leave existing X-Hashcash headers alone.
4422 (mail-add-payment)
4423 (message "Generating hashcash...done"))
4424 (save-restriction
4425 (message-narrow-to-headers)
4426 ;; Generate the Mail-Followup-To header if the header is not there...
4427 (if (and (message-subscribed-p)
4428 (not (mail-fetch-field "mail-followup-to")))
4429 (setq headers
4430 (cons
4431 (cons "Mail-Followup-To" (message-make-mail-followup-to))
4432 message-required-mail-headers))
4433 ;; otherwise, delete the MFT header if the field is empty
4434 (when (equal "" (mail-fetch-field "mail-followup-to"))
4435 (message-remove-header "^Mail-Followup-To:")))
4436 ;; Insert some headers.
4437 (let ((message-deletable-headers
4438 (if news nil message-deletable-headers)))
4439 (message-generate-headers headers))
4440 ;; Check continuation headers.
4441 (message-check 'continuation-headers
4442 (goto-char (point-min))
4443 (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t)
4444 (goto-char (match-beginning 0))
4445 (if (y-or-n-p "Fix continuation lines? ")
4446 (insert " ")
4447 (forward-line 1)
4448 (unless (y-or-n-p "Send anyway? ")
4449 (error "Failed to send the message")))))
4450 ;; Let the user do all of the above.
4451 (run-hooks 'message-header-hook))
4452 (unwind-protect
4453 (with-current-buffer tembuf
4454 (erase-buffer)
4455 ;; Avoid copying text props (except hard newlines).
4456 (insert (with-current-buffer mailbuf
4457 (mml-buffer-substring-no-properties-except-hard-newlines
4458 (point-min) (point-max))))
4459 ;; Remove some headers.
4460 (message-encode-message-body)
4461 (save-restriction
4462 (message-narrow-to-headers)
4463 ;; We (re)generate the Lines header.
4464 (when (memq 'Lines message-required-mail-headers)
4465 (message-generate-headers '(Lines)))
4466 ;; Remove some headers.
4467 (message-remove-header message-ignored-mail-headers t)
4468 (let ((mail-parse-charset message-default-charset))
4469 (mail-encode-encoded-word-buffer)))
4470 (goto-char (point-max))
4471 ;; require one newline at the end.
4472 (or (= (preceding-char) ?\n)
4473 (insert ?\n))
4474 (message-cleanup-headers)
4475 ;; FIXME: we're inserting the courtesy copy after encoding.
4476 ;; This is wrong if the courtesy copy string contains
4477 ;; non-ASCII characters. -- jh
4478 (when
4479 (save-restriction
4480 (message-narrow-to-headers)
4481 (and news
4482 (or (message-fetch-field "cc")
4483 (message-fetch-field "bcc")
4484 (message-fetch-field "to"))
4485 (let ((content-type (message-fetch-field
4486 "content-type")))
4487 (and
4488 (or
4489 (not content-type)
4490 (string= "text/plain"
4491 (car
4492 (mail-header-parse-content-type
4493 content-type))))
4494 (not
4495 (string= "base64"
4496 (message-fetch-field
4497 "content-transfer-encoding")))))))
4498 (message-insert-courtesy-copy))
4499 ;; Let's make sure we encoded all the body.
4500 (assert (save-excursion
4501 (goto-char (point-min))
4502 (not (re-search-forward "[^\000-\377]" nil t))))
4503 (mm-disable-multibyte)
4504 (if (or (not message-send-mail-partially-limit)
4505 (< (buffer-size) message-send-mail-partially-limit)
4506 (not (message-y-or-n-p
4507 "The message size is too large, split? "
4508 t
4509 "\
4510 The message size, "
4511 (/ (buffer-size) 1000) "KB, is too large.
4512
4513 Some mail gateways (MTA's) bounce large messages. To avoid the
4514 problem, answer `y', and the message will be split into several
4515 smaller pieces, the size of each is about "
4516 (/ message-send-mail-partially-limit 1000)
4517 "KB except the last
4518 one.
4519
4520 However, some mail readers (MUA's) can't read split messages, i.e.,
4521 mails in message/partially format. Answer `n', and the message will be
4522 sent in one piece.
4523
4524 The size limit is controlled by `message-send-mail-partially-limit'.
4525 If you always want Gnus to send messages in one piece, set
4526 `message-send-mail-partially-limit' to nil.
4527 ")))
4528 (progn
4529 (message "Sending via mail...")
4530 (funcall (or message-send-mail-real-function
4531 message-send-mail-function)))
4532 (message-send-mail-partially)))
4533 (kill-buffer tembuf))
4534 (set-buffer mailbuf)
4535 (push 'mail message-sent-message-via)))
4536
4537 (defun message-send-mail-with-sendmail ()
4538 "Send off the prepared buffer with sendmail."
4539 (require 'sendmail)
4540 (let ((errbuf (if message-interactive
4541 (message-generate-new-buffer-clone-locals
4542 " sendmail errors")
4543 0))
4544 resend-to-addresses delimline)
4545 (unwind-protect
4546 (progn
4547 (let ((case-fold-search t))
4548 (save-restriction
4549 (message-narrow-to-headers)
4550 (setq resend-to-addresses (message-fetch-field "resent-to")))
4551 ;; Change header-delimiter to be what sendmail expects.
4552 (goto-char (point-min))
4553 (re-search-forward
4554 (concat "^" (regexp-quote mail-header-separator) "\n"))
4555 (replace-match "\n")
4556 (backward-char 1)
4557 (setq delimline (point-marker))
4558 (run-hooks 'message-send-mail-hook)
4559 ;; Insert an extra newline if we need it to work around
4560 ;; Sun's bug that swallows newlines.
4561 (goto-char (1+ delimline))
4562 (when (eval message-mailer-swallows-blank-line)
4563 (newline))
4564 (when message-interactive
4565 (with-current-buffer errbuf
4566 (erase-buffer))))
4567 (let* ((default-directory "/")
4568 (coding-system-for-write message-send-coding-system)
4569 (cpr (apply
4570 'call-process-region
4571 (append
4572 (list (point-min) (point-max)
4573 (cond ((boundp 'sendmail-program)
4574 sendmail-program)
4575 ((file-exists-p "/usr/sbin/sendmail")
4576 "/usr/sbin/sendmail")
4577 ((file-exists-p "/usr/lib/sendmail")
4578 "/usr/lib/sendmail")
4579 ((file-exists-p "/usr/ucblib/sendmail")
4580 "/usr/ucblib/sendmail")
4581 (t "fakemail"))
4582 nil errbuf nil "-oi")
4583 message-sendmail-extra-arguments
4584 ;; Always specify who from,
4585 ;; since some systems have broken sendmails.
4586 ;; But some systems are more broken with -f, so
4587 ;; we'll let users override this.
4588 (and (null message-sendmail-f-is-evil)
4589 (list "-f" (message-sendmail-envelope-from)))
4590 ;; These mean "report errors by mail"
4591 ;; and "deliver in background".
4592 (if (null message-interactive) '("-oem" "-odb"))
4593 ;; Get the addresses from the message
4594 ;; unless this is a resend.
4595 ;; We must not do that for a resend
4596 ;; because we would find the original addresses.
4597 ;; For a resend, include the specific addresses.
4598 (if resend-to-addresses
4599 (list resend-to-addresses)
4600 '("-t"))))))
4601 (unless (or (null cpr) (and (numberp cpr) (zerop cpr)))
4602 (if errbuf (pop-to-buffer errbuf))
4603 (error "Sending...failed with exit value %d" cpr)))
4604 (when message-interactive
4605 (with-current-buffer errbuf
4606 (goto-char (point-min))
4607 (while (re-search-forward "\n+ *" nil t)
4608 (replace-match "; "))
4609 (if (not (zerop (buffer-size)))
4610 (error "Sending...failed to %s"
4611 (buffer-string))))))
4612 (when (bufferp errbuf)
4613 (kill-buffer errbuf)))))
4614
4615 (defun message-send-mail-with-qmail ()
4616 "Pass the prepared message buffer to qmail-inject.
4617 Refer to the documentation for the variable `message-send-mail-function'
4618 to find out how to use this."
4619 ;; replace the header delimiter with a blank line
4620 (goto-char (point-min))
4621 (re-search-forward
4622 (concat "^" (regexp-quote mail-header-separator) "\n"))
4623 (replace-match "\n")
4624 (run-hooks 'message-send-mail-hook)
4625 ;; send the message
4626 (case
4627 (let ((coding-system-for-write message-send-coding-system))
4628 (apply
4629 'call-process-region (point-min) (point-max)
4630 message-qmail-inject-program nil nil nil
4631 ;; qmail-inject's default behavior is to look for addresses on the
4632 ;; command line; if there're none, it scans the headers.
4633 ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
4634 ;;
4635 ;; in general, ALL of qmail-inject's defaults are perfect for simply
4636 ;; reading a formatted (i. e., at least a To: or Resent-To header)
4637 ;; message from stdin.
4638 ;;
4639 ;; qmail also has the advantage of not having been raped by
4640 ;; various vendors, so we don't have to allow for that, either --
4641 ;; compare this with message-send-mail-with-sendmail and weep
4642 ;; for sendmail's lost innocence.
4643 ;;
4644 ;; all this is way cool coz it lets us keep the arguments entirely
4645 ;; free for -inject-arguments -- a big win for the user and for us
4646 ;; since we don't have to play that double-guessing game and the user
4647 ;; gets full control (no gestapo'ish -f's, for instance). --sj
4648 (if (functionp message-qmail-inject-args)
4649 (funcall message-qmail-inject-args)
4650 message-qmail-inject-args)))
4651 ;; qmail-inject doesn't say anything on it's stdout/stderr,
4652 ;; we have to look at the retval instead
4653 (0 nil)
4654 (100 (error "qmail-inject reported permanent failure"))
4655 (111 (error "qmail-inject reported transient failure"))
4656 ;; should never happen
4657 (t (error "qmail-inject reported unknown failure"))))
4658
4659 (defun message-send-mail-with-mh ()
4660 "Send the prepared message buffer with mh."
4661 (let ((mh-previous-window-config nil)
4662 (name (mh-new-draft-name)))
4663 (setq buffer-file-name name)
4664 ;; MH wants to generate these headers itself.
4665 (when message-mh-deletable-headers
4666 (let ((headers message-mh-deletable-headers))
4667 (while headers
4668 (goto-char (point-min))
4669 (and (re-search-forward
4670 (concat "^" (symbol-name (car headers)) ": *") nil t)
4671 (message-delete-line))
4672 (pop headers))))
4673 (run-hooks 'message-send-mail-hook)
4674 ;; Pass it on to mh.
4675 (mh-send-letter)))
4676
4677 (defun message-smtpmail-send-it ()
4678 "Send the prepared message buffer with `smtpmail-send-it'.
4679 The only difference from `smtpmail-send-it' is that this command
4680 evaluates `message-send-mail-hook' just before sending a message.
4681 It is useful if your ISP requires the POP-before-SMTP
4682 authentication. See the Gnus manual for details."
4683 (run-hooks 'message-send-mail-hook)
4684 (smtpmail-send-it))
4685
4686 (defun message-send-mail-with-mailclient ()
4687 "Send the prepared message buffer with `mailclient-send-it'.
4688 The only difference from `mailclient-send-it' is that this
4689 command evaluates `message-send-mail-hook' just before sending a message."
4690 (run-hooks 'message-send-mail-hook)
4691 (mailclient-send-it))
4692
4693 (defun message-canlock-generate ()
4694 "Return a string that is non-trivial to guess.
4695 Do not use this for anything important, it is cryptographically weak."
4696 (require 'sha1)
4697 (let (sha1-maximum-internal-length)
4698 (sha1 (concat (message-unique-id)
4699 (format "%x%x%x" (random) (random t) (random))
4700 (prin1-to-string (recent-keys))
4701 (prin1-to-string (garbage-collect))))))
4702
4703 (defvar canlock-password)
4704 (defvar canlock-password-for-verify)
4705
4706 (defun message-canlock-password ()
4707 "The password used by message for cancel locks.
4708 This is the value of `canlock-password', if that option is non-nil.
4709 Otherwise, generate and save a value for `canlock-password' first."
4710 (require 'canlock)
4711 (unless canlock-password
4712 (customize-save-variable 'canlock-password (message-canlock-generate))
4713 (setq canlock-password-for-verify canlock-password))
4714 canlock-password)
4715
4716 (defun message-insert-canlock ()
4717 (when message-insert-canlock
4718 (message-canlock-password)
4719 (canlock-insert-header)))
4720
4721 (autoload 'nnheader-get-report "nnheader")
4722
4723 (declare-function gnus-setup-posting-charset "gnus-msg" (group))
4724
4725 (defun message-send-news (&optional arg)
4726 (require 'gnus-msg)
4727 (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
4728 (case-fold-search nil)
4729 (method (if (functionp message-post-method)
4730 (funcall message-post-method arg)
4731 message-post-method))
4732 (newsgroups-field (save-restriction
4733 (message-narrow-to-headers-or-head)
4734 (message-fetch-field "Newsgroups")))
4735 (followup-field (save-restriction
4736 (message-narrow-to-headers-or-head)
4737 (message-fetch-field "Followup-To")))
4738 ;; BUG: We really need to get the charset for each name in the
4739 ;; Newsgroups and Followup-To lines to allow crossposting
4740 ;; between group namess with incompatible character sets.
4741 ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
4742 (group-field-charset
4743 (gnus-group-name-charset method newsgroups-field))
4744 (followup-field-charset
4745 (gnus-group-name-charset method (or followup-field "")))
4746 (rfc2047-header-encoding-alist
4747 (append (when group-field-charset
4748 (list (cons "Newsgroups" group-field-charset)))
4749 (when followup-field-charset
4750 (list (cons "Followup-To" followup-field-charset)))
4751 rfc2047-header-encoding-alist))
4752 (messbuf (current-buffer))
4753 (message-syntax-checks
4754 (if (and arg
4755 (listp message-syntax-checks))
4756 (cons '(existing-newsgroups . disabled)
4757 message-syntax-checks)
4758 message-syntax-checks))
4759 (message-this-is-news t)
4760 (message-posting-charset
4761 (gnus-setup-posting-charset newsgroups-field))
4762 result)
4763 (if (not (message-check-news-body-syntax))
4764 nil
4765 (save-restriction
4766 (message-narrow-to-headers)
4767 ;; Insert some headers.
4768 (message-generate-headers message-required-news-headers)
4769 (message-insert-canlock)
4770 ;; Let the user do all of the above.
4771 (run-hooks 'message-header-hook))
4772 ;; Note: This check will be disabled by the ".*" default value for
4773 ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07.
4774 (when (and group-field-charset
4775 (listp message-syntax-checks))
4776 (setq message-syntax-checks
4777 (cons '(valid-newsgroups . disabled)
4778 message-syntax-checks)))
4779 (message-cleanup-headers)
4780 (if (not (let ((message-post-method method))
4781 (message-check-news-syntax)))
4782 nil
4783 (unwind-protect
4784 (with-current-buffer tembuf
4785 (buffer-disable-undo)
4786 (erase-buffer)
4787 ;; Avoid copying text props (except hard newlines).
4788 (insert
4789 (with-current-buffer messbuf
4790 (mml-buffer-substring-no-properties-except-hard-newlines
4791 (point-min) (point-max))))
4792 (message-encode-message-body)
4793 ;; Remove some headers.
4794 (save-restriction
4795 (message-narrow-to-headers)
4796 ;; We (re)generate the Lines header.
4797 (when (memq 'Lines message-required-mail-headers)
4798 (message-generate-headers '(Lines)))
4799 ;; Remove some headers.
4800 (message-remove-header message-ignored-news-headers t)
4801 (let ((mail-parse-charset message-default-charset))
4802 (mail-encode-encoded-word-buffer)))
4803 (goto-char (point-max))
4804 ;; require one newline at the end.
4805 (or (= (preceding-char) ?\n)
4806 (insert ?\n))
4807 (let ((case-fold-search t))
4808 ;; Remove the delimiter.
4809 (goto-char (point-min))
4810 (re-search-forward
4811 (concat "^" (regexp-quote mail-header-separator) "\n"))
4812 (replace-match "\n")
4813 (backward-char 1))
4814 (run-hooks 'message-send-news-hook)
4815 (gnus-open-server method)
4816 (message "Sending news via %s..." (gnus-server-string method))
4817 (setq result (let ((mail-header-separator ""))
4818 (gnus-request-post method))))
4819 (kill-buffer tembuf))
4820 (set-buffer messbuf)
4821 (if result
4822 (push 'news message-sent-message-via)
4823 (message "Couldn't send message via news: %s"
4824 (nnheader-get-report (car method)))
4825 nil)))))
4826
4827 ;;;
4828 ;;; Header generation & syntax checking.
4829 ;;;
4830
4831 (defun message-check-element (type)
4832 "Return non-nil if this TYPE is not to be checked."
4833 (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
4834 t
4835 (let ((able (assq type message-syntax-checks)))
4836 (and (consp able)
4837 (eq (cdr able) 'disabled)))))
4838
4839 (defun message-check-news-syntax ()
4840 "Check the syntax of the message."
4841 (save-excursion
4842 (save-restriction
4843 (widen)
4844 ;; We narrow to the headers and check them first.
4845 (save-excursion
4846 (save-restriction
4847 (message-narrow-to-headers)
4848 (message-check-news-header-syntax))))))
4849
4850 (defun message-check-news-header-syntax ()
4851 (and
4852 ;; Check Newsgroups header.
4853 (message-check 'newsgroups
4854 (let ((group (message-fetch-field "newsgroups")))
4855 (or
4856 (and group
4857 (not (string-match "\\`[ \t]*\\'" group)))
4858 (ignore
4859 (message
4860 "The newsgroups field is empty or missing. Posting is denied.")))))
4861 ;; Check the Subject header.
4862 (message-check 'subject
4863 (let* ((case-fold-search t)
4864 (subject (message-fetch-field "subject")))
4865 (or
4866 (and subject
4867 (not (string-match "\\`[ \t]*\\'" subject)))
4868 (ignore
4869 (message
4870 "The subject field is empty or missing. Posting is denied.")))))
4871 ;; Check for commands in Subject.
4872 (message-check 'subject-cmsg
4873 (if (string-match "^cmsg " (message-fetch-field "subject"))
4874 (y-or-n-p
4875 "The control code \"cmsg\" is in the subject. Really post? ")
4876 t))
4877 ;; Check long header lines.
4878 (message-check 'long-header-lines
4879 (let ((start (point))
4880 (header nil)
4881 (length 0)
4882 found)
4883 (while (and (not found)
4884 (re-search-forward "^\\([^ \t:]+\\): " nil t))
4885 (if (> (- (point) (match-beginning 0)) 998)
4886 (setq found t
4887 length (- (point) (match-beginning 0)))
4888 (setq header (match-string-no-properties 1)))
4889 (setq start (match-beginning 0))
4890 (forward-line 1))
4891 (if found
4892 (y-or-n-p (format "Your %s header is too long (%d). Really post? "
4893 header length))
4894 t)))
4895 ;; Check for multiple identical headers.
4896 (message-check 'multiple-headers
4897 (let (found)
4898 (while (and (not found)
4899 (re-search-forward "^[^ \t:]+: " nil t))
4900 (save-excursion
4901 (or (re-search-forward
4902 (concat "^"
4903 (regexp-quote
4904 (setq found
4905 (buffer-substring
4906 (match-beginning 0) (- (match-end 0) 2))))
4907 ":")
4908 nil t)
4909 (setq found nil))))
4910 (if found
4911 (y-or-n-p (format "Multiple %s headers. Really post? " found))
4912 t)))
4913 ;; Check for Version and Sendsys.
4914 (message-check 'sendsys
4915 (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
4916 (y-or-n-p
4917 (format "The article contains a %s command. Really post? "
4918 (buffer-substring (match-beginning 0)
4919 (1- (match-end 0)))))
4920 t))
4921 ;; See whether we can shorten Followup-To.
4922 (message-check 'shorten-followup-to
4923 (let ((newsgroups (message-fetch-field "newsgroups"))
4924 (followup-to (message-fetch-field "followup-to"))
4925 to)
4926 (when (and newsgroups
4927 (string-match "," newsgroups)
4928 (not followup-to)
4929 (not
4930 (zerop
4931 (length
4932 (setq to (completing-read
4933 "Followups to (default no Followup-To header): "
4934 (mapcar #'list
4935 (cons "poster"
4936 (message-tokenize-header
4937 newsgroups)))))))))
4938 (goto-char (point-min))
4939 (insert "Followup-To: " to "\n"))
4940 t))
4941 ;; Check "Shoot me".
4942 (message-check 'shoot
4943 (if (re-search-forward
4944 "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t)
4945 (y-or-n-p "You appear to have a misconfigured system. Really post? ")
4946 t))
4947 ;; Check for Approved.
4948 (message-check 'approved
4949 (if (re-search-forward "^Approved:" nil t)
4950 (y-or-n-p "The article contains an Approved header. Really post? ")
4951 t))
4952 ;; Check the Message-ID header.
4953 (message-check 'message-id
4954 (let* ((case-fold-search t)
4955 (message-id (message-fetch-field "message-id" t)))
4956 (or (not message-id)
4957 ;; Is there an @ in the ID?
4958 (and (string-match "@" message-id)
4959 ;; Is there a dot in the ID?
4960 (string-match "@[^.]*\\." message-id)
4961 ;; Does the ID end with a dot?
4962 (not (string-match "\\.>" message-id)))
4963 (y-or-n-p
4964 (format "The Message-ID looks strange: \"%s\". Really post? "
4965 message-id)))))
4966 ;; Check the Newsgroups & Followup-To headers.
4967 (message-check 'existing-newsgroups
4968 (let* ((case-fold-search t)
4969 (newsgroups (message-fetch-field "newsgroups"))
4970 (followup-to (message-fetch-field "followup-to"))
4971 (groups (message-tokenize-header
4972 (if followup-to
4973 (concat newsgroups "," followup-to)
4974 newsgroups)))
4975 (post-method (if (functionp message-post-method)
4976 (funcall message-post-method)
4977 message-post-method))
4978 ;; KLUDGE to handle nnvirtual groups. Doing this right
4979 ;; would probably involve a new nnoo function.
4980 ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17.
4981 (method (if (and (consp post-method)
4982 (eq (car post-method) 'nnvirtual)
4983 gnus-message-group-art)
4984 (let ((group (car (nnvirtual-find-group-art
4985 (car gnus-message-group-art)
4986 (cdr gnus-message-group-art)))))
4987 (gnus-find-method-for-group group))
4988 post-method))
4989 (known-groups
4990 (mapcar (lambda (n)
4991 (gnus-group-name-decode
4992 (gnus-group-real-name n)
4993 (gnus-group-name-charset method n)))
4994 (gnus-groups-from-server method)))
4995 errors)
4996 (while groups
4997 (when (and (not (equal (car groups) "poster"))
4998 (not (member (car groups) known-groups))
4999 (not (member (car groups) errors)))
5000 (push (car groups) errors))
5001 (pop groups))
5002 (cond
5003 ;; Gnus is not running.
5004 ((or (not (and (boundp 'gnus-active-hashtb)
5005 gnus-active-hashtb))
5006 (not (boundp 'gnus-read-active-file)))
5007 t)
5008 ;; We don't have all the group names.
5009 ((and (or (not gnus-read-active-file)
5010 (eq gnus-read-active-file 'some))
5011 errors)
5012 (y-or-n-p
5013 (format
5014 "Really use %s possibly unknown group%s: %s? "
5015 (if (= (length errors) 1) "this" "these")
5016 (if (= (length errors) 1) "" "s")
5017 (mapconcat 'identity errors ", "))))
5018 ;; There were no errors.
5019 ((not errors)
5020 t)
5021 ;; There are unknown groups.
5022 (t
5023 (y-or-n-p
5024 (format
5025 "Really post to %s unknown group%s: %s? "
5026 (if (= (length errors) 1) "this" "these")
5027 (if (= (length errors) 1) "" "s")
5028 (mapconcat 'identity errors ", ")))))))
5029 ;; Check continuation headers.
5030 (message-check 'continuation-headers
5031 (goto-char (point-min))
5032 (let ((do-posting t))
5033 (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t)
5034 (goto-char (match-beginning 0))
5035 (if (y-or-n-p "Fix continuation lines? ")
5036 (insert " ")
5037 (forward-line 1)
5038 (unless (y-or-n-p "Send anyway? ")
5039 (setq do-posting nil))))
5040 do-posting))
5041 ;; Check the Newsgroups & Followup-To headers for syntax errors.
5042 (message-check 'valid-newsgroups
5043 (let ((case-fold-search t)
5044 (headers '("Newsgroups" "Followup-To"))
5045 header error)
5046 (while (and headers (not error))
5047 (when (setq header (mail-fetch-field (car headers)))
5048 (if (or
5049 (not
5050 (string-match
5051 "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
5052 header))
5053 (memq
5054 nil (mapcar
5055 (lambda (g)
5056 (not (string-match "\\.\\'\\|\\.\\." g)))
5057 (message-tokenize-header header ","))))
5058 (setq error t)))
5059 (unless error
5060 (pop headers)))
5061 (if (not error)
5062 t
5063 (y-or-n-p
5064 (format "The %s header looks odd: \"%s\". Really post? "
5065 (car headers) header)))))
5066 (message-check 'repeated-newsgroups
5067 (let ((case-fold-search t)
5068 (headers '("Newsgroups" "Followup-To"))
5069 header error groups group)
5070 (while (and headers
5071 (not error))
5072 (when (setq header (mail-fetch-field (pop headers)))
5073 (setq groups (message-tokenize-header header ","))
5074 (while (setq group (pop groups))
5075 (when (member group groups)
5076 (setq error group
5077 groups nil)))))
5078 (if (not error)
5079 t
5080 (y-or-n-p
5081 (format "Group %s is repeated in headers. Really post? " error)))))
5082 ;; Check the From header.
5083 (message-check 'from
5084 (let* ((case-fold-search t)
5085 (from (message-fetch-field "from"))
5086 ad)
5087 (cond
5088 ((not from)
5089 (message "There is no From line. Posting is denied.")
5090 nil)
5091 ((or (not (string-match
5092 "@[^\\.]*\\."
5093 (setq ad (nth 1 (mail-extract-address-components
5094 from))))) ;larsi@ifi
5095 (string-match "\\.\\." ad) ;larsi@ifi..uio
5096 (string-match "@\\." ad) ;larsi@.ifi.uio
5097 (string-match "\\.$" ad) ;larsi@ifi.uio.
5098 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
5099 (string-match "(.*).*(.*)" from)) ;(lars) (lars)
5100 (message
5101 "Denied posting -- the From looks strange: \"%s\"." from)
5102 nil)
5103 ((let ((addresses (rfc822-addresses from)))
5104 ;; `rfc822-addresses' returns a string if parsing fails.
5105 (while (and (consp addresses)
5106 (not (eq (string-to-char (car addresses)) ?\()))
5107 (setq addresses (cdr addresses)))
5108 addresses)
5109 (message
5110 "Denied posting -- bad From address: \"%s\"." from)
5111 nil)
5112 (t t))))
5113 ;; Check the Reply-To header.
5114 (message-check 'reply-to
5115 (let* ((case-fold-search t)
5116 (reply-to (message-fetch-field "reply-to"))
5117 ad)
5118 (cond
5119 ((not reply-to)
5120 t)
5121 ((string-match "," reply-to)
5122 (y-or-n-p
5123 (format "Multiple Reply-To addresses: \"%s\". Really post? "
5124 reply-to)))
5125 ((or (not (string-match
5126 "@[^\\.]*\\."
5127 (setq ad (nth 1 (mail-extract-address-components
5128 reply-to))))) ;larsi@ifi
5129 (string-match "\\.\\." ad) ;larsi@ifi..uio
5130 (string-match "@\\." ad) ;larsi@.ifi.uio
5131 (string-match "\\.$" ad) ;larsi@ifi.uio.
5132 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
5133 (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars)
5134 (y-or-n-p
5135 (format
5136 "The Reply-To looks strange: \"%s\". Really post? "
5137 reply-to)))
5138 (t t))))))
5139
5140 (defun message-check-news-body-syntax ()
5141 (and
5142 ;; Check for long lines.
5143 (message-check 'long-lines
5144 (goto-char (point-min))
5145 (re-search-forward
5146 (concat "^" (regexp-quote mail-header-separator) "$"))
5147 (forward-line 1)
5148 (while (and
5149 (or (looking-at
5150 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)")
5151 (let ((p (point)))
5152 (end-of-line)
5153 (< (- (point) p) 80)))
5154 (zerop (forward-line 1))))
5155 (or (bolp)
5156 (eobp)
5157 (y-or-n-p
5158 "You have lines longer than 79 characters. Really post? ")))
5159 ;; Check whether the article is empty.
5160 (message-check 'empty
5161 (goto-char (point-min))
5162 (re-search-forward
5163 (concat "^" (regexp-quote mail-header-separator) "$"))
5164 (forward-line 1)
5165 (let ((b (point)))
5166 (goto-char (point-max))
5167 (re-search-backward message-signature-separator nil t)
5168 (beginning-of-line)
5169 (or (re-search-backward "[^ \n\t]" b t)
5170 (if (message-gnksa-enable-p 'empty-article)
5171 (y-or-n-p "Empty article. Really post? ")
5172 (message "Denied posting -- Empty article.")
5173 nil))))
5174 ;; Check for control characters.
5175 (message-check 'control-chars
5176 (if (re-search-forward
5177 (mm-string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]")
5178 nil t)
5179 (y-or-n-p
5180 "The article contains control characters. Really post? ")
5181 t))
5182 ;; Check excessive size.
5183 (message-check 'size
5184 (if (> (buffer-size) 60000)
5185 (y-or-n-p
5186 (format "The article is %d octets long. Really post? "
5187 (buffer-size)))
5188 t))
5189 ;; Check whether any new text has been added.
5190 (message-check 'new-text
5191 (or
5192 (not message-checksum)
5193 (not (eq (message-checksum) message-checksum))
5194 (if (message-gnksa-enable-p 'quoted-text-only)
5195 (y-or-n-p
5196 "It looks like no new text has been added. Really post? ")
5197 (message "Denied posting -- no new text has been added.")
5198 nil)))
5199 ;; Check the length of the signature.
5200 (message-check 'signature
5201 (let (sig-start sig-end)
5202 (goto-char (point-max))
5203 (if (not (re-search-backward message-signature-separator nil t))
5204 t
5205 (setq sig-start (1+ (point-at-eol)))
5206 (setq sig-end
5207 (if (re-search-forward
5208 "<#/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
5209 (- (point-at-bol) 1)
5210 (point-max)))
5211 (if (>= (count-lines sig-start sig-end) 5)
5212 (if (message-gnksa-enable-p 'signature)
5213 (y-or-n-p
5214 (format "Signature is excessively long (%d lines). Really post? "
5215 (count-lines sig-start sig-end)))
5216 (message "Denied posting -- Excessive signature.")
5217 nil)
5218 t))))
5219 ;; Ensure that text follows last quoted portion.
5220 (message-check 'quoting-style
5221 (goto-char (point-max))
5222 (let ((no-problem t))
5223 (when (search-backward-regexp "^>[^\n]*\n" nil t)
5224 (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t)))
5225 (if no-problem
5226 t
5227 (if (message-gnksa-enable-p 'quoted-text-only)
5228 (y-or-n-p "Your text should follow quoted text. Really post? ")
5229 ;; Ensure that
5230 (goto-char (point-min))
5231 (re-search-forward
5232 (concat "^" (regexp-quote mail-header-separator) "$"))
5233 (if (search-forward-regexp "^[ \t]*[^>\n]" nil t)
5234 (y-or-n-p "Your text should follow quoted text. Really post? ")
5235 (message "Denied posting -- only quoted text.")
5236 nil)))))))
5237
5238 (defun message-checksum ()
5239 "Return a \"checksum\" for the current buffer."
5240 (let ((sum 0))
5241 (save-excursion
5242 (goto-char (point-min))
5243 (re-search-forward
5244 (concat "^" (regexp-quote mail-header-separator) "$"))
5245 (while (not (eobp))
5246 (when (not (looking-at "[ \t\n]"))
5247 (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
5248 (char-after))))
5249 (forward-char 1)))
5250 sum))
5251
5252 (defun message-do-fcc ()
5253 "Process Fcc headers in the current buffer."
5254 (let ((case-fold-search t)
5255 (buf (current-buffer))
5256 list file
5257 (mml-externalize-attachments message-fcc-externalize-attachments))
5258 (save-excursion
5259 (save-restriction
5260 (message-narrow-to-headers)
5261 (setq file (message-fetch-field "fcc" t)))
5262 (when file
5263 (set-buffer (get-buffer-create " *message temp*"))
5264 (erase-buffer)
5265 (insert-buffer-substring buf)
5266 (message-encode-message-body)
5267 (save-restriction
5268 (message-narrow-to-headers)
5269 (while (setq file (message-fetch-field "fcc" t))
5270 (push file list)
5271 (message-remove-header "fcc" nil t))
5272 (let ((mail-parse-charset message-default-charset)
5273 (rfc2047-header-encoding-alist
5274 (cons '("Newsgroups" . default)
5275 rfc2047-header-encoding-alist)))
5276 (mail-encode-encoded-word-buffer)))
5277 (goto-char (point-min))
5278 (when (re-search-forward
5279 (concat "^" (regexp-quote mail-header-separator) "$")
5280 nil t)
5281 (replace-match "" t t ))
5282 ;; Process FCC operations.
5283 (while list
5284 (setq file (pop list))
5285 (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
5286 ;; Pipe the article to the program in question.
5287 (call-process-region (point-min) (point-max) shell-file-name
5288 nil nil nil shell-command-switch
5289 (match-string 1 file))
5290 ;; Save the article.
5291 (setq file (expand-file-name file))
5292 (unless (file-exists-p (file-name-directory file))
5293 (make-directory (file-name-directory file) t))
5294 (if (and message-fcc-handler-function
5295 (not (eq message-fcc-handler-function 'rmail-output)))
5296 (funcall message-fcc-handler-function file)
5297 ;; FIXME this option, rmail-output (also used if
5298 ;; message-fcc-handler-function is nil) is not
5299 ;; documented anywhere AFAICS. It should work in Emacs
5300 ;; 23; I suspect it does not work in Emacs 22.
5301 ;; FIXME I don't see the need for the two different cases here.
5302 ;; mail-use-rfc822 makes no difference (in Emacs 23),and
5303 ;; the third argument just controls \"Wrote file\" message.
5304 (if (and (file-readable-p file) (mail-file-babyl-p file))
5305 (rmail-output file 1 nil t)
5306 (let ((mail-use-rfc822 t))
5307 (rmail-output file 1 t t))))))
5308 (kill-buffer (current-buffer))))))
5309
5310 (defun message-output (filename)
5311 "Append this article to Unix/babyl mail file FILENAME."
5312 (if (or (and (file-readable-p filename)
5313 (mail-file-babyl-p filename))
5314 ;; gnus-output-to-mail does the wrong thing with live, mbox
5315 ;; Rmail buffers in Emacs 23.
5316 ;; http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=597255
5317 (let ((buff (find-buffer-visiting filename)))
5318 (and buff (with-current-buffer buff
5319 (eq major-mode 'rmail-mode)))))
5320 (gnus-output-to-rmail filename t)
5321 (gnus-output-to-mail filename t)))
5322
5323 (defun message-cleanup-headers ()
5324 "Do various automatic cleanups of the headers."
5325 ;; Remove empty lines in the header.
5326 (save-restriction
5327 (message-narrow-to-headers)
5328 ;; Remove blank lines.
5329 (while (re-search-forward "^[ \t]*\n" nil t)
5330 (replace-match "" t t))
5331
5332 ;; Correct Newsgroups and Followup-To headers: Change sequence of
5333 ;; spaces to comma and eliminate spaces around commas. Eliminate
5334 ;; embedded line breaks.
5335 (goto-char (point-min))
5336 (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
5337 (save-restriction
5338 (narrow-to-region
5339 (point)
5340 (if (re-search-forward "^[^ \t]" nil t)
5341 (match-beginning 0)
5342 (forward-line 1)
5343 (point)))
5344 (goto-char (point-min))
5345 (while (re-search-forward "\n[ \t]+" nil t)
5346 (replace-match " " t t)) ;No line breaks (too confusing)
5347 (goto-char (point-min))
5348 (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
5349 (replace-match "," t t))
5350 (goto-char (point-min))
5351 ;; Remove trailing commas.
5352 (when (re-search-forward ",+$" nil t)
5353 (replace-match "" t t))))))
5354
5355 (defun message-make-date (&optional now)
5356 "Make a valid data header.
5357 If NOW, use that time instead."
5358 (let ((system-time-locale "C"))
5359 (format-time-string "%a, %d %b %Y %T %z" now)))
5360
5361 (defun message-insert-expires (days)
5362 "Insert the Expires header. Expiry in DAYS days."
5363 (interactive "NExpire article in how many days? ")
5364 (save-excursion
5365 (message-position-on-field "Expires" "X-Draft-From")
5366 (insert (message-make-expires-date days))))
5367
5368 (defun message-make-expires-date (days)
5369 "Make date string for the Expires header. Expiry in DAYS days.
5370
5371 In posting styles use `(\"Expires\" (make-expires-date 30))'."
5372 (let* ((cur (decode-time (current-time)))
5373 (nday (+ days (nth 3 cur))))
5374 (setf (nth 3 cur) nday)
5375 (message-make-date (apply 'encode-time cur))))
5376
5377 (defun message-make-message-id ()
5378 "Make a unique Message-ID."
5379 (concat "<" (message-unique-id)
5380 (let ((psubject (save-excursion (message-fetch-field "subject")))
5381 (psupersedes
5382 (save-excursion (message-fetch-field "supersedes"))))
5383 (if (or
5384 (and message-reply-headers
5385 (mail-header-references message-reply-headers)
5386 (mail-header-subject message-reply-headers)
5387 psubject
5388 (not (string=
5389 (message-strip-subject-re
5390 (mail-header-subject message-reply-headers))
5391 (message-strip-subject-re psubject))))
5392 (and psupersedes
5393 (string-match "_-_@" psupersedes)))
5394 "_-_" ""))
5395 "@" (message-make-fqdn) ">"))
5396
5397 (defvar message-unique-id-char nil)
5398
5399 ;; If you ever change this function, make sure the new version
5400 ;; cannot generate IDs that the old version could.
5401 ;; You might for example insert a "." somewhere (not next to another dot
5402 ;; or string boundary), or modify the "fsf" string.
5403 (defun message-unique-id ()
5404 ;; Don't use microseconds from (current-time), they may be unsupported.
5405 ;; Instead we use this randomly inited counter.
5406 (setq message-unique-id-char
5407 (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
5408 ;; (current-time) returns 16-bit ints,
5409 ;; and 2^16*25 just fits into 4 digits i base 36.
5410 (* 25 25)))
5411 (let ((tm (current-time)))
5412 (concat
5413 (if (or (eq system-type 'ms-dos)
5414 ;; message-number-base36 doesn't handle bigints.
5415 (floatp (user-uid)))
5416 (let ((user (downcase (user-login-name))))
5417 (while (string-match "[^a-z0-9_]" user)
5418 (aset user (match-beginning 0) ?_))
5419 user)
5420 (message-number-base36 (user-uid) -1))
5421 (message-number-base36 (+ (car tm)
5422 (lsh (% message-unique-id-char 25) 16)) 4)
5423 (message-number-base36 (+ (nth 1 tm)
5424 (lsh (/ message-unique-id-char 25) 16)) 4)
5425 ;; Append a given name, because while the generated ID is unique
5426 ;; to this newsreader, other newsreaders might otherwise generate
5427 ;; the same ID via another algorithm.
5428 ".fsf")))
5429
5430 (defun message-number-base36 (num len)
5431 (if (if (< len 0)
5432 (<= num 0)
5433 (= len 0))
5434 ""
5435 (concat (message-number-base36 (/ num 36) (1- len))
5436 (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
5437 (% num 36))))))
5438
5439 (defun message-make-organization ()
5440 "Make an Organization header."
5441 (let* ((organization
5442 (when message-user-organization
5443 (if (functionp message-user-organization)
5444 (funcall message-user-organization)
5445 message-user-organization))))
5446 (with-temp-buffer
5447 (mm-enable-multibyte)
5448 (cond ((stringp organization)
5449 (insert organization))
5450 ((and (eq t organization)
5451 message-user-organization-file
5452 (file-exists-p message-user-organization-file))
5453 (insert-file-contents message-user-organization-file)))
5454 (goto-char (point-min))
5455 (while (re-search-forward "[\t\n]+" nil t)
5456 (replace-match "" t t))
5457 (unless (zerop (buffer-size))
5458 (buffer-string)))))
5459
5460 (defun message-make-lines ()
5461 "Count the number of lines and return numeric string."
5462 (save-excursion
5463 (save-restriction
5464 (widen)
5465 (message-goto-body)
5466 (int-to-string (count-lines (point) (point-max))))))
5467
5468 (defun message-make-references ()
5469 "Return the References header for this message."
5470 (when message-reply-headers
5471 (let ((message-id (mail-header-id message-reply-headers))
5472 (references (mail-header-references message-reply-headers)))
5473 (if (or references message-id)
5474 (concat (or references "") (and references " ")
5475 (or message-id ""))
5476 nil))))
5477
5478 (defun message-make-in-reply-to ()
5479 "Return the In-Reply-To header for this message."
5480 (when message-reply-headers
5481 (let ((from (mail-header-from message-reply-headers))
5482 (date (mail-header-date message-reply-headers))
5483 (msg-id (mail-header-id message-reply-headers)))
5484 (when from
5485 (let ((name (mail-extract-address-components from)))
5486 (concat
5487 msg-id (if msg-id " (")
5488 (if (car name)
5489 (if (string-match "[^\000-\177]" (car name))
5490 ;; Quote a string containing non-ASCII characters.
5491 ;; It will make the RFC2047 encoder cause an error
5492 ;; if there are special characters.
5493 (mm-with-multibyte-buffer
5494 (insert (car name))
5495 (goto-char (point-min))
5496 (while (search-forward "\"" nil t)
5497 (when (prog2
5498 (backward-char)
5499 (zerop (% (skip-chars-backward "\\\\") 2))
5500 (goto-char (match-beginning 0)))
5501 (insert "\\"))
5502 (forward-char))
5503 ;; Those quotes will be removed by the RFC2047 encoder.
5504 (concat "\"" (buffer-string) "\""))
5505 (car name))
5506 (nth 1 name))
5507 "'s message of \""
5508 (if (or (not date) (string= date ""))
5509 "(unknown date)" date)
5510 "\"" (if msg-id ")")))))))
5511
5512 (defun message-make-distribution ()
5513 "Make a Distribution header."
5514 (let ((orig-distribution (message-fetch-reply-field "distribution")))
5515 (cond ((functionp message-distribution-function)
5516 (funcall message-distribution-function))
5517 (t orig-distribution))))
5518
5519 (defun message-make-expires ()
5520 "Return an Expires header based on `message-expires'."
5521 (let ((current (current-time))
5522 (future (* 1.0 message-expires 60 60 24)))
5523 ;; Add the future to current.
5524 (setcar current (+ (car current) (round (/ future (expt 2 16)))))
5525 (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
5526 (message-make-date current)))
5527
5528 (defun message-make-path ()
5529 "Return uucp path."
5530 (let ((login-name (user-login-name)))
5531 (cond ((null message-user-path)
5532 (concat (system-name) "!" login-name))
5533 ((stringp message-user-path)
5534 ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com.
5535 (concat message-user-path "!" login-name))
5536 (t login-name))))
5537
5538 (defun message-make-from (&optional name address)
5539 "Make a From header."
5540 (let* ((style message-from-style)
5541 (login (or address (message-make-address)))
5542 (fullname (or name
5543 (and (boundp 'user-full-name)
5544 user-full-name)
5545 (user-full-name))))
5546 (when (string= fullname "&")
5547 (setq fullname (user-login-name)))
5548 (with-temp-buffer
5549 (mm-enable-multibyte)
5550 (cond
5551 ((or (null style)
5552 (equal fullname ""))
5553 (insert login))
5554 ((or (eq style 'angles)
5555 (and (not (eq style 'parens))
5556 ;; Use angles if no quoting is needed, or if parens would
5557 ;; need quoting too.
5558 (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
5559 (let ((tmp (concat fullname nil)))
5560 (while (string-match "([^()]*)" tmp)
5561 (aset tmp (match-beginning 0) ?-)
5562 (aset tmp (1- (match-end 0)) ?-))
5563 (string-match "[\\()]" tmp)))))
5564 (insert fullname)
5565 (goto-char (point-min))
5566 ;; Look for a character that cannot appear unquoted
5567 ;; according to RFC 822.
5568 (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
5569 ;; Quote fullname, escaping specials.
5570 (goto-char (point-min))
5571 (insert "\"")
5572 (while (re-search-forward "[\"\\]" nil 1)
5573 (replace-match "\\\\\\&" t))
5574 (insert "\""))
5575 (insert " <" login ">"))
5576 (t ; 'parens or default
5577 (insert login " (")
5578 (let ((fullname-start (point)))
5579 (insert fullname)
5580 (goto-char fullname-start)
5581 ;; RFC 822 says \ and nonmatching parentheses
5582 ;; must be escaped in comments.
5583 ;; Escape every instance of ()\ ...
5584 (while (re-search-forward "[()\\]" nil 1)
5585 (replace-match "\\\\\\&" t))
5586 ;; ... then undo escaping of matching parentheses,
5587 ;; including matching nested parentheses.
5588 (goto-char fullname-start)
5589 (while (re-search-forward
5590 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
5591 nil 1)
5592 (replace-match "\\1(\\3)" t)
5593 (goto-char fullname-start)))
5594 (insert ")")))
5595 (buffer-string))))
5596
5597 (defun message-make-sender ()
5598 "Return the \"real\" user address.
5599 This function tries to ignore all user modifications, and
5600 give as trustworthy answer as possible."
5601 (concat (user-login-name) "@" (system-name)))
5602
5603 (defun message-make-address ()
5604 "Make the address of the user."
5605 (or (message-user-mail-address)
5606 (concat (user-login-name) "@" (message-make-domain))))
5607
5608 (defun message-user-mail-address ()
5609 "Return the pertinent part of `user-mail-address'."
5610 (when (and user-mail-address
5611 (string-match "@.*\\." user-mail-address))
5612 (if (string-match " " user-mail-address)
5613 (nth 1 (mail-extract-address-components user-mail-address))
5614 user-mail-address)))
5615
5616 (defun message-sendmail-envelope-from ()
5617 "Return the envelope from."
5618 (cond ((eq message-sendmail-envelope-from 'header)
5619 (nth 1 (mail-extract-address-components
5620 (message-fetch-field "from"))))
5621 ((stringp message-sendmail-envelope-from)
5622 message-sendmail-envelope-from)
5623 (t
5624 (message-make-address))))
5625
5626 (defun message-make-fqdn ()
5627 "Return user's fully qualified domain name."
5628 (let* ((system-name (system-name))
5629 (user-mail (message-user-mail-address))
5630 (user-domain
5631 (if (and user-mail
5632 (string-match "@\\(.*\\)\\'" user-mail))
5633 (match-string 1 user-mail)))
5634 (case-fold-search t))
5635 (cond
5636 ((and message-user-fqdn
5637 (stringp message-user-fqdn)
5638 (string-match message-valid-fqdn-regexp message-user-fqdn)
5639 (not (string-match message-bogus-system-names message-user-fqdn)))
5640 ;; `message-user-fqdn' seems to be valid
5641 message-user-fqdn)
5642 ((and (string-match message-valid-fqdn-regexp system-name)
5643 (not (string-match message-bogus-system-names system-name)))
5644 ;; `system-name' returned the right result.
5645 system-name)
5646 ;; Try `mail-host-address'.
5647 ((and (boundp 'mail-host-address)
5648 (stringp mail-host-address)
5649 (string-match message-valid-fqdn-regexp mail-host-address)
5650 (not (string-match message-bogus-system-names mail-host-address)))
5651 mail-host-address)
5652 ;; We try `user-mail-address' as a backup.
5653 ((and user-domain
5654 (stringp user-domain)
5655 (string-match message-valid-fqdn-regexp user-domain)
5656 (not (string-match message-bogus-system-names user-domain)))
5657 user-domain)
5658 ;; Default to this bogus thing.
5659 (t
5660 (concat system-name
5661 ".i-did-not-set--mail-host-address--so-tickle-me")))))
5662
5663 (defun message-make-host-name ()
5664 "Return the name of the host."
5665 (let ((fqdn (message-make-fqdn)))
5666 (string-match "^[^.]+\\." fqdn)
5667 (substring fqdn 0 (1- (match-end 0)))))
5668
5669 (defun message-make-domain ()
5670 "Return the domain name."
5671 (or mail-host-address
5672 (message-make-fqdn)))
5673
5674 (defun message-to-list-only ()
5675 "Send a message to the list only.
5676 Remove all addresses but the list address from To and Cc headers."
5677 (interactive)
5678 (let ((listaddr (message-make-mail-followup-to t)))
5679 (when listaddr
5680 (save-excursion
5681 (message-remove-header "to")
5682 (message-remove-header "cc")
5683 (message-position-on-field "To" "X-Draft-From")
5684 (insert listaddr)))))
5685
5686 (defun message-make-mail-followup-to (&optional only-show-subscribed)
5687 "Return the Mail-Followup-To header.
5688 If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the
5689 subscribed address (and not the additional To and Cc header contents)."
5690 (let* ((case-fold-search t)
5691 (to (message-fetch-field "To"))
5692 (cc (message-fetch-field "cc"))
5693 (msg-recipients (concat to (and to cc ", ") cc))
5694 (recipients
5695 (mapcar 'mail-strip-quoted-names
5696 (message-tokenize-header msg-recipients)))
5697 (file-regexps
5698 (if message-subscribed-address-file
5699 (let (begin end item re)
5700 (save-excursion
5701 (with-temp-buffer
5702 (insert-file-contents message-subscribed-address-file)
5703 (while (not (eobp))
5704 (setq begin (point))
5705 (forward-line 1)
5706 (setq end (point))
5707 (if (bolp) (setq end (1- end)))
5708 (setq item (regexp-quote (buffer-substring begin end)))
5709 (if re (setq re (concat re "\\|" item))
5710 (setq re (concat "\\`\\(" item))))
5711 (and re (list (concat re "\\)\\'"))))))))
5712 (mft-regexps (apply 'append message-subscribed-regexps
5713 (mapcar 'regexp-quote
5714 message-subscribed-addresses)
5715 file-regexps
5716 (mapcar 'funcall
5717 message-subscribed-address-functions))))
5718 (save-match-data
5719 (let ((list
5720 (loop for recipient in recipients
5721 when (loop for regexp in mft-regexps
5722 when (string-match regexp recipient) return t)
5723 return recipient)))
5724 (when list
5725 (if only-show-subscribed
5726 list
5727 msg-recipients))))))
5728
5729 (defun message-idna-to-ascii-rhs-1 (header)
5730 "Interactively potentially IDNA encode domain names in HEADER."
5731 (let ((field (message-fetch-field header))
5732 rhs ace address)
5733 (when field
5734 (dolist (rhs
5735 (mm-delete-duplicates
5736 (mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) ""))
5737 (mapcar 'downcase
5738 (mapcar
5739 (lambda (elem)
5740 (or (cadr elem)
5741 ""))
5742 (mail-extract-address-components field t))))))
5743 ;; Note that `rhs' will be "" if the address does not have
5744 ;; the domain part, i.e., if it is a local user's address.
5745 (setq ace (if (string-match "\\`[[:ascii:]]*\\'" rhs)
5746 rhs
5747 (downcase (idna-to-ascii rhs))))
5748 (when (and (not (equal rhs ace))
5749 (or (not (eq message-use-idna 'ask))
5750 (y-or-n-p (format "Replace %s with %s in %s:? "
5751 rhs ace header))))
5752 (goto-char (point-min))
5753 (while (re-search-forward (concat "^" header ":") nil t)
5754 (message-narrow-to-field)
5755 (while (search-forward (concat "@" rhs) nil t)
5756 (replace-match (concat "@" ace) t t))
5757 (goto-char (point-max))
5758 (widen)))))))
5759
5760 (defun message-idna-to-ascii-rhs ()
5761 "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
5762 See `message-idna-encode'."
5763 (interactive)
5764 (when message-use-idna
5765 (save-excursion
5766 (save-restriction
5767 ;; `message-narrow-to-head' that recognizes only the first empty
5768 ;; line as the message header separator used to be used here.
5769 ;; However, since there is the "--text follows this line--" line
5770 ;; normally, it failed in narrowing to the headers and potentially
5771 ;; caused the IDNA encoding on lines that look like headers in
5772 ;; the message body.
5773 (message-narrow-to-headers-or-head)
5774 (message-idna-to-ascii-rhs-1 "From")
5775 (message-idna-to-ascii-rhs-1 "To")
5776 (message-idna-to-ascii-rhs-1 "Reply-To")
5777 (message-idna-to-ascii-rhs-1 "Mail-Reply-To")
5778 (message-idna-to-ascii-rhs-1 "Mail-Followup-To")
5779 (message-idna-to-ascii-rhs-1 "Cc")))))
5780
5781 (defun message-generate-headers (headers)
5782 "Prepare article HEADERS.
5783 Headers already prepared in the buffer are not modified."
5784 (setq headers (append headers message-required-headers))
5785 (save-restriction
5786 (message-narrow-to-headers)
5787 (let* ((Date (message-make-date))
5788 (Message-ID (message-make-message-id))
5789 (Organization (message-make-organization))
5790 (From (message-make-from))
5791 (Path (message-make-path))
5792 (Subject nil)
5793 (Newsgroups nil)
5794 (In-Reply-To (message-make-in-reply-to))
5795 (References (message-make-references))
5796 (To nil)
5797 (Distribution (message-make-distribution))
5798 (Lines (message-make-lines))
5799 (User-Agent message-newsreader)
5800 (Expires (message-make-expires))
5801 (case-fold-search t)
5802 (optionalp nil)
5803 header value elem header-string)
5804 ;; First we remove any old generated headers.
5805 (let ((headers message-deletable-headers))
5806 (unless (buffer-modified-p)
5807 (setq headers (delq 'Message-ID (copy-sequence headers))))
5808 (while headers
5809 (goto-char (point-min))
5810 (and (re-search-forward
5811 (concat "^" (symbol-name (car headers)) ": *") nil t)
5812 (get-text-property (1+ (match-beginning 0)) 'message-deletable)
5813 (message-delete-line))
5814 (pop headers)))
5815 ;; Go through all the required headers and see if they are in the
5816 ;; articles already. If they are not, or are empty, they are
5817 ;; inserted automatically - except for Subject, Newsgroups and
5818 ;; Distribution.
5819 (while headers
5820 (goto-char (point-min))
5821 (setq elem (pop headers))
5822 (if (consp elem)
5823 (if (eq (car elem) 'optional)
5824 (setq header (cdr elem)
5825 optionalp t)
5826 (setq header (car elem)))
5827 (setq header elem))
5828 (setq header-string (if (stringp header)
5829 header
5830 (symbol-name header)))
5831 (when (or (not (re-search-forward
5832 (concat "^"
5833 (regexp-quote (downcase header-string))
5834 ":")
5835 nil t))
5836 (progn
5837 ;; The header was found. We insert a space after the
5838 ;; colon, if there is none.
5839 (if (/= (char-after) ? ) (insert " ") (forward-char 1))
5840 ;; Find out whether the header is empty.
5841 (looking-at "[ \t]*\n[^ \t]")))
5842 ;; So we find out what value we should insert.
5843 (setq value
5844 (cond
5845 ((and (consp elem)
5846 (eq (car elem) 'optional)
5847 (not (member header-string message-inserted-headers)))
5848 ;; This is an optional header. If the cdr of this
5849 ;; is something that is nil, then we do not insert
5850 ;; this header.
5851 (setq header (cdr elem))
5852 (or (and (functionp (cdr elem))
5853 (funcall (cdr elem)))
5854 (and (boundp (cdr elem))
5855 (symbol-value (cdr elem)))))
5856 ((consp elem)
5857 ;; The element is a cons. Either the cdr is a
5858 ;; string to be inserted verbatim, or it is a
5859 ;; function, and we insert the value returned from
5860 ;; this function.
5861 (or (and (stringp (cdr elem))
5862 (cdr elem))
5863 (and (functionp (cdr elem))
5864 (funcall (cdr elem)))))
5865 ((and (boundp header)
5866 (symbol-value header))
5867 ;; The element is a symbol. We insert the value
5868 ;; of this symbol, if any.
5869 (symbol-value header))
5870 ((not (message-check-element
5871 (intern (downcase (symbol-name header)))))
5872 ;; We couldn't generate a value for this header,
5873 ;; so we just ask the user.
5874 (read-from-minibuffer
5875 (format "Empty header for %s; enter value: " header)))))
5876 ;; Finally insert the header.
5877 (when (and value
5878 (not (equal value "")))
5879 (save-excursion
5880 (if (bolp)
5881 (progn
5882 ;; This header didn't exist, so we insert it.
5883 (goto-char (point-max))
5884 (let ((formatter
5885 (cdr (assq header message-header-format-alist))))
5886 (if formatter
5887 (funcall formatter header value)
5888 (insert header-string ": " value))
5889 (push header-string message-inserted-headers)
5890 (goto-char (message-fill-field))
5891 ;; We check whether the value was ended by a
5892 ;; newline. If not, we insert one.
5893 (unless (bolp)
5894 (insert "\n"))
5895 (forward-line -1)))
5896 ;; The value of this header was empty, so we clear
5897 ;; totally and insert the new value.
5898 (delete-region (point) (point-at-eol))
5899 ;; If the header is optional, and the header was
5900 ;; empty, we can't insert it anyway.
5901 (unless optionalp
5902 (push header-string message-inserted-headers)
5903 (insert value)
5904 (message-fill-field)))
5905 ;; Add the deletable property to the headers that require it.
5906 (and (memq header message-deletable-headers)
5907 (progn (beginning-of-line) (looking-at "[^:]+: "))
5908 (add-text-properties
5909 (point) (match-end 0)
5910 '(message-deletable t face italic) (current-buffer)))))))
5911 ;; Insert new Sender if the From is strange.
5912 (let ((from (message-fetch-field "from"))
5913 (sender (message-fetch-field "sender"))
5914 (secure-sender (message-make-sender)))
5915 (when (and from
5916 (not (message-check-element 'sender))
5917 (not (string=
5918 (downcase
5919 (cadr (mail-extract-address-components from)))
5920 (downcase secure-sender)))
5921 (or (null sender)
5922 (not
5923 (string=
5924 (downcase
5925 (cadr (mail-extract-address-components sender)))
5926 (downcase secure-sender)))))
5927 (goto-char (point-min))
5928 ;; Rename any old Sender headers to Original-Sender.
5929 (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
5930 (beginning-of-line)
5931 (insert "Original-")
5932 (beginning-of-line))
5933 (when (or (message-news-p)
5934 (string-match "@.+\\.." secure-sender))
5935 (insert "Sender: " secure-sender "\n"))))
5936 ;; Check for IDNA
5937 (message-idna-to-ascii-rhs))))
5938
5939 (defun message-insert-courtesy-copy ()
5940 "Insert a courtesy message in mail copies of combined messages."
5941 (let (newsgroups)
5942 (save-excursion
5943 (save-restriction
5944 (message-narrow-to-headers)
5945 (when (setq newsgroups (message-fetch-field "newsgroups"))
5946 (goto-char (point-max))
5947 (insert "Posted-To: " newsgroups "\n")))
5948 (forward-line 1)
5949 (when message-courtesy-message
5950 (cond
5951 ((string-match "%s" message-courtesy-message)
5952 (insert (format message-courtesy-message newsgroups)))
5953 (t
5954 (insert message-courtesy-message)))))))
5955
5956 ;;;
5957 ;;; Setting up a message buffer
5958 ;;;
5959
5960 (defun message-skip-to-next-address ()
5961 (let ((end (save-excursion
5962 (message-next-header)
5963 (point)))
5964 quoted char)
5965 (when (looking-at ",")
5966 (forward-char 1))
5967 (while (and (not (= (point) end))
5968 (or (not (eq char ?,))
5969 quoted))
5970 (skip-chars-forward "^,\"" (point-max))
5971 (when (eq (setq char (following-char)) ?\")
5972 (setq quoted (not quoted)))
5973 (unless (= (point) end)
5974 (forward-char 1)))
5975 (skip-chars-forward " \t\n")))
5976
5977 (defun message-fill-address (header value)
5978 (insert (capitalize (symbol-name header))
5979 ": "
5980 (if (consp value) (car value) value)
5981 "\n")
5982 (message-fill-field-address))
5983
5984 (defun message-split-line ()
5985 "Split current line, moving portion beyond point vertically down.
5986 If the current line has `message-yank-prefix', insert it on the new line."
5987 (interactive "*")
5988 (condition-case nil
5989 (split-line message-yank-prefix) ;; Emacs 22.1+ supports arg.
5990 (error
5991 (split-line))))
5992
5993 (defun message-insert-header (header value)
5994 (insert (capitalize (symbol-name header))
5995 ": "
5996 (if (consp value) (car value) value)))
5997
5998 (defun message-field-name ()
5999 (save-excursion
6000 (goto-char (point-min))
6001 (when (looking-at "\\([^:]+\\):")
6002 (intern (capitalize (match-string 1))))))
6003
6004 (defun message-fill-field ()
6005 (save-excursion
6006 (save-restriction
6007 (message-narrow-to-field)
6008 (let ((field-name (message-field-name)))
6009 (funcall (or (cadr (assq field-name message-field-fillers))
6010 'message-fill-field-general)))
6011 (point-max))))
6012
6013 (defun message-fill-field-address ()
6014 (while (not (eobp))
6015 (message-skip-to-next-address)
6016 (let (last)
6017 (if (and (> (current-column) 78)
6018 last)
6019 (progn
6020 (save-excursion
6021 (goto-char last)
6022 (insert "\n\t"))
6023 (setq last (1+ (point))))
6024 (setq last (1+ (point)))))))
6025
6026 (defun message-fill-field-general ()
6027 (let ((begin (point))
6028 (fill-column 78)
6029 (fill-prefix "\t"))
6030 (while (and (search-forward "\n" nil t)
6031 (not (eobp)))
6032 (replace-match " " t t))
6033 (fill-region-as-paragraph begin (point-max))
6034 ;; Tapdance around looong Message-IDs.
6035 (forward-line -1)
6036 (when (looking-at "[ \t]*$")
6037 (message-delete-line))
6038 (goto-char begin)
6039 (search-forward ":" nil t)
6040 (when (looking-at "\n[ \t]+")
6041 (replace-match " " t t))
6042 (goto-char (point-max))))
6043
6044 (defun message-shorten-1 (list cut surplus)
6045 "Cut SURPLUS elements out of LIST, beginning with CUTth one."
6046 (setcdr (nthcdr (- cut 2) list)
6047 (nthcdr (+ (- cut 2) surplus 1) list)))
6048
6049 (defun message-shorten-references (header references)
6050 "Trim REFERENCES to be 21 Message-ID long or less, and fold them.
6051 When sending via news, also check that the REFERENCES are less
6052 than 988 characters long, and if they are not, trim them until
6053 they are."
6054 ;; 21 is the number suggested by USEAGE.
6055 (let ((maxcount 21)
6056 (count 0)
6057 (cut 2)
6058 refs)
6059 (with-temp-buffer
6060 (insert references)
6061 (goto-char (point-min))
6062 ;; Cons a list of valid references. GNKSA says we must not include MIDs
6063 ;; with whitespace or missing brackets (7.a "Does not propagate broken
6064 ;; Message-IDs in original References").
6065 (while (re-search-forward "<[^ <]+@[^ <]+>" nil t)
6066 (push (match-string 0) refs))
6067 (setq refs (nreverse refs)
6068 count (length refs)))
6069
6070 ;; If the list has more than MAXCOUNT elements, trim it by
6071 ;; removing the CUTth element and the required number of
6072 ;; elements that follow.
6073 (when (> count maxcount)
6074 (let ((surplus (- count maxcount)))
6075 (message-shorten-1 refs cut surplus)
6076 (decf count surplus)))
6077
6078 ;; When sending via news, make sure the total folded length will
6079 ;; be less than 998 characters. This is to cater to broken INN
6080 ;; 2.3 which counts the total number of characters in a header
6081 ;; rather than the physical line length of each line, as it should.
6082 ;;
6083 ;; This hack should be removed when it's believed than INN 2.3 is
6084 ;; no longer widely used.
6085 ;;
6086 ;; At this point the headers have not been generated, thus we use
6087 ;; message-this-is-news directly.
6088 (when message-this-is-news
6089 (while (< 998
6090 (with-temp-buffer
6091 (message-insert-header
6092 header (mapconcat #'identity refs " "))
6093 (buffer-size)))
6094 (message-shorten-1 refs cut 1)))
6095 ;; Finally, collect the references back into a string and insert
6096 ;; it into the buffer.
6097 (message-insert-header header (mapconcat #'identity refs " "))))
6098
6099 (defun message-position-point ()
6100 "Move point to where the user probably wants to find it."
6101 (message-narrow-to-headers)
6102 (cond
6103 ((re-search-forward "^[^:]+:[ \t]*$" nil t)
6104 (search-backward ":" )
6105 (widen)
6106 (forward-char 1)
6107 (if (eq (char-after) ? )
6108 (forward-char 1)
6109 (insert " ")))
6110 (t
6111 (goto-char (point-max))
6112 (widen)
6113 (forward-line 1)
6114 (unless (looking-at "$")
6115 (forward-line 2)))
6116 (sit-for 0)))
6117
6118 (defcustom message-beginning-of-line t
6119 "Whether \\<message-mode-map>\\[message-beginning-of-line]\
6120 goes to beginning of header values."
6121 :version "22.1"
6122 :group 'message-buffers
6123 :link '(custom-manual "(message)Movement")
6124 :type 'boolean)
6125
6126 (defun message-beginning-of-line (&optional n)
6127 "Move point to beginning of header value or to beginning of line.
6128 The prefix argument N is passed directly to `beginning-of-line'.
6129
6130 This command is identical to `beginning-of-line' if point is
6131 outside the message header or if the option `message-beginning-of-line'
6132 is nil.
6133
6134 If point is in the message header and on a (non-continued) header
6135 line, move point to the beginning of the header value or the beginning of line,
6136 whichever is closer. If point is already at beginning of line, move point to
6137 beginning of header value. Therefore, repeated calls will toggle point
6138 between beginning of field and beginning of line."
6139 (interactive "p")
6140 (let ((zrs 'zmacs-region-stays))
6141 (when (and (featurep 'xemacs) (interactive-p) (boundp zrs))
6142 (set zrs t)))
6143 (if (and message-beginning-of-line
6144 (message-point-in-header-p))
6145 (let* ((here (point))
6146 (bol (progn (beginning-of-line n) (point)))
6147 (eol (point-at-eol))
6148 (eoh (re-search-forward ": *" eol t)))
6149 (goto-char
6150 (if (and eoh (or (< eoh here) (= bol here)))
6151 eoh bol)))
6152 (beginning-of-line n)))
6153
6154 (defun message-buffer-name (type &optional to group)
6155 "Return a new (unique) buffer name based on TYPE and TO."
6156 (cond
6157 ;; Generate a new buffer name The Message Way.
6158 ((memq message-generate-new-buffers '(unique t))
6159 (generate-new-buffer-name
6160 (concat "*" type
6161 (if to
6162 (concat " to "
6163 (or (car (mail-extract-address-components to))
6164 to) "")
6165 "")
6166 (if (and group (not (string= group ""))) (concat " on " group) "")
6167 "*")))
6168 ;; Check whether `message-generate-new-buffers' is a function,
6169 ;; and if so, call it.
6170 ((functionp message-generate-new-buffers)
6171 (funcall message-generate-new-buffers type to group))
6172 ((eq message-generate-new-buffers 'unsent)
6173 (generate-new-buffer-name
6174 (concat "*unsent " type
6175 (if to
6176 (concat " to "
6177 (or (car (mail-extract-address-components to))
6178 to) "")
6179 "")
6180 (if (and group (not (string= group ""))) (concat " on " group) "")
6181 "*")))
6182 ;; Search for the existing message buffer with the specified name.
6183 (t
6184 (let* ((new (if (eq message-generate-new-buffers 'standard)
6185 (generate-new-buffer-name (concat "*" type " message*"))
6186 (let ((message-generate-new-buffers 'unique))
6187 (message-buffer-name type to group))))
6188 (regexp (concat "\\`"
6189 (regexp-quote
6190 (if (string-match "<[0-9]+>\\'" new)
6191 (substring new 0 (match-beginning 0))
6192 new))
6193 "\\(?:<\\([0-9]+\\)>\\)?\\'"))
6194 (case-fold-search nil))
6195 (or (cdar
6196 (last
6197 (sort
6198 (delq nil
6199 (mapcar
6200 (lambda (b)
6201 (when (and (string-match regexp (setq b (buffer-name b)))
6202 (eq (with-current-buffer b major-mode)
6203 'message-mode))
6204 (cons (string-to-number (or (match-string 1 b) "1"))
6205 b)))
6206 (buffer-list)))
6207 'car-less-than-car)))
6208 new)))))
6209
6210 (defun message-pop-to-buffer (name &optional switch-function)
6211 "Pop to buffer NAME, and warn if it already exists and is modified."
6212 (let ((buffer (get-buffer name)))
6213 (if (and buffer
6214 (buffer-name buffer))
6215 (let ((window (get-buffer-window buffer 0)))
6216 (if window
6217 ;; Raise the frame already displaying the message buffer.
6218 (progn
6219 (gnus-select-frame-set-input-focus (window-frame window))
6220 (select-window window))
6221 (funcall (or switch-function 'pop-to-buffer) buffer)
6222 (set-buffer buffer))
6223 (when (and (buffer-modified-p)
6224 (not (prog1
6225 (y-or-n-p
6226 "Message already being composed; erase? ")
6227 (message nil))))
6228 (error "Message being composed")))
6229 (funcall (or switch-function 'pop-to-buffer) name)
6230 (set-buffer name))
6231 (erase-buffer)
6232 (message-mode)))
6233
6234 (defun message-do-send-housekeeping ()
6235 "Kill old message buffers."
6236 ;; We might have sent this buffer already. Delete it from the
6237 ;; list of buffers.
6238 (setq message-buffer-list (delq (current-buffer) message-buffer-list))
6239 (while (and message-max-buffers
6240 message-buffer-list
6241 (>= (length message-buffer-list) message-max-buffers))
6242 ;; Kill the oldest buffer -- unless it has been changed.
6243 (let ((buffer (pop message-buffer-list)))
6244 (when (and (buffer-name buffer)
6245 (not (buffer-modified-p buffer)))
6246 (kill-buffer buffer))))
6247 ;; Rename the buffer.
6248 (if message-send-rename-function
6249 (funcall message-send-rename-function)
6250 ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
6251 (when (string-match
6252 "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
6253 (buffer-name))
6254 (let ((name (match-string 2 (buffer-name)))
6255 to group)
6256 (if (not (or (null name)
6257 (string-equal name "mail")
6258 (string-equal name "posting")))
6259 (setq name (concat "*sent " name "*"))
6260 (message-narrow-to-headers)
6261 (setq to (message-fetch-field "to"))
6262 (setq group (message-fetch-field "newsgroups"))
6263 (widen)
6264 (setq name
6265 (cond
6266 (to (concat "*sent mail to "
6267 (or (car (mail-extract-address-components to))
6268 to) "*"))
6269 ((and group (not (string= group "")))
6270 (concat "*sent posting on " group "*"))
6271 (t "*sent mail*"))))
6272 (unless (string-equal name (buffer-name))
6273 (rename-buffer name t)))))
6274 ;; Push the current buffer onto the list.
6275 (when message-max-buffers
6276 (setq message-buffer-list
6277 (nconc message-buffer-list (list (current-buffer))))))
6278
6279 (defun message-mail-user-agent ()
6280 (let ((mua (cond
6281 ((not message-mail-user-agent) nil)
6282 ((eq message-mail-user-agent t) mail-user-agent)
6283 (t message-mail-user-agent))))
6284 (if (memq mua '(message-user-agent gnus-user-agent))
6285 nil
6286 mua)))
6287
6288 ;; YANK-ACTION, if non-nil, can be a buffer or a yank action of the
6289 ;; form (FUNCTION . ARGS).
6290 (defun message-setup (headers &optional yank-action actions
6291 continue switch-function)
6292 (let ((mua (message-mail-user-agent))
6293 subject to field)
6294 (if (not (and message-this-is-mail mua))
6295 (message-setup-1 headers yank-action actions)
6296 (setq headers (copy-sequence headers))
6297 (setq field (assq 'Subject headers))
6298 (when field
6299 (setq subject (cdr field))
6300 (setq headers (delq field headers)))
6301 (setq field (assq 'To headers))
6302 (when field
6303 (setq to (cdr field))
6304 (setq headers (delq field headers)))
6305 (let ((mail-user-agent mua))
6306 (compose-mail to subject
6307 (mapcar (lambda (item)
6308 (cons
6309 (format "%s" (car item))
6310 (cdr item)))
6311 headers)
6312 continue switch-function
6313 (if (bufferp yank-action)
6314 (list 'insert-buffer yank-action)
6315 yank-action)
6316 actions)))))
6317
6318 (defun message-headers-to-generate (headers included-headers excluded-headers)
6319 "Return a list that includes all headers from HEADERS.
6320 If INCLUDED-HEADERS is a list, just include those headers. If it is
6321 t, include all headers. In any case, headers from EXCLUDED-HEADERS
6322 are not included."
6323 (let ((result nil)
6324 header-name)
6325 (dolist (header headers)
6326 (setq header-name (cond
6327 ((and (consp header)
6328 (eq (car header) 'optional))
6329 ;; On the form (optional . Header)
6330 (cdr header))
6331 ((consp header)
6332 ;; On the form (Header . function)
6333 (car header))
6334 (t
6335 ;; Just a Header.
6336 header)))
6337 (when (and (not (memq header-name excluded-headers))
6338 (or (eq included-headers t)
6339 (memq header-name included-headers)))
6340 (push header result)))
6341 (nreverse result)))
6342
6343 (defun message-setup-1 (headers &optional yank-action actions)
6344 (dolist (action actions)
6345 (condition-case nil
6346 (add-to-list 'message-send-actions
6347 `(apply ',(car action) ',(cdr action)))))
6348 (setq message-reply-buffer
6349 (if (and (consp yank-action)
6350 (eq (car yank-action) 'insert-buffer))
6351 (nth 1 yank-action)
6352 yank-action))
6353 (goto-char (point-min))
6354 ;; Insert all the headers.
6355 (mail-header-format
6356 (let ((h headers)
6357 (alist message-header-format-alist))
6358 (while h
6359 (unless (assq (caar h) message-header-format-alist)
6360 (push (list (caar h)) alist))
6361 (pop h))
6362 alist)
6363 headers)
6364 (delete-region (point) (progn (forward-line -1) (point)))
6365 (when message-default-headers
6366 (insert
6367 (if (functionp message-default-headers)
6368 (funcall message-default-headers)
6369 message-default-headers))
6370 (or (bolp) (insert ?\n)))
6371 (insert mail-header-separator "\n")
6372 (forward-line -1)
6373 (when (message-news-p)
6374 (when message-default-news-headers
6375 (insert message-default-news-headers)
6376 (or (bolp) (insert ?\n)))
6377 (when message-generate-headers-first
6378 (message-generate-headers
6379 (message-headers-to-generate
6380 (append message-required-news-headers
6381 message-required-headers)
6382 message-generate-headers-first
6383 '(Lines Subject)))))
6384 (when (message-mail-p)
6385 (when message-default-mail-headers
6386 (insert message-default-mail-headers)
6387 (or (bolp) (insert ?\n)))
6388 (when message-generate-headers-first
6389 (message-generate-headers
6390 (message-headers-to-generate
6391 (append message-required-mail-headers
6392 message-required-headers)
6393 message-generate-headers-first
6394 '(Lines Subject)))))
6395 (run-hooks 'message-signature-setup-hook)
6396 (message-insert-signature)
6397 (save-restriction
6398 (message-narrow-to-headers)
6399 (run-hooks 'message-header-setup-hook))
6400 (setq buffer-undo-list nil)
6401 (when message-generate-hashcash
6402 ;; Generate hashcash headers for recipients already known
6403 (mail-add-payment-async))
6404 ;; Gnus posting styles are applied via buffer-local `message-setup-hook'
6405 ;; values.
6406 (run-hooks 'message-setup-hook)
6407 ;; Do this last to give it precedence over posting styles, etc.
6408 (when (message-mail-p)
6409 (save-restriction
6410 (message-narrow-to-headers)
6411 (if message-alternative-emails
6412 (message-use-alternative-email-as-from))))
6413 (message-position-point)
6414 ;; Allow correct handling of `message-checksum' in `message-yank-original':
6415 (set-buffer-modified-p nil)
6416 (undo-boundary))
6417
6418 (defun message-set-auto-save-file-name ()
6419 "Associate the message buffer with a file in the drafts directory."
6420 (when message-auto-save-directory
6421 (unless (file-directory-p
6422 (directory-file-name message-auto-save-directory))
6423 (make-directory message-auto-save-directory t))
6424 (if (gnus-alive-p)
6425 (setq message-draft-article
6426 (nndraft-request-associate-buffer "drafts"))
6427
6428 ;; If Gnus were alive, draft messages would be saved in the drafts folder.
6429 ;; But Gnus is not alive, so arrange to save the draft message in a
6430 ;; regular file in message-auto-save-directory. Append a unique
6431 ;; time-based suffix to the filename to allow multiple drafts to be saved
6432 ;; simultaneously without overwriting each other (which mimics the
6433 ;; functionality of the Gnus drafts folder).
6434 (setq buffer-file-name (expand-file-name
6435 (concat
6436 (if (memq system-type
6437 '(ms-dos windows-nt cygwin))
6438 "message"
6439 "*message*")
6440 (format-time-string "-%Y%m%d-%H%M%S"))
6441 message-auto-save-directory))
6442 (setq buffer-auto-save-file-name (make-auto-save-file-name)))
6443 (clear-visited-file-modtime)
6444 (setq buffer-file-coding-system message-draft-coding-system)))
6445
6446 (defun message-disassociate-draft ()
6447 "Disassociate the message buffer from the drafts directory."
6448 (when message-draft-article
6449 (nndraft-request-expire-articles
6450 (list message-draft-article) "drafts" nil t)))
6451
6452 (defun message-insert-headers ()
6453 "Generate the headers for the article."
6454 (interactive)
6455 (save-excursion
6456 (save-restriction
6457 (message-narrow-to-headers)
6458 (when (message-news-p)
6459 (message-generate-headers
6460 (delq 'Lines
6461 (delq 'Subject
6462 (copy-sequence message-required-news-headers)))))
6463 (when (message-mail-p)
6464 (message-generate-headers
6465 (delq 'Lines
6466 (delq 'Subject
6467 (copy-sequence message-required-mail-headers))))))))
6468
6469 \f
6470
6471 ;;;
6472 ;;; Commands for interfacing with message
6473 ;;;
6474
6475 ;;;###autoload
6476 (defun message-mail (&optional to subject
6477 other-headers continue switch-function
6478 yank-action send-actions)
6479 "Start editing a mail message to be sent.
6480 OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether
6481 to continue editing a message already being composed. SWITCH-FUNCTION
6482 is a function used to switch to and display the mail buffer."
6483 (interactive)
6484 (let ((message-this-is-mail t))
6485 (unless (message-mail-user-agent)
6486 (message-pop-to-buffer
6487 ;; Search for the existing message buffer if `continue' is non-nil.
6488 (let ((message-generate-new-buffers
6489 (when (or (not continue)
6490 (eq message-generate-new-buffers 'standard)
6491 (functionp message-generate-new-buffers))
6492 message-generate-new-buffers)))
6493 (message-buffer-name "mail" to))
6494 switch-function))
6495 (message-setup
6496 (nconc
6497 `((To . ,(or to "")) (Subject . ,(or subject "")))
6498 (when other-headers other-headers))
6499 yank-action send-actions continue switch-function)
6500 ;; FIXME: Should return nil if failure.
6501 t))
6502
6503 ;;;###autoload
6504 (defun message-news (&optional newsgroups subject)
6505 "Start editing a news article to be sent."
6506 (interactive)
6507 (let ((message-this-is-news t))
6508 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))
6509 (message-setup `((Newsgroups . ,(or newsgroups ""))
6510 (Subject . ,(or subject ""))))))
6511
6512 (defun message-alter-recipients-discard-bogus-full-name (addrcell)
6513 "Discard mail address in full names.
6514 When the full name in reply headers contains the mail
6515 address (e.g. \"foo@bar <foo@bar>\"), discard full name.
6516 ADDRCELL is a cons cell where the car is the mail address and the
6517 cdr is the complete address (full name and mail address)."
6518 (if (string-match (concat (regexp-quote (car addrcell)) ".*"
6519 (regexp-quote (car addrcell)))
6520 (cdr addrcell))
6521 (cons (car addrcell) (car addrcell))
6522 addrcell))
6523
6524 (defcustom message-alter-recipients-function nil
6525 "Function called to allow alteration of reply header structures.
6526 It is called in `message-get-reply-headers' for each recipient.
6527 The function is called with one parameter, a cons cell ..."
6528 :type '(choice (const :tag "None" nil)
6529 (const :tag "Discard bogus full name"
6530 message-alter-recipients-discard-bogus-full-name)
6531 function)
6532 :version "23.1" ;; No Gnus
6533 :group 'message-headers)
6534
6535 (defun message-get-reply-headers (wide &optional to-address address-headers)
6536 (let (follow-to mct never-mct to cc author mft recipients extra)
6537 ;; Find all relevant headers we need.
6538 (save-restriction
6539 (message-narrow-to-headers-or-head)
6540 ;; Gmane renames "To". Look at "Original-To", too, if it is present in
6541 ;; message-header-synonyms.
6542 (setq to (or (message-fetch-field "to")
6543 (and (loop for synonym in message-header-synonyms
6544 when (memq 'Original-To synonym)
6545 return t)
6546 (message-fetch-field "original-to")))
6547 cc (message-fetch-field "cc")
6548 extra (when message-extra-wide-headers
6549 (mapconcat 'identity
6550 (mapcar 'message-fetch-field
6551 message-extra-wide-headers)
6552 ", "))
6553 mct (message-fetch-field "mail-copies-to")
6554 author (or (message-fetch-field "mail-reply-to")
6555 (message-fetch-field "reply-to")
6556 (message-fetch-field "from")
6557 "")
6558 mft (and message-use-mail-followup-to
6559 (message-fetch-field "mail-followup-to"))))
6560
6561 ;; Handle special values of Mail-Copies-To.
6562 (when mct
6563 (cond ((or (equal (downcase mct) "never")
6564 (equal (downcase mct) "nobody"))
6565 (setq never-mct t)
6566 (setq mct nil))
6567 ((or (equal (downcase mct) "always")
6568 (equal (downcase mct) "poster"))
6569 (setq mct author))))
6570
6571 (save-match-data
6572 ;; Build (textual) list of new recipient addresses.
6573 (cond
6574 (to-address
6575 (setq recipients (concat ", " to-address))
6576 ;; If the author explicitly asked for a copy, we don't deny it to them.
6577 (if mct (setq recipients (concat recipients ", " mct))))
6578 ((not wide)
6579 (setq recipients (concat ", " author)))
6580 (address-headers
6581 (dolist (header address-headers)
6582 (let ((value (message-fetch-field header)))
6583 (when value
6584 (setq recipients (concat recipients ", " value))))))
6585 ((and mft
6586 (string-match "[^ \t,]" mft)
6587 (or (not (eq message-use-mail-followup-to 'ask))
6588 (message-y-or-n-p "Obey Mail-Followup-To? " t "\
6589 You should normally obey the Mail-Followup-To: header. In this
6590 article, it has the value of
6591
6592 " mft "
6593
6594 which directs your response to " (if (string-match "," mft)
6595 "the specified addresses"
6596 "that address only") ".
6597
6598 Most commonly, Mail-Followup-To is used by a mailing list poster to
6599 express that responses should be sent to just the list, and not the
6600 poster as well.
6601
6602 If a message is posted to several mailing lists, Mail-Followup-To may
6603 also be used to direct the following discussion to one list only,
6604 because discussions that are spread over several lists tend to be
6605 fragmented and very difficult to follow.
6606
6607 Also, some source/announcement lists are not intended for discussion;
6608 responses here are directed to other addresses.
6609
6610 You may customize the variable `message-use-mail-followup-to', if you
6611 want to get rid of this query permanently.")))
6612 (setq recipients (concat ", " mft)))
6613 (t
6614 (setq recipients (if never-mct "" (concat ", " author)))
6615 (if to (setq recipients (concat recipients ", " to)))
6616 (if cc (setq recipients (concat recipients ", " cc)))
6617 (if extra (setq recipients (concat recipients ", " extra)))
6618 (if mct (setq recipients (concat recipients ", " mct)))))
6619 (if (>= (length recipients) 2)
6620 ;; Strip the leading ", ".
6621 (setq recipients (substring recipients 2)))
6622 ;; Squeeze whitespace.
6623 (while (string-match "[ \t][ \t]+" recipients)
6624 (setq recipients (replace-match " " t t recipients)))
6625 ;; Remove addresses that match `rmail-dont-reply-to-names'.
6626 (let ((rmail-dont-reply-to-names (message-dont-reply-to-names)))
6627 (setq recipients (rmail-dont-reply-to recipients)))
6628 ;; Perhaps "Mail-Copies-To: never" removed the only address?
6629 (if (string-equal recipients "")
6630 (setq recipients author))
6631 ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...).
6632 (setq recipients
6633 (mapcar
6634 (lambda (addr)
6635 (if message-alter-recipients-function
6636 (funcall message-alter-recipients-function
6637 (cons (downcase (mail-strip-quoted-names addr))
6638 addr))
6639 (cons (downcase (mail-strip-quoted-names addr)) addr)))
6640 (message-tokenize-header recipients)))
6641 ;; Remove first duplicates. (Why not all duplicates? Is this a bug?)
6642 (let ((s recipients))
6643 (while s
6644 (setq recipients (delq (assoc (car (pop s)) s) recipients))))
6645
6646 ;; Remove hierarchical lists that are contained within each other,
6647 ;; if message-hierarchical-addresses is defined.
6648 (when message-hierarchical-addresses
6649 (let ((plain-addrs (mapcar 'car recipients))
6650 subaddrs recip)
6651 (while plain-addrs
6652 (setq subaddrs (assoc (car plain-addrs)
6653 message-hierarchical-addresses)
6654 plain-addrs (cdr plain-addrs))
6655 (when subaddrs
6656 (setq subaddrs (cdr subaddrs))
6657 (while subaddrs
6658 (setq recip (assoc (car subaddrs) recipients)
6659 subaddrs (cdr subaddrs))
6660 (if recip
6661 (setq recipients (delq recip recipients))))))))
6662
6663 (setq recipients (message-prune-recipients recipients))
6664
6665 ;; Build the header alist. Allow the user to be asked whether
6666 ;; or not to reply to all recipients in a wide reply.
6667 (setq follow-to (list (cons 'To (cdr (pop recipients)))))
6668 (when (and recipients
6669 (or (not message-wide-reply-confirm-recipients)
6670 (y-or-n-p "Reply to all recipients? ")))
6671 (setq recipients (mapconcat
6672 (lambda (addr) (cdr addr)) recipients ", "))
6673 (if (string-match "^ +" recipients)
6674 (setq recipients (substring recipients (match-end 0))))
6675 (push (cons 'Cc recipients) follow-to)))
6676 follow-to))
6677
6678 (defun message-prune-recipients (recipients)
6679 (dolist (rule message-prune-recipient-rules)
6680 (let ((match (car rule))
6681 dup-match
6682 address)
6683 (dolist (recipient recipients)
6684 (setq address (car recipient))
6685 (when (string-match match address)
6686 (setq dup-match (replace-match (cadr rule) nil nil address))
6687 (dolist (recipient recipients)
6688 ;; Don't delete the address that triggered this.
6689 (when (and (not (eq address (car recipient)))
6690 (string-match dup-match (car recipient)))
6691 (setq recipients (delq recipient recipients))))))))
6692 recipients)
6693
6694 (defcustom message-simplify-subject-functions
6695 '(message-strip-list-identifiers
6696 message-strip-subject-re
6697 message-strip-subject-trailing-was
6698 message-strip-subject-encoded-words)
6699 "List of functions taking a string argument that simplify subjects.
6700 The functions are applied when replying to a message.
6701
6702 Useful functions to put in this list include:
6703 `message-strip-list-identifiers', `message-strip-subject-re',
6704 `message-strip-subject-trailing-was', and
6705 `message-strip-subject-encoded-words'."
6706 :version "22.1" ;; Gnus 5.10.9
6707 :group 'message-various
6708 :type '(repeat function))
6709
6710 (defun message-simplify-subject (subject &optional functions)
6711 "Return simplified SUBJECT."
6712 (unless functions
6713 ;; Simplify fully:
6714 (setq functions message-simplify-subject-functions))
6715 (when (and (memq 'message-strip-list-identifiers functions)
6716 gnus-list-identifiers)
6717 (setq subject (message-strip-list-identifiers subject)))
6718 (when (memq 'message-strip-subject-re functions)
6719 (setq subject (concat "Re: " (message-strip-subject-re subject))))
6720 (when (and (memq 'message-strip-subject-trailing-was functions)
6721 message-subject-trailing-was-query)
6722 (setq subject (message-strip-subject-trailing-was subject)))
6723 (when (memq 'message-strip-subject-encoded-words functions)
6724 (setq subject (message-strip-subject-encoded-words subject)))
6725 subject)
6726
6727 ;;;###autoload
6728 (defun message-reply (&optional to-address wide)
6729 "Start editing a reply to the article in the current buffer."
6730 (interactive)
6731 (require 'gnus-sum) ; for gnus-list-identifiers
6732 (let ((cur (current-buffer))
6733 from subject date reply-to to cc
6734 references message-id follow-to
6735 (inhibit-point-motion-hooks t)
6736 (message-this-is-mail t)
6737 gnus-warning)
6738 (save-restriction
6739 (message-narrow-to-head-1)
6740 ;; Allow customizations to have their say.
6741 (if (not wide)
6742 ;; This is a regular reply.
6743 (when (functionp message-reply-to-function)
6744 (save-excursion
6745 (setq follow-to (funcall message-reply-to-function))))
6746 ;; This is a followup.
6747 (when (functionp message-wide-reply-to-function)
6748 (save-excursion
6749 (setq follow-to
6750 (funcall message-wide-reply-to-function)))))
6751 (setq message-id (message-fetch-field "message-id" t)
6752 references (message-fetch-field "references")
6753 date (message-fetch-field "date")
6754 from (or (message-fetch-field "from") "nobody")
6755 subject (or (message-fetch-field "subject") "none"))
6756
6757 ;; Strip list identifiers, "Re: ", and "was:"
6758 (setq subject (message-simplify-subject subject))
6759
6760 (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
6761 (string-match "<[^>]+>" gnus-warning))
6762 (setq message-id (match-string 0 gnus-warning)))
6763
6764 (unless follow-to
6765 (setq follow-to (message-get-reply-headers wide to-address))))
6766
6767 (unless (message-mail-user-agent)
6768 (message-pop-to-buffer
6769 (message-buffer-name
6770 (if wide "wide reply" "reply") from
6771 (if wide to-address nil))))
6772
6773 (setq message-reply-headers
6774 (vector 0 subject from date message-id references 0 0 ""))
6775
6776 (message-setup
6777 `((Subject . ,subject)
6778 ,@follow-to)
6779 cur)))
6780
6781 ;;;###autoload
6782 (defun message-wide-reply (&optional to-address)
6783 "Make a \"wide\" reply to the message in the current buffer."
6784 (interactive)
6785 (message-reply to-address t))
6786
6787 ;;;###autoload
6788 (defun message-followup (&optional to-newsgroups)
6789 "Follow up to the message in the current buffer.
6790 If TO-NEWSGROUPS, use that as the new Newsgroups line."
6791 (interactive)
6792 (require 'gnus-sum) ; for gnus-list-identifiers
6793 (let ((cur (current-buffer))
6794 from subject date reply-to mrt mct
6795 references message-id follow-to
6796 (inhibit-point-motion-hooks t)
6797 (message-this-is-news t)
6798 followup-to distribution newsgroups gnus-warning posted-to)
6799 (save-restriction
6800 (narrow-to-region
6801 (goto-char (point-min))
6802 (if (search-forward "\n\n" nil t)
6803 (1- (point))
6804 (point-max)))
6805 (when (functionp message-followup-to-function)
6806 (setq follow-to
6807 (funcall message-followup-to-function)))
6808 (setq from (message-fetch-field "from")
6809 date (message-fetch-field "date")
6810 subject (or (message-fetch-field "subject") "none")
6811 references (message-fetch-field "references")
6812 message-id (message-fetch-field "message-id" t)
6813 followup-to (message-fetch-field "followup-to")
6814 newsgroups (message-fetch-field "newsgroups")
6815 posted-to (message-fetch-field "posted-to")
6816 reply-to (message-fetch-field "reply-to")
6817 mrt (message-fetch-field "mail-reply-to")
6818 distribution (message-fetch-field "distribution")
6819 mct (message-fetch-field "mail-copies-to"))
6820 (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
6821 (string-match "<[^>]+>" gnus-warning))
6822 (setq message-id (match-string 0 gnus-warning)))
6823 ;; Remove bogus distribution.
6824 (when (and (stringp distribution)
6825 (let ((case-fold-search t))
6826 (string-match "world" distribution)))
6827 (setq distribution nil))
6828 ;; Strip list identifiers, "Re: ", and "was:"
6829 (setq subject (message-simplify-subject subject))
6830 (widen))
6831
6832 (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
6833
6834 (setq message-reply-headers
6835 (vector 0 subject from date message-id references 0 0 ""))
6836
6837 (message-setup
6838 `((Subject . ,subject)
6839 ,@(cond
6840 (to-newsgroups
6841 (list (cons 'Newsgroups to-newsgroups)))
6842 (follow-to follow-to)
6843 ((and followup-to message-use-followup-to)
6844 (list
6845 (cond
6846 ((equal (downcase followup-to) "poster")
6847 (if (or (eq message-use-followup-to 'use)
6848 (message-y-or-n-p "Obey Followup-To: poster? " t "\
6849 You should normally obey the Followup-To: header.
6850
6851 `Followup-To: poster' sends your response via e-mail instead of news.
6852
6853 A typical situation where `Followup-To: poster' is used is when the poster
6854 does not read the newsgroup, so he wouldn't see any replies sent to it.
6855
6856 You may customize the variable `message-use-followup-to', if you
6857 want to get rid of this query permanently."))
6858 (progn
6859 (setq message-this-is-news nil)
6860 (cons 'To (or mrt reply-to from "")))
6861 (cons 'Newsgroups newsgroups)))
6862 (t
6863 (if (or (equal followup-to newsgroups)
6864 (not (eq message-use-followup-to 'ask))
6865 (message-y-or-n-p
6866 (concat "Obey Followup-To: " followup-to "? ") t "\
6867 You should normally obey the Followup-To: header.
6868
6869 `Followup-To: " followup-to "'
6870 directs your response to " (if (string-match "," followup-to)
6871 "the specified newsgroups"
6872 "that newsgroup only") ".
6873
6874 If a message is posted to several newsgroups, Followup-To is often
6875 used to direct the following discussion to one newsgroup only,
6876 because discussions that are spread over several newsgroup tend to
6877 be fragmented and very difficult to follow.
6878
6879 Also, some source/announcement newsgroups are not intended for discussion;
6880 responses here are directed to other newsgroups.
6881
6882 You may customize the variable `message-use-followup-to', if you
6883 want to get rid of this query permanently."))
6884 (cons 'Newsgroups followup-to)
6885 (cons 'Newsgroups newsgroups))))))
6886 (posted-to
6887 `((Newsgroups . ,posted-to)))
6888 (t
6889 `((Newsgroups . ,newsgroups))))
6890 ,@(and distribution (list (cons 'Distribution distribution)))
6891 ,@(when (and mct
6892 (not (or (equal (downcase mct) "never")
6893 (equal (downcase mct) "nobody"))))
6894 (list (cons 'Cc (if (or (equal (downcase mct) "always")
6895 (equal (downcase mct) "poster"))
6896 (or mrt reply-to from "")
6897 mct)))))
6898
6899 cur)))
6900
6901 (defun message-is-yours-p ()
6902 "Non-nil means current article is yours.
6903 If you have added 'cancel-messages to `message-shoot-gnksa-feet', all articles
6904 are yours except those that have Cancel-Lock header not belonging to you.
6905 Instead of shooting GNKSA feet, you should modify `message-alternative-emails'
6906 regexp to match all of yours addresses."
6907 ;; Canlock-logic as suggested by Per Abrahamsen
6908 ;; <abraham@dina.kvl.dk>
6909 ;;
6910 ;; IF article has cancel-lock THEN
6911 ;; IF we can verify it THEN
6912 ;; issue cancel
6913 ;; ELSE
6914 ;; error: cancellock: article is not yours
6915 ;; ELSE
6916 ;; Use old rules, comparing sender...
6917 (save-excursion
6918 (save-restriction
6919 (message-narrow-to-head-1)
6920 (if (message-fetch-field "Cancel-Lock")
6921 (if (null (canlock-verify))
6922 t
6923 (error "Failed to verify Cancel-lock: This article is not yours"))
6924 (let (sender from)
6925 (or
6926 (message-gnksa-enable-p 'cancel-messages)
6927 (and (setq sender (message-fetch-field "sender"))
6928 (string-equal (downcase sender)
6929 (downcase (message-make-sender))))
6930 ;; Email address in From field equals to our address
6931 (and (setq from (message-fetch-field "from"))
6932 (string-equal
6933 (downcase (car (mail-header-parse-address from)))
6934 (downcase (car (mail-header-parse-address
6935 (message-make-from))))))
6936 ;; Email address in From field matches
6937 ;; 'message-alternative-emails' regexp
6938 (and from
6939 message-alternative-emails
6940 (string-match
6941 message-alternative-emails
6942 (car (mail-header-parse-address from))))))))))
6943
6944 ;;;###autoload
6945 (defun message-cancel-news (&optional arg)
6946 "Cancel an article you posted.
6947 If ARG, allow editing of the cancellation message."
6948 (interactive "P")
6949 (unless (message-news-p)
6950 (error "This is not a news article; canceling is impossible"))
6951 (let (from newsgroups message-id distribution buf)
6952 (save-excursion
6953 ;; Get header info from original article.
6954 (save-restriction
6955 (message-narrow-to-head-1)
6956 (setq from (message-fetch-field "from")
6957 newsgroups (message-fetch-field "newsgroups")
6958 message-id (message-fetch-field "message-id" t)
6959 distribution (message-fetch-field "distribution")))
6960 ;; Make sure that this article was written by the user.
6961 (unless (message-is-yours-p)
6962 (error "This article is not yours"))
6963 (when (yes-or-no-p "Do you really want to cancel this article? ")
6964 ;; Make control message.
6965 (if arg
6966 (message-news)
6967 (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
6968 (erase-buffer)
6969 (insert "Newsgroups: " newsgroups "\n"
6970 "From: " from "\n"
6971 "Subject: cmsg cancel " message-id "\n"
6972 "Control: cancel " message-id "\n"
6973 (if distribution
6974 (concat "Distribution: " distribution "\n")
6975 "")
6976 mail-header-separator "\n"
6977 message-cancel-message)
6978 (run-hooks 'message-cancel-hook)
6979 (unless arg
6980 (message "Canceling your article...")
6981 (if (let ((message-syntax-checks
6982 'dont-check-for-anything-just-trust-me))
6983 (funcall message-send-news-function))
6984 (message "Canceling your article...done"))
6985 (kill-buffer buf))))))
6986
6987 ;;;###autoload
6988 (defun message-supersede ()
6989 "Start composing a message to supersede the current message.
6990 This is done simply by taking the old article and adding a Supersedes
6991 header line with the old Message-ID."
6992 (interactive)
6993 (let ((cur (current-buffer)))
6994 ;; Check whether the user owns the article that is to be superseded.
6995 (unless (message-is-yours-p)
6996 (error "This article is not yours"))
6997 ;; Get a normal message buffer.
6998 (message-pop-to-buffer (message-buffer-name "supersede"))
6999 (insert-buffer-substring cur)
7000 (mime-to-mml)
7001 (message-narrow-to-head-1)
7002 ;; Remove unwanted headers.
7003 (when message-ignored-supersedes-headers
7004 (message-remove-header message-ignored-supersedes-headers t))
7005 (goto-char (point-min))
7006 (if (not (re-search-forward "^Message-ID: " nil t))
7007 (error "No Message-ID in this article")
7008 (replace-match "Supersedes: " t t))
7009 (goto-char (point-max))
7010 (insert mail-header-separator)
7011 (widen)
7012 (forward-line 1)))
7013
7014 ;;;###autoload
7015 (defun message-recover ()
7016 "Reread contents of current buffer from its last auto-save file."
7017 (interactive)
7018 (let ((file-name (make-auto-save-file-name)))
7019 (cond ((save-window-excursion
7020 (with-output-to-temp-buffer "*Directory*"
7021 (with-current-buffer standard-output
7022 (fundamental-mode)) ; for Emacs 20.4+
7023 (buffer-disable-undo standard-output)
7024 (let ((default-directory "/"))
7025 (call-process
7026 "ls" nil standard-output nil "-l" file-name)))
7027 (yes-or-no-p (format "Recover auto save file %s? " file-name)))
7028 (let ((buffer-read-only nil))
7029 (erase-buffer)
7030 (insert-file-contents file-name nil)))
7031 (t (error "message-recover cancelled")))))
7032
7033 ;;; Washing Subject:
7034
7035 (defun message-wash-subject (subject)
7036 "Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT.
7037 Previous forwarders, replyers, etc. may add it."
7038 (with-temp-buffer
7039 (insert subject)
7040 (goto-char (point-min))
7041 ;; strip Re/Fwd stuff off the beginning
7042 (while (re-search-forward
7043 "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
7044 (replace-match ""))
7045
7046 ;; and gnus-style forwards [foo@bar.com] subject
7047 (goto-char (point-min))
7048 (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
7049 (replace-match ""))
7050
7051 ;; and off the end
7052 (goto-char (point-max))
7053 (while (re-search-backward "([Ff][Ww][Dd])" nil t)
7054 (replace-match ""))
7055
7056 ;; and finally, any whitespace that was left-over
7057 (goto-char (point-min))
7058 (while (re-search-forward "^[ \t]+" nil t)
7059 (replace-match ""))
7060 (goto-char (point-max))
7061 (while (re-search-backward "[ \t]+$" nil t)
7062 (replace-match ""))
7063
7064 (buffer-string)))
7065
7066 ;;; Forwarding messages.
7067
7068 (defvar message-forward-decoded-p nil
7069 "Non-nil means the original message is decoded.")
7070
7071 (defun message-forward-subject-name-subject (subject)
7072 "Generate a SUBJECT for a forwarded message.
7073 The form is: [Source] Subject, where if the original message was mail,
7074 Source is the name of the sender, and if the original message was
7075 news, Source is the list of newsgroups is was posted to."
7076 (let* ((group (message-fetch-field "newsgroups"))
7077 (from (message-fetch-field "from"))
7078 (prefix
7079 (if group
7080 (gnus-group-decoded-name group)
7081 (or (and from (or
7082 (car (gnus-extract-address-components from))
7083 (cadr (gnus-extract-address-components from))))
7084 "(nowhere)"))))
7085 (concat "["
7086 (if message-forward-decoded-p
7087 prefix
7088 (mail-decode-encoded-word-string prefix))
7089 "] " subject)))
7090
7091 (defun message-forward-subject-author-subject (subject)
7092 "Generate a SUBJECT for a forwarded message.
7093 The form is: [Source] Subject, where if the original message was mail,
7094 Source is the sender, and if the original message was news, Source is
7095 the list of newsgroups is was posted to."
7096 (let* ((group (message-fetch-field "newsgroups"))
7097 (prefix
7098 (if group
7099 (gnus-group-decoded-name group)
7100 (or (message-fetch-field "from")
7101 "(nowhere)"))))
7102 (concat "["
7103 (if message-forward-decoded-p
7104 prefix
7105 (mail-decode-encoded-word-string prefix))
7106 "] " subject)))
7107
7108 (defun message-forward-subject-fwd (subject)
7109 "Generate a SUBJECT for a forwarded message.
7110 The form is: Fwd: Subject, where Subject is the original subject of
7111 the message."
7112 (if (string-match "^Fwd: " subject)
7113 subject
7114 (concat "Fwd: " subject)))
7115
7116 (defun message-make-forward-subject ()
7117 "Return a Subject header suitable for the message in the current buffer."
7118 (save-excursion
7119 (save-restriction
7120 (message-narrow-to-head-1)
7121 (let ((funcs message-make-forward-subject-function)
7122 (subject (message-fetch-field "Subject")))
7123 (setq subject
7124 (if subject
7125 (if message-forward-decoded-p
7126 subject
7127 (mail-decode-encoded-word-string subject))
7128 ""))
7129 (when message-wash-forwarded-subjects
7130 (setq subject (message-wash-subject subject)))
7131 ;; Make sure funcs is a list.
7132 (and funcs
7133 (not (listp funcs))
7134 (setq funcs (list funcs)))
7135 ;; Apply funcs in order, passing subject generated by previous
7136 ;; func to the next one.
7137 (dolist (func funcs)
7138 (when (functionp func)
7139 (setq subject (funcall func subject))))
7140 subject))))
7141
7142 (defvar gnus-article-decoded-p)
7143
7144
7145 ;;;###autoload
7146 (defun message-forward (&optional news digest)
7147 "Forward the current message via mail.
7148 Optional NEWS will use news to forward instead of mail.
7149 Optional DIGEST will use digest to forward."
7150 (interactive "P")
7151 (let* ((cur (current-buffer))
7152 (message-forward-decoded-p
7153 (if (local-variable-p 'gnus-article-decoded-p (current-buffer))
7154 gnus-article-decoded-p ;; In an article buffer.
7155 message-forward-decoded-p))
7156 (subject (message-make-forward-subject)))
7157 (if news
7158 (message-news nil subject)
7159 (message-mail nil subject))
7160 (message-forward-make-body cur digest)))
7161
7162 (defun message-forward-make-body-plain (forward-buffer)
7163 (insert
7164 "\n-------------------- Start of forwarded message --------------------\n")
7165 (let ((b (point))
7166 (contents (with-current-buffer forward-buffer (buffer-string)))
7167 e)
7168 (unless (featurep 'xemacs)
7169 (unless (mm-multibyte-string-p contents)
7170 (error "Attempt to insert unibyte string from the buffer \"%s\"\
7171 to the multibyte buffer \"%s\""
7172 (if (bufferp forward-buffer)
7173 (buffer-name forward-buffer)
7174 forward-buffer)
7175 (buffer-name))))
7176 (insert (mm-with-multibyte-buffer
7177 (insert contents)
7178 (mime-to-mml)
7179 (goto-char (point-min))
7180 (when (looking-at "From ")
7181 (replace-match "X-From-Line: "))
7182 (buffer-string)))
7183 (unless (bolp) (insert "\n"))
7184 (setq e (point))
7185 (insert
7186 "-------------------- End of forwarded message --------------------\n")
7187 (message-remove-ignored-headers b e)))
7188
7189 (defun message-remove-ignored-headers (b e)
7190 (when message-forward-ignored-headers
7191 (save-restriction
7192 (narrow-to-region b e)
7193 (goto-char b)
7194 (narrow-to-region (point)
7195 (or (search-forward "\n\n" nil t) (point)))
7196 (let ((ignored (if (stringp message-forward-ignored-headers)
7197 (list message-forward-ignored-headers)
7198 message-forward-ignored-headers)))
7199 (dolist (elem ignored)
7200 (message-remove-header elem t))))))
7201
7202 (defun message-forward-make-body-mime (forward-buffer)
7203 (let ((b (point)))
7204 (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
7205 (save-restriction
7206 (narrow-to-region (point) (point))
7207 (mml-insert-buffer forward-buffer)
7208 (goto-char (point-min))
7209 (when (looking-at "From ")
7210 (replace-match "X-From-Line: "))
7211 (goto-char (point-max)))
7212 (insert "<#/part>\n")
7213 ;; Consider there is no illegible text.
7214 (add-text-properties
7215 b (point)
7216 `(no-illegible-text t rear-nonsticky t start-open t))))
7217
7218 (defun message-forward-make-body-mml (forward-buffer)
7219 (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
7220 (let ((b (point)) e)
7221 (if (not message-forward-decoded-p)
7222 (let ((contents (with-current-buffer forward-buffer (buffer-string))))
7223 (unless (featurep 'xemacs)
7224 (unless (mm-multibyte-string-p contents)
7225 (error "Attempt to insert unibyte string from the buffer \"%s\"\
7226 to the multibyte buffer \"%s\""
7227 (if (bufferp forward-buffer)
7228 (buffer-name forward-buffer)
7229 forward-buffer)
7230 (buffer-name))))
7231 (insert (mm-with-multibyte-buffer
7232 (insert contents)
7233 (mime-to-mml)
7234 (goto-char (point-min))
7235 (when (looking-at "From ")
7236 (replace-match "X-From-Line: "))
7237 (buffer-string))))
7238 (save-restriction
7239 (narrow-to-region (point) (point))
7240 (mml-insert-buffer forward-buffer)
7241 (goto-char (point-min))
7242 (when (looking-at "From ")
7243 (replace-match "X-From-Line: "))
7244 (goto-char (point-max))))
7245 (setq e (point))
7246 (insert "<#/mml>\n")
7247 (when (and (not message-forward-decoded-p)
7248 message-forward-ignored-headers)
7249 (message-remove-ignored-headers b e))))
7250
7251 (defun message-forward-make-body-digest-plain (forward-buffer)
7252 (insert
7253 "\n-------------------- Start of forwarded message --------------------\n")
7254 (let ((b (point)) e)
7255 (mml-insert-buffer forward-buffer)
7256 (setq e (point))
7257 (insert
7258 "\n-------------------- End of forwarded message --------------------\n")))
7259
7260 (defun message-forward-make-body-digest-mime (forward-buffer)
7261 (insert "\n<#multipart type=digest>\n")
7262 (let ((b (point)) e)
7263 (insert-buffer-substring forward-buffer)
7264 (setq e (point))
7265 (insert "<#/multipart>\n")
7266 (save-restriction
7267 (narrow-to-region b e)
7268 (goto-char b)
7269 (narrow-to-region (point)
7270 (or (search-forward "\n\n" nil t) (point)))
7271 (delete-region (point-min) (point-max)))))
7272
7273 (defun message-forward-make-body-digest (forward-buffer)
7274 (if message-forward-as-mime
7275 (message-forward-make-body-digest-mime forward-buffer)
7276 (message-forward-make-body-digest-plain forward-buffer)))
7277
7278 (autoload 'mm-uu-dissect-text-parts "mm-uu")
7279 (autoload 'mm-uu-dissect "mm-uu")
7280
7281 (defun message-signed-or-encrypted-p (&optional dont-emulate-mime handles)
7282 "Say whether the current buffer contains signed or encrypted message.
7283 If DONT-EMULATE-MIME is nil, this function does the MIME emulation on
7284 messages that don't conform to PGP/MIME described in RFC2015. HANDLES
7285 is for the internal use."
7286 (unless handles
7287 (let ((mm-decrypt-option 'never)
7288 (mm-verify-option 'never))
7289 (if (setq handles (mm-dissect-buffer nil t))
7290 (unless dont-emulate-mime
7291 (mm-uu-dissect-text-parts handles))
7292 (unless dont-emulate-mime
7293 (setq handles (mm-uu-dissect))))))
7294 ;; Check text/plain message in which there is a signed or encrypted
7295 ;; body that has been encoded by B or Q.
7296 (unless (or handles dont-emulate-mime)
7297 (let ((cur (current-buffer))
7298 (mm-decrypt-option 'never)
7299 (mm-verify-option 'never))
7300 (with-temp-buffer
7301 (insert-buffer-substring cur)
7302 (when (setq handles (mm-dissect-buffer t t))
7303 (if (and (prog1
7304 (bufferp (car handles))
7305 (mm-destroy-parts handles))
7306 (equal (mm-handle-media-type handles) "text/plain"))
7307 (progn
7308 (mm-decode-content-transfer-encoding
7309 (mm-handle-encoding handles))
7310 (setq handles (mm-uu-dissect)))
7311 (setq handles nil))))))
7312 (when handles
7313 (prog1
7314 (catch 'found
7315 (dolist (handle (if (stringp (car handles))
7316 (if (member (car handles)
7317 '("multipart/signed"
7318 "multipart/encrypted"))
7319 (throw 'found t)
7320 (cdr handles))
7321 (list handles)))
7322 (if (stringp (car handle))
7323 (when (message-signed-or-encrypted-p dont-emulate-mime handle)
7324 (throw 'found t))
7325 (when (and (bufferp (car handle))
7326 (equal (mm-handle-media-type handle)
7327 "message/rfc822"))
7328 (with-current-buffer (mm-handle-buffer handle)
7329 (when (message-signed-or-encrypted-p dont-emulate-mime)
7330 (throw 'found t)))))))
7331 (mm-destroy-parts handles))))
7332
7333 ;;;###autoload
7334 (defun message-forward-make-body (forward-buffer &optional digest)
7335 ;; Put point where we want it before inserting the forwarded
7336 ;; message.
7337 (if message-forward-before-signature
7338 (message-goto-body)
7339 (goto-char (point-max)))
7340 (if digest
7341 (message-forward-make-body-digest forward-buffer)
7342 (if message-forward-as-mime
7343 (if (and message-forward-show-mml
7344 (not (and (eq message-forward-show-mml 'best)
7345 ;; Use the raw form in the body if it contains
7346 ;; signed or encrypted message so as not to be
7347 ;; destroyed by re-encoding.
7348 (with-current-buffer forward-buffer
7349 (condition-case nil
7350 (message-signed-or-encrypted-p)
7351 (error t))))))
7352 (message-forward-make-body-mml forward-buffer)
7353 (message-forward-make-body-mime forward-buffer))
7354 (message-forward-make-body-plain forward-buffer)))
7355 (message-position-point))
7356
7357 (declare-function rmail-toggle-header "rmail" (&optional arg))
7358
7359 ;;;###autoload
7360 (defun message-forward-rmail-make-body (forward-buffer)
7361 (save-window-excursion
7362 (set-buffer forward-buffer)
7363 (if (rmail-msg-is-pruned)
7364 (if (fboundp 'rmail-msg-restore-non-pruned-header)
7365 (rmail-msg-restore-non-pruned-header) ; Emacs 22
7366 (rmail-toggle-header 0)))) ; Emacs 23
7367 (message-forward-make-body forward-buffer))
7368
7369 ;; Fixme: Should have defcustom.
7370 ;;;###autoload
7371 (defun message-insinuate-rmail ()
7372 "Let RMAIL use message to forward."
7373 (interactive)
7374 (setq rmail-enable-mime-composing t)
7375 (setq rmail-insert-mime-forwarded-message-function
7376 'message-forward-rmail-make-body))
7377
7378 ;;;###autoload
7379 (defun message-resend (address)
7380 "Resend the current article to ADDRESS."
7381 (interactive
7382 (list (message-read-from-minibuffer "Resend message to: ")))
7383 (message "Resending message to %s..." address)
7384 (save-excursion
7385 (let ((cur (current-buffer))
7386 beg)
7387 ;; We first set up a normal mail buffer.
7388 (unless (message-mail-user-agent)
7389 (set-buffer (get-buffer-create " *message resend*"))
7390 (erase-buffer))
7391 (let ((message-this-is-mail t)
7392 message-generate-hashcash
7393 message-setup-hook)
7394 (message-setup `((To . ,address))))
7395 ;; Insert our usual headers.
7396 (message-generate-headers '(From Date To Message-ID))
7397 (message-narrow-to-headers)
7398 ;; Remove X-Draft-From header etc.
7399 (message-remove-header message-ignored-mail-headers t)
7400 ;; Rename them all to "Resent-*".
7401 (goto-char (point-min))
7402 (while (re-search-forward "^[A-Za-z]" nil t)
7403 (forward-char -1)
7404 (insert "Resent-"))
7405 (widen)
7406 (forward-line)
7407 (delete-region (point) (point-max))
7408 (setq beg (point))
7409 ;; Insert the message to be resent.
7410 (insert-buffer-substring cur)
7411 (goto-char (point-min))
7412 (search-forward "\n\n")
7413 (forward-char -1)
7414 (save-restriction
7415 (narrow-to-region beg (point))
7416 (message-remove-header message-ignored-resent-headers t)
7417 (goto-char (point-max)))
7418 (insert mail-header-separator)
7419 ;; Rename all old ("Also-")Resent headers.
7420 (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
7421 (beginning-of-line)
7422 (insert "Also-"))
7423 ;; Quote any "From " lines at the beginning.
7424 (goto-char beg)
7425 (when (looking-at "From ")
7426 (replace-match "X-From-Line: "))
7427 ;; Send it.
7428 (let ((message-inhibit-body-encoding t)
7429 (message-inhibit-ecomplete t)
7430 message-required-mail-headers
7431 message-generate-hashcash
7432 rfc2047-encode-encoded-words)
7433 (message-send-mail))
7434 (kill-buffer (current-buffer)))
7435 (message "Resending message to %s...done" address)))
7436
7437 ;;;###autoload
7438 (defun message-bounce ()
7439 "Re-mail the current message.
7440 This only makes sense if the current message is a bounce message that
7441 contains some mail you have written which has been bounced back to
7442 you."
7443 (interactive)
7444 (let ((handles (mm-dissect-buffer t))
7445 boundary)
7446 (message-pop-to-buffer (message-buffer-name "bounce"))
7447 (if (stringp (car handles))
7448 ;; This is a MIME bounce.
7449 (mm-insert-part (car (last handles)))
7450 ;; This is a non-MIME bounce, so we try to remove things
7451 ;; manually.
7452 (mm-insert-part handles)
7453 (undo-boundary)
7454 (goto-char (point-min))
7455 (re-search-forward "\n\n+" nil t)
7456 (setq boundary (point))
7457 ;; We remove everything before the bounced mail.
7458 (if (or (re-search-forward message-unsent-separator nil t)
7459 (progn
7460 (search-forward "\n\n" nil 'move)
7461 (re-search-backward "^Return-Path:.*\n" boundary t)))
7462 (progn
7463 (forward-line 1)
7464 (delete-region (point-min)
7465 (if (re-search-forward "^[^ \n\t]+:" nil t)
7466 (match-beginning 0)
7467 (point))))
7468 (goto-char boundary)
7469 (when (re-search-backward "^.?From .*\n" nil t)
7470 (delete-region (match-beginning 0) (match-end 0)))))
7471 (mime-to-mml)
7472 (save-restriction
7473 (message-narrow-to-head-1)
7474 (message-remove-header message-ignored-bounced-headers t)
7475 (goto-char (point-max))
7476 (insert mail-header-separator))
7477 (message-position-point)))
7478
7479 ;;;
7480 ;;; Interactive entry points for new message buffers.
7481 ;;;
7482
7483 ;;;###autoload
7484 (defun message-mail-other-window (&optional to subject)
7485 "Like `message-mail' command, but display mail buffer in another window."
7486 (interactive)
7487 (unless (message-mail-user-agent)
7488 (let ((pop-up-windows t)
7489 (special-display-buffer-names nil)
7490 (special-display-regexps nil)
7491 (same-window-buffer-names nil)
7492 (same-window-regexps nil))
7493 (message-pop-to-buffer (message-buffer-name "mail" to))))
7494 (let ((message-this-is-mail t))
7495 (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
7496 nil nil nil 'switch-to-buffer-other-window)))
7497
7498 ;;;###autoload
7499 (defun message-mail-other-frame (&optional to subject)
7500 "Like `message-mail' command, but display mail buffer in another frame."
7501 (interactive)
7502 (unless (message-mail-user-agent)
7503 (let ((pop-up-frames t)
7504 (special-display-buffer-names nil)
7505 (special-display-regexps nil)
7506 (same-window-buffer-names nil)
7507 (same-window-regexps nil))
7508 (message-pop-to-buffer (message-buffer-name "mail" to))))
7509 (let ((message-this-is-mail t))
7510 (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
7511 nil nil nil 'switch-to-buffer-other-frame)))
7512
7513 ;;;###autoload
7514 (defun message-news-other-window (&optional newsgroups subject)
7515 "Start editing a news article to be sent."
7516 (interactive)
7517 (let ((pop-up-windows t)
7518 (special-display-buffer-names nil)
7519 (special-display-regexps nil)
7520 (same-window-buffer-names nil)
7521 (same-window-regexps nil))
7522 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
7523 (let ((message-this-is-news t))
7524 (message-setup `((Newsgroups . ,(or newsgroups ""))
7525 (Subject . ,(or subject ""))))))
7526
7527 ;;;###autoload
7528 (defun message-news-other-frame (&optional newsgroups subject)
7529 "Start editing a news article to be sent."
7530 (interactive)
7531 (let ((pop-up-frames t)
7532 (special-display-buffer-names nil)
7533 (special-display-regexps nil)
7534 (same-window-buffer-names nil)
7535 (same-window-regexps nil))
7536 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
7537 (let ((message-this-is-news t))
7538 (message-setup `((Newsgroups . ,(or newsgroups ""))
7539 (Subject . ,(or subject ""))))))
7540
7541 ;;; underline.el
7542
7543 ;; This code should be moved to underline.el (from which it is stolen).
7544
7545 ;;;###autoload
7546 (defun message-bold-region (start end)
7547 "Bold all nonblank characters in the region.
7548 Works by overstriking characters.
7549 Called from program, takes two arguments START and END
7550 which specify the range to operate on."
7551 (interactive "r")
7552 (save-excursion
7553 (let ((end1 (make-marker)))
7554 (move-marker end1 (max start end))
7555 (goto-char (min start end))
7556 (while (< (point) end1)
7557 (or (looking-at "[_\^@- ]")
7558 (insert (char-after) "\b"))
7559 (forward-char 1)))))
7560
7561 ;;;###autoload
7562 (defun message-unbold-region (start end)
7563 "Remove all boldness (overstruck characters) in the region.
7564 Called from program, takes two arguments START and END
7565 which specify the range to operate on."
7566 (interactive "r")
7567 (save-excursion
7568 (let ((end1 (make-marker)))
7569 (move-marker end1 (max start end))
7570 (goto-char (min start end))
7571 (while (search-forward "\b" end1 t)
7572 (if (eq (char-after) (char-after (- (point) 2)))
7573 (delete-char -2))))))
7574
7575 (defun message-exchange-point-and-mark ()
7576 "Exchange point and mark, but don't activate region if it was inactive."
7577 (goto-char (prog1 (mark t)
7578 (set-marker (mark-marker) (point)))))
7579
7580 (defalias 'message-make-overlay 'make-overlay)
7581 (defalias 'message-delete-overlay 'delete-overlay)
7582 (defalias 'message-overlay-put 'overlay-put)
7583 (defun message-kill-all-overlays ()
7584 (if (featurep 'xemacs)
7585 (map-extents (lambda (extent ignore) (delete-extent extent)))
7586 (mapcar #'delete-overlay (overlays-in (point-min) (point-max)))))
7587
7588 ;; Support for toolbar
7589 (defvar tool-bar-mode)
7590
7591 ;; Note: The :set function in the `message-tool-bar*' variables will only
7592 ;; affect _new_ message buffers. We might add a function that walks thru all
7593 ;; message-mode buffers and force the update.
7594 (defun message-tool-bar-update (&optional symbol value)
7595 "Update message mode toolbar.
7596 Setter function for custom variables."
7597 (setq-default message-tool-bar-map nil)
7598 (when symbol
7599 ;; When used as ":set" function:
7600 (set-default symbol value)))
7601
7602 (defcustom message-tool-bar (if (eq gmm-tool-bar-style 'gnome)
7603 'message-tool-bar-gnome
7604 'message-tool-bar-retro)
7605 "Specifies the message mode tool bar.
7606
7607 It can be either a list or a symbol refering to a list. See
7608 `gmm-tool-bar-from-list' for the format of the list. The
7609 default key map is `message-mode-map'.
7610
7611 Pre-defined symbols include `message-tool-bar-gnome' and
7612 `message-tool-bar-retro'."
7613 :type '(repeat gmm-tool-bar-list-item)
7614 :type '(choice (const :tag "GNOME style" message-tool-bar-gnome)
7615 (const :tag "Retro look" message-tool-bar-retro)
7616 (repeat :tag "User defined list" gmm-tool-bar-item)
7617 (symbol))
7618 :version "23.1" ;; No Gnus
7619 :initialize 'custom-initialize-default
7620 :set 'message-tool-bar-update
7621 :group 'message)
7622
7623 (defcustom message-tool-bar-gnome
7624 '((ispell-message "spell" nil
7625 :visible (or (not (boundp 'flyspell-mode))
7626 (not flyspell-mode)))
7627 (flyspell-buffer "spell" t
7628 :visible (and (boundp 'flyspell-mode)
7629 flyspell-mode)
7630 :help "Flyspell whole buffer")
7631 (gmm-ignore "separator")
7632 (message-send-and-exit "mail/send")
7633 (message-dont-send "mail/save-draft")
7634 (message-kill-buffer "close") ;; stock_cancel
7635 (mml-attach-file "attach" mml-mode-map)
7636 (mml-preview "mail/preview" mml-mode-map)
7637 (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil)
7638 (message-insert-importance-high "important" nil :visible nil)
7639 (message-insert-importance-low "unimportant" nil :visible nil)
7640 (message-insert-disposition-notification-to "receipt" nil :visible nil)
7641 (gmm-customize-mode "preferences" t :help "Edit mode preferences")
7642 (message-info "help" t :help "Message manual"))
7643 "List of items for the message tool bar (GNOME style).
7644
7645 See `gmm-tool-bar-from-list' for details on the format of the list."
7646 :type '(repeat gmm-tool-bar-item)
7647 :version "23.1" ;; No Gnus
7648 :initialize 'custom-initialize-default
7649 :set 'message-tool-bar-update
7650 :group 'message)
7651
7652 (defcustom message-tool-bar-retro
7653 '(;; Old Emacs 21 icon for consistency.
7654 (message-send-and-exit "gnus/mail-send")
7655 (message-kill-buffer "close")
7656 (message-dont-send "cancel")
7657 (mml-attach-file "attach" mml-mode-map)
7658 (ispell-message "spell")
7659 (mml-preview "preview" mml-mode-map)
7660 (message-insert-importance-high "gnus/important")
7661 (message-insert-importance-low "gnus/unimportant")
7662 (message-insert-disposition-notification-to "gnus/receipt"))
7663 "List of items for the message tool bar (retro style).
7664
7665 See `gmm-tool-bar-from-list' for details on the format of the list."
7666 :type '(repeat gmm-tool-bar-item)
7667 :version "23.1" ;; No Gnus
7668 :initialize 'custom-initialize-default
7669 :set 'message-tool-bar-update
7670 :group 'message)
7671
7672 (defcustom message-tool-bar-zap-list
7673 '(new-file open-file dired kill-buffer write-file
7674 print-buffer customize help)
7675 "List of icon items from the global tool bar.
7676 These items are not displayed on the message mode tool bar.
7677
7678 See `gmm-tool-bar-from-list' for the format of the list."
7679 :type 'gmm-tool-bar-zap-list
7680 :version "23.1" ;; No Gnus
7681 :initialize 'custom-initialize-default
7682 :set 'message-tool-bar-update
7683 :group 'message)
7684
7685 (defvar image-load-path)
7686
7687 (defun message-make-tool-bar (&optional force)
7688 "Make a message mode tool bar from `message-tool-bar-list'.
7689 When FORCE, rebuild the tool bar."
7690 (when (and (not (featurep 'xemacs))
7691 (boundp 'tool-bar-mode)
7692 tool-bar-mode
7693 (or (not message-tool-bar-map) force))
7694 (setq message-tool-bar-map
7695 (let* ((load-path
7696 (gmm-image-load-path-for-library "message"
7697 "mail/save-draft.xpm"
7698 nil t))
7699 (image-load-path (cons (car load-path)
7700 (when (boundp 'image-load-path)
7701 image-load-path))))
7702 (gmm-tool-bar-from-list message-tool-bar
7703 message-tool-bar-zap-list
7704 'message-mode-map))))
7705 message-tool-bar-map)
7706
7707 ;;; Group name completion.
7708
7709 (defcustom message-newgroups-header-regexp
7710 "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
7711 "Regexp that match headers that lists groups."
7712 :group 'message
7713 :type 'regexp)
7714
7715 (defcustom message-completion-alist
7716 (list (cons message-newgroups-header-regexp 'message-expand-group)
7717 '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name)
7718 '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
7719 . message-expand-name)
7720 '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):"
7721 . message-expand-name))
7722 "Alist of (RE . FUN). Use FUN for completion on header lines matching RE."
7723 :version "22.1"
7724 :group 'message
7725 :type '(alist :key-type regexp :value-type function))
7726
7727 (defcustom message-expand-name-databases
7728 (list 'bbdb 'eudc)
7729 "List of databases to try for name completion (`message-expand-name').
7730 Each element is a symbol and can be `bbdb' or `eudc'."
7731 :group 'message
7732 :type '(set (const bbdb) (const eudc)))
7733
7734 (defcustom message-tab-body-function nil
7735 "*Function to execute when `message-tab' (TAB) is executed in the body.
7736 If nil, the function bound in `text-mode-map' or `global-map' is executed."
7737 :version "22.1"
7738 :group 'message
7739 :link '(custom-manual "(message)Various Commands")
7740 :type '(choice (const nil)
7741 function))
7742
7743 (declare-function mail-abbrev-in-expansion-header-p "mailabbrev" ())
7744
7745 (defun message-tab ()
7746 "Complete names according to `message-completion-alist'.
7747 Execute function specified by `message-tab-body-function' when not in
7748 those headers."
7749 (interactive)
7750 (let ((alist message-completion-alist))
7751 (while (and alist
7752 (let ((mail-abbrev-mode-regexp (caar alist)))
7753 (not (mail-abbrev-in-expansion-header-p))))
7754 (setq alist (cdr alist)))
7755 (funcall (or (cdar alist) message-tab-body-function
7756 (lookup-key text-mode-map "\t")
7757 (lookup-key global-map "\t")
7758 'indent-relative))))
7759
7760 (eval-and-compile
7761 (condition-case nil
7762 (with-temp-buffer
7763 (let ((standard-output (current-buffer)))
7764 (eval '(display-completion-list nil "")))
7765 (defalias 'message-display-completion-list 'display-completion-list))
7766 (error ;; Don't use `wrong-number-of-arguments' here because of XEmacs.
7767 (defun message-display-completion-list (completions &optional ignore)
7768 "Display the list of completions, COMPLETIONS, using `standard-output'."
7769 (display-completion-list completions)))))
7770
7771 (defun message-expand-group ()
7772 "Expand the group name under point."
7773 (let* ((b (save-excursion
7774 (save-restriction
7775 (narrow-to-region
7776 (save-excursion
7777 (beginning-of-line)
7778 (skip-chars-forward "^:")
7779 (1+ (point)))
7780 (point))
7781 (skip-chars-backward "^, \t\n") (point))))
7782 (completion-ignore-case t)
7783 (e (progn (skip-chars-forward "^,\t\n ") (point)))
7784 (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)))
7785 (message-completion-in-region e b hashtb)))
7786
7787 (defalias 'message-completion-in-region
7788 (if (fboundp 'completion-in-region)
7789 'completion-in-region
7790 (lambda (e b hashtb)
7791 (let* ((string (buffer-substring b e))
7792 (completions (all-completions string hashtb))
7793 comp)
7794 (delete-region b (point))
7795 (cond
7796 ((= (length completions) 1)
7797 (if (string= (car completions) string)
7798 (progn
7799 (insert string)
7800 (message "Only matching group"))
7801 (insert (car completions))))
7802 ((and (setq comp (try-completion string hashtb))
7803 (not (string= comp string)))
7804 (insert comp))
7805 (t
7806 (insert string)
7807 (if (not comp)
7808 (message "No matching groups")
7809 (save-selected-window
7810 (pop-to-buffer "*Completions*")
7811 (buffer-disable-undo)
7812 (let ((buffer-read-only nil))
7813 (erase-buffer)
7814 (let ((standard-output (current-buffer)))
7815 (message-display-completion-list (sort completions 'string<)
7816 string))
7817 (setq buffer-read-only nil)
7818 (goto-char (point-min))
7819 (delete-region (point)
7820 (progn (forward-line 3) (point))))))))))))
7821
7822 (defun message-expand-name ()
7823 (cond ((and (memq 'eudc message-expand-name-databases)
7824 (boundp 'eudc-protocol)
7825 eudc-protocol)
7826 (eudc-expand-inline))
7827 ((and (memq 'bbdb message-expand-name-databases)
7828 (fboundp 'bbdb-complete-name))
7829 (bbdb-complete-name))
7830 (t
7831 (expand-abbrev))))
7832
7833 ;;; Help stuff.
7834
7835 (defun message-talkative-question (ask question show &rest text)
7836 "Call FUNCTION with argument QUESTION; optionally display TEXT... args.
7837 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer.
7838 The following arguments may contain lists of values."
7839 (if (and show
7840 (setq text (message-flatten-list text)))
7841 (save-window-excursion
7842 (with-output-to-temp-buffer " *MESSAGE information message*"
7843 (with-current-buffer " *MESSAGE information message*"
7844 (fundamental-mode) ; for Emacs 20.4+
7845 (mapc 'princ text)
7846 (goto-char (point-min))))
7847 (funcall ask question))
7848 (funcall ask question)))
7849
7850 (defun message-flatten-list (list)
7851 "Return a new, flat list that contains all elements of LIST.
7852
7853 \(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
7854 => (1 2 3 4 5 6 7)"
7855 (cond ((consp list)
7856 (apply 'append (mapcar 'message-flatten-list list)))
7857 (list
7858 (list list))))
7859
7860 (defun message-generate-new-buffer-clone-locals (name &optional varstr)
7861 "Create and return a buffer with name based on NAME using `generate-new-buffer'.
7862 Then clone the local variables and values from the old buffer to the
7863 new one, cloning only the locals having a substring matching the
7864 regexp VARSTR."
7865 (let ((oldbuf (current-buffer)))
7866 (with-current-buffer (generate-new-buffer name)
7867 (message-clone-locals oldbuf varstr)
7868 (current-buffer))))
7869
7870 (defun message-clone-locals (buffer &optional varstr)
7871 "Clone the local variables from BUFFER to the current buffer."
7872 (let ((locals (with-current-buffer buffer (buffer-local-variables)))
7873 (regexp "^gnus\\|^nn\\|^message\\|^sendmail\\|^smtp\\|^user-mail-address"))
7874 (mapcar
7875 (lambda (local)
7876 (when (and (consp local)
7877 (car local)
7878 (string-match regexp (symbol-name (car local)))
7879 (or (null varstr)
7880 (string-match varstr (symbol-name (car local)))))
7881 (ignore-errors
7882 (set (make-local-variable (car local))
7883 (cdr local)))))
7884 locals)))
7885
7886 ;;;
7887 ;;; MIME functions
7888 ;;;
7889
7890 (defvar message-inhibit-body-encoding nil)
7891
7892 (defun message-encode-message-body ()
7893 (unless message-inhibit-body-encoding
7894 (let ((mail-parse-charset (or mail-parse-charset
7895 message-default-charset))
7896 (case-fold-search t)
7897 lines content-type-p)
7898 (message-goto-body)
7899 (save-restriction
7900 (narrow-to-region (point) (point-max))
7901 (let ((new (mml-generate-mime)))
7902 (when new
7903 (delete-region (point-min) (point-max))
7904 (insert new)
7905 (goto-char (point-min))
7906 (if (eq (aref new 0) ?\n)
7907 (delete-char 1)
7908 (search-forward "\n\n")
7909 (setq lines (buffer-substring (point-min) (1- (point))))
7910 (delete-region (point-min) (point))))))
7911 (save-restriction
7912 (message-narrow-to-headers-or-head)
7913 (message-remove-header "Mime-Version")
7914 (goto-char (point-max))
7915 (insert "MIME-Version: 1.0\n")
7916 (when lines
7917 (insert lines))
7918 (setq content-type-p
7919 (or mml-boundary
7920 (re-search-backward "^Content-Type:" nil t))))
7921 (save-restriction
7922 (message-narrow-to-headers-or-head)
7923 (message-remove-first-header "Content-Type")
7924 (message-remove-first-header "Content-Transfer-Encoding"))
7925 ;; We always make sure that the message has a Content-Type
7926 ;; header. This is because some broken MTAs and MUAs get
7927 ;; awfully confused when confronted with a message with a
7928 ;; MIME-Version header and without a Content-Type header. For
7929 ;; instance, Solaris' /usr/bin/mail.
7930 (unless content-type-p
7931 (goto-char (point-min))
7932 ;; For unknown reason, MIME-Version doesn't exist.
7933 (when (re-search-forward "^MIME-Version:" nil t)
7934 (forward-line 1)
7935 (insert "Content-Type: text/plain; charset=us-ascii\n"))))))
7936
7937 (defun message-read-from-minibuffer (prompt &optional initial-contents)
7938 "Read from the minibuffer while providing abbrev expansion."
7939 (if (fboundp 'mail-abbrevs-setup)
7940 (let ((mail-abbrev-mode-regexp "")
7941 (minibuffer-setup-hook 'mail-abbrevs-setup)
7942 (minibuffer-local-map message-minibuffer-local-map))
7943 (read-from-minibuffer prompt initial-contents))
7944 (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
7945 (minibuffer-local-map message-minibuffer-local-map))
7946 (read-string prompt initial-contents))))
7947
7948 (defun message-use-alternative-email-as-from ()
7949 "Set From field of the outgoing message to the first matching
7950 address in `message-alternative-emails', looking at To, Cc and
7951 From headers in the original article."
7952 (require 'mail-utils)
7953 (let* ((fields '("To" "Cc" "From"))
7954 (emails
7955 (split-string
7956 (mail-strip-quoted-names
7957 (mapconcat 'message-fetch-reply-field fields ","))
7958 "[ \f\t\n\r\v,]+"))
7959 email)
7960 (while emails
7961 (if (string-match message-alternative-emails (car emails))
7962 (setq email (car emails)
7963 emails nil))
7964 (pop emails))
7965 (unless (or (not email) (equal email user-mail-address))
7966 (message-remove-header "From")
7967 (goto-char (point-max))
7968 (insert "From: " (let ((user-mail-address email)) (message-make-from))
7969 "\n"))))
7970
7971 (defun message-options-get (symbol)
7972 (cdr (assq symbol message-options)))
7973
7974 (defun message-options-set (symbol value)
7975 (let ((the-cons (assq symbol message-options)))
7976 (if the-cons
7977 (if value
7978 (setcdr the-cons value)
7979 (setq message-options (delq the-cons message-options)))
7980 (and value
7981 (push (cons symbol value) message-options))))
7982 value)
7983
7984 (defun message-options-set-recipient ()
7985 (save-restriction
7986 (message-narrow-to-headers-or-head)
7987 (message-options-set 'message-sender
7988 (mail-strip-quoted-names
7989 (message-fetch-field "from")))
7990 (message-options-set 'message-recipients
7991 (mail-strip-quoted-names
7992 (let ((to (message-fetch-field "to"))
7993 (cc (message-fetch-field "cc"))
7994 (bcc (message-fetch-field "bcc")))
7995 (concat
7996 (or to "")
7997 (if (and to cc) ", ")
7998 (or cc "")
7999 (if (and (or to cc) bcc) ", ")
8000 (or bcc "")))))))
8001
8002 (defun message-hide-headers ()
8003 "Hide headers based on the `message-hidden-headers' variable."
8004 (let ((regexps (if (stringp message-hidden-headers)
8005 (list message-hidden-headers)
8006 message-hidden-headers))
8007 (inhibit-point-motion-hooks t)
8008 (after-change-functions nil)
8009 (end-of-headers (point-min)))
8010 (when regexps
8011 (save-excursion
8012 (save-restriction
8013 (message-narrow-to-headers)
8014 (goto-char (point-min))
8015 (while (not (eobp))
8016 (if (not (message-hide-header-p regexps))
8017 (message-next-header)
8018 (let ((begin (point))
8019 header header-len)
8020 (message-next-header)
8021 (setq header (buffer-substring begin (point))
8022 header-len (- (point) begin))
8023 (delete-region begin (point))
8024 (goto-char end-of-headers)
8025 (insert header)
8026 (setq end-of-headers
8027 (+ end-of-headers header-len))))))))
8028 (narrow-to-region end-of-headers (point-max))))
8029
8030 (defun message-hide-header-p (regexps)
8031 (let ((result nil)
8032 (reverse nil))
8033 (when (eq (car regexps) 'not)
8034 (setq reverse t)
8035 (pop regexps))
8036 (dolist (regexp regexps)
8037 (setq result (or result (looking-at regexp))))
8038 (if reverse
8039 (not result)
8040 result)))
8041
8042 (declare-function ecomplete-add-item "ecomplete" (type key text))
8043 (declare-function ecomplete-save "ecomplete" ())
8044
8045 (defun message-put-addresses-in-ecomplete ()
8046 (require 'ecomplete)
8047 (dolist (header '("to" "cc" "from" "reply-to"))
8048 (let ((value (message-field-value header)))
8049 (dolist (string (mail-header-parse-addresses value 'raw))
8050 (setq string
8051 (gnus-replace-in-string
8052 (gnus-replace-in-string string "^ +\\| +$" "") "\n" ""))
8053 (ecomplete-add-item 'mail (car (mail-header-parse-address string))
8054 string))))
8055 (ecomplete-save))
8056
8057 (autoload 'ecomplete-display-matches "ecomplete")
8058
8059 (defun message-display-abbrev (&optional choose)
8060 "Display the next possible abbrev for the text before point."
8061 (interactive (list t))
8062 (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? ))
8063 (message-point-in-header-p)
8064 (save-excursion
8065 (beginning-of-line)
8066 (while (and (memq (char-after) '(?\t ? ))
8067 (zerop (forward-line -1))))
8068 (looking-at "To:\\|Cc:")))
8069 (let* ((end (point))
8070 (start (save-excursion
8071 (and (re-search-backward "[\n\t ]" nil t)
8072 (1+ (point)))))
8073 (word (when start (buffer-substring start end)))
8074 (match (when (and word
8075 (not (zerop (length word))))
8076 (ecomplete-display-matches 'mail word choose))))
8077 (when (and choose match)
8078 (delete-region start end)
8079 (insert match)))))
8080
8081 ;; To send pre-formatted letters like the example below, you can use
8082 ;; `message-send-form-letter':
8083 ;; --8<---------------cut here---------------start------------->8---
8084 ;; To: alice@invalid.invalid
8085 ;; Subject: Verification of your contact information
8086 ;; From: Contact verification <admin@foo.invalid>
8087 ;; --text follows this line--
8088 ;; Hi Alice,
8089 ;; please verify that your contact information is still valid:
8090 ;; Alice A, A avenue 11, 1111 A town, Austria
8091 ;; ----------next form letter message follows this line----------
8092 ;; To: bob@invalid.invalid
8093 ;; Subject: Verification of your contact information
8094 ;; From: Contact verification <admin@foo.invalid>
8095 ;; --text follows this line--
8096 ;; Hi Bob,
8097 ;; please verify that your contact information is still valid:
8098 ;; Bob, B street 22, 22222 Be town, Belgium
8099 ;; ----------next form letter message follows this line----------
8100 ;; To: charlie@invalid.invalid
8101 ;; Subject: Verification of your contact information
8102 ;; From: Contact verification <admin@foo.invalid>
8103 ;; --text follows this line--
8104 ;; Hi Charlie,
8105 ;; please verify that your contact information is still valid:
8106 ;; Charlie Chaplin, C plaza 33, 33333 C town, Chile
8107 ;; --8<---------------cut here---------------end--------------->8---
8108
8109 ;; FIXME: What is the most common term (circular letter, form letter, serial
8110 ;; letter, standard letter) for such kind of letter? See also
8111 ;; <http://en.wikipedia.org/wiki/Form_letter>
8112
8113 ;; FIXME: Maybe extent message-mode's font-lock support to recognize
8114 ;; `message-form-letter-separator', i.e. highlight each message like a single
8115 ;; message.
8116
8117 (defcustom message-form-letter-separator
8118 "\n----------next form letter message follows this line----------\n"
8119 "Separator for `message-send-form-letter'."
8120 ;; :group 'message-form-letter
8121 :group 'message-various
8122 :version "23.1" ;; No Gnus
8123 :type 'string)
8124
8125 (defcustom message-send-form-letter-delay 1
8126 "Delay in seconds when sending a message with `message-send-form-letter'.
8127 Only used when `message-send-form-letter' is called with non-nil
8128 argument `force'."
8129 ;; :group 'message-form-letter
8130 :group 'message-various
8131 :version "23.1" ;; No Gnus
8132 :type 'integer)
8133
8134 (defun message-send-form-letter (&optional force)
8135 "Sent all form letter messages from current buffer.
8136 Unless FORCE, prompt before sending.
8137
8138 The messages are separated by `message-form-letter-separator'.
8139 Header and body are separated by `mail-header-separator'."
8140 (interactive "P")
8141 (let ((sent 0) (skipped 0)
8142 start end text
8143 buff
8144 to done)
8145 (goto-char (point-min))
8146 (while (not done)
8147 (setq start (point)
8148 end (if (search-forward message-form-letter-separator nil t)
8149 (- (point) (length message-form-letter-separator) -1)
8150 (setq done t)
8151 (point-max)))
8152 (setq text
8153 (buffer-substring-no-properties start end))
8154 (setq buff (generate-new-buffer "*mail - form letter*"))
8155 (with-current-buffer buff
8156 (insert text)
8157 (message-mode)
8158 (setq to (message-fetch-field "To"))
8159 (switch-to-buffer buff)
8160 (when force
8161 (sit-for message-send-form-letter-delay))
8162 (if (or force
8163 (y-or-n-p (format "Send message to `%s'? " to)))
8164 (progn
8165 (setq sent (1+ sent))
8166 (message-send-and-exit))
8167 (message (format "Message to `%s' skipped." to))
8168 (setq skipped (1+ skipped)))
8169 (when (buffer-live-p buff)
8170 (kill-buffer buff))))
8171 (message "%s message(s) sent, %s skipped." sent skipped)))
8172
8173 (defun message-replace-header (header new-value &optional after force)
8174 "Remove HEADER and insert the NEW-VALUE.
8175 If AFTER, insert after this header. If FORCE, insert new field
8176 even if NEW-VALUE is empty."
8177 ;; Similar to `nnheader-replace-header' but for message buffers.
8178 (save-excursion
8179 (save-restriction
8180 (message-narrow-to-headers)
8181 (message-remove-header header))
8182 (when (or force (> (length new-value) 0))
8183 (if after
8184 (message-position-on-field header after)
8185 (message-position-on-field header))
8186 (insert new-value))))
8187
8188 (defcustom message-recipients-without-full-name
8189 (list "ding@gnus.org"
8190 "bugs@gnus.org"
8191 "emacs-devel@gnu.org"
8192 "emacs-pretest-bug@gnu.org"
8193 "bug-gnu-emacs@gnu.org")
8194 "Mail addresses that have no full name.
8195 Used in `message-simplify-recipients'."
8196 ;; Maybe the addresses could be extracted from
8197 ;; `gnus-parameter-to-list-alist'?
8198 :type '(choice (const :tag "None" nil)
8199 (repeat string))
8200 :version "23.1" ;; No Gnus
8201 :group 'message-headers)
8202
8203 (defun message-simplify-recipients ()
8204 (interactive)
8205 (dolist (hdr '("Cc" "To"))
8206 (message-replace-header
8207 hdr
8208 (mapconcat
8209 (lambda (addrcomp)
8210 (if (and message-recipients-without-full-name
8211 (string-match
8212 (regexp-opt message-recipients-without-full-name)
8213 (cadr addrcomp)))
8214 (cadr addrcomp)
8215 (if (car addrcomp)
8216 (message-make-from (car addrcomp) (cadr addrcomp))
8217 (cadr addrcomp))))
8218 (when (message-fetch-field hdr)
8219 (mail-extract-address-components
8220 (message-fetch-field hdr) t))
8221 ", "))))
8222
8223 (when (featurep 'xemacs)
8224 (require 'messagexmas)
8225 (message-xmas-redefine))
8226
8227 (provide 'message)
8228
8229 (run-hooks 'message-load-hook)
8230
8231 ;; Local Variables:
8232 ;; coding: iso-8859-1
8233 ;; End:
8234
8235 ;;; message.el ends here