Mercurial > emacs
comparison lisp/gnus/message.el @ 56927:55fd4f77387a after-merge-gnus-5_10
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Merge from emacs--gnus--5.10, gnus--rel--5.10
Patches applied:
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--base-0
tag of miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-464
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-1
Import from CVS branch gnus-5_10-branch
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-2
Merge from lorentey@elte.hu--2004/emacs--multi-tty--0, emacs--cvs-trunk--0
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-3
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-4
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-18
Update from CVS
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-19
Remove autoconf-generated files from archive
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-20
Update from CVS
author | Miles Bader <miles@gnu.org> |
---|---|
date | Sat, 04 Sep 2004 13:13:48 +0000 |
parents | 5284e720208b |
children | a1a3a7ab3bad |
comparison
equal
deleted
inserted
replaced
56926:f8e248e9a717 | 56927:55fd4f77387a |
---|---|
1 ;;; message.el --- composing mail and news messages -*- coding: iso-latin-1 -*- | 1 ;;; message.el --- composing mail and news messages |
2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 | 2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 |
3 ;; Free Software Foundation, Inc. | 3 ;; Free Software Foundation, Inc. |
4 | 4 |
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
6 ;; Keywords: mail, news | 6 ;; Keywords: mail, news |
7 | 7 |
30 | 30 |
31 ;;; Code: | 31 ;;; Code: |
32 | 32 |
33 (eval-when-compile | 33 (eval-when-compile |
34 (require 'cl) | 34 (require 'cl) |
35 (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary | 35 (defvar gnus-message-group-art) |
36 (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary | |
37 (require 'canlock) | |
36 (require 'mailheader) | 38 (require 'mailheader) |
37 (require 'nnheader) | 39 (require 'nnheader) |
38 ;; This is apparently necessary even though things are autoloaded: | 40 ;; This is apparently necessary even though things are autoloaded. |
41 ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better | |
42 ;; require mailabbrev here. | |
39 (if (featurep 'xemacs) | 43 (if (featurep 'xemacs) |
40 (require 'mail-abbrevs)) | 44 (require 'mail-abbrevs) |
45 (require 'mailabbrev)) | |
41 (require 'mail-parse) | 46 (require 'mail-parse) |
42 (require 'mml) | 47 (require 'mml) |
48 (require 'rfc822) | |
49 (eval-and-compile | |
50 (autoload 'gnus-find-method-for-group "gnus") | |
51 (autoload 'nnvirtual-find-group-art "nnvirtual") | |
52 (autoload 'gnus-group-decoded-name "gnus-group")) | |
43 | 53 |
44 (defgroup message '((user-mail-address custom-variable) | 54 (defgroup message '((user-mail-address custom-variable) |
45 (user-full-name custom-variable)) | 55 (user-full-name custom-variable)) |
46 "Mail and news message composing." | 56 "Mail and news message composing." |
47 :link '(custom-manual "(message)Top") | 57 :link '(custom-manual "(message)Top") |
121 mailbox format." | 131 mailbox format." |
122 :type '(radio (function-item message-output) | 132 :type '(radio (function-item message-output) |
123 (function :tag "Other")) | 133 (function :tag "Other")) |
124 :group 'message-sending) | 134 :group 'message-sending) |
125 | 135 |
136 (defcustom message-fcc-externalize-attachments nil | |
137 "If non-nil, attachments are included as external parts in Fcc copies." | |
138 :type 'boolean | |
139 :group 'message-sending) | |
140 | |
126 (defcustom message-courtesy-message | 141 (defcustom message-courtesy-message |
127 "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" | 142 "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" |
128 "*This is inserted at the start of a mailed copy of a posted message. | 143 "*This is inserted at the start of a mailed copy of a posted message. |
129 If the string contains the format spec \"%s\", the Newsgroups | 144 If the string contains the format spec \"%s\", the Newsgroups |
130 the article has been posted to will be inserted there. | 145 the article has been posted to will be inserted there. |
131 If this variable is nil, no such courtesy message will be added." | 146 If this variable is nil, no such courtesy message will be added." |
132 :group 'message-sending | 147 :group 'message-sending |
133 :type 'string) | 148 :type '(radio (string :format "%t: %v\n" :size 0) (const nil))) |
134 | 149 |
135 (defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" | 150 (defcustom message-ignored-bounced-headers |
151 "^\\(Received\\|Return-Path\\|Delivered-To\\):" | |
136 "*Regexp that matches headers to be removed in resent bounced mail." | 152 "*Regexp that matches headers to be removed in resent bounced mail." |
137 :group 'message-interface | 153 :group 'message-interface |
138 :type 'regexp) | 154 :type 'regexp) |
139 | 155 |
140 ;;;###autoload | 156 ;;;###autoload |
154 (const parens) | 170 (const parens) |
155 (const angles) | 171 (const angles) |
156 (const default)) | 172 (const default)) |
157 :group 'message-headers) | 173 :group 'message-headers) |
158 | 174 |
159 (defcustom message-syntax-checks nil | 175 (defcustom message-insert-canlock t |
176 "Whether to insert a Cancel-Lock header in news postings." | |
177 :version "21.3" | |
178 :group 'message-headers | |
179 :type 'boolean) | |
180 | |
181 (defcustom message-syntax-checks | |
182 (if message-insert-canlock '((sender . disabled)) nil) | |
160 ;; Guess this one shouldn't be easy to customize... | 183 ;; Guess this one shouldn't be easy to customize... |
161 "*Controls what syntax checks should not be performed on outgoing posts. | 184 "*Controls what syntax checks should not be performed on outgoing posts. |
162 To disable checking of long signatures, for instance, add | 185 To disable checking of long signatures, for instance, add |
163 `(signature . disabled)' to this list. | 186 `(signature . disabled)' to this list. |
164 | 187 |
167 Checks include `subject-cmsg', `multiple-headers', `sendsys', | 190 Checks include `subject-cmsg', `multiple-headers', `sendsys', |
168 `message-id', `from', `long-lines', `control-chars', `size', | 191 `message-id', `from', `long-lines', `control-chars', `size', |
169 `new-text', `quoting-style', `redirected-followup', `signature', | 192 `new-text', `quoting-style', `redirected-followup', `signature', |
170 `approved', `sender', `empty', `empty-headers', `message-id', `from', | 193 `approved', `sender', `empty', `empty-headers', `message-id', `from', |
171 `subject', `shorten-followup-to', `existing-newsgroups', | 194 `subject', `shorten-followup-to', `existing-newsgroups', |
172 `buffer-file-name', `unchanged', `newsgroups'." | 195 `buffer-file-name', `unchanged', `newsgroups', `reply-to', |
196 `continuation-headers', `long-header-lines', `invisible-text' and | |
197 `illegible-text'." | |
173 :group 'message-news | 198 :group 'message-news |
174 :type '(repeat sexp)) ; Fixme: improve this | 199 :type '(repeat sexp)) ; Fixme: improve this |
175 | 200 |
201 (defcustom message-required-headers '((optional . References) | |
202 From) | |
203 "*Headers to be generated or prompted for when sending a message. | |
204 Also see `message-required-news-headers' and | |
205 `message-required-mail-headers'." | |
206 :group 'message-news | |
207 :group 'message-headers | |
208 :link '(custom-manual "(message)Message Headers") | |
209 :type '(repeat sexp)) | |
210 | |
211 (defcustom message-draft-headers '(References From) | |
212 "*Headers to be generated when saving a draft message." | |
213 :group 'message-news | |
214 :group 'message-headers | |
215 :link '(custom-manual "(message)Message Headers") | |
216 :type '(repeat sexp)) | |
217 | |
176 (defcustom message-required-news-headers | 218 (defcustom message-required-news-headers |
177 '(From Newsgroups Subject Date Message-ID | 219 '(From Newsgroups Subject Date Message-ID |
178 (optional . Organization) Lines | 220 (optional . Organization) |
179 (optional . User-Agent)) | 221 (optional . User-Agent)) |
180 "*Headers to be generated or prompted for when posting an article. | 222 "*Headers to be generated or prompted for when posting an article. |
181 RFC977 and RFC1036 require From, Date, Newsgroups, Subject, | 223 RFC977 and RFC1036 require From, Date, Newsgroups, Subject, |
182 Message-ID. Organization, Lines, In-Reply-To, Expires, and | 224 Message-ID. Organization, Lines, In-Reply-To, Expires, and |
183 User-Agent are optional. If don't you want message to insert some | 225 User-Agent are optional. If don't you want message to insert some |
184 header, remove it from this list." | 226 header, remove it from this list." |
185 :group 'message-news | 227 :group 'message-news |
186 :group 'message-headers | 228 :group 'message-headers |
229 :link '(custom-manual "(message)Message Headers") | |
187 :type '(repeat sexp)) | 230 :type '(repeat sexp)) |
188 | 231 |
189 (defcustom message-required-mail-headers | 232 (defcustom message-required-mail-headers |
190 '(From Subject Date (optional . In-Reply-To) Message-ID Lines | 233 '(From Subject Date (optional . In-Reply-To) Message-ID |
191 (optional . User-Agent)) | 234 (optional . User-Agent)) |
192 "*Headers to be generated or prompted for when mailing a message. | 235 "*Headers to be generated or prompted for when mailing a message. |
193 RFC822 required that From, Date, To, Subject and Message-ID be | 236 It is recommended that From, Date, To, Subject and Message-ID be |
194 included. Organization, Lines and User-Agent are optional." | 237 included. Organization and User-Agent are optional." |
195 :group 'message-mail | 238 :group 'message-mail |
196 :group 'message-headers | 239 :group 'message-headers |
240 :link '(custom-manual "(message)Message Headers") | |
197 :type '(repeat sexp)) | 241 :type '(repeat sexp)) |
198 | 242 |
199 (defcustom message-deletable-headers '(Message-ID Date Lines) | 243 (defcustom message-deletable-headers '(Message-ID Date Lines) |
200 "Headers to be deleted if they already exist and were generated by message previously." | 244 "Headers to be deleted if they already exist and were generated by message previously." |
201 :group 'message-headers | 245 :group 'message-headers |
246 :link '(custom-manual "(message)Message Headers") | |
202 :type 'sexp) | 247 :type 'sexp) |
203 | 248 |
204 (defcustom message-ignored-news-headers | 249 (defcustom message-ignored-news-headers |
205 "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:" | 250 "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" |
206 "*Regexp of headers to be removed unconditionally before posting." | 251 "*Regexp of headers to be removed unconditionally before posting." |
207 :group 'message-news | 252 :group 'message-news |
208 :group 'message-headers | 253 :group 'message-headers |
254 :link '(custom-manual "(message)Message Headers") | |
209 :type 'regexp) | 255 :type 'regexp) |
210 | 256 |
211 (defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:" | 257 (defcustom message-ignored-mail-headers |
258 "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" | |
212 "*Regexp of headers to be removed unconditionally before mailing." | 259 "*Regexp of headers to be removed unconditionally before mailing." |
213 :group 'message-mail | 260 :group 'message-mail |
214 :group 'message-headers | 261 :group 'message-headers |
262 :link '(custom-manual "(message)Mail Headers") | |
215 :type 'regexp) | 263 :type 'regexp) |
216 | 264 |
217 (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:" | 265 (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:" |
218 "*Header lines matching this regexp will be deleted before posting. | 266 "*Header lines matching this regexp will be deleted before posting. |
219 It's best to delete old Path and Date headers before posting to avoid | 267 It's best to delete old Path and Date headers before posting to avoid |
220 any confusion." | 268 any confusion." |
221 :group 'message-interface | 269 :group 'message-interface |
270 :link '(custom-manual "(message)Superseding") | |
222 :type 'regexp) | 271 :type 'regexp) |
223 | 272 |
224 (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*" | 273 (defcustom message-subject-re-regexp |
274 "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*" | |
225 "*Regexp matching \"Re: \" in the subject line." | 275 "*Regexp matching \"Re: \" in the subject line." |
226 :group 'message-various | 276 :group 'message-various |
277 :link '(custom-manual "(message)Message Headers") | |
227 :type 'regexp) | 278 :type 'regexp) |
279 | |
280 ;;; Start of variables adopted from `message-utils.el'. | |
281 | |
282 (defcustom message-subject-trailing-was-query 'ask | |
283 "*What to do with trailing \"(was: <old subject>)\" in subject lines. | |
284 If nil, leave the subject unchanged. If it is the symbol `ask', query | |
285 the user what do do. In this case, the subject is matched against | |
286 `message-subject-trailing-was-ask-regexp'. If | |
287 `message-subject-trailing-was-query' is t, always strip the trailing | |
288 old subject. In this case, `message-subject-trailing-was-regexp' is | |
289 used." | |
290 :type '(choice (const :tag "never" nil) | |
291 (const :tag "always strip" t) | |
292 (const ask)) | |
293 :link '(custom-manual "(message)Message Headers") | |
294 :group 'message-various) | |
295 | |
296 (defcustom message-subject-trailing-was-ask-regexp | |
297 "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)" | |
298 "*Regexp matching \"(was: <old subject>)\" in the subject line. | |
299 | |
300 The function `message-strip-subject-trailing-was' uses this regexp if | |
301 `message-subject-trailing-was-query' is set to the symbol `ask'. If | |
302 the variable is t instead of `ask', use | |
303 `message-subject-trailing-was-regexp' instead. | |
304 | |
305 It is okay to create some false positives here, as the user is asked." | |
306 :group 'message-various | |
307 :link '(custom-manual "(message)Message Headers") | |
308 :type 'regexp) | |
309 | |
310 (defcustom message-subject-trailing-was-regexp | |
311 "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" | |
312 "*Regexp matching \"(was: <old subject>)\" in the subject line. | |
313 | |
314 If `message-subject-trailing-was-query' is set to t, the subject is | |
315 matched against `message-subject-trailing-was-regexp' in | |
316 `message-strip-subject-trailing-was'. You should use a regexp creating very | |
317 few false positives here." | |
318 :group 'message-various | |
319 :link '(custom-manual "(message)Message Headers") | |
320 :type 'regexp) | |
321 | |
322 ;; Fixme: Why are all these things autoloaded? | |
323 | |
324 ;;; marking inserted text | |
325 | |
326 ;;;###autoload | |
327 (defcustom message-mark-insert-begin | |
328 "--8<---------------cut here---------------start------------->8---\n" | |
329 "How to mark the beginning of some inserted text." | |
330 :type 'string | |
331 :link '(custom-manual "(message)Insertion Variables") | |
332 :group 'message-various) | |
333 | |
334 ;;;###autoload | |
335 (defcustom message-mark-insert-end | |
336 "--8<---------------cut here---------------end--------------->8---\n" | |
337 "How to mark the end of some inserted text." | |
338 :type 'string | |
339 :link '(custom-manual "(message)Insertion Variables") | |
340 :group 'message-various) | |
341 | |
342 ;;;###autoload | |
343 (defcustom message-archive-header | |
344 "X-No-Archive: Yes\n" | |
345 "Header to insert when you don't want your article to be archived. | |
346 Archives \(such as groups.google.com\) respect this header." | |
347 :type 'string | |
348 :link '(custom-manual "(message)Header Commands") | |
349 :group 'message-various) | |
350 | |
351 ;;;###autoload | |
352 (defcustom message-archive-note | |
353 "X-No-Archive: Yes - save http://groups.google.com/" | |
354 "Note to insert why you wouldn't want this posting archived. | |
355 If nil, don't insert any text in the body." | |
356 :type '(radio (string :format "%t: %v\n" :size 0) | |
357 (const nil)) | |
358 :link '(custom-manual "(message)Header Commands") | |
359 :group 'message-various) | |
360 | |
361 ;;; Crossposts and Followups | |
362 ;; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de> | |
363 ;; new suggestions by R. Weikusat <rw at another.de> | |
364 | |
365 (defvar message-cross-post-old-target nil | |
366 "Old target for cross-posts or follow-ups.") | |
367 (make-variable-buffer-local 'message-cross-post-old-target) | |
368 | |
369 ;;;###autoload | |
370 (defcustom message-cross-post-default t | |
371 "When non-nil `message-cross-post-followup-to' will perform a crosspost. | |
372 If nil, `message-cross-post-followup-to' will only do a followup. Note that | |
373 you can explicitly override this setting by calling | |
374 `message-cross-post-followup-to' with a prefix." | |
375 :type 'boolean | |
376 :group 'message-various) | |
377 | |
378 ;;;###autoload | |
379 (defcustom message-cross-post-note | |
380 "Crosspost & Followup-To: " | |
381 "Note to insert before signature to notify of cross-post and follow-up." | |
382 :type 'string | |
383 :group 'message-various) | |
384 | |
385 ;;;###autoload | |
386 (defcustom message-followup-to-note | |
387 "Followup-To: " | |
388 "Note to insert before signature to notify of follow-up only." | |
389 :type 'string | |
390 :group 'message-various) | |
391 | |
392 ;;;###autoload | |
393 (defcustom message-cross-post-note-function | |
394 'message-cross-post-insert-note | |
395 "Function to use to insert note about Crosspost or Followup-To. | |
396 The function will be called with four arguments. The function should not only | |
397 insert a note, but also ensure old notes are deleted. See the documentation | |
398 for `message-cross-post-insert-note'." | |
399 :type 'function | |
400 :group 'message-various) | |
401 | |
402 ;;; End of variables adopted from `message-utils.el'. | |
228 | 403 |
229 ;;;###autoload | 404 ;;;###autoload |
230 (defcustom message-signature-separator "^-- *$" | 405 (defcustom message-signature-separator "^-- *$" |
231 "Regexp matching the signature separator." | 406 "Regexp matching the signature separator." |
232 :type 'regexp | 407 :type 'regexp |
408 :link '(custom-manual "(message)Various Message Variables") | |
233 :group 'message-various) | 409 :group 'message-various) |
234 | 410 |
235 (defcustom message-elide-ellipsis "\n[...]\n\n" | 411 (defcustom message-elide-ellipsis "\n[...]\n\n" |
236 "*The string which is inserted for elided text." | 412 "*The string which is inserted for elided text." |
237 :type 'string | 413 :type 'string |
414 :link '(custom-manual "(message)Various Commands") | |
238 :group 'message-various) | 415 :group 'message-various) |
239 | 416 |
240 (defcustom message-interactive nil | 417 (defcustom message-interactive t |
241 "Non-nil means when sending a message wait for and display errors. | 418 "Non-nil means when sending a message wait for and display errors. |
242 nil means let mailer mail back a message to report errors." | 419 nil means let mailer mail back a message to report errors." |
243 :group 'message-sending | 420 :group 'message-sending |
244 :group 'message-mail | 421 :group 'message-mail |
422 :link '(custom-manual "(message)Sending Variables") | |
245 :type 'boolean) | 423 :type 'boolean) |
246 | 424 |
247 (defcustom message-generate-new-buffers 'unique | 425 (defcustom message-generate-new-buffers 'unique |
248 "*Non-nil means create a new message buffer whenever `message-setup' is called. | 426 "*Non-nil means create a new message buffer whenever `message-setup' is called. |
249 If this is a function, call that function with three parameters: The type, | 427 If this is a function, call that function with three parameters: The type, |
250 the to address and the group name. (Any of these may be nil.) The function | 428 the to address and the group name. (Any of these may be nil.) The function |
251 should return the new buffer name." | 429 should return the new buffer name." |
252 :group 'message-buffers | 430 :group 'message-buffers |
431 :link '(custom-manual "(message)Message Buffers") | |
253 :type '(choice (const :tag "off" nil) | 432 :type '(choice (const :tag "off" nil) |
254 (const :tag "unique" unique) | 433 (const :tag "unique" unique) |
255 (const :tag "unsent" unsent) | 434 (const :tag "unsent" unsent) |
256 (function fun))) | 435 (function fun))) |
257 | 436 |
258 (defcustom message-kill-buffer-on-exit nil | 437 (defcustom message-kill-buffer-on-exit nil |
259 "*Non-nil means that the message buffer will be killed after sending a message." | 438 "*Non-nil means that the message buffer will be killed after sending a message." |
260 :group 'message-buffers | 439 :group 'message-buffers |
440 :link '(custom-manual "(message)Message Buffers") | |
261 :type 'boolean) | 441 :type 'boolean) |
262 | 442 |
263 (eval-when-compile | 443 (eval-when-compile |
264 (defvar gnus-local-organization)) | 444 (defvar gnus-local-organization)) |
265 (defcustom message-user-organization | 445 (defcustom message-user-organization |
276 | 456 |
277 ;;;###autoload | 457 ;;;###autoload |
278 (defcustom message-user-organization-file "/usr/lib/news/organization" | 458 (defcustom message-user-organization-file "/usr/lib/news/organization" |
279 "*Local news organization file." | 459 "*Local news organization file." |
280 :type 'file | 460 :type 'file |
461 :link '(custom-manual "(message)News Headers") | |
281 :group 'message-headers) | 462 :group 'message-headers) |
282 | 463 |
283 (defcustom message-make-forward-subject-function | 464 (defcustom message-make-forward-subject-function |
284 'message-forward-subject-author-subject | 465 #'message-forward-subject-name-subject |
285 "*List of functions called to generate subject headers for forwarded messages. | 466 "*List of functions called to generate subject headers for forwarded messages. |
286 The subject generated by the previous function is passed into each | 467 The subject generated by the previous function is passed into each |
287 successive function. | 468 successive function. |
288 | 469 |
289 The provided functions are: | 470 The provided functions are: |
290 | 471 |
291 * `message-forward-subject-author-subject' (Source of article (author or | 472 * `message-forward-subject-author-subject' Source of article (author or |
292 newsgroup)), in brackets followed by the subject | 473 newsgroup), in brackets followed by the subject |
293 * `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended | 474 * `message-forward-subject-name-subject' Source of article (name of author |
475 or newsgroup), in brackets followed by the subject | |
476 * `message-forward-subject-fwd' Subject of article with 'Fwd:' prepended | |
294 to it." | 477 to it." |
295 :group 'message-forwarding | 478 :group 'message-forwarding |
479 :link '(custom-manual "(message)Forwarding") | |
296 :type '(radio (function-item message-forward-subject-author-subject) | 480 :type '(radio (function-item message-forward-subject-author-subject) |
297 (function-item message-forward-subject-fwd) | 481 (function-item message-forward-subject-fwd) |
482 (function-item message-forward-subject-name-subject) | |
298 (repeat :tag "List of functions" function))) | 483 (repeat :tag "List of functions" function))) |
299 | 484 |
300 (defcustom message-forward-as-mime t | 485 (defcustom message-forward-as-mime t |
301 "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." | 486 "*Non-nil means forward messages as an inline/rfc822 MIME section. |
487 Otherwise, directly inline the old message in the forwarded message." | |
302 :version "21.1" | 488 :version "21.1" |
303 :group 'message-forwarding | 489 :group 'message-forwarding |
490 :link '(custom-manual "(message)Forwarding") | |
304 :type 'boolean) | 491 :type 'boolean) |
305 | 492 |
306 (defcustom message-forward-show-mml t | 493 (defcustom message-forward-show-mml 'best |
307 "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged." | 494 "*Non-nil means show forwarded messages as MML (decoded from MIME). |
495 Otherwise, forwarded messages are unchanged. | |
496 Can also be the symbol `best' to indicate that MML should be | |
497 used, except when it is a bad idea to use MML. One example where | |
498 it is a bad idea is when forwarding a signed or encrypted | |
499 message, because converting MIME to MML would invalidate the | |
500 digital signature." | |
308 :version "21.1" | 501 :version "21.1" |
309 :group 'message-forwarding | 502 :group 'message-forwarding |
310 :type 'boolean) | 503 :type '(choice (const :tag "use MML" t) |
504 (const :tag "don't use MML " nil) | |
505 (const :tag "use MML when appropriate" best))) | |
311 | 506 |
312 (defcustom message-forward-before-signature t | 507 (defcustom message-forward-before-signature t |
313 "*If non-nil, put forwarded message before signature, else after." | 508 "*Non-nil means put forwarded message before signature, else after." |
314 :group 'message-forwarding | 509 :group 'message-forwarding |
315 :type 'boolean) | 510 :type 'boolean) |
316 | 511 |
317 (defcustom message-wash-forwarded-subjects nil | 512 (defcustom message-wash-forwarded-subjects nil |
318 "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward." | 513 "*Non-nil means try to remove as much cruft as possible from the subject. |
514 Done before generating the new subject of a forward." | |
319 :group 'message-forwarding | 515 :group 'message-forwarding |
516 :link '(custom-manual "(message)Forwarding") | |
320 :type 'boolean) | 517 :type 'boolean) |
321 | 518 |
322 (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:" | 519 (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From " |
323 "*All headers that match this regexp will be deleted when resending a message." | 520 "*All headers that match this regexp will be deleted when resending a message." |
324 :group 'message-interface | 521 :group 'message-interface |
522 :link '(custom-manual "(message)Resending") | |
325 :type 'regexp) | 523 :type 'regexp) |
326 | 524 |
327 (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" | 525 (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" |
328 "*All headers that match this regexp will be deleted when forwarding a message." | 526 "*All headers that match this regexp will be deleted when forwarding a message." |
329 :version "21.1" | 527 :version "21.1" |
332 regexp)) | 530 regexp)) |
333 | 531 |
334 (defcustom message-ignored-cited-headers "." | 532 (defcustom message-ignored-cited-headers "." |
335 "*Delete these headers from the messages you yank." | 533 "*Delete these headers from the messages you yank." |
336 :group 'message-insertion | 534 :group 'message-insertion |
535 :link '(custom-manual "(message)Insertion Variables") | |
536 :type 'regexp) | |
537 | |
538 (defcustom message-cite-prefix-regexp | |
539 (if (string-match "[[:digit:]]" "1") ;; support POSIX? | |
540 "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+" | |
541 ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. | |
542 (let ((old-table (syntax-table)) | |
543 non-word-constituents) | |
544 (set-syntax-table text-mode-syntax-table) | |
545 (setq non-word-constituents | |
546 (concat | |
547 (if (string-match "\\w" "-") "" "-") | |
548 (if (string-match "\\w" "_") "" "_") | |
549 (if (string-match "\\w" ".") "" "."))) | |
550 (set-syntax-table old-table) | |
551 (if (equal non-word-constituents "") | |
552 "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+" | |
553 (concat "\\([ \t]*\\(\\w\\|[" | |
554 non-word-constituents | |
555 "]\\)+>+\\|[ \t]*[]>|}+]\\)+")))) | |
556 "*Regexp matching the longest possible citation prefix on a line." | |
557 :group 'message-insertion | |
558 :link '(custom-manual "(message)Insertion Variables") | |
337 :type 'regexp) | 559 :type 'regexp) |
338 | 560 |
339 (defcustom message-cancel-message "I am canceling my own article.\n" | 561 (defcustom message-cancel-message "I am canceling my own article.\n" |
340 "Message to be inserted in the cancel message." | 562 "Message to be inserted in the cancel message." |
341 :group 'message-interface | 563 :group 'message-interface |
564 :link '(custom-manual "(message)Canceling News") | |
342 :type 'string) | 565 :type 'string) |
343 | 566 |
344 ;; Useful to set in site-init.el | 567 ;; Useful to set in site-init.el |
345 ;;;###autoload | 568 ;;;###autoload |
346 (defcustom message-send-mail-function 'message-send-mail-with-sendmail | 569 (defcustom message-send-mail-function 'message-send-mail-with-sendmail |
348 The headers should be delimited by a line whose contents match the | 571 The headers should be delimited by a line whose contents match the |
349 variable `mail-header-separator'. | 572 variable `mail-header-separator'. |
350 | 573 |
351 Valid values include `message-send-mail-with-sendmail' (the default), | 574 Valid values include `message-send-mail-with-sendmail' (the default), |
352 `message-send-mail-with-mh', `message-send-mail-with-qmail', | 575 `message-send-mail-with-mh', `message-send-mail-with-qmail', |
353 `smtpmail-send-it' and `feedmail-send-it'. | 576 `message-smtpmail-send-it', `smtpmail-send-it' and `feedmail-send-it'. |
354 | 577 |
355 See also `send-mail-function'." | 578 See also `send-mail-function'." |
356 :type '(radio (function-item message-send-mail-with-sendmail) | 579 :type '(radio (function-item message-send-mail-with-sendmail) |
357 (function-item message-send-mail-with-mh) | 580 (function-item message-send-mail-with-mh) |
358 (function-item message-send-mail-with-qmail) | 581 (function-item message-send-mail-with-qmail) |
582 (function-item message-smtpmail-send-it) | |
359 (function-item smtpmail-send-it) | 583 (function-item smtpmail-send-it) |
360 (function-item feedmail-send-it) | 584 (function-item feedmail-send-it) |
361 (function :tag "Other")) | 585 (function :tag "Other")) |
362 :group 'message-sending | 586 :group 'message-sending |
587 :link '(custom-manual "(message)Mail Variables") | |
363 :group 'message-mail) | 588 :group 'message-mail) |
364 | 589 |
365 (defcustom message-send-news-function 'message-send-news | 590 (defcustom message-send-news-function 'message-send-news |
366 "Function to call to send the current buffer as news. | 591 "Function to call to send the current buffer as news. |
367 The headers should be delimited by a line whose contents match the | 592 The headers should be delimited by a line whose contents match the |
368 variable `mail-header-separator'." | 593 variable `mail-header-separator'." |
369 :group 'message-sending | 594 :group 'message-sending |
370 :group 'message-news | 595 :group 'message-news |
596 :link '(custom-manual "(message)News Variables") | |
371 :type 'function) | 597 :type 'function) |
372 | 598 |
373 (defcustom message-reply-to-function nil | 599 (defcustom message-reply-to-function nil |
374 "If non-nil, function that should return a list of headers. | 600 "If non-nil, function that should return a list of headers. |
375 This function should pick out addresses from the To, Cc, and From headers | 601 This function should pick out addresses from the To, Cc, and From headers |
376 and respond with new To and Cc headers." | 602 and respond with new To and Cc headers." |
377 :group 'message-interface | 603 :group 'message-interface |
604 :link '(custom-manual "(message)Reply") | |
378 :type '(choice function (const nil))) | 605 :type '(choice function (const nil))) |
379 | 606 |
380 (defcustom message-wide-reply-to-function nil | 607 (defcustom message-wide-reply-to-function nil |
381 "If non-nil, function that should return a list of headers. | 608 "If non-nil, function that should return a list of headers. |
382 This function should pick out addresses from the To, Cc, and From headers | 609 This function should pick out addresses from the To, Cc, and From headers |
383 and respond with new To and Cc headers." | 610 and respond with new To and Cc headers." |
384 :group 'message-interface | 611 :group 'message-interface |
612 :link '(custom-manual "(message)Wide Reply") | |
385 :type '(choice function (const nil))) | 613 :type '(choice function (const nil))) |
386 | 614 |
387 (defcustom message-followup-to-function nil | 615 (defcustom message-followup-to-function nil |
388 "If non-nil, function that should return a list of headers. | 616 "If non-nil, function that should return a list of headers. |
389 This function should pick out addresses from the To, Cc, and From headers | 617 This function should pick out addresses from the To, Cc, and From headers |
390 and respond with new To and Cc headers." | 618 and respond with new To and Cc headers." |
391 :group 'message-interface | 619 :group 'message-interface |
620 :link '(custom-manual "(message)Followup") | |
392 :type '(choice function (const nil))) | 621 :type '(choice function (const nil))) |
393 | 622 |
394 (defcustom message-use-followup-to 'ask | 623 (defcustom message-use-followup-to 'ask |
395 "*Specifies what to do with Followup-To header. | 624 "*Specifies what to do with Followup-To header. |
396 If nil, always ignore the header. If it is t, use its value, but | 625 If nil, always ignore the header. If it is t, use its value, but |
397 query before using the \"poster\" value. If it is the symbol `ask', | 626 query before using the \"poster\" value. If it is the symbol `ask', |
398 always query the user whether to use the value. If it is the symbol | 627 always query the user whether to use the value. If it is the symbol |
399 `use', always use the value." | 628 `use', always use the value." |
400 :group 'message-interface | 629 :group 'message-interface |
630 :link '(custom-manual "(message)Followup") | |
631 :type '(choice (const :tag "ignore" nil) | |
632 (const :tag "use & query" t) | |
633 (const use) | |
634 (const ask))) | |
635 | |
636 (defcustom message-use-mail-followup-to 'use | |
637 "*Specifies what to do with Mail-Followup-To header. | |
638 If nil, always ignore the header. If it is the symbol `ask', always | |
639 query the user whether to use the value. If it is the symbol `use', | |
640 always use the value." | |
641 :group 'message-interface | |
642 :link '(custom-manual "(message)Mailing Lists") | |
401 :type '(choice (const :tag "ignore" nil) | 643 :type '(choice (const :tag "ignore" nil) |
402 (const use) | 644 (const use) |
645 (const ask))) | |
646 | |
647 (defcustom message-subscribed-address-functions nil | |
648 "*Specifies functions for determining list subscription. | |
649 If nil, do not attempt to determine list subscription with functions. | |
650 If non-nil, this variable contains a list of functions which return | |
651 regular expressions to match lists. These functions can be used in | |
652 conjunction with `message-subscribed-regexps' and | |
653 `message-subscribed-addresses'." | |
654 :group 'message-interface | |
655 :link '(custom-manual "(message)Mailing Lists") | |
656 :type '(repeat sexp)) | |
657 | |
658 (defcustom message-subscribed-address-file nil | |
659 "*A file containing addresses the user is subscribed to. | |
660 If nil, do not look at any files to determine list subscriptions. If | |
661 non-nil, each line of this file should be a mailing list address." | |
662 :group 'message-interface | |
663 :link '(custom-manual "(message)Mailing Lists") | |
664 :type '(radio (file :format "%t: %v\n" :size 0) | |
665 (const nil))) | |
666 | |
667 (defcustom message-subscribed-addresses nil | |
668 "*Specifies a list of addresses the user is subscribed to. | |
669 If nil, do not use any predefined list subscriptions. This list of | |
670 addresses can be used in conjunction with | |
671 `message-subscribed-address-functions' and `message-subscribed-regexps'." | |
672 :group 'message-interface | |
673 :link '(custom-manual "(message)Mailing Lists") | |
674 :type '(repeat string)) | |
675 | |
676 (defcustom message-subscribed-regexps nil | |
677 "*Specifies a list of addresses the user is subscribed to. | |
678 If nil, do not use any predefined list subscriptions. This list of | |
679 regular expressions can be used in conjunction with | |
680 `message-subscribed-address-functions' and `message-subscribed-addresses'." | |
681 :group 'message-interface | |
682 :link '(custom-manual "(message)Mailing Lists") | |
683 :type '(repeat regexp)) | |
684 | |
685 (defcustom message-allow-no-recipients 'ask | |
686 "Specifies what to do when there are no recipients other than Gcc/Fcc. | |
687 If it is the symbol `always', the posting is allowed. If it is the | |
688 symbol `never', the posting is not allowed. If it is the symbol | |
689 `ask', you are prompted." | |
690 :group 'message-interface | |
691 :link '(custom-manual "(message)Message Headers") | |
692 :type '(choice (const always) | |
693 (const never) | |
403 (const ask))) | 694 (const ask))) |
404 | 695 |
405 (defcustom message-sendmail-f-is-evil nil | 696 (defcustom message-sendmail-f-is-evil nil |
406 "*Non-nil means don't add \"-f username\" to the sendmail command line. | 697 "*Non-nil means don't add \"-f username\" to the sendmail command line. |
407 Doing so would be even more evil than leaving it out." | 698 Doing so would be even more evil than leaving it out." |
408 :group 'message-sending | 699 :group 'message-sending |
700 :link '(custom-manual "(message)Mail Variables") | |
409 :type 'boolean) | 701 :type 'boolean) |
702 | |
703 (defcustom message-sendmail-envelope-from nil | |
704 "*Envelope-from when sending mail with sendmail. | |
705 If this is nil, use `user-mail-address'. If it is the symbol | |
706 `header', use the From: header of the message." | |
707 :type '(choice (string :tag "From name") | |
708 (const :tag "Use From: header from message" header) | |
709 (const :tag "Use `user-mail-address'" nil)) | |
710 :link '(custom-manual "(message)Mail Variables") | |
711 :group 'message-sending) | |
410 | 712 |
411 ;; qmail-related stuff | 713 ;; qmail-related stuff |
412 (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" | 714 (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" |
413 "Location of the qmail-inject program." | 715 "Location of the qmail-inject program." |
414 :group 'message-sending | 716 :group 'message-sending |
717 :link '(custom-manual "(message)Mail Variables") | |
415 :type 'file) | 718 :type 'file) |
416 | 719 |
417 (defcustom message-qmail-inject-args nil | 720 (defcustom message-qmail-inject-args nil |
418 "Arguments passed to qmail-inject programs. | 721 "Arguments passed to qmail-inject programs. |
419 This should be a list of strings, one string for each argument. | 722 This should be a list of strings, one string for each argument. It |
723 may also be a function. | |
420 | 724 |
421 For e.g., if you wish to set the envelope sender address so that bounces | 725 For e.g., if you wish to set the envelope sender address so that bounces |
422 go to the right place or to deal with listserv's usage of that address, you | 726 go to the right place or to deal with listserv's usage of that address, you |
423 might set this variable to '(\"-f\" \"you@some.where\")." | 727 might set this variable to '(\"-f\" \"you@some.where\")." |
424 :group 'message-sending | 728 :group 'message-sending |
425 :type '(repeat string)) | 729 :link '(custom-manual "(message)Mail Variables") |
730 :type '(choice (function) | |
731 (repeat string))) | |
426 | 732 |
427 (defvar message-cater-to-broken-inn t | 733 (defvar message-cater-to-broken-inn t |
428 "Non-nil means Gnus should not fold the `References' header. | 734 "Non-nil means Gnus should not fold the `References' header. |
429 Folding `References' makes ancient versions of INN create incorrect | 735 Folding `References' makes ancient versions of INN create incorrect |
430 NOV lines.") | 736 NOV lines.") |
447 :group 'message-sending | 753 :group 'message-sending |
448 ;; This should be the `gnus-select-method' widget, but that might | 754 ;; This should be the `gnus-select-method' widget, but that might |
449 ;; create a dependence to `gnus.el'. | 755 ;; create a dependence to `gnus.el'. |
450 :type 'sexp) | 756 :type 'sexp) |
451 | 757 |
452 (defcustom message-generate-headers-first nil | 758 ;; FIXME: This should be a temporary workaround until someone implements a |
453 "*If non-nil, generate all possible headers before composing." | 759 ;; proper solution. If a crash happens while replying, the auto-save file |
760 ;; will *not* have a `References:' header if `message-generate-headers-first' | |
761 ;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138 | |
762 (defcustom message-generate-headers-first '(references) | |
763 "Which headers should be generated before starting to compose a message. | |
764 If `t', generate all required headers. This can also be a list of headers to | |
765 generate. The variables `message-required-news-headers' and | |
766 `message-required-mail-headers' specify which headers to generate. | |
767 | |
768 Note that the variable `message-deletable-headers' specifies headers which | |
769 are to be deleted and then re-generated before sending, so this variable | |
770 will not have a visible effect for those headers." | |
454 :group 'message-headers | 771 :group 'message-headers |
455 :type 'boolean) | 772 :link '(custom-manual "(message)Message Headers") |
773 :type '(choice (const :tag "None" nil) | |
774 (const :tag "References" '(references)) | |
775 (const :tag "All" t) | |
776 (repeat (sexp :tag "Header")))) | |
456 | 777 |
457 (defcustom message-setup-hook nil | 778 (defcustom message-setup-hook nil |
458 "Normal hook, run each time a new outgoing message is initialized. | 779 "Normal hook, run each time a new outgoing message is initialized. |
459 The function `message-setup' runs this hook." | 780 The function `message-setup' runs this hook." |
460 :group 'message-various | 781 :group 'message-various |
782 :link '(custom-manual "(message)Various Message Variables") | |
461 :type 'hook) | 783 :type 'hook) |
462 | 784 |
463 (defcustom message-cancel-hook nil | 785 (defcustom message-cancel-hook nil |
464 "Hook run when cancelling articles." | 786 "Hook run when cancelling articles." |
465 :group 'message-various | 787 :group 'message-various |
788 :link '(custom-manual "(message)Various Message Variables") | |
466 :type 'hook) | 789 :type 'hook) |
467 | 790 |
468 (defcustom message-signature-setup-hook nil | 791 (defcustom message-signature-setup-hook nil |
469 "Normal hook, run each time a new outgoing message is initialized. | 792 "Normal hook, run each time a new outgoing message is initialized. |
470 It is run after the headers have been inserted and before | 793 It is run after the headers have been inserted and before |
471 the signature is inserted." | 794 the signature is inserted." |
472 :group 'message-various | 795 :group 'message-various |
796 :link '(custom-manual "(message)Various Message Variables") | |
473 :type 'hook) | 797 :type 'hook) |
474 | 798 |
475 (defcustom message-mode-hook nil | 799 (defcustom message-mode-hook nil |
476 "Hook run in message mode buffers." | 800 "Hook run in message mode buffers." |
477 :group 'message-various | 801 :group 'message-various |
483 :type 'hook) | 807 :type 'hook) |
484 | 808 |
485 (defcustom message-header-setup-hook nil | 809 (defcustom message-header-setup-hook nil |
486 "Hook called narrowed to the headers when setting up a message buffer." | 810 "Hook called narrowed to the headers when setting up a message buffer." |
487 :group 'message-various | 811 :group 'message-various |
812 :link '(custom-manual "(message)Various Message Variables") | |
488 :type 'hook) | 813 :type 'hook) |
814 | |
815 (defcustom message-minibuffer-local-map | |
816 (let ((map (make-sparse-keymap 'message-minibuffer-local-map))) | |
817 (set-keymap-parent map minibuffer-local-map) | |
818 map) | |
819 "Keymap for `message-read-from-minibuffer'.") | |
489 | 820 |
490 ;;;###autoload | 821 ;;;###autoload |
491 (defcustom message-citation-line-function 'message-insert-citation-line | 822 (defcustom message-citation-line-function 'message-insert-citation-line |
492 "*Function called to insert the \"Whomever writes:\" line." | 823 "*Function called to insert the \"Whomever writes:\" line. |
824 | |
825 Note that Gnus provides a feature where the reader can click on | |
826 `writes:' to hide the cited text. If you change this line too much, | |
827 people who read your message will have to change their Gnus | |
828 configuration. See the variable `gnus-cite-attribution-suffix'." | |
493 :type 'function | 829 :type 'function |
830 :link '(custom-manual "(message)Insertion Variables") | |
494 :group 'message-insertion) | 831 :group 'message-insertion) |
495 | 832 |
496 ;;;###autoload | 833 ;;;###autoload |
497 (defcustom message-yank-prefix "> " | 834 (defcustom message-yank-prefix "> " |
498 "*Prefix inserted on the lines of yanked messages." | 835 "*Prefix inserted on the lines of yanked messages. |
836 Fix `message-cite-prefix-regexp' if it is set to an abnormal value. | |
837 See also `message-yank-cited-prefix'." | |
499 :type 'string | 838 :type 'string |
839 :link '(custom-manual "(message)Insertion Variables") | |
840 :group 'message-insertion) | |
841 | |
842 (defcustom message-yank-cited-prefix ">" | |
843 "*Prefix inserted on cited or empty lines of yanked messages. | |
844 Fix `message-cite-prefix-regexp' if it is set to an abnormal value. | |
845 See also `message-yank-prefix'." | |
846 :type 'string | |
847 :link '(custom-manual "(message)Insertion Variables") | |
500 :group 'message-insertion) | 848 :group 'message-insertion) |
501 | 849 |
502 (defcustom message-indentation-spaces 3 | 850 (defcustom message-indentation-spaces 3 |
503 "*Number of spaces to insert at the beginning of each cited line. | 851 "*Number of spaces to insert at the beginning of each cited line. |
504 Used by `message-yank-original' via `message-yank-cite'." | 852 Used by `message-yank-original' via `message-yank-cite'." |
505 :group 'message-insertion | 853 :group 'message-insertion |
854 :link '(custom-manual "(message)Insertion Variables") | |
506 :type 'integer) | 855 :type 'integer) |
507 | 856 |
508 ;;;###autoload | 857 ;;;###autoload |
509 (defcustom message-cite-function 'message-cite-original | 858 (defcustom message-cite-function 'message-cite-original |
510 "*Function for citing an original message. | 859 "*Function for citing an original message. |
513 Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil." | 862 Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil." |
514 :type '(radio (function-item message-cite-original) | 863 :type '(radio (function-item message-cite-original) |
515 (function-item message-cite-original-without-signature) | 864 (function-item message-cite-original-without-signature) |
516 (function-item sc-cite-original) | 865 (function-item sc-cite-original) |
517 (function :tag "Other")) | 866 (function :tag "Other")) |
867 :link '(custom-manual "(message)Insertion Variables") | |
518 :group 'message-insertion) | 868 :group 'message-insertion) |
519 | 869 |
520 ;;;###autoload | 870 ;;;###autoload |
521 (defcustom message-indent-citation-function 'message-indent-citation | 871 (defcustom message-indent-citation-function 'message-indent-citation |
522 "*Function for modifying a citation just inserted in the mail buffer. | 872 "*Function for modifying a citation just inserted in the mail buffer. |
523 This can also be a list of functions. Each function can find the | 873 This can also be a list of functions. Each function can find the |
524 citation between (point) and (mark t). And each function should leave | 874 citation between (point) and (mark t). And each function should leave |
525 point and mark around the citation text as modified." | 875 point and mark around the citation text as modified." |
526 :type 'function | 876 :type 'function |
877 :link '(custom-manual "(message)Insertion Variables") | |
527 :group 'message-insertion) | 878 :group 'message-insertion) |
528 | |
529 (defvar message-abbrevs-loaded nil) | |
530 | 879 |
531 ;;;###autoload | 880 ;;;###autoload |
532 (defcustom message-signature t | 881 (defcustom message-signature t |
533 "*String to be inserted at the end of the message buffer. | 882 "*String to be inserted at the end of the message buffer. |
534 If t, the `message-signature-file' file will be inserted instead. | 883 If t, the `message-signature-file' file will be inserted instead. |
535 If a function, the result from the function will be used instead. | 884 If a function, the result from the function will be used instead. |
536 If a form, the result from the form will be used instead." | 885 If a form, the result from the form will be used instead." |
537 :type 'sexp | 886 :type 'sexp |
887 :link '(custom-manual "(message)Insertion Variables") | |
538 :group 'message-insertion) | 888 :group 'message-insertion) |
539 | 889 |
540 ;;;###autoload | 890 ;;;###autoload |
541 (defcustom message-signature-file "~/.signature" | 891 (defcustom message-signature-file "~/.signature" |
542 "*Name of file containing the text inserted at end of message buffer. | 892 "*Name of file containing the text inserted at end of message buffer. |
543 Ignored if the named file doesn't exist. | 893 Ignored if the named file doesn't exist. |
544 If nil, don't insert a signature." | 894 If nil, don't insert a signature." |
545 :type '(choice file (const :tags "None" nil)) | 895 :type '(choice file (const :tags "None" nil)) |
896 :link '(custom-manual "(message)Insertion Variables") | |
897 :group 'message-insertion) | |
898 | |
899 ;;;###autoload | |
900 (defcustom message-signature-insert-empty-line t | |
901 "*If non-nil, insert an empty line before the signature separator." | |
902 :type 'boolean | |
903 :link '(custom-manual "(message)Insertion Variables") | |
546 :group 'message-insertion) | 904 :group 'message-insertion) |
547 | 905 |
548 (defcustom message-distribution-function nil | 906 (defcustom message-distribution-function nil |
549 "*Function called to return a Distribution header." | 907 "*Function called to return a Distribution header." |
550 :group 'message-news | 908 :group 'message-news |
551 :group 'message-headers | 909 :group 'message-headers |
910 :link '(custom-manual "(message)News Headers") | |
552 :type '(choice function (const nil))) | 911 :type '(choice function (const nil))) |
553 | 912 |
554 (defcustom message-expires 14 | 913 (defcustom message-expires 14 |
555 "Number of days before your article expires." | 914 "Number of days before your article expires." |
556 :group 'message-news | 915 :group 'message-news |
567 :type '(choice (const :tag "nntp" nil) | 926 :type '(choice (const :tag "nntp" nil) |
568 (string :tag "name") | 927 (string :tag "name") |
569 (sexp :tag "none" :format "%t" t))) | 928 (sexp :tag "none" :format "%t" t))) |
570 | 929 |
571 (defvar message-reply-buffer nil) | 930 (defvar message-reply-buffer nil) |
572 (defvar message-reply-headers nil) | 931 (defvar message-reply-headers nil |
932 "The headers of the current replied article. | |
933 It is a vector of the following headers: | |
934 \[number subject from date id references chars lines xref extra].") | |
573 (defvar message-newsreader nil) | 935 (defvar message-newsreader nil) |
574 (defvar message-mailer nil) | 936 (defvar message-mailer nil) |
575 (defvar message-sent-message-via nil) | 937 (defvar message-sent-message-via nil) |
576 (defvar message-checksum nil) | 938 (defvar message-checksum nil) |
577 (defvar message-send-actions nil | 939 (defvar message-send-actions nil |
592 (defcustom message-default-headers "" | 954 (defcustom message-default-headers "" |
593 "*A string containing header lines to be inserted in outgoing messages. | 955 "*A string containing header lines to be inserted in outgoing messages. |
594 It is inserted before you edit the message, so you can edit or delete | 956 It is inserted before you edit the message, so you can edit or delete |
595 these lines." | 957 these lines." |
596 :group 'message-headers | 958 :group 'message-headers |
959 :link '(custom-manual "(message)Message Headers") | |
597 :type 'message-header-lines) | 960 :type 'message-header-lines) |
598 | 961 |
599 (defcustom message-default-mail-headers "" | 962 (defcustom message-default-mail-headers "" |
600 "*A string of header lines to be inserted in outgoing mails." | 963 "*A string of header lines to be inserted in outgoing mails." |
601 :group 'message-headers | 964 :group 'message-headers |
602 :group 'message-mail | 965 :group 'message-mail |
966 :link '(custom-manual "(message)Mail Headers") | |
603 :type 'message-header-lines) | 967 :type 'message-header-lines) |
604 | 968 |
605 (defcustom message-default-news-headers "" | 969 (defcustom message-default-news-headers "" |
606 "*A string of header lines to be inserted in outgoing news articles." | 970 "*A string of header lines to be inserted in outgoing news articles." |
607 :group 'message-headers | 971 :group 'message-headers |
608 :group 'message-news | 972 :group 'message-news |
973 :link '(custom-manual "(message)News Headers") | |
609 :type 'message-header-lines) | 974 :type 'message-header-lines) |
610 | 975 |
611 ;; Note: could use /usr/ucb/mail instead of sendmail; | 976 ;; Note: could use /usr/ucb/mail instead of sendmail; |
612 ;; options -t, and -v if not interactive. | 977 ;; options -t, and -v if not interactive. |
613 (defcustom message-mailer-swallows-blank-line | 978 (defcustom message-mailer-swallows-blank-line |
631 "*Set this non-nil if the system's mailer runs the header and body together. | 996 "*Set this non-nil if the system's mailer runs the header and body together. |
632 \(This problem exists on Sunos 4 when sendmail is run in remote mode.) | 997 \(This problem exists on Sunos 4 when sendmail is run in remote mode.) |
633 The value should be an expression to test whether the problem will | 998 The value should be an expression to test whether the problem will |
634 actually occur." | 999 actually occur." |
635 :group 'message-sending | 1000 :group 'message-sending |
1001 :link '(custom-manual "(message)Mail Variables") | |
636 :type 'sexp) | 1002 :type 'sexp) |
637 | 1003 |
638 ;;;###autoload | 1004 ;;;###autoload |
639 (define-mail-user-agent 'message-user-agent | 1005 (define-mail-user-agent 'message-user-agent |
640 'message-mail 'message-send-and-exit | 1006 'message-mail 'message-send-and-exit |
669 (defcustom message-auto-save-directory | 1035 (defcustom message-auto-save-directory |
670 (file-name-as-directory (nnheader-concat message-directory "drafts")) | 1036 (file-name-as-directory (nnheader-concat message-directory "drafts")) |
671 "*Directory where Message auto-saves buffers if Gnus isn't running. | 1037 "*Directory where Message auto-saves buffers if Gnus isn't running. |
672 If nil, Message won't auto-save." | 1038 If nil, Message won't auto-save." |
673 :group 'message-buffers | 1039 :group 'message-buffers |
1040 :link '(custom-manual "(message)Various Message Variables") | |
674 :type '(choice directory (const :tag "Don't auto-save" nil))) | 1041 :type '(choice directory (const :tag "Don't auto-save" nil))) |
675 | |
676 (defcustom message-buffer-naming-style 'unique | |
677 "*The way new message buffers are named. | |
678 Valid values are `unique' and `unsent'." | |
679 :version "21.1" | |
680 :group 'message-buffers | |
681 :type '(choice (const :tag "unique" unique) | |
682 (const :tag "unsent" unsent))) | |
683 | 1042 |
684 (defcustom message-default-charset | 1043 (defcustom message-default-charset |
685 (and (not (mm-multibyte-p)) 'iso-8859-1) | 1044 (and (not (mm-multibyte-p)) 'iso-8859-1) |
686 "Default charset used in non-MULE Emacsen. | 1045 "Default charset used in non-MULE Emacsen. |
687 If nil, you might be asked to input the charset." | 1046 If nil, you might be asked to input the charset." |
688 :version "21.1" | 1047 :version "21.1" |
689 :group 'message | 1048 :group 'message |
1049 :link '(custom-manual "(message)Various Message Variables") | |
690 :type 'symbol) | 1050 :type 'symbol) |
691 | 1051 |
692 (defcustom message-dont-reply-to-names | 1052 (defcustom message-dont-reply-to-names |
693 (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) | 1053 (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) |
694 "*A regexp specifying names to prune when doing wide replies. | 1054 "*A regexp specifying addresses to prune when doing wide replies. |
695 A value of nil means exclude your own name only." | 1055 A value of nil means exclude your own user name only." |
696 :version "21.1" | 1056 :version "21.1" |
697 :group 'message | 1057 :group 'message |
1058 :link '(custom-manual "(message)Wide Reply") | |
698 :type '(choice (const :tag "Yourself" nil) | 1059 :type '(choice (const :tag "Yourself" nil) |
699 regexp)) | 1060 regexp)) |
1061 | |
1062 (defvar message-shoot-gnksa-feet nil | |
1063 "*A list of GNKSA feet you are allowed to shoot. | |
1064 Gnus gives you all the opportunity you could possibly want for | |
1065 shooting yourself in the foot. Also, Gnus allows you to shoot the | |
1066 feet of Good Net-Keeping Seal of Approval. The following are foot | |
1067 candidates: | |
1068 `empty-article' Allow you to post an empty article; | |
1069 `quoted-text-only' Allow you to post quoted text only; | |
1070 `multiple-copies' Allow you to post multiple copies; | |
1071 `cancel-messages' Allow you to cancel or supersede messages from | |
1072 your other email addresses.") | |
1073 | |
1074 (defsubst message-gnksa-enable-p (feature) | |
1075 (or (not (listp message-shoot-gnksa-feet)) | |
1076 (memq feature message-shoot-gnksa-feet))) | |
1077 | |
1078 (defcustom message-hidden-headers nil | |
1079 "Regexp of headers to be hidden when composing new messages. | |
1080 This can also be a list of regexps to match headers. Or a list | |
1081 starting with `not' and followed by regexps." | |
1082 :group 'message | |
1083 :link '(custom-manual "(message)Message Headers") | |
1084 :type '(repeat regexp)) | |
700 | 1085 |
701 ;;; Internal variables. | 1086 ;;; Internal variables. |
702 ;;; Well, not really internal. | 1087 ;;; Well, not really internal. |
703 | 1088 |
704 (defvar message-mode-syntax-table | 1089 (defvar message-mode-syntax-table |
707 (modify-syntax-entry ?> ". " table) | 1092 (modify-syntax-entry ?> ". " table) |
708 (modify-syntax-entry ?< ". " table) | 1093 (modify-syntax-entry ?< ". " table) |
709 table) | 1094 table) |
710 "Syntax table used while in Message mode.") | 1095 "Syntax table used while in Message mode.") |
711 | 1096 |
712 (defvar message-mode-abbrev-table text-mode-abbrev-table | |
713 "Abbrev table used in Message mode buffers. | |
714 Defaults to `text-mode-abbrev-table'.") | |
715 | |
716 (defface message-header-to-face | 1097 (defface message-header-to-face |
717 '((((class color) | 1098 '((((class color) |
718 (background dark)) | 1099 (background dark)) |
719 (:foreground "green2" :weight bold)) | 1100 (:foreground "green2" :bold t)) |
720 (((class color) | 1101 (((class color) |
721 (background light)) | 1102 (background light)) |
722 (:foreground "MidnightBlue" :weight bold)) | 1103 (:foreground "MidnightBlue" :bold t)) |
723 (t | 1104 (t |
724 (:weight bold :slant italic))) | 1105 (:bold t :italic t))) |
725 "Face used for displaying From headers." | 1106 "Face used for displaying From headers." |
726 :group 'message-faces) | 1107 :group 'message-faces) |
727 | 1108 |
728 (defface message-header-cc-face | 1109 (defface message-header-cc-face |
729 '((((class color) | 1110 '((((class color) |
730 (background dark)) | 1111 (background dark)) |
731 (:foreground "green4" :weight bold)) | 1112 (:foreground "green4" :bold t)) |
732 (((class color) | 1113 (((class color) |
733 (background light)) | 1114 (background light)) |
734 (:foreground "MidnightBlue")) | 1115 (:foreground "MidnightBlue")) |
735 (t | 1116 (t |
736 (:weight bold))) | 1117 (:bold t))) |
737 "Face used for displaying Cc headers." | 1118 "Face used for displaying Cc headers." |
738 :group 'message-faces) | 1119 :group 'message-faces) |
739 | 1120 |
740 (defface message-header-subject-face | 1121 (defface message-header-subject-face |
741 '((((class color) | 1122 '((((class color) |
742 (background dark)) | 1123 (background dark)) |
743 (:foreground "green3")) | 1124 (:foreground "green3")) |
744 (((class color) | 1125 (((class color) |
745 (background light)) | 1126 (background light)) |
746 (:foreground "navy blue" :weight bold)) | 1127 (:foreground "navy blue" :bold t)) |
747 (t | 1128 (t |
748 (:weight bold))) | 1129 (:bold t))) |
749 "Face used for displaying subject headers." | 1130 "Face used for displaying subject headers." |
750 :group 'message-faces) | 1131 :group 'message-faces) |
751 | 1132 |
752 (defface message-header-newsgroups-face | 1133 (defface message-header-newsgroups-face |
753 '((((class color) | 1134 '((((class color) |
754 (background dark)) | 1135 (background dark)) |
755 (:foreground "yellow" :weight bold :slant italic)) | 1136 (:foreground "yellow" :bold t :italic t)) |
756 (((class color) | 1137 (((class color) |
757 (background light)) | 1138 (background light)) |
758 (:foreground "blue4" :weight bold :slant italic)) | 1139 (:foreground "blue4" :bold t :italic t)) |
759 (t | 1140 (t |
760 (:weight bold :slant italic))) | 1141 (:bold t :italic t))) |
761 "Face used for displaying newsgroups headers." | 1142 "Face used for displaying newsgroups headers." |
762 :group 'message-faces) | 1143 :group 'message-faces) |
763 | 1144 |
764 (defface message-header-other-face | 1145 (defface message-header-other-face |
765 '((((class color) | 1146 '((((class color) |
767 (:foreground "#b00000")) | 1148 (:foreground "#b00000")) |
768 (((class color) | 1149 (((class color) |
769 (background light)) | 1150 (background light)) |
770 (:foreground "steel blue")) | 1151 (:foreground "steel blue")) |
771 (t | 1152 (t |
772 (:weight bold :slant italic))) | 1153 (:bold t :italic t))) |
773 "Face used for displaying newsgroups headers." | 1154 "Face used for displaying newsgroups headers." |
774 :group 'message-faces) | 1155 :group 'message-faces) |
775 | 1156 |
776 (defface message-header-name-face | 1157 (defface message-header-name-face |
777 '((((class color) | 1158 '((((class color) |
779 (:foreground "DarkGreen")) | 1160 (:foreground "DarkGreen")) |
780 (((class color) | 1161 (((class color) |
781 (background light)) | 1162 (background light)) |
782 (:foreground "cornflower blue")) | 1163 (:foreground "cornflower blue")) |
783 (t | 1164 (t |
784 (:weight bold))) | 1165 (:bold t))) |
785 "Face used for displaying header names." | 1166 "Face used for displaying header names." |
786 :group 'message-faces) | 1167 :group 'message-faces) |
787 | 1168 |
788 (defface message-header-xheader-face | 1169 (defface message-header-xheader-face |
789 '((((class color) | 1170 '((((class color) |
791 (:foreground "blue")) | 1172 (:foreground "blue")) |
792 (((class color) | 1173 (((class color) |
793 (background light)) | 1174 (background light)) |
794 (:foreground "blue")) | 1175 (:foreground "blue")) |
795 (t | 1176 (t |
796 (:weight bold))) | 1177 (:bold t))) |
797 "Face used for displaying X-Header headers." | 1178 "Face used for displaying X-Header headers." |
798 :group 'message-faces) | 1179 :group 'message-faces) |
799 | 1180 |
800 (defface message-separator-face | 1181 (defface message-separator-face |
801 '((((class color) | 1182 '((((class color) |
803 (:foreground "blue3")) | 1184 (:foreground "blue3")) |
804 (((class color) | 1185 (((class color) |
805 (background light)) | 1186 (background light)) |
806 (:foreground "brown")) | 1187 (:foreground "brown")) |
807 (t | 1188 (t |
808 (:weight bold))) | 1189 (:bold t))) |
809 "Face used for displaying the separator." | 1190 "Face used for displaying the separator." |
810 :group 'message-faces) | 1191 :group 'message-faces) |
811 | 1192 |
812 (defface message-cited-text-face | 1193 (defface message-cited-text-face |
813 '((((class color) | 1194 '((((class color) |
815 (:foreground "red")) | 1196 (:foreground "red")) |
816 (((class color) | 1197 (((class color) |
817 (background light)) | 1198 (background light)) |
818 (:foreground "red")) | 1199 (:foreground "red")) |
819 (t | 1200 (t |
820 (:weight bold))) | 1201 (:bold t))) |
821 "Face used for displaying cited text names." | 1202 "Face used for displaying cited text names." |
822 :group 'message-faces) | 1203 :group 'message-faces) |
823 | 1204 |
824 (defface message-mml-face | 1205 (defface message-mml-face |
825 '((((class color) | 1206 '((((class color) |
827 (:foreground "ForestGreen")) | 1208 (:foreground "ForestGreen")) |
828 (((class color) | 1209 (((class color) |
829 (background light)) | 1210 (background light)) |
830 (:foreground "ForestGreen")) | 1211 (:foreground "ForestGreen")) |
831 (t | 1212 (t |
832 (:weight bold))) | 1213 (:bold t))) |
833 "Face used for displaying MML." | 1214 "Face used for displaying MML." |
834 :group 'message-faces) | 1215 :group 'message-faces) |
835 | 1216 |
1217 (defun message-font-lock-make-header-matcher (regexp) | |
1218 (let ((form | |
1219 `(lambda (limit) | |
1220 (let ((start (point))) | |
1221 (save-restriction | |
1222 (widen) | |
1223 (goto-char (point-min)) | |
1224 (if (re-search-forward | |
1225 (concat "^" (regexp-quote mail-header-separator) "$") | |
1226 nil t) | |
1227 (setq limit (min limit (match-beginning 0)))) | |
1228 (goto-char start)) | |
1229 (and (< start limit) | |
1230 (re-search-forward ,regexp limit t)))))) | |
1231 (if (featurep 'bytecomp) | |
1232 (byte-compile form) | |
1233 form))) | |
1234 | |
836 (defvar message-font-lock-keywords | 1235 (defvar message-font-lock-keywords |
837 (let* ((cite-prefix "[:alpha:]") | 1236 (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) |
838 (cite-suffix (concat cite-prefix "0-9_.@-")) | 1237 `((,(message-font-lock-make-header-matcher |
839 (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) | 1238 (concat "^\\([Tt]o:\\)" content)) |
840 `((,(concat "^\\([Tt]o:\\)" content) | |
841 (1 'message-header-name-face) | 1239 (1 'message-header-name-face) |
842 (2 'message-header-to-face nil t)) | 1240 (2 'message-header-to-face nil t)) |
843 (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) | 1241 (,(message-font-lock-make-header-matcher |
1242 (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)) | |
844 (1 'message-header-name-face) | 1243 (1 'message-header-name-face) |
845 (2 'message-header-cc-face nil t)) | 1244 (2 'message-header-cc-face nil t)) |
846 (,(concat "^\\([Ss]ubject:\\)" content) | 1245 (,(message-font-lock-make-header-matcher |
1246 (concat "^\\([Ss]ubject:\\)" content)) | |
847 (1 'message-header-name-face) | 1247 (1 'message-header-name-face) |
848 (2 'message-header-subject-face nil t)) | 1248 (2 'message-header-subject-face nil t)) |
849 (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content) | 1249 (,(message-font-lock-make-header-matcher |
1250 (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)) | |
850 (1 'message-header-name-face) | 1251 (1 'message-header-name-face) |
851 (2 'message-header-newsgroups-face nil t)) | 1252 (2 'message-header-newsgroups-face nil t)) |
852 (,(concat "^\\([A-Z][^: \n\t]+:\\)" content) | 1253 (,(message-font-lock-make-header-matcher |
1254 (concat "^\\([A-Z][^: \n\t]+:\\)" content)) | |
853 (1 'message-header-name-face) | 1255 (1 'message-header-name-face) |
854 (2 'message-header-other-face nil t)) | 1256 (2 'message-header-other-face nil t)) |
855 (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content) | 1257 (,(message-font-lock-make-header-matcher |
1258 (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) | |
856 (1 'message-header-name-face) | 1259 (1 'message-header-name-face) |
857 (2 'message-header-name-face)) | 1260 (2 'message-header-name-face)) |
858 ,@(if (and mail-header-separator | 1261 ,@(if (and mail-header-separator |
859 (not (equal mail-header-separator ""))) | 1262 (not (equal mail-header-separator ""))) |
860 `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") | 1263 `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") |
861 1 'message-separator-face)) | 1264 1 'message-separator-face)) |
862 nil) | 1265 nil) |
863 (,(concat "^[ \t]*" | 1266 ((lambda (limit) |
864 "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" | 1267 (re-search-forward (concat "^\\(" |
865 "[:>|}].*") | 1268 message-cite-prefix-regexp |
1269 "\\).*") | |
1270 limit t)) | |
866 (0 'message-cited-text-face)) | 1271 (0 'message-cited-text-face)) |
867 ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>" | 1272 ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>" |
868 (0 'message-mml-face)))) | 1273 (0 'message-mml-face)))) |
869 "Additional expressions to highlight in Message mode.") | 1274 "Additional expressions to highlight in Message mode.") |
1275 | |
870 | 1276 |
871 ;; XEmacs does it like this. For Emacs, we have to set the | 1277 ;; XEmacs does it like this. For Emacs, we have to set the |
872 ;; `font-lock-defaults' buffer-local variable. | 1278 ;; `font-lock-defaults' buffer-local variable. |
873 (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) | 1279 (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) |
874 | 1280 |
880 (ununderline-region b e)))) | 1286 (ununderline-region b e)))) |
881 "Alist of mail and news faces for facemenu. | 1287 "Alist of mail and news faces for facemenu. |
882 The cdr of each entry is a function for applying the face to a region.") | 1288 The cdr of each entry is a function for applying the face to a region.") |
883 | 1289 |
884 (defcustom message-send-hook nil | 1290 (defcustom message-send-hook nil |
885 "Hook run before sending messages." | 1291 "Hook run before sending messages. |
1292 This hook is run quite early when sending." | |
886 :group 'message-various | 1293 :group 'message-various |
887 :options '(ispell-message) | 1294 :options '(ispell-message) |
1295 :link '(custom-manual "(message)Various Message Variables") | |
888 :type 'hook) | 1296 :type 'hook) |
889 | 1297 |
890 (defcustom message-send-mail-hook nil | 1298 (defcustom message-send-mail-hook nil |
891 "Hook run before sending mail messages." | 1299 "Hook run before sending mail messages. |
1300 This hook is run very late -- just before the message is sent as | |
1301 mail." | |
892 :group 'message-various | 1302 :group 'message-various |
1303 :link '(custom-manual "(message)Various Message Variables") | |
893 :type 'hook) | 1304 :type 'hook) |
894 | 1305 |
895 (defcustom message-send-news-hook nil | 1306 (defcustom message-send-news-hook nil |
896 "Hook run before sending news messages." | 1307 "Hook run before sending news messages. |
1308 This hook is run very late -- just before the message is sent as | |
1309 news." | |
897 :group 'message-various | 1310 :group 'message-various |
1311 :link '(custom-manual "(message)Various Message Variables") | |
898 :type 'hook) | 1312 :type 'hook) |
899 | 1313 |
900 (defcustom message-sent-hook nil | 1314 (defcustom message-sent-hook nil |
901 "Hook run after sending messages." | 1315 "Hook run after sending messages." |
902 :group 'message-various | 1316 :group 'message-various |
905 (defvar message-send-coding-system 'binary | 1319 (defvar message-send-coding-system 'binary |
906 "Coding system to encode outgoing mail.") | 1320 "Coding system to encode outgoing mail.") |
907 | 1321 |
908 (defvar message-draft-coding-system | 1322 (defvar message-draft-coding-system |
909 mm-auto-save-coding-system | 1323 mm-auto-save-coding-system |
910 "Coding system to compose mail.") | 1324 "*Coding system to compose mail. |
1325 If you'd like to make it possible to share draft files between XEmacs | |
1326 and Emacs, you may use `iso-2022-7bit' for this value at your own risk. | |
1327 Note that the coding-system `iso-2022-7bit' isn't suitable to all data.") | |
911 | 1328 |
912 (defcustom message-send-mail-partially-limit 1000000 | 1329 (defcustom message-send-mail-partially-limit 1000000 |
913 "The limitation of messages sent as message/partial. | 1330 "The limitation of messages sent as message/partial. |
914 The lower bound of message size in characters, beyond which the message | 1331 The lower bound of message size in characters, beyond which the message |
915 should be sent in several parts. If it is nil, the size is unlimited." | 1332 should be sent in several parts. If it is nil, the size is unlimited." |
916 :version "21.1" | 1333 :version "21.1" |
917 :group 'message-buffers | 1334 :group 'message-buffers |
1335 :link '(custom-manual "(message)Mail Variables") | |
918 :type '(choice (const :tag "unlimited" nil) | 1336 :type '(choice (const :tag "unlimited" nil) |
919 (integer 1000000))) | 1337 (integer 1000000))) |
920 | 1338 |
921 (defcustom message-alternative-emails nil | 1339 (defcustom message-alternative-emails nil |
922 "A regexp to match the alternative email addresses. | 1340 "A regexp to match the alternative email addresses. |
923 The first matched address (not primary one) is used in the From field." | 1341 The first matched address (not primary one) is used in the From field." |
924 :group 'message-headers | 1342 :group 'message-headers |
1343 :link '(custom-manual "(message)Message Headers") | |
925 :type '(choice (const :tag "Always use primary" nil) | 1344 :type '(choice (const :tag "Always use primary" nil) |
926 regexp)) | 1345 regexp)) |
1346 | |
1347 (defcustom message-hierarchical-addresses nil | |
1348 "A list of hierarchical mail address definitions. | |
1349 | |
1350 Inside each entry, the first address is the \"top\" address, and | |
1351 subsequent addresses are subaddresses; this is used to indicate that | |
1352 mail sent to the first address will automatically be delivered to the | |
1353 subaddresses. So if the first address appears in the recipient list | |
1354 for a message, the subaddresses will be removed (if present) before | |
1355 the mail is sent. All addresses in this structure should be | |
1356 downcased." | |
1357 :group 'message-headers | |
1358 :type '(repeat (repeat string))) | |
927 | 1359 |
928 (defcustom message-mail-user-agent nil | 1360 (defcustom message-mail-user-agent nil |
929 "Like `mail-user-agent'. | 1361 "Like `mail-user-agent'. |
930 Except if it is nil, use Gnus native MUA; if it is t, use | 1362 Except if it is nil, use Gnus native MUA; if it is t, use |
931 `mail-user-agent'." | 1363 `mail-user-agent'." |
943 mh-e-user-agent) | 1375 mh-e-user-agent) |
944 (function :tag "Other")) | 1376 (function :tag "Other")) |
945 :version "21.1" | 1377 :version "21.1" |
946 :group 'message) | 1378 :group 'message) |
947 | 1379 |
1380 (defcustom message-wide-reply-confirm-recipients nil | |
1381 "Whether to confirm a wide reply to multiple email recipients. | |
1382 If this variable is nil, don't ask whether to reply to all recipients. | |
1383 If this variable is non-nil, pose the question \"Reply to all | |
1384 recipients?\" before a wide reply to multiple recipients. If the user | |
1385 answers yes, reply to all recipients as usual. If the user answers | |
1386 no, only reply back to the author." | |
1387 :version "21.3" | |
1388 :group 'message-headers | |
1389 :link '(custom-manual "(message)Wide Reply") | |
1390 :type 'boolean) | |
1391 | |
1392 (defcustom message-user-fqdn nil | |
1393 "*Domain part of Messsage-Ids." | |
1394 :group 'message-headers | |
1395 :link '(custom-manual "(message)News Headers") | |
1396 :type '(radio (const :format "%v " nil) | |
1397 (string :format "FQDN: %v\n" :size 0))) | |
1398 | |
1399 (defcustom message-use-idna (and (condition-case nil (require 'idna) | |
1400 (file-error)) | |
1401 (mm-coding-system-p 'utf-8) | |
1402 (executable-find idna-program) | |
1403 'ask) | |
1404 "Whether to encode non-ASCII in domain names into ASCII according to IDNA." | |
1405 :group 'message-headers | |
1406 :link '(custom-manual "(message)IDNA") | |
1407 :type '(choice (const :tag "Ask" ask) | |
1408 (const :tag "Never" nil) | |
1409 (const :tag "Always" t))) | |
1410 | |
948 ;;; Internal variables. | 1411 ;;; Internal variables. |
949 | 1412 |
950 (defvar message-sending-message "Sending...") | 1413 (defvar message-sending-message "Sending...") |
951 (defvar message-buffer-list nil) | 1414 (defvar message-buffer-list nil) |
952 (defvar message-this-is-news nil) | 1415 (defvar message-this-is-news nil) |
953 (defvar message-this-is-mail nil) | 1416 (defvar message-this-is-mail nil) |
954 (defvar message-draft-article nil) | 1417 (defvar message-draft-article nil) |
955 (defvar message-mime-part nil) | 1418 (defvar message-mime-part nil) |
956 (defvar message-posting-charset nil) | 1419 (defvar message-posting-charset nil) |
1420 (defvar message-inserted-headers nil) | |
957 | 1421 |
958 ;; Byte-compiler warning | 1422 ;; Byte-compiler warning |
959 (eval-when-compile | 1423 (eval-when-compile |
960 (defvar gnus-active-hashtb) | 1424 (defvar gnus-active-hashtb) |
961 (defvar gnus-read-active-file)) | 1425 (defvar gnus-read-active-file)) |
977 ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g. | 1441 ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g. |
978 ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF | 1442 ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF |
979 ;; can be removed, e.g. | 1443 ;; can be removed, e.g. |
980 ;; From: joe@y.z (Joe K | 1444 ;; From: joe@y.z (Joe K |
981 ;; User) | 1445 ;; User) |
982 ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and | 1446 ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and |
983 ;; From: Joe User | 1447 ;; From: Joe User |
984 ;; <joe@y.z> | 1448 ;; <joe@y.z> |
985 ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'. | 1449 ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'. |
986 ;; The mailbox can be removed or be replaced by white space, e.g. | 1450 ;; The mailbox can be removed or be replaced by white space, e.g. |
987 ;; From: "Joe User"{space}{tab} | 1451 ;; From: "Joe User"{space}{tab} |
989 ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996', | 1453 ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996', |
990 ;; where {space} and {tab} represent the Ascii space and tab characters. | 1454 ;; where {space} and {tab} represent the Ascii space and tab characters. |
991 ;; We want to match the results of any of these manglings. | 1455 ;; We want to match the results of any of these manglings. |
992 ;; The following regexp rejects names whose first characters are | 1456 ;; The following regexp rejects names whose first characters are |
993 ;; obviously bogus, but after that anything goes. | 1457 ;; obviously bogus, but after that anything goes. |
994 "\\([^\0-\b\n-\r\^?].*\\)? " | 1458 "\\([^\0-\b\n-\r\^?].*\\)?" |
995 | 1459 |
996 ;; The time the message was sent. | 1460 ;; The time the message was sent. |
997 "\\([^\0-\r \^?]+\\) +" ; day of the week | 1461 "\\([^\0-\r \^?]+\\) +" ; day of the week |
998 "\\([^\0-\r \^?]+\\) +" ; month | 1462 "\\([^\0-\r \^?]+\\) +" ; month |
999 "\\([0-3]?[0-9]\\) +" ; day of month | 1463 "\\([0-3]?[0-9]\\) +" ; day of month |
1042 (Message-ID) | 1506 (Message-ID) |
1043 (References . message-shorten-references) | 1507 (References . message-shorten-references) |
1044 (User-Agent)) | 1508 (User-Agent)) |
1045 "Alist used for formatting headers.") | 1509 "Alist used for formatting headers.") |
1046 | 1510 |
1511 (defvar message-options nil | |
1512 "Some saved answers when sending message.") | |
1513 | |
1514 (defvar message-send-mail-real-function nil | |
1515 "Internal send mail function.") | |
1516 | |
1517 (defvar message-bogus-system-names "^localhost\\." | |
1518 "The regexp of bogus system names.") | |
1519 | |
1520 (defcustom message-valid-fqdn-regexp | |
1521 (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain. | |
1522 ;; valid TLDs: | |
1523 "\\([a-z][a-z]" ;; two letter country TDLs | |
1524 "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org" | |
1525 "\\|aero\\|coop\\|info\\|name\\|museum" | |
1526 "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style? | |
1527 "\\)") | |
1528 "Regular expression that matches a valid FQDN." | |
1529 ;; see also: gnus-button-valid-fqdn-regexp | |
1530 :group 'message-headers | |
1531 :type 'regexp) | |
1532 | |
1047 (eval-and-compile | 1533 (eval-and-compile |
1534 (autoload 'idna-to-ascii "idna") | |
1048 (autoload 'message-setup-toolbar "messagexmas") | 1535 (autoload 'message-setup-toolbar "messagexmas") |
1049 (autoload 'mh-new-draft-name "mh-comp") | 1536 (autoload 'mh-new-draft-name "mh-comp") |
1050 (autoload 'mh-send-letter "mh-comp") | 1537 (autoload 'mh-send-letter "mh-comp") |
1051 (autoload 'gnus-point-at-eol "gnus-util") | 1538 (autoload 'gnus-point-at-eol "gnus-util") |
1052 (autoload 'gnus-point-at-bol "gnus-util") | 1539 (autoload 'gnus-point-at-bol "gnus-util") |
1053 (autoload 'gnus-output-to-rmail "gnus-util") | 1540 (autoload 'gnus-output-to-rmail "gnus-util") |
1054 (autoload 'gnus-output-to-mail "gnus-util") | 1541 (autoload 'gnus-output-to-mail "gnus-util") |
1055 (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") | |
1056 (autoload 'nndraft-request-associate-buffer "nndraft") | 1542 (autoload 'nndraft-request-associate-buffer "nndraft") |
1057 (autoload 'nndraft-request-expire-articles "nndraft") | 1543 (autoload 'nndraft-request-expire-articles "nndraft") |
1058 (autoload 'gnus-open-server "gnus-int") | 1544 (autoload 'gnus-open-server "gnus-int") |
1059 (autoload 'gnus-request-post "gnus-int") | 1545 (autoload 'gnus-request-post "gnus-int") |
1060 (autoload 'gnus-alive-p "gnus-util") | 1546 (autoload 'gnus-alive-p "gnus-util") |
1547 (autoload 'gnus-server-string "gnus") | |
1061 (autoload 'gnus-group-name-charset "gnus-group") | 1548 (autoload 'gnus-group-name-charset "gnus-group") |
1062 (autoload 'rmail-output "rmailout")) | 1549 (autoload 'gnus-group-name-decode "gnus-group") |
1550 (autoload 'gnus-groups-from-server "gnus") | |
1551 (autoload 'rmail-output "rmailout") | |
1552 (autoload 'gnus-delay-article "gnus-delay") | |
1553 (autoload 'gnus-make-local-hook "gnus-util") | |
1554 (autoload 'gnus-extract-address-components "gnus-util")) | |
1063 | 1555 |
1064 | 1556 |
1065 | 1557 |
1066 ;;; | 1558 ;;; |
1067 ;;; Utility functions. | 1559 ;;; Utility functions. |
1074 (defmacro message-delete-line (&optional n) | 1566 (defmacro message-delete-line (&optional n) |
1075 "Delete the current line (and the next N lines)." | 1567 "Delete the current line (and the next N lines)." |
1076 `(delete-region (progn (beginning-of-line) (point)) | 1568 `(delete-region (progn (beginning-of-line) (point)) |
1077 (progn (forward-line ,(or n 1)) (point)))) | 1569 (progn (forward-line ,(or n 1)) (point)))) |
1078 | 1570 |
1571 (defun message-mark-active-p () | |
1572 "Non-nil means the mark and region are currently active in this buffer." | |
1573 mark-active) | |
1574 | |
1079 (defun message-unquote-tokens (elems) | 1575 (defun message-unquote-tokens (elems) |
1080 "Remove double quotes (\") from strings in list ELEMS." | 1576 "Remove double quotes (\") from strings in list ELEMS." |
1081 (mapcar (lambda (item) | 1577 (mapcar (lambda (item) |
1082 (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) | 1578 (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) |
1083 (setq item (concat (match-string 1 item) | 1579 (setq item (concat (match-string 1 item) |
1084 (match-string 2 item)))) | 1580 (match-string 2 item)))) |
1085 item) | 1581 item) |
1086 elems)) | 1582 elems)) |
1087 | 1583 |
1088 (defun message-tokenize-header (header &optional separator) | 1584 (defun message-tokenize-header (header &optional separator) |
1089 "Split HEADER into a list of header elements. | 1585 "Split HEADER into a list of header elements. |
1090 SEPARATOR is a string of characters to be used as separators. \",\" | 1586 SEPARATOR is a string of characters to be used as separators. \",\" |
1091 is used by default." | 1587 is used by default." |
1093 nil | 1589 nil |
1094 (let ((regexp (format "[%s]+" (or separator ","))) | 1590 (let ((regexp (format "[%s]+" (or separator ","))) |
1095 (beg 1) | 1591 (beg 1) |
1096 (first t) | 1592 (first t) |
1097 quoted elems paren) | 1593 quoted elems paren) |
1098 (save-excursion | 1594 (with-temp-buffer |
1099 (message-set-work-buffer) | 1595 (mm-enable-multibyte) |
1100 (insert header) | 1596 (insert header) |
1101 (goto-char (point-min)) | 1597 (goto-char (point-min)) |
1102 (while (not (eobp)) | 1598 (while (not (eobp)) |
1103 (if first | 1599 (if first |
1104 (setq first nil) | 1600 (setq first nil) |
1116 (not quoted)) | 1612 (not quoted)) |
1117 (setq paren t)) | 1613 (setq paren t)) |
1118 ((and (eq (char-after) ?\)) | 1614 ((and (eq (char-after) ?\)) |
1119 (not quoted)) | 1615 (not quoted)) |
1120 (setq paren nil)))) | 1616 (setq paren nil)))) |
1121 (nreverse elems))))) | 1617 (nreverse elems))))) |
1122 | 1618 |
1123 (defun message-mail-file-mbox-p (file) | 1619 (defun message-mail-file-mbox-p (file) |
1124 "Say whether FILE looks like a Unix mbox file." | 1620 "Say whether FILE looks like a Unix mbox file." |
1125 (when (and (file-exists-p file) | 1621 (when (and (file-exists-p file) |
1126 (file-readable-p file) | 1622 (file-readable-p file) |
1129 (nnheader-insert-file-contents file) | 1625 (nnheader-insert-file-contents file) |
1130 (goto-char (point-min)) | 1626 (goto-char (point-min)) |
1131 (looking-at message-unix-mail-delimiter)))) | 1627 (looking-at message-unix-mail-delimiter)))) |
1132 | 1628 |
1133 (defun message-fetch-field (header &optional not-all) | 1629 (defun message-fetch-field (header &optional not-all) |
1134 "The same as `mail-fetch-field', only remove all newlines." | 1630 "The same as `mail-fetch-field', only remove all newlines. |
1631 The buffer is expected to be narrowed to just the header of the message; | |
1632 see `message-narrow-to-headers-or-head'." | |
1135 (let* ((inhibit-point-motion-hooks t) | 1633 (let* ((inhibit-point-motion-hooks t) |
1136 (case-fold-search t) | 1634 (case-fold-search t) |
1137 (value (mail-fetch-field header nil (not not-all)))) | 1635 (value (mail-fetch-field header nil (not not-all)))) |
1138 (when value | 1636 (when value |
1139 (while (string-match "\n[\t ]+" value) | 1637 (while (string-match "\n[\t ]+" value) |
1140 (setq value (replace-match " " t t value))) | 1638 (setq value (replace-match " " t t value))) |
1141 (set-text-properties 0 (length value) nil value) | 1639 (set-text-properties 0 (length value) nil value) |
1142 value))) | 1640 value))) |
1641 | |
1642 (defun message-field-value (header &optional not-all) | |
1643 "The same as `message-fetch-field', only narrow to the headers first." | |
1644 (save-excursion | |
1645 (save-restriction | |
1646 (message-narrow-to-headers-or-head) | |
1647 (message-fetch-field header not-all)))) | |
1143 | 1648 |
1144 (defun message-narrow-to-field () | 1649 (defun message-narrow-to-field () |
1145 "Narrow the buffer to the header on the current line." | 1650 "Narrow the buffer to the header on the current line." |
1146 (beginning-of-line) | 1651 (beginning-of-line) |
1147 (narrow-to-region | 1652 (narrow-to-region |
1163 (error "Invalid header `%s'" (car headers))) | 1668 (error "Invalid header `%s'" (car headers))) |
1164 (setq hclean (match-string 1 (car headers))) | 1669 (setq hclean (match-string 1 (car headers))) |
1165 (save-restriction | 1670 (save-restriction |
1166 (message-narrow-to-headers) | 1671 (message-narrow-to-headers) |
1167 (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) | 1672 (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) |
1168 (insert (car headers) ?\n)))) | 1673 (goto-char (point-max)) |
1674 (if (string-match "\n$" (car headers)) | |
1675 (insert (car headers)) | |
1676 (insert (car headers) ?\n))))) | |
1169 (setq headers (cdr headers)))) | 1677 (setq headers (cdr headers)))) |
1170 | 1678 |
1679 (defmacro message-with-reply-buffer (&rest forms) | |
1680 "Evaluate FORMS in the reply buffer, if it exists." | |
1681 `(when (and message-reply-buffer | |
1682 (buffer-name message-reply-buffer)) | |
1683 (save-excursion | |
1684 (set-buffer message-reply-buffer) | |
1685 ,@forms))) | |
1686 | |
1687 (put 'message-with-reply-buffer 'lisp-indent-function 0) | |
1688 (put 'message-with-reply-buffer 'edebug-form-spec '(body)) | |
1171 | 1689 |
1172 (defun message-fetch-reply-field (header) | 1690 (defun message-fetch-reply-field (header) |
1173 "Fetch field HEADER from the message we're replying to." | 1691 "Fetch field HEADER from the message we're replying to." |
1174 (when (and message-reply-buffer | 1692 (message-with-reply-buffer |
1175 (buffer-name message-reply-buffer)) | 1693 (save-restriction |
1176 (save-excursion | 1694 (mail-narrow-to-head) |
1177 (set-buffer message-reply-buffer) | |
1178 (message-fetch-field header)))) | 1695 (message-fetch-field header)))) |
1179 | |
1180 (defun message-set-work-buffer () | |
1181 (if (get-buffer " *message work*") | |
1182 (progn | |
1183 (set-buffer " *message work*") | |
1184 (erase-buffer)) | |
1185 (set-buffer (get-buffer-create " *message work*")) | |
1186 (kill-all-local-variables) | |
1187 (mm-enable-multibyte))) | |
1188 | |
1189 (defun message-functionp (form) | |
1190 "Return non-nil if FORM is funcallable." | |
1191 (or (and (symbolp form) (fboundp form)) | |
1192 (and (listp form) (eq (car form) 'lambda)) | |
1193 (byte-code-function-p form))) | |
1194 | 1696 |
1195 (defun message-strip-list-identifiers (subject) | 1697 (defun message-strip-list-identifiers (subject) |
1196 "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT." | 1698 "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT." |
1197 (require 'gnus-sum) ; for gnus-list-identifiers | 1699 (require 'gnus-sum) ; for gnus-list-identifiers |
1198 (let ((regexp (if (stringp gnus-list-identifiers) | 1700 (let ((regexp (if (stringp gnus-list-identifiers) |
1199 gnus-list-identifiers | 1701 gnus-list-identifiers |
1200 (mapconcat 'identity gnus-list-identifiers " *\\|")))) | 1702 (mapconcat 'identity gnus-list-identifiers " *\\|")))) |
1201 (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp | 1703 (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp |
1202 " *\\)\\)+\\(Re: +\\)?\\)") subject) | 1704 " *\\)\\)+\\(Re: +\\)?\\)") subject) |
1203 (concat (substring subject 0 (match-beginning 1)) | 1705 (concat (substring subject 0 (match-beginning 1)) |
1204 (or (match-string 3 subject) | 1706 (or (match-string 3 subject) |
1205 (match-string 5 subject)) | 1707 (match-string 5 subject)) |
1206 (substring subject | 1708 (substring subject |
1207 (match-end 1))) | 1709 (match-end 1))) |
1210 (defun message-strip-subject-re (subject) | 1712 (defun message-strip-subject-re (subject) |
1211 "Remove \"Re:\" from subject lines in string SUBJECT." | 1713 "Remove \"Re:\" from subject lines in string SUBJECT." |
1212 (if (string-match message-subject-re-regexp subject) | 1714 (if (string-match message-subject-re-regexp subject) |
1213 (substring subject (match-end 0)) | 1715 (substring subject (match-end 0)) |
1214 subject)) | 1716 subject)) |
1717 | |
1718 ;;; Start of functions adopted from `message-utils.el'. | |
1719 | |
1720 (defun message-strip-subject-trailing-was (subject) | |
1721 "Remove trailing \"(Was: <old subject>)\" from SUBJECT lines. | |
1722 Leading \"Re: \" is not stripped by this function. Use the function | |
1723 `message-strip-subject-re' for this." | |
1724 (let* ((query message-subject-trailing-was-query) | |
1725 (new) (found)) | |
1726 (setq found | |
1727 (string-match | |
1728 (if (eq query 'ask) | |
1729 message-subject-trailing-was-ask-regexp | |
1730 message-subject-trailing-was-regexp) | |
1731 subject)) | |
1732 (if found | |
1733 (setq new (substring subject 0 (match-beginning 0)))) | |
1734 (if (or (not found) (eq query nil)) | |
1735 subject | |
1736 (if (eq query 'ask) | |
1737 (if (message-y-or-n-p | |
1738 "Strip `(was: <old subject>)' in subject? " t | |
1739 (concat | |
1740 "Strip `(was: <old subject>)' in subject " | |
1741 "and use the new one instead?\n\n" | |
1742 "Current subject is: \"" | |
1743 subject "\"\n\n" | |
1744 "New subject would be: \"" | |
1745 new "\"\n\n" | |
1746 "See the variable `message-subject-trailing-was-query' " | |
1747 "to get rid of this query." | |
1748 )) | |
1749 new subject) | |
1750 new)))) | |
1751 | |
1752 ;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/ | |
1753 | |
1754 ;;;###autoload | |
1755 (defun message-change-subject (new-subject) | |
1756 "Ask for NEW-SUBJECT header, append (was: <Old Subject>)." | |
1757 ;; <URL:http://www.landfield.com/usefor/drafts/draft-ietf-usefor-useage--1.02.unpaged> | |
1758 (interactive | |
1759 (list | |
1760 (read-from-minibuffer "New subject: "))) | |
1761 (cond ((and (not (or (null new-subject) ; new subject not empty | |
1762 (zerop (string-width new-subject)) | |
1763 (string-match "^[ \t]*$" new-subject)))) | |
1764 (save-excursion | |
1765 (let ((old-subject | |
1766 (save-restriction | |
1767 (message-narrow-to-headers) | |
1768 (message-fetch-field "Subject")))) | |
1769 (cond ((not old-subject) | |
1770 (error "No current subject")) | |
1771 ((not (string-match | |
1772 (concat "^[ \t]*" | |
1773 (regexp-quote new-subject) | |
1774 " \t]*$") | |
1775 old-subject)) ; yes, it really is a new subject | |
1776 ;; delete eventual Re: prefix | |
1777 (setq old-subject | |
1778 (message-strip-subject-re old-subject)) | |
1779 (message-goto-subject) | |
1780 (message-delete-line) | |
1781 (insert (concat "Subject: " | |
1782 new-subject | |
1783 " (was: " | |
1784 old-subject ")\n"))))))))) | |
1785 | |
1786 ;;;###autoload | |
1787 (defun message-mark-inserted-region (beg end) | |
1788 "Mark some region in the current article with enclosing tags. | |
1789 See `message-mark-insert-begin' and `message-mark-insert-end'." | |
1790 (interactive "r") | |
1791 (save-excursion | |
1792 ;; add to the end of the region first, otherwise end would be invalid | |
1793 (goto-char end) | |
1794 (insert message-mark-insert-end) | |
1795 (goto-char beg) | |
1796 (insert message-mark-insert-begin))) | |
1797 | |
1798 ;;;###autoload | |
1799 (defun message-mark-insert-file (file) | |
1800 "Insert FILE at point, marking it with enclosing tags. | |
1801 See `message-mark-insert-begin' and `message-mark-insert-end'." | |
1802 (interactive "fFile to insert: ") | |
1803 ;; reverse insertion to get correct result. | |
1804 (let ((p (point))) | |
1805 (insert message-mark-insert-end) | |
1806 (goto-char p) | |
1807 (insert-file-contents file) | |
1808 (goto-char p) | |
1809 (insert message-mark-insert-begin))) | |
1810 | |
1811 ;;;###autoload | |
1812 (defun message-add-archive-header () | |
1813 "Insert \"X-No-Archive: Yes\" in the header and a note in the body. | |
1814 The note can be customized using `message-archive-note'. When called with a | |
1815 prefix argument, ask for a text to insert. If you don't want the note in the | |
1816 body, set `message-archive-note' to nil." | |
1817 (interactive) | |
1818 (if current-prefix-arg | |
1819 (setq message-archive-note | |
1820 (read-from-minibuffer "Reason for No-Archive: " | |
1821 (cons message-archive-note 0)))) | |
1822 (save-excursion | |
1823 (if (message-goto-signature) | |
1824 (re-search-backward message-signature-separator)) | |
1825 (when message-archive-note | |
1826 (insert message-archive-note) | |
1827 (newline)) | |
1828 (message-add-header message-archive-header) | |
1829 (message-sort-headers))) | |
1830 | |
1831 ;;;###autoload | |
1832 (defun message-cross-post-followup-to-header (target-group) | |
1833 "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP. | |
1834 With prefix-argument just set Follow-Up, don't cross-post." | |
1835 (interactive | |
1836 (list ; Completion based on Gnus | |
1837 (completing-read "Followup To: " | |
1838 (if (boundp 'gnus-newsrc-alist) | |
1839 gnus-newsrc-alist) | |
1840 nil nil '("poster" . 0) | |
1841 (if (boundp 'gnus-group-history) | |
1842 'gnus-group-history)))) | |
1843 (message-remove-header "Follow[Uu]p-[Tt]o" t) | |
1844 (message-goto-newsgroups) | |
1845 (beginning-of-line) | |
1846 ;; if we already did a crosspost before, kill old target | |
1847 (if (and message-cross-post-old-target | |
1848 (re-search-forward | |
1849 (regexp-quote (concat "," message-cross-post-old-target)) | |
1850 nil t)) | |
1851 (replace-match "")) | |
1852 ;; unless (followup is to poster or user explicitly asked not | |
1853 ;; to cross-post, or target-group is already in Newsgroups) | |
1854 ;; add target-group to Newsgroups line. | |
1855 (cond ((and (or | |
1856 ;; def: cross-post, req:no | |
1857 (and message-cross-post-default (not current-prefix-arg)) | |
1858 ;; def: no-cross-post, req:yes | |
1859 (and (not message-cross-post-default) current-prefix-arg)) | |
1860 (not (string-match "poster" target-group)) | |
1861 (not (string-match (regexp-quote target-group) | |
1862 (message-fetch-field "Newsgroups")))) | |
1863 (end-of-line) | |
1864 (insert (concat "," target-group)))) | |
1865 (end-of-line) ; ensure Followup: comes after Newsgroups: | |
1866 ;; unless new followup would be identical to Newsgroups line | |
1867 ;; make a new Followup-To line | |
1868 (if (not (string-match (concat "^[ \t]*" | |
1869 target-group | |
1870 "[ \t]*$") | |
1871 (message-fetch-field "Newsgroups"))) | |
1872 (insert (concat "\nFollowup-To: " target-group))) | |
1873 (setq message-cross-post-old-target target-group)) | |
1874 | |
1875 ;;;###autoload | |
1876 (defun message-cross-post-insert-note (target-group cross-post in-old | |
1877 old-groups) | |
1878 "Insert a in message body note about a set Followup or Crosspost. | |
1879 If there have been previous notes, delete them. TARGET-GROUP specifies the | |
1880 group to Followup-To. When CROSS-POST is t, insert note about | |
1881 crossposting. IN-OLD specifies whether TARGET-GROUP is a member of | |
1882 OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have | |
1883 been made to before the user asked for a Crosspost." | |
1884 ;; start scanning body for previous uses | |
1885 (message-goto-signature) | |
1886 (let ((head (re-search-backward | |
1887 (concat "^" mail-header-separator) | |
1888 nil t))) ; just search in body | |
1889 (message-goto-signature) | |
1890 (while (re-search-backward | |
1891 (concat "^" (regexp-quote message-cross-post-note) ".*") | |
1892 head t) | |
1893 (message-delete-line)) | |
1894 (message-goto-signature) | |
1895 (while (re-search-backward | |
1896 (concat "^" (regexp-quote message-followup-to-note) ".*") | |
1897 head t) | |
1898 (message-delete-line)) | |
1899 ;; insert new note | |
1900 (if (message-goto-signature) | |
1901 (re-search-backward message-signature-separator)) | |
1902 (if (or in-old | |
1903 (not cross-post) | |
1904 (string-match "^[ \t]*poster[ \t]*$" target-group)) | |
1905 (insert (concat message-followup-to-note target-group "\n")) | |
1906 (insert (concat message-cross-post-note target-group "\n"))))) | |
1907 | |
1908 ;;;###autoload | |
1909 (defun message-cross-post-followup-to (target-group) | |
1910 "Crossposts message and set Followup-To to TARGET-GROUP. | |
1911 With prefix-argument just set Follow-Up, don't cross-post." | |
1912 (interactive | |
1913 (list ; Completion based on Gnus | |
1914 (completing-read "Followup To: " | |
1915 (if (boundp 'gnus-newsrc-alist) | |
1916 gnus-newsrc-alist) | |
1917 nil nil '("poster" . 0) | |
1918 (if (boundp 'gnus-group-history) | |
1919 'gnus-group-history)))) | |
1920 (cond ((not (or (null target-group) ; new subject not empty | |
1921 (zerop (string-width target-group)) | |
1922 (string-match "^[ \t]*$" target-group))) | |
1923 (save-excursion | |
1924 (let* ((old-groups (message-fetch-field "Newsgroups")) | |
1925 (in-old (string-match | |
1926 (regexp-quote target-group) | |
1927 (or old-groups "")))) | |
1928 ;; check whether target exactly matches old Newsgroups | |
1929 (cond ((not old-groups) | |
1930 (error "No current newsgroup")) | |
1931 ((or (not in-old) | |
1932 (not (string-match | |
1933 (concat "^[ \t]*" | |
1934 (regexp-quote target-group) | |
1935 "[ \t]*$") | |
1936 old-groups))) | |
1937 ;; yes, Newsgroups line must change | |
1938 (message-cross-post-followup-to-header target-group) | |
1939 ;; insert note whether we do cross-post or followup-to | |
1940 (funcall message-cross-post-note-function | |
1941 target-group | |
1942 (if (or (and message-cross-post-default | |
1943 (not current-prefix-arg)) | |
1944 (and (not message-cross-post-default) | |
1945 current-prefix-arg)) t) | |
1946 in-old old-groups)))))))) | |
1947 | |
1948 ;;; Reduce To: to Cc: or Bcc: header | |
1949 | |
1950 ;;;###autoload | |
1951 (defun message-reduce-to-to-cc () | |
1952 "Replace contents of To: header with contents of Cc: or Bcc: header." | |
1953 (interactive) | |
1954 (let ((cc-content | |
1955 (save-restriction (message-narrow-to-headers) | |
1956 (message-fetch-field "cc"))) | |
1957 (bcc nil)) | |
1958 (if (and (not cc-content) | |
1959 (setq cc-content | |
1960 (save-restriction | |
1961 (message-narrow-to-headers) | |
1962 (message-fetch-field "bcc")))) | |
1963 (setq bcc t)) | |
1964 (cond (cc-content | |
1965 (save-excursion | |
1966 (message-goto-to) | |
1967 (message-delete-line) | |
1968 (insert (concat "To: " cc-content "\n")) | |
1969 (save-restriction | |
1970 (message-narrow-to-headers) | |
1971 (message-remove-header (if bcc | |
1972 "bcc" | |
1973 "cc")))))))) | |
1974 | |
1975 ;;; End of functions adopted from `message-utils.el'. | |
1215 | 1976 |
1216 (defun message-remove-header (header &optional is-regexp first reverse) | 1977 (defun message-remove-header (header &optional is-regexp first reverse) |
1217 "Remove HEADER in the narrowed buffer. | 1978 "Remove HEADER in the narrowed buffer. |
1218 If IS-REGEXP, HEADER is a regular expression. | 1979 If IS-REGEXP, HEADER is a regular expression. |
1219 If FIRST, only remove the first instance of the header. | 1980 If FIRST, only remove the first instance of the header. |
1319 (message-narrow-to-headers) | 2080 (message-narrow-to-headers) |
1320 (or (message-fetch-field "to") | 2081 (or (message-fetch-field "to") |
1321 (message-fetch-field "cc") | 2082 (message-fetch-field "cc") |
1322 (message-fetch-field "bcc"))))))) | 2083 (message-fetch-field "bcc"))))))) |
1323 | 2084 |
2085 (defun message-subscribed-p () | |
2086 "Say whether we need to insert a MFT header." | |
2087 (or message-subscribed-regexps | |
2088 message-subscribed-addresses | |
2089 message-subscribed-address-file | |
2090 message-subscribed-address-functions)) | |
2091 | |
1324 (defun message-next-header () | 2092 (defun message-next-header () |
1325 "Go to the beginning of the next header." | 2093 "Go to the beginning of the next header." |
1326 (beginning-of-line) | 2094 (beginning-of-line) |
1327 (or (eobp) (forward-char 1)) | 2095 (or (eobp) (forward-char 1)) |
1328 (not (if (re-search-forward "^[^ \t]" nil t) | 2096 (not (if (re-search-forward "^[^ \t]" nil t) |
1362 message-header-format-alist))) | 2130 message-header-format-alist))) |
1363 (- max rank) | 2131 (- max rank) |
1364 (1+ max))))) | 2132 (1+ max))))) |
1365 (message-sort-headers-1)))) | 2133 (message-sort-headers-1)))) |
1366 | 2134 |
2135 | |
1367 | 2136 |
1368 | 2137 |
1369 ;;; | 2138 ;;; |
1370 ;;; Message mode | 2139 ;;; Message mode |
1371 ;;; | 2140 ;;; |
1378 (setq message-mode-map (make-keymap)) | 2147 (setq message-mode-map (make-keymap)) |
1379 (set-keymap-parent message-mode-map text-mode-map) | 2148 (set-keymap-parent message-mode-map text-mode-map) |
1380 (define-key message-mode-map "\C-c?" 'describe-mode) | 2149 (define-key message-mode-map "\C-c?" 'describe-mode) |
1381 | 2150 |
1382 (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) | 2151 (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) |
2152 (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from) | |
1383 (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc) | 2153 (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc) |
1384 (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) | 2154 (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) |
1385 (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) | 2155 (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) |
1386 (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject) | 2156 (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject) |
1387 (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) | 2157 (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) |
1388 (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) | 2158 (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) |
1389 (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) | 2159 (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) |
1390 (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) | 2160 (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) |
2161 (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to) | |
1391 (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords) | 2162 (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords) |
1392 (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) | 2163 (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) |
2164 (define-key message-mode-map "\C-c\C-f\C-i" | |
2165 'message-insert-or-toggle-importance) | |
2166 (define-key message-mode-map "\C-c\C-f\C-a" | |
2167 'message-generate-unsubscribed-mail-followup-to) | |
2168 | |
2169 ;; modify headers (and insert notes in body) | |
2170 (define-key message-mode-map "\C-c\C-fs" 'message-change-subject) | |
2171 ;; | |
2172 (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to) | |
2173 ;; prefix+message-cross-post-followup-to = same w/o cross-post | |
2174 (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc) | |
2175 (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header) | |
2176 ;; mark inserted text | |
2177 (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region) | |
2178 (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file) | |
2179 | |
1393 (define-key message-mode-map "\C-c\C-b" 'message-goto-body) | 2180 (define-key message-mode-map "\C-c\C-b" 'message-goto-body) |
1394 (define-key message-mode-map "\C-c\C-i" 'message-goto-signature) | 2181 (define-key message-mode-map "\C-c\C-i" 'message-goto-signature) |
1395 | 2182 |
1396 (define-key message-mode-map "\C-c\C-t" 'message-insert-to) | 2183 (define-key message-mode-map "\C-c\C-t" 'message-insert-to) |
2184 (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply) | |
1397 (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) | 2185 (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) |
2186 (define-key message-mode-map "\C-c\C-l" 'message-to-list-only) | |
2187 | |
2188 (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance) | |
2189 (define-key message-mode-map "\C-c\M-n" | |
2190 'message-insert-disposition-notification-to) | |
1398 | 2191 |
1399 (define-key message-mode-map "\C-c\C-y" 'message-yank-original) | 2192 (define-key message-mode-map "\C-c\C-y" 'message-yank-original) |
1400 (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) | 2193 (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) |
1401 (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) | 2194 (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) |
1402 (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) | 2195 (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) |
1407 | 2200 |
1408 (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit) | 2201 (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit) |
1409 (define-key message-mode-map "\C-c\C-s" 'message-send) | 2202 (define-key message-mode-map "\C-c\C-s" 'message-send) |
1410 (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) | 2203 (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) |
1411 (define-key message-mode-map "\C-c\C-d" 'message-dont-send) | 2204 (define-key message-mode-map "\C-c\C-d" 'message-dont-send) |
2205 (define-key message-mode-map "\C-c\n" 'gnus-delay-article) | |
1412 | 2206 |
1413 (define-key message-mode-map "\C-c\C-e" 'message-elide-region) | 2207 (define-key message-mode-map "\C-c\C-e" 'message-elide-region) |
1414 (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) | 2208 (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) |
1415 (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) | 2209 (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) |
1416 (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) | 2210 (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) |
2211 ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph) | |
1417 (define-key message-mode-map [remap split-line] 'message-split-line) | 2212 (define-key message-mode-map [remap split-line] 'message-split-line) |
1418 | 2213 |
1419 (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) | 2214 (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) |
1420 | 2215 |
1421 (define-key message-mode-map "\t" 'message-tab)) | 2216 (define-key message-mode-map "\C-a" 'message-beginning-of-line) |
2217 (define-key message-mode-map "\t" 'message-tab) | |
2218 (define-key message-mode-map "\M-;" 'comment-region)) | |
1422 | 2219 |
1423 (easy-menu-define | 2220 (easy-menu-define |
1424 message-mode-menu message-mode-map "Message Menu." | 2221 message-mode-menu message-mode-map "Message Menu." |
1425 '("Message" | 2222 `("Message" |
1426 ["Sort Headers" message-sort-headers t] | 2223 ["Yank Original" message-yank-original message-reply-buffer] |
1427 ["Yank Original" message-yank-original t] | 2224 ["Fill Yanked Message" message-fill-yanked-message t] |
1428 ["Fill Yanked Message" message-fill-yanked-message t] | 2225 ["Insert Signature" message-insert-signature t] |
1429 ["Insert Signature" message-insert-signature t] | 2226 ["Caesar (rot13) Message" message-caesar-buffer-body t] |
1430 ["Caesar (rot13) Message" message-caesar-buffer-body t] | 2227 ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)] |
1431 ["Caesar (rot13) Region" message-caesar-region (mark t)] | 2228 ["Elide Region" message-elide-region |
1432 ["Elide Region" message-elide-region (mark t)] | 2229 :active (message-mark-active-p) |
1433 ["Delete Outside Region" message-delete-not-region (mark t)] | 2230 ,@(if (featurep 'xemacs) nil |
1434 ["Kill To Signature" message-kill-to-signature t] | 2231 '(:help "Replace text in region with an ellipsis"))] |
1435 ["Newline and Reformat" message-newline-and-reformat t] | 2232 ["Delete Outside Region" message-delete-not-region |
1436 ["Rename buffer" message-rename-buffer t] | 2233 :active (message-mark-active-p) |
1437 ["Spellcheck" ispell-message | 2234 ,@(if (featurep 'xemacs) nil |
1438 :help "Spellcheck this message"] | 2235 '(:help "Delete all quoted text outside region"))] |
1439 ["Attach file as MIME" mml-attach-file | 2236 ["Kill To Signature" message-kill-to-signature t] |
1440 :help "Attach a file at point"] | 2237 ["Newline and Reformat" message-newline-and-reformat t] |
1441 "----" | 2238 ["Rename buffer" message-rename-buffer t] |
1442 ["Send Message" message-send-and-exit | 2239 ["Spellcheck" ispell-message |
1443 :help "Send this message"] | 2240 ,@(if (featurep 'xemacs) '(t) |
1444 ["Abort Message" message-dont-send | 2241 '(:help "Spellcheck this message"))] |
1445 :help "File this draft message and exit"] | 2242 "----" |
1446 ["Kill Message" message-kill-buffer | 2243 ["Insert Region Marked" message-mark-inserted-region |
1447 :help "Delete this message without sending"])) | 2244 :active (message-mark-active-p) |
2245 ,@(if (featurep 'xemacs) nil | |
2246 '(:help "Mark region with enclosing tags"))] | |
2247 ["Insert File Marked..." message-mark-insert-file | |
2248 ,@(if (featurep 'xemacs) '(t) | |
2249 '(:help "Insert file at point marked with enclosing tags"))] | |
2250 "----" | |
2251 ["Send Message" message-send-and-exit | |
2252 ,@(if (featurep 'xemacs) '(t) | |
2253 '(:help "Send this message"))] | |
2254 ["Postpone Message" message-dont-send | |
2255 ,@(if (featurep 'xemacs) '(t) | |
2256 '(:help "File this draft message and exit"))] | |
2257 ["Send at Specific Time..." gnus-delay-article | |
2258 ,@(if (featurep 'xemacs) '(t) | |
2259 '(:help "Ask, then arrange to send message at that time"))] | |
2260 ["Kill Message" message-kill-buffer | |
2261 ,@(if (featurep 'xemacs) '(t) | |
2262 '(:help "Delete this message without sending"))])) | |
1448 | 2263 |
1449 (easy-menu-define | 2264 (easy-menu-define |
1450 message-mode-field-menu message-mode-map "" | 2265 message-mode-field-menu message-mode-map "" |
1451 '("Field" | 2266 `("Field" |
1452 ["Fetch To" message-insert-to t] | 2267 ["To" message-goto-to t] |
1453 ["Fetch Newsgroups" message-insert-newsgroups t] | 2268 ["From" message-goto-from t] |
1454 "----" | 2269 ["Subject" message-goto-subject t] |
1455 ["To" message-goto-to t] | 2270 ["Change subject..." message-change-subject t] |
1456 ["Subject" message-goto-subject t] | 2271 ["Cc" message-goto-cc t] |
1457 ["Cc" message-goto-cc t] | 2272 ["Bcc" message-goto-bcc t] |
1458 ["Reply-To" message-goto-reply-to t] | 2273 ["Fcc" message-goto-fcc t] |
1459 ["Summary" message-goto-summary t] | 2274 ["Reply-To" message-goto-reply-to t] |
1460 ["Keywords" message-goto-keywords t] | 2275 ["Flag As Important" message-insert-importance-high |
1461 ["Newsgroups" message-goto-newsgroups t] | 2276 ,@(if (featurep 'xemacs) '(t) |
1462 ["Followup-To" message-goto-followup-to t] | 2277 '(:help "Mark this message as important"))] |
1463 ["Distribution" message-goto-distribution t] | 2278 ["Flag As Unimportant" message-insert-importance-low |
1464 ["Body" message-goto-body t] | 2279 ,@(if (featurep 'xemacs) '(t) |
1465 ["Signature" message-goto-signature t])) | 2280 '(:help "Mark this message as unimportant"))] |
2281 ["Request Receipt" | |
2282 message-insert-disposition-notification-to | |
2283 ,@(if (featurep 'xemacs) '(t) | |
2284 '(:help "Request a receipt notification"))] | |
2285 "----" | |
2286 ;; (typical) news stuff | |
2287 ["Summary" message-goto-summary t] | |
2288 ["Keywords" message-goto-keywords t] | |
2289 ["Newsgroups" message-goto-newsgroups t] | |
2290 ["Fetch Newsgroups" message-insert-newsgroups t] | |
2291 ["Followup-To" message-goto-followup-to t] | |
2292 ;; ["Followup-To (with note in body)" message-cross-post-followup-to t] | |
2293 ["Crosspost / Followup-To..." message-cross-post-followup-to t] | |
2294 ["Distribution" message-goto-distribution t] | |
2295 ["X-No-Archive:" message-add-archive-header t ] | |
2296 "----" | |
2297 ;; (typical) mailing-lists stuff | |
2298 ["Fetch To" message-insert-to | |
2299 ,@(if (featurep 'xemacs) '(t) | |
2300 '(:help "Insert a To header that points to the author."))] | |
2301 ["Fetch To and Cc" message-insert-wide-reply | |
2302 ,@(if (featurep 'xemacs) '(t) | |
2303 '(:help | |
2304 "Insert To and Cc headers as if you were doing a wide reply."))] | |
2305 "----" | |
2306 ["Send to list only" message-to-list-only t] | |
2307 ["Mail-Followup-To" message-goto-mail-followup-to t] | |
2308 ["Unsubscribed list post" message-generate-unsubscribed-mail-followup-to | |
2309 ,@(if (featurep 'xemacs) '(t) | |
2310 '(:help "Insert a reasonable `Mail-Followup-To:' header."))] | |
2311 ["Reduce To: to Cc:" message-reduce-to-to-cc t] | |
2312 "----" | |
2313 ["Sort Headers" message-sort-headers t] | |
2314 ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t] | |
2315 ["Goto Body" message-goto-body t] | |
2316 ["Goto Signature" message-goto-signature t])) | |
2317 | |
2318 (defvar message-tool-bar-map nil) | |
1466 | 2319 |
1467 (eval-when-compile | 2320 (eval-when-compile |
1468 (defvar facemenu-add-face-function) | 2321 (defvar facemenu-add-face-function) |
1469 (defvar facemenu-remove-face-function)) | 2322 (defvar facemenu-remove-face-function)) |
1470 | 2323 |
2324 ;;; Forbidden properties | |
2325 ;; | |
2326 ;; We use `after-change-functions' to keep special text properties | |
2327 ;; that interfer with the normal function of message mode out of the | |
2328 ;; buffer. | |
2329 | |
2330 (defcustom message-strip-special-text-properties t | |
2331 "Strip special properties from the message buffer. | |
2332 | |
2333 Emacs has a number of special text properties which can break message | |
2334 composing in various ways. If this option is set, message will strip | |
2335 these properties from the message composition buffer. However, some | |
2336 packages requires these properties to be present in order to work. | |
2337 If you use one of these packages, turn this option off, and hope the | |
2338 message composition doesn't break too bad." | |
2339 :group 'message-various | |
2340 :link '(custom-manual "(message)Various Message Variables") | |
2341 :type 'boolean) | |
2342 | |
2343 (defconst message-forbidden-properties | |
2344 ;; No reason this should be clutter up customize. We make it a | |
2345 ;; property list (rather than a list of property symbols), to be | |
2346 ;; directly useful for `remove-text-properties'. | |
2347 '(field nil read-only nil invisible nil intangible nil | |
2348 mouse-face nil modification-hooks nil insert-in-front-hooks nil | |
2349 insert-behind-hooks nil point-entered nil point-left nil) | |
2350 ;; Other special properties: | |
2351 ;; category, face, display: probably doesn't do any harm. | |
2352 ;; fontified: is used by font-lock. | |
2353 ;; syntax-table, local-map: I dunno. | |
2354 ;; We need to add XEmacs names to the list. | |
2355 "Property list of with properties.forbidden in message buffers. | |
2356 The values of the properties are ignored, only the property names are used.") | |
2357 | |
2358 (defun message-tamago-not-in-use-p (pos) | |
2359 "Return t when tamago version 4 is not in use at the cursor position. | |
2360 Tamago version 4 is a popular input method for writing Japanese text. | |
2361 It uses the properties `intangible', `invisible', `modification-hooks' | |
2362 and `read-only' when translating ascii or kana text to kanji text. | |
2363 These properties are essential to work, so we should never strip them." | |
2364 (not (and (boundp 'egg-modefull-mode) | |
2365 (symbol-value 'egg-modefull-mode) | |
2366 (or (memq (get-text-property pos 'intangible) | |
2367 '(its-part-1 its-part-2)) | |
2368 (get-text-property pos 'egg-end) | |
2369 (get-text-property pos 'egg-lang) | |
2370 (get-text-property pos 'egg-start))))) | |
2371 | |
2372 (defun message-strip-forbidden-properties (begin end &optional old-length) | |
2373 "Strip forbidden properties between BEGIN and END, ignoring the third arg. | |
2374 This function is intended to be called from `after-change-functions'. | |
2375 See also `message-forbidden-properties'." | |
2376 (when (and message-strip-special-text-properties | |
2377 (message-tamago-not-in-use-p begin)) | |
2378 (while (not (= begin end)) | |
2379 (when (not (get-text-property begin 'message-hidden)) | |
2380 (remove-text-properties begin (1+ begin) | |
2381 message-forbidden-properties)) | |
2382 (incf begin)))) | |
2383 | |
1471 ;;;###autoload | 2384 ;;;###autoload |
1472 (defun message-mode () | 2385 (define-derived-mode message-mode text-mode "Message" |
1473 "Major mode for editing mail and news to be sent. | 2386 "Major mode for editing mail and news to be sent. |
1474 Like Text Mode but with these additional commands:\\<message-mode-map> | 2387 Like Text Mode but with these additional commands:\\<message-mode-map> |
1475 C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit' | 2388 C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit' |
1476 C-c C-d Postpone sending the message C-c C-k Kill the message | 2389 C-c C-d Postpone sending the message C-c C-k Kill the message |
1477 C-c C-f move to a header field (and create it if there isn't): | 2390 C-c C-f move to a header field (and create it if there isn't): |
1478 C-c C-f C-t move to To C-c C-f C-s move to Subject | 2391 C-c C-f C-t move to To C-c C-f C-s move to Subject |
1479 C-c C-f C-c move to Cc C-c C-f C-b move to Bcc | 2392 C-c C-f C-c move to Cc C-c C-f C-b move to Bcc |
1480 C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To | 2393 C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To |
1481 C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups | 2394 C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups |
1482 C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution | 2395 C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution |
2396 C-c C-f C-o move to From (\"Originator\") | |
1483 C-c C-f C-f move to Followup-To | 2397 C-c C-f C-f move to Followup-To |
2398 C-c C-f C-m move to Mail-Followup-To | |
2399 C-c C-f C-i cycle through Importance values | |
2400 C-c C-f s change subject and append \"(was: <Old Subject>)\" | |
2401 C-c C-f x crossposting with FollowUp-To header and note in body | |
2402 C-c C-f t replace To: header with contents of Cc: or Bcc: | |
2403 C-c C-f a Insert X-No-Archive: header and a note in the body | |
1484 C-c C-t `message-insert-to' (add a To header to a news followup) | 2404 C-c C-t `message-insert-to' (add a To header to a news followup) |
2405 C-c C-l `message-to-list-only' (removes all but list address in to/cc) | |
1485 C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) | 2406 C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) |
1486 C-c C-b `message-goto-body' (move to beginning of message text). | 2407 C-c C-b `message-goto-body' (move to beginning of message text). |
1487 C-c C-i `message-goto-signature' (move to the beginning of the signature). | 2408 C-c C-i `message-goto-signature' (move to the beginning of the signature). |
1488 C-c C-w `message-insert-signature' (insert `message-signature-file' file). | 2409 C-c C-w `message-insert-signature' (insert `message-signature-file' file). |
1489 C-c C-y `message-yank-original' (insert current message, if any). | 2410 C-c C-y `message-yank-original' (insert current message, if any). |
1491 C-c C-e `message-elide-region' (elide the text between point and mark). | 2412 C-c C-e `message-elide-region' (elide the text between point and mark). |
1492 C-c C-v `message-delete-not-region' (remove the text outside the region). | 2413 C-c C-v `message-delete-not-region' (remove the text outside the region). |
1493 C-c C-z `message-kill-to-signature' (kill the text up to the signature). | 2414 C-c C-z `message-kill-to-signature' (kill the text up to the signature). |
1494 C-c C-r `message-caesar-buffer-body' (rot13 the message body). | 2415 C-c C-r `message-caesar-buffer-body' (rot13 the message body). |
1495 C-c C-a `mml-attach-file' (attach a file as MIME). | 2416 C-c C-a `mml-attach-file' (attach a file as MIME). |
2417 C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance). | |
2418 C-c M-n `message-insert-disposition-notification-to' (request receipt). | |
2419 C-c M-m `message-mark-inserted-region' (mark region with enclosing tags). | |
2420 C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags). | |
1496 M-RET `message-newline-and-reformat' (break the line and reformat)." | 2421 M-RET `message-newline-and-reformat' (break the line and reformat)." |
1497 (interactive) | 2422 (setq local-abbrev-table text-mode-abbrev-table) |
1498 (if (local-variable-p 'mml-buffer-list (current-buffer)) | |
1499 (mml-destroy-buffers)) | |
1500 (kill-all-local-variables) | |
1501 (set (make-local-variable 'message-reply-buffer) nil) | 2423 (set (make-local-variable 'message-reply-buffer) nil) |
1502 (make-local-variable 'message-send-actions) | 2424 (set (make-local-variable 'message-inserted-headers) nil) |
1503 (make-local-variable 'message-exit-actions) | 2425 (set (make-local-variable 'message-send-actions) nil) |
1504 (make-local-variable 'message-kill-actions) | 2426 (set (make-local-variable 'message-exit-actions) nil) |
1505 (make-local-variable 'message-postpone-actions) | 2427 (set (make-local-variable 'message-kill-actions) nil) |
1506 (make-local-variable 'message-draft-article) | 2428 (set (make-local-variable 'message-postpone-actions) nil) |
1507 (make-local-hook 'kill-buffer-hook) | 2429 (set (make-local-variable 'message-draft-article) nil) |
1508 (set-syntax-table message-mode-syntax-table) | |
1509 (use-local-map message-mode-map) | |
1510 (setq local-abbrev-table message-mode-abbrev-table) | |
1511 (setq major-mode 'message-mode) | |
1512 (setq mode-name "Message") | |
1513 (setq buffer-offer-save t) | 2430 (setq buffer-offer-save t) |
1514 (make-local-variable 'facemenu-add-face-function) | 2431 (set (make-local-variable 'facemenu-add-face-function) |
1515 (make-local-variable 'facemenu-remove-face-function) | 2432 (lambda (face end) |
1516 (setq facemenu-add-face-function | 2433 (let ((face-fun (cdr (assq face message-face-alist)))) |
1517 (lambda (face end) | 2434 (if face-fun |
1518 (let ((face-fun (cdr (assq face message-face-alist)))) | 2435 (funcall face-fun (point) end) |
1519 (if face-fun | 2436 (error "Face %s not configured for %s mode" face mode-name))) |
1520 (funcall face-fun (point) end) | 2437 "")) |
1521 (error "Face %s not configured for %s mode" face mode-name))) | 2438 (set (make-local-variable 'facemenu-remove-face-function) t) |
1522 "") | 2439 (set (make-local-variable 'message-reply-headers) nil) |
1523 facemenu-remove-face-function t) | |
1524 (make-local-variable 'message-reply-headers) | |
1525 (setq message-reply-headers nil) | |
1526 (make-local-variable 'message-newsreader) | 2440 (make-local-variable 'message-newsreader) |
1527 (make-local-variable 'message-mailer) | 2441 (make-local-variable 'message-mailer) |
1528 (make-local-variable 'message-post-method) | 2442 (make-local-variable 'message-post-method) |
1529 (set (make-local-variable 'message-sent-message-via) nil) | 2443 (set (make-local-variable 'message-sent-message-via) nil) |
1530 (set (make-local-variable 'message-checksum) nil) | 2444 (set (make-local-variable 'message-checksum) nil) |
1531 (set (make-local-variable 'message-mime-part) 0) | 2445 (set (make-local-variable 'message-mime-part) 0) |
1532 (message-setup-fill-variables) | 2446 (message-setup-fill-variables) |
1533 ;; Allow using comment commands to add/remove quoting. | 2447 ;; Allow using comment commands to add/remove quoting. |
2448 ;; (set (make-local-variable 'comment-start) message-yank-prefix) | |
1534 (when message-yank-prefix | 2449 (when message-yank-prefix |
1535 (set (make-local-variable 'comment-start) message-yank-prefix) | 2450 (set (make-local-variable 'comment-start) message-yank-prefix) |
1536 (set (make-local-variable 'comment-start-skip) | 2451 (set (make-local-variable 'comment-start-skip) |
1537 (concat "^" (regexp-quote message-yank-prefix) "[ \t]*"))) | 2452 (concat "^" (regexp-quote message-yank-prefix) "[ \t]*"))) |
1538 ;;(when (fboundp 'mail-hist-define-keys) | |
1539 ;; (mail-hist-define-keys)) | |
1540 (if (featurep 'xemacs) | 2453 (if (featurep 'xemacs) |
1541 (message-setup-toolbar) | 2454 (message-setup-toolbar) |
1542 (set (make-local-variable 'font-lock-defaults) | 2455 (set (make-local-variable 'font-lock-defaults) |
1543 '(message-font-lock-keywords t)) | 2456 '(message-font-lock-keywords t)) |
1544 (if (boundp 'message-tool-bar-map) | 2457 (if (boundp 'tool-bar-map) |
1545 (set (make-local-variable 'tool-bar-map) message-tool-bar-map))) | 2458 (set (make-local-variable 'tool-bar-map) (message-tool-bar-map)))) |
1546 (easy-menu-add message-mode-menu message-mode-map) | 2459 (easy-menu-add message-mode-menu message-mode-map) |
1547 (easy-menu-add message-mode-field-menu message-mode-map) | 2460 (easy-menu-add message-mode-field-menu message-mode-map) |
2461 (gnus-make-local-hook 'after-change-functions) | |
2462 ;; Mmmm... Forbidden properties... | |
2463 (add-hook 'after-change-functions 'message-strip-forbidden-properties | |
2464 nil 'local) | |
1548 ;; Allow mail alias things. | 2465 ;; Allow mail alias things. |
1549 (when (eq message-mail-alias-type 'abbrev) | 2466 (when (eq message-mail-alias-type 'abbrev) |
1550 (if (fboundp 'mail-abbrevs-setup) | 2467 (if (fboundp 'mail-abbrevs-setup) |
1551 (mail-abbrevs-setup) | 2468 (mail-abbrevs-setup) |
1552 (mail-aliases-setup))) | 2469 (if (fboundp 'mail-aliases-setup) ; warning avoidance |
2470 (mail-aliases-setup)))) | |
1553 (unless buffer-file-name | 2471 (unless buffer-file-name |
1554 (message-set-auto-save-file-name)) | 2472 (message-set-auto-save-file-name)) |
1555 (mm-enable-multibyte) | 2473 (unless (buffer-base-buffer) |
1556 (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation. | 2474 ;; Don't enable multibyte on an indirect buffer. Maybe enabling |
1557 (setq indent-tabs-mode nil) | 2475 ;; multibyte is not necessary at all. -- zsh |
1558 (mml-mode) | 2476 (mm-enable-multibyte)) |
1559 (run-hooks 'text-mode-hook 'message-mode-hook)) | 2477 (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation. |
2478 (mml-mode)) | |
1560 | 2479 |
1561 (defun message-setup-fill-variables () | 2480 (defun message-setup-fill-variables () |
1562 "Setup message fill variables." | 2481 "Setup message fill variables." |
2482 (set (make-local-variable 'fill-paragraph-function) | |
2483 'message-fill-paragraph) | |
1563 (make-local-variable 'paragraph-separate) | 2484 (make-local-variable 'paragraph-separate) |
1564 (make-local-variable 'paragraph-start) | 2485 (make-local-variable 'paragraph-start) |
1565 (make-local-variable 'adaptive-fill-regexp) | 2486 (make-local-variable 'adaptive-fill-regexp) |
1566 (unless (boundp 'adaptive-fill-first-line-regexp) | 2487 (unless (boundp 'adaptive-fill-first-line-regexp) |
1567 (setq adaptive-fill-first-line-regexp nil)) | 2488 (setq adaptive-fill-first-line-regexp nil)) |
1568 (make-local-variable 'adaptive-fill-first-line-regexp) | 2489 (make-local-variable 'adaptive-fill-first-line-regexp) |
1569 (make-local-variable 'auto-fill-inhibit-regexp) | |
1570 (let ((quote-prefix-regexp | 2490 (let ((quote-prefix-regexp |
1571 (concat | 2491 ;; User should change message-cite-prefix-regexp if |
1572 "[ \t]*" ; possible initial space | 2492 ;; message-yank-prefix is set to an abnormal value. |
1573 "\\(\\(" (regexp-quote message-yank-prefix) "\\|" ; user's prefix | 2493 (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*"))) |
1574 "\\w+>\\|" ; supercite-style prefix | |
1575 "[|:>]" ; standard prefix | |
1576 "\\)[ \t]*\\)+"))) ; possible space after each prefix | |
1577 (setq paragraph-start | 2494 (setq paragraph-start |
1578 (concat | 2495 (concat |
1579 (regexp-quote mail-header-separator) "$\\|" | 2496 (regexp-quote mail-header-separator) "$\\|" |
1580 "[ \t]*$\\|" ; blank lines | 2497 "[ \t]*$\\|" ; blank lines |
1581 "-- $\\|" ; signature delimiter | 2498 "-- $\\|" ; signature delimiter |
1582 "---+$\\|" ; delimiters for forwarded messages | 2499 "---+$\\|" ; delimiters for forwarded messages |
1583 page-delimiter "$\\|" ; spoiler warnings | 2500 page-delimiter "$\\|" ; spoiler warnings |
1584 ".*wrote:$\\|" ; attribution lines | 2501 ".*wrote:$\\|" ; attribution lines |
1585 quote-prefix-regexp "$")) ; empty lines in quoted text | 2502 quote-prefix-regexp "$\\|" ; empty lines in quoted text |
2503 ; mml tags | |
2504 "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)")) | |
1586 (setq paragraph-separate paragraph-start) | 2505 (setq paragraph-separate paragraph-start) |
1587 (setq adaptive-fill-regexp | 2506 (setq adaptive-fill-regexp |
1588 (concat quote-prefix-regexp "\\|" adaptive-fill-regexp)) | 2507 (concat quote-prefix-regexp "\\|" adaptive-fill-regexp)) |
1589 (setq adaptive-fill-first-line-regexp | 2508 (setq adaptive-fill-first-line-regexp |
1590 (concat quote-prefix-regexp "\\|" | 2509 (concat quote-prefix-regexp "\\|" |
1591 adaptive-fill-first-line-regexp)) | 2510 adaptive-fill-first-line-regexp))) |
1592 (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:"))) | 2511 (make-local-variable 'auto-fill-inhibit-regexp) |
2512 ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:") | |
2513 (setq auto-fill-inhibit-regexp nil) | |
2514 (make-local-variable 'normal-auto-fill-function) | |
2515 (setq normal-auto-fill-function 'message-do-auto-fill) | |
2516 ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'. | |
2517 ;; In that case, ensure that it uses the right function. The real | |
2518 ;; solution would be not to use `define-derived-mode', and run | |
2519 ;; `text-mode-hook' ourself at the end of the mode. | |
2520 ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19. | |
2521 (when auto-fill-function | |
2522 (setq auto-fill-function normal-auto-fill-function))) | |
1593 | 2523 |
1594 | 2524 |
1595 | 2525 |
1596 ;;; | 2526 ;;; |
1597 ;;; Message mode commands | 2527 ;;; Message mode commands |
1602 (defun message-goto-to () | 2532 (defun message-goto-to () |
1603 "Move point to the To header." | 2533 "Move point to the To header." |
1604 (interactive) | 2534 (interactive) |
1605 (message-position-on-field "To")) | 2535 (message-position-on-field "To")) |
1606 | 2536 |
2537 (defun message-goto-from () | |
2538 "Move point to the From header." | |
2539 (interactive) | |
2540 (message-position-on-field "From")) | |
2541 | |
1607 (defun message-goto-subject () | 2542 (defun message-goto-subject () |
1608 "Move point to the Subject header." | 2543 "Move point to the Subject header." |
1609 (interactive) | 2544 (interactive) |
1610 (message-position-on-field "Subject")) | 2545 (message-position-on-field "Subject")) |
1611 | 2546 |
1642 (defun message-goto-followup-to () | 2577 (defun message-goto-followup-to () |
1643 "Move point to the Followup-To header." | 2578 "Move point to the Followup-To header." |
1644 (interactive) | 2579 (interactive) |
1645 (message-position-on-field "Followup-To" "Newsgroups")) | 2580 (message-position-on-field "Followup-To" "Newsgroups")) |
1646 | 2581 |
2582 (defun message-goto-mail-followup-to () | |
2583 "Move point to the Mail-Followup-To header." | |
2584 (interactive) | |
2585 (message-position-on-field "Mail-Followup-To" "From")) | |
2586 | |
1647 (defun message-goto-keywords () | 2587 (defun message-goto-keywords () |
1648 "Move point to the Keywords header." | 2588 "Move point to the Keywords header." |
1649 (interactive) | 2589 (interactive) |
1650 (message-position-on-field "Keywords" "Subject")) | 2590 (message-position-on-field "Keywords" "Subject")) |
1651 | 2591 |
1652 (defun message-goto-summary () | 2592 (defun message-goto-summary () |
1653 "Move point to the Summary header." | 2593 "Move point to the Summary header." |
1654 (interactive) | 2594 (interactive) |
1655 (message-position-on-field "Summary" "Subject")) | 2595 (message-position-on-field "Summary" "Subject")) |
1656 | 2596 |
1657 (defun message-goto-body () | 2597 (defun message-goto-body (&optional interactivep) |
1658 "Move point to the beginning of the message body." | 2598 "Move point to the beginning of the message body." |
1659 (interactive) | 2599 (interactive (list t)) |
1660 (if (looking-at "[ \t]*\n") (expand-abbrev)) | 2600 (when (and interactivep |
2601 (looking-at "[ \t]*\n")) | |
2602 (expand-abbrev)) | |
1661 (goto-char (point-min)) | 2603 (goto-char (point-min)) |
1662 (or (search-forward (concat "\n" mail-header-separator "\n") nil t) | 2604 (or (search-forward (concat "\n" mail-header-separator "\n") nil t) |
1663 (search-forward "\n\n" nil t))) | 2605 (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) |
1664 | 2606 |
1665 (defun message-goto-eoh () | 2607 (defun message-goto-eoh () |
1666 "Move point to the end of the headers." | 2608 "Move point to the end of the headers." |
1667 (interactive) | 2609 (interactive) |
1668 (message-goto-body) | 2610 (message-goto-body) |
1677 (if (re-search-forward message-signature-separator nil t) | 2619 (if (re-search-forward message-signature-separator nil t) |
1678 (forward-line 1) | 2620 (forward-line 1) |
1679 (goto-char (point-max)) | 2621 (goto-char (point-max)) |
1680 nil)) | 2622 nil)) |
1681 | 2623 |
2624 (defun message-generate-unsubscribed-mail-followup-to (&optional include-cc) | |
2625 "Insert a reasonable MFT header in a post to an unsubscribed list. | |
2626 When making original posts to a mailing list you are not subscribed to, | |
2627 you have to type in a MFT header by hand. The contents, usually, are | |
2628 the addresses of the list and your own address. This function inserts | |
2629 such a header automatically. It fetches the contents of the To: header | |
2630 in the current mail buffer, and appends the current `user-mail-address'. | |
2631 | |
2632 If the optional argument INCLUDE-CC is non-nil, the addresses in the | |
2633 Cc: header are also put into the MFT." | |
2634 | |
2635 (interactive "P") | |
2636 (let* (cc tos) | |
2637 (save-restriction | |
2638 (message-narrow-to-headers) | |
2639 (message-remove-header "Mail-Followup-To") | |
2640 (setq cc (and include-cc (message-fetch-field "Cc"))) | |
2641 (setq tos (if cc | |
2642 (concat (message-fetch-field "To") "," cc) | |
2643 (message-fetch-field "To")))) | |
2644 (message-goto-mail-followup-to) | |
2645 (insert (concat tos ", " user-mail-address)))) | |
2646 | |
1682 | 2647 |
1683 | 2648 |
1684 (defun message-insert-to (&optional force) | 2649 (defun message-insert-to (&optional force) |
1685 "Insert a To header that points to the author of the article being replied to. | 2650 "Insert a To header that points to the author of the article being replied to. |
1686 If the original author requested not to be sent mail, the function signals | 2651 If the original author requested not to be sent mail, don't insert unless the |
1687 an error. | 2652 prefix FORCE is given." |
1688 With the prefix argument FORCE, insert the header anyway." | |
1689 (interactive "P") | 2653 (interactive "P") |
1690 (let ((co (message-fetch-reply-field "mail-copies-to"))) | 2654 (let* ((mct (message-fetch-reply-field "mail-copies-to")) |
1691 (when (and (null force) | 2655 (dont (and mct (or (equal (downcase mct) "never") |
1692 co | 2656 (equal (downcase mct) "nobody")))) |
1693 (or (equal (downcase co) "never") | 2657 (to (or (message-fetch-reply-field "mail-reply-to") |
1694 (equal (downcase co) "nobody"))) | 2658 (message-fetch-reply-field "reply-to") |
1695 (error "The user has requested not to have copies sent via mail"))) | 2659 (message-fetch-reply-field "from")))) |
1696 (when (and (message-position-on-field "To") | 2660 (when (and dont to) |
1697 (mail-fetch-field "to") | 2661 (message |
1698 (not (string-match "\\` *\\'" (mail-fetch-field "to")))) | 2662 (if force |
1699 (insert ", ")) | 2663 "Ignoring the user request not to have copies sent via mail" |
1700 (insert (or (message-fetch-reply-field "reply-to") | 2664 "Complying with the user request not to have copies sent via mail"))) |
1701 (message-fetch-reply-field "from") ""))) | 2665 (when (and force (not to)) |
2666 (error "No mail address in the article")) | |
2667 (when (and to (or force (not dont))) | |
2668 (message-carefully-insert-headers (list (cons 'To to)))))) | |
2669 | |
2670 (defun message-insert-wide-reply () | |
2671 "Insert To and Cc headers as if you were doing a wide reply." | |
2672 (interactive) | |
2673 (let ((headers (message-with-reply-buffer | |
2674 (message-get-reply-headers t)))) | |
2675 (message-carefully-insert-headers headers))) | |
2676 | |
2677 (defcustom message-header-synonyms | |
2678 '((To Cc Bcc)) | |
2679 "List of lists of header synonyms. | |
2680 E.g., if this list contains a member list with elements `Cc' and `To', | |
2681 then `message-carefully-insert-headers' will not insert a `To' header | |
2682 when the message is already `Cc'ed to the recipient." | |
2683 :group 'message-headers | |
2684 :link '(custom-manual "(message)Message Headers") | |
2685 :type '(repeat sexp)) | |
2686 | |
2687 (defun message-carefully-insert-headers (headers) | |
2688 "Insert the HEADERS, an alist, into the message buffer. | |
2689 Does not insert the headers when they are already present there | |
2690 or in the synonym headers, defined by `message-header-synonyms'." | |
2691 ;; FIXME: Should compare only the address and not the full name. Comparison | |
2692 ;; should be done case-folded (and with `string=' rather than | |
2693 ;; `string-match'). | |
2694 (dolist (header headers) | |
2695 (let* ((header-name (symbol-name (car header))) | |
2696 (new-header (cdr header)) | |
2697 (synonyms (loop for synonym in message-header-synonyms | |
2698 when (memq (car header) synonym) return synonym)) | |
2699 (old-header | |
2700 (loop for synonym in synonyms | |
2701 for old-header = (mail-fetch-field (symbol-name synonym)) | |
2702 when (and old-header (string-match new-header old-header)) | |
2703 return synonym))) | |
2704 (if old-header | |
2705 (message "already have `%s' in `%s'" new-header old-header) | |
2706 (when (and (message-position-on-field header-name) | |
2707 (setq old-header (mail-fetch-field header-name)) | |
2708 (not (string-match "\\` *\\'" old-header))) | |
2709 (insert ", ")) | |
2710 (insert new-header))))) | |
1702 | 2711 |
1703 (defun message-widen-reply () | 2712 (defun message-widen-reply () |
1704 "Widen the reply to include maximum recipients." | 2713 "Widen the reply to include maximum recipients." |
1705 (interactive) | 2714 (interactive) |
1706 (let ((follow-to | 2715 (let ((follow-to |
1732 ;;; Various commands | 2741 ;;; Various commands |
1733 | 2742 |
1734 (defun message-delete-not-region (beg end) | 2743 (defun message-delete-not-region (beg end) |
1735 "Delete everything in the body of the current message outside of the region." | 2744 "Delete everything in the body of the current message outside of the region." |
1736 (interactive "r") | 2745 (interactive "r") |
1737 (save-excursion | 2746 (let (citeprefix) |
1738 (goto-char end) | 2747 (save-excursion |
1739 (delete-region (point) (if (not (message-goto-signature)) | 2748 (goto-char beg) |
1740 (point) | 2749 ;; snarf citation prefix, if appropriate |
1741 (forward-line -2) | 2750 (unless (eq (point) (progn (beginning-of-line) (point))) |
1742 (point))) | 2751 (when (looking-at message-cite-prefix-regexp) |
1743 (insert "\n") | 2752 (setq citeprefix (match-string 0)))) |
1744 (goto-char beg) | 2753 (goto-char end) |
1745 (delete-region beg (progn (message-goto-body) | 2754 (delete-region (point) (if (not (message-goto-signature)) |
1746 (forward-line 2) | 2755 (point) |
1747 (point)))) | 2756 (forward-line -2) |
2757 (point))) | |
2758 (insert "\n") | |
2759 (goto-char beg) | |
2760 (delete-region beg (progn (message-goto-body) | |
2761 (forward-line 2) | |
2762 (point))) | |
2763 (when citeprefix | |
2764 (insert citeprefix)))) | |
1748 (when (message-goto-signature) | 2765 (when (message-goto-signature) |
1749 (forward-line -2))) | 2766 (forward-line -2))) |
1750 | 2767 |
1751 (defun message-kill-to-signature () | 2768 (defun message-kill-to-signature () |
1752 "Deletes all text up to the signature." | 2769 "Deletes all text up to the signature." |
1753 (interactive) | 2770 (interactive) |
1754 (let ((point (point))) | 2771 (let ((point (point))) |
1755 (message-goto-signature) | 2772 (message-goto-signature) |
1756 (unless (eobp) | 2773 (unless (eobp) |
1757 (forward-line -2)) | 2774 (end-of-line -1)) |
1758 (kill-region point (point)) | 2775 (kill-region point (point)) |
1759 (unless (bolp) | 2776 (unless (bolp) |
1760 (insert "\n")))) | 2777 (insert "\n")))) |
1761 | 2778 |
1762 (defun message-newline-and-reformat () | 2779 (defun message-newline-and-reformat (&optional arg not-break) |
1763 "Insert four newlines, and then reformat if inside quoted text." | 2780 "Insert four newlines, and then reformat if inside quoted text. |
1764 (interactive) | 2781 Prefix arg means justify as well." |
1765 ;; The Latin-1 angle quote looks pretty dubious. -- fx | 2782 (interactive (list (if current-prefix-arg 'full))) |
1766 (let ((prefix "[]>»|:}+ \t]*") | 2783 (let (quoted point beg end leading-space bolp) |
1767 (supercite-thing "[-._[:alnum:]]*[>]+[ \t]*") | |
1768 quoted point) | |
1769 (unless (bolp) | |
1770 (save-excursion | |
1771 (beginning-of-line) | |
1772 (when (looking-at (concat prefix | |
1773 supercite-thing)) | |
1774 (setq quoted (match-string 0)))) | |
1775 (insert "\n")) | |
1776 (setq point (point)) | 2784 (setq point (point)) |
1777 (insert "\n\n\n") | 2785 (beginning-of-line) |
1778 (delete-region (point) (re-search-forward "[ \t]*")) | 2786 (setq beg (point)) |
1779 (when quoted | 2787 (setq bolp (= beg point)) |
1780 (insert quoted)) | 2788 ;; Find first line of the paragraph. |
1781 (fill-paragraph nil) | 2789 (if not-break |
2790 (while (and (not (eobp)) | |
2791 (not (looking-at message-cite-prefix-regexp)) | |
2792 (looking-at paragraph-start)) | |
2793 (forward-line 1))) | |
2794 ;; Find the prefix | |
2795 (when (looking-at message-cite-prefix-regexp) | |
2796 (setq quoted (match-string 0)) | |
2797 (goto-char (match-end 0)) | |
2798 (looking-at "[ \t]*") | |
2799 (setq leading-space (match-string 0))) | |
2800 (if (and quoted | |
2801 (not not-break) | |
2802 (not bolp) | |
2803 (< (- point beg) (length quoted))) | |
2804 ;; break inside the cite prefix. | |
2805 (setq quoted nil | |
2806 end nil)) | |
2807 (if quoted | |
2808 (progn | |
2809 (forward-line 1) | |
2810 (while (and (not (eobp)) | |
2811 (not (looking-at paragraph-separate)) | |
2812 (looking-at message-cite-prefix-regexp) | |
2813 (equal quoted (match-string 0))) | |
2814 (goto-char (match-end 0)) | |
2815 (looking-at "[ \t]*") | |
2816 (if (> (length leading-space) (length (match-string 0))) | |
2817 (setq leading-space (match-string 0))) | |
2818 (forward-line 1)) | |
2819 (setq end (point)) | |
2820 (goto-char beg) | |
2821 (while (and (if (bobp) nil (forward-line -1) t) | |
2822 (not (looking-at paragraph-start)) | |
2823 (looking-at message-cite-prefix-regexp) | |
2824 (equal quoted (match-string 0))) | |
2825 (setq beg (point)) | |
2826 (goto-char (match-end 0)) | |
2827 (looking-at "[ \t]*") | |
2828 (if (> (length leading-space) (length (match-string 0))) | |
2829 (setq leading-space (match-string 0))))) | |
2830 (while (and (not (eobp)) | |
2831 (not (looking-at paragraph-separate)) | |
2832 (not (looking-at message-cite-prefix-regexp))) | |
2833 (forward-line 1)) | |
2834 (setq end (point)) | |
2835 (goto-char beg) | |
2836 (while (and (if (bobp) nil (forward-line -1) t) | |
2837 (not (looking-at paragraph-start)) | |
2838 (not (looking-at message-cite-prefix-regexp))) | |
2839 (setq beg (point)))) | |
1782 (goto-char point) | 2840 (goto-char point) |
1783 (forward-line 1))) | 2841 (save-restriction |
1784 | 2842 (narrow-to-region beg end) |
1785 (defun message-split-line () | 2843 (if not-break |
1786 "Split current line, moving portion beyond point vertically down. | 2844 (setq point nil) |
1787 If the current line has `message-yank-prefix', insert it on the new line." | 2845 (if bolp |
1788 (interactive "*") | 2846 (newline) |
1789 (split-line message-yank-prefix)) | 2847 (newline) |
2848 (newline)) | |
2849 (setq point (point)) | |
2850 ;; (newline 2) doesn't mark both newline's as hard, so call | |
2851 ;; newline twice. -jas | |
2852 (newline) | |
2853 (newline) | |
2854 (delete-region (point) (re-search-forward "[ \t]*")) | |
2855 (when (and quoted (not bolp)) | |
2856 (insert quoted leading-space))) | |
2857 (undo-boundary) | |
2858 (if quoted | |
2859 (let* ((adaptive-fill-regexp | |
2860 (regexp-quote (concat quoted leading-space))) | |
2861 (adaptive-fill-first-line-regexp | |
2862 adaptive-fill-regexp )) | |
2863 (fill-paragraph arg)) | |
2864 (fill-paragraph arg)) | |
2865 (if point (goto-char point))))) | |
2866 | |
2867 (defun message-fill-paragraph (&optional arg) | |
2868 "Like `fill-paragraph'." | |
2869 (interactive (list (if current-prefix-arg 'full))) | |
2870 (if (if (boundp 'filladapt-mode) filladapt-mode) | |
2871 nil | |
2872 (message-newline-and-reformat arg t) | |
2873 t)) | |
2874 | |
2875 ;; Is it better to use `mail-header-end'? | |
2876 (defun message-point-in-header-p () | |
2877 "Return t if point is in the header." | |
2878 (save-excursion | |
2879 (let ((p (point))) | |
2880 (goto-char (point-min)) | |
2881 (not (re-search-forward | |
2882 (concat "^" (regexp-quote mail-header-separator) "\n") | |
2883 p t))))) | |
2884 | |
2885 (defun message-do-auto-fill () | |
2886 "Like `do-auto-fill', but don't fill in message header." | |
2887 (unless (message-point-in-header-p) | |
2888 (do-auto-fill))) | |
1790 | 2889 |
1791 (defun message-insert-signature (&optional force) | 2890 (defun message-insert-signature (&optional force) |
1792 "Insert a signature. See documentation for variable `message-signature'." | 2891 "Insert a signature. See documentation for variable `message-signature'." |
1793 (interactive (list 0)) | 2892 (interactive (list 0)) |
1794 (let* ((signature | 2893 (let* ((signature |
1799 (goto-char (point-max)) | 2898 (goto-char (point-max)) |
1800 (not (re-search-backward message-signature-separator nil t)))) | 2899 (not (re-search-backward message-signature-separator nil t)))) |
1801 ((and (null message-signature) | 2900 ((and (null message-signature) |
1802 force) | 2901 force) |
1803 t) | 2902 t) |
1804 ((message-functionp message-signature) | 2903 ((functionp message-signature) |
1805 (funcall message-signature)) | 2904 (funcall message-signature)) |
1806 ((listp message-signature) | 2905 ((listp message-signature) |
1807 (eval message-signature)) | 2906 (eval message-signature)) |
1808 (t message-signature))) | 2907 (t message-signature))) |
1809 (signature | 2908 (signature |
1816 (when signature | 2915 (when signature |
1817 (goto-char (point-max)) | 2916 (goto-char (point-max)) |
1818 ;; Insert the signature. | 2917 ;; Insert the signature. |
1819 (unless (bolp) | 2918 (unless (bolp) |
1820 (insert "\n")) | 2919 (insert "\n")) |
1821 (insert "\n-- \n") | 2920 (when message-signature-insert-empty-line |
2921 (insert "\n")) | |
2922 (insert "-- \n") | |
1822 (if (eq signature t) | 2923 (if (eq signature t) |
1823 (insert-file-contents message-signature-file) | 2924 (insert-file-contents message-signature-file) |
1824 (insert signature)) | 2925 (insert signature)) |
1825 (goto-char (point-max)) | 2926 (goto-char (point-max)) |
1826 (or (bolp) (insert "\n"))))) | 2927 (or (bolp) (insert "\n"))))) |
2928 | |
2929 (defun message-insert-importance-high () | |
2930 "Insert header to mark message as important." | |
2931 (interactive) | |
2932 (save-excursion | |
2933 (save-restriction | |
2934 (message-narrow-to-headers) | |
2935 (message-remove-header "Importance")) | |
2936 (message-goto-eoh) | |
2937 (insert "Importance: high\n"))) | |
2938 | |
2939 (defun message-insert-importance-low () | |
2940 "Insert header to mark message as unimportant." | |
2941 (interactive) | |
2942 (save-excursion | |
2943 (save-restriction | |
2944 (message-narrow-to-headers) | |
2945 (message-remove-header "Importance")) | |
2946 (message-goto-eoh) | |
2947 (insert "Importance: low\n"))) | |
2948 | |
2949 (defun message-insert-or-toggle-importance () | |
2950 "Insert a \"Importance: high\" header, or cycle through the header values. | |
2951 The three allowed values according to RFC 1327 are `high', `normal' | |
2952 and `low'." | |
2953 (interactive) | |
2954 (save-excursion | |
2955 (let ((valid '("high" "normal" "low")) | |
2956 (new "high") | |
2957 cur) | |
2958 (save-restriction | |
2959 (message-narrow-to-headers) | |
2960 (when (setq cur (message-fetch-field "Importance")) | |
2961 (message-remove-header "Importance") | |
2962 (setq new (cond ((string= cur "high") | |
2963 "low") | |
2964 ((string= cur "low") | |
2965 "normal") | |
2966 (t | |
2967 "high"))))) | |
2968 (message-goto-eoh) | |
2969 (insert (format "Importance: %s\n" new))))) | |
2970 | |
2971 (defun message-insert-disposition-notification-to () | |
2972 "Request a disposition notification (return receipt) to this message. | |
2973 Note that this should not be used in newsgroups." | |
2974 (interactive) | |
2975 (save-excursion | |
2976 (save-restriction | |
2977 (message-narrow-to-headers) | |
2978 (message-remove-header "Disposition-Notification-To")) | |
2979 (message-goto-eoh) | |
2980 (insert (format "Disposition-Notification-To: %s\n" | |
2981 (or (message-field-value "Reply-to") | |
2982 (message-field-value "From") | |
2983 (message-make-from)))))) | |
1827 | 2984 |
1828 (defun message-elide-region (b e) | 2985 (defun message-elide-region (b e) |
1829 "Elide the text in the region. | 2986 "Elide the text in the region. |
1830 An ellipsis (from `message-elide-ellipsis') will be inserted where the | 2987 An ellipsis (from `message-elide-ellipsis') will be inserted where the |
1831 text was killed." | 2988 text was killed." |
1843 (max (point) (or (mark t) (point))) | 3000 (max (point) (or (mark t) (point))) |
1844 (when current-prefix-arg | 3001 (when current-prefix-arg |
1845 (prefix-numeric-value current-prefix-arg)))) | 3002 (prefix-numeric-value current-prefix-arg)))) |
1846 | 3003 |
1847 (setq n (if (numberp n) (mod n 26) 13)) ;canonize N | 3004 (setq n (if (numberp n) (mod n 26) 13)) ;canonize N |
1848 (unless (or (zerop n) ; no action needed for a rot of 0 | 3005 (unless (or (zerop n) ; no action needed for a rot of 0 |
1849 (= b e)) ; no region to rotate | 3006 (= b e)) ; no region to rotate |
1850 ;; We build the table, if necessary. | 3007 ;; We build the table, if necessary. |
1851 (when (or (not message-caesar-translation-table) | 3008 (when (or (not message-caesar-translation-table) |
1852 (/= (aref message-caesar-translation-table ?a) (+ ?a n))) | 3009 (/= (aref message-caesar-translation-table ?a) (+ ?a n))) |
1853 (setq message-caesar-translation-table | 3010 (setq message-caesar-translation-table |
1886 (defun message-pipe-buffer-body (program) | 3043 (defun message-pipe-buffer-body (program) |
1887 "Pipe the message body in the current buffer through PROGRAM." | 3044 "Pipe the message body in the current buffer through PROGRAM." |
1888 (save-excursion | 3045 (save-excursion |
1889 (save-restriction | 3046 (save-restriction |
1890 (when (message-goto-body) | 3047 (when (message-goto-body) |
1891 (narrow-to-region (point) (point-max))) | 3048 (narrow-to-region (point) (point-max))) |
1892 (shell-command-on-region | 3049 (shell-command-on-region |
1893 (point-min) (point-max) program nil t)))) | 3050 (point-min) (point-max) program nil t)))) |
1894 | 3051 |
1895 (defun message-rename-buffer (&optional enter-string) | 3052 (defun message-rename-buffer (&optional enter-string) |
1896 "Rename the *message* buffer to \"*message* RECIPIENT\". | 3053 "Rename the *message* buffer to \"*message* RECIPIENT\". |
1966 (if (null message-yank-prefix) | 3123 (if (null message-yank-prefix) |
1967 (indent-rigidly start (mark t) message-indentation-spaces) | 3124 (indent-rigidly start (mark t) message-indentation-spaces) |
1968 (save-excursion | 3125 (save-excursion |
1969 (goto-char start) | 3126 (goto-char start) |
1970 (while (< (point) (mark t)) | 3127 (while (< (point) (mark t)) |
1971 (insert message-yank-prefix) | 3128 (if (or (looking-at ">") (looking-at "^$")) |
3129 (insert message-yank-cited-prefix) | |
3130 (insert message-yank-prefix)) | |
1972 (forward-line 1)))) | 3131 (forward-line 1)))) |
1973 (goto-char start))) | 3132 (goto-char start))) |
1974 | 3133 |
1975 (defun message-yank-original (&optional arg) | 3134 (defun message-yank-original (&optional arg) |
1976 "Insert the message being replied to, if any. | 3135 "Insert the message being replied to, if any. |
1997 (setq message-checksum (message-checksum)))))) | 3156 (setq message-checksum (message-checksum)))))) |
1998 | 3157 |
1999 (defun message-yank-buffer (buffer) | 3158 (defun message-yank-buffer (buffer) |
2000 "Insert BUFFER into the current buffer and quote it." | 3159 "Insert BUFFER into the current buffer and quote it." |
2001 (interactive "bYank buffer: ") | 3160 (interactive "bYank buffer: ") |
2002 (let ((message-reply-buffer buffer)) | 3161 (let ((message-reply-buffer (get-buffer buffer))) |
2003 (save-window-excursion | 3162 (save-window-excursion |
2004 (message-yank-original)))) | 3163 (message-yank-original)))) |
2005 | 3164 |
2006 (defun message-buffers () | 3165 (defun message-buffers () |
2007 "Return a list of active message buffers." | 3166 "Return a list of active message buffers." |
2014 (push (buffer-name buffer) buffers)))) | 3173 (push (buffer-name buffer) buffers)))) |
2015 (nreverse buffers))) | 3174 (nreverse buffers))) |
2016 | 3175 |
2017 (defun message-cite-original-without-signature () | 3176 (defun message-cite-original-without-signature () |
2018 "Cite function in the standard Message manner." | 3177 "Cite function in the standard Message manner." |
2019 (let ((start (point)) | 3178 (let* ((start (point)) |
2020 (end (mark t)) | 3179 (end (mark t)) |
2021 (functions | 3180 (functions |
2022 (when message-indent-citation-function | 3181 (when message-indent-citation-function |
2023 (if (listp message-indent-citation-function) | 3182 (if (listp message-indent-citation-function) |
2024 message-indent-citation-function | 3183 message-indent-citation-function |
2025 (list message-indent-citation-function))))) | 3184 (list message-indent-citation-function)))) |
3185 ;; This function may be called by `gnus-summary-yank-message' and | |
3186 ;; may insert a different article from the original. So, we will | |
3187 ;; modify the value of `message-reply-headers' with that article. | |
3188 (message-reply-headers | |
3189 (save-restriction | |
3190 (narrow-to-region start end) | |
3191 (message-narrow-to-head-1) | |
3192 (vector 0 | |
3193 (or (message-fetch-field "subject") "none") | |
3194 (message-fetch-field "from") | |
3195 (message-fetch-field "date") | |
3196 (message-fetch-field "message-id" t) | |
3197 (message-fetch-field "references") | |
3198 0 0 "")))) | |
2026 (mml-quote-region start end) | 3199 (mml-quote-region start end) |
2027 ;; Allow undoing. | 3200 ;; Allow undoing. |
2028 (undo-boundary) | 3201 (undo-boundary) |
2029 (goto-char end) | 3202 (goto-char end) |
2030 (when (re-search-backward message-signature-separator start t) | 3203 (when (re-search-backward message-signature-separator start t) |
2043 (when message-citation-line-function | 3216 (when message-citation-line-function |
2044 (unless (bolp) | 3217 (unless (bolp) |
2045 (insert "\n")) | 3218 (insert "\n")) |
2046 (funcall message-citation-line-function)))) | 3219 (funcall message-citation-line-function)))) |
2047 | 3220 |
2048 (eval-when-compile (defvar mail-citation-hook)) ;Compiler directive | 3221 (eval-when-compile (defvar mail-citation-hook)) ;Compiler directive |
2049 (defun message-cite-original () | 3222 (defun message-cite-original () |
2050 "Cite function in the standard Message manner." | 3223 "Cite function in the standard Message manner." |
2051 (if (and (boundp 'mail-citation-hook) | 3224 (if (and (boundp 'mail-citation-hook) |
2052 mail-citation-hook) | 3225 mail-citation-hook) |
2053 (run-hooks 'mail-citation-hook) | 3226 (run-hooks 'mail-citation-hook) |
2054 (let ((start (point)) | 3227 (let* ((start (point)) |
2055 (end (mark t)) | 3228 (end (mark t)) |
2056 (functions | 3229 (functions |
2057 (when message-indent-citation-function | 3230 (when message-indent-citation-function |
2058 (if (listp message-indent-citation-function) | 3231 (if (listp message-indent-citation-function) |
2059 message-indent-citation-function | 3232 message-indent-citation-function |
2060 (list message-indent-citation-function))))) | 3233 (list message-indent-citation-function)))) |
3234 ;; This function may be called by `gnus-summary-yank-message' and | |
3235 ;; may insert a different article from the original. So, we will | |
3236 ;; modify the value of `message-reply-headers' with that article. | |
3237 (message-reply-headers | |
3238 (save-restriction | |
3239 (narrow-to-region start end) | |
3240 (message-narrow-to-head-1) | |
3241 (vector 0 | |
3242 (or (message-fetch-field "subject") "none") | |
3243 (message-fetch-field "from") | |
3244 (message-fetch-field "date") | |
3245 (message-fetch-field "message-id" t) | |
3246 (message-fetch-field "references") | |
3247 0 0 "")))) | |
2061 (mml-quote-region start end) | 3248 (mml-quote-region start end) |
2062 (goto-char start) | 3249 (goto-char start) |
2063 (while functions | 3250 (while functions |
2064 (funcall (pop functions))) | 3251 (funcall (pop functions))) |
2065 (when message-citation-line-function | 3252 (when message-citation-line-function |
2142 (message-bury buf))) | 3329 (message-bury buf))) |
2143 (message-do-actions actions) | 3330 (message-do-actions actions) |
2144 t))) | 3331 t))) |
2145 | 3332 |
2146 (defun message-dont-send () | 3333 (defun message-dont-send () |
2147 "Don't send the message you have been editing." | 3334 "Don't send the message you have been editing. |
3335 Instead, just auto-save the buffer and then bury it." | |
2148 (interactive) | 3336 (interactive) |
2149 (set-buffer-modified-p t) | 3337 (set-buffer-modified-p t) |
2150 (save-buffer) | 3338 (save-buffer) |
2151 (let ((actions message-postpone-actions)) | 3339 (let ((actions message-postpone-actions)) |
2152 (message-bury (current-buffer)) | 3340 (message-bury (current-buffer)) |
2155 (defun message-kill-buffer () | 3343 (defun message-kill-buffer () |
2156 "Kill the current buffer." | 3344 "Kill the current buffer." |
2157 (interactive) | 3345 (interactive) |
2158 (when (or (not (buffer-modified-p)) | 3346 (when (or (not (buffer-modified-p)) |
2159 (yes-or-no-p "Message modified; kill anyway? ")) | 3347 (yes-or-no-p "Message modified; kill anyway? ")) |
2160 (let ((actions message-kill-actions)) | 3348 (let ((actions message-kill-actions) |
3349 (draft-article message-draft-article) | |
3350 (auto-save-file-name buffer-auto-save-file-name) | |
3351 (file-name buffer-file-name) | |
3352 (modified (buffer-modified-p))) | |
2161 (setq buffer-file-name nil) | 3353 (setq buffer-file-name nil) |
2162 (kill-buffer (current-buffer)) | 3354 (kill-buffer (current-buffer)) |
3355 (when (and (or (and auto-save-file-name | |
3356 (file-exists-p auto-save-file-name)) | |
3357 (and file-name | |
3358 (file-exists-p file-name))) | |
3359 (yes-or-no-p (format "Remove the backup file%s? " | |
3360 (if modified " too" "")))) | |
3361 (ignore-errors | |
3362 (delete-file auto-save-file-name)) | |
3363 (let ((message-draft-article draft-article)) | |
3364 (message-disassociate-draft))) | |
2163 (message-do-actions actions)))) | 3365 (message-do-actions actions)))) |
2164 | 3366 |
2165 (defun message-bury (buffer) | 3367 (defun message-bury (buffer) |
2166 "Bury this mail BUFFER." | 3368 "Bury this mail BUFFER." |
2167 (let ((newbuf (other-buffer buffer))) | 3369 (let ((newbuf (other-buffer buffer))) |
2188 (message-fix-before-sending) | 3390 (message-fix-before-sending) |
2189 (run-hooks 'message-send-hook) | 3391 (run-hooks 'message-send-hook) |
2190 (message message-sending-message) | 3392 (message message-sending-message) |
2191 (let ((alist message-send-method-alist) | 3393 (let ((alist message-send-method-alist) |
2192 (success t) | 3394 (success t) |
2193 elem sent) | 3395 elem sent dont-barf-on-no-method |
3396 (message-options message-options)) | |
3397 (message-options-set-recipient) | |
2194 (while (and success | 3398 (while (and success |
2195 (setq elem (pop alist))) | 3399 (setq elem (pop alist))) |
2196 (when (funcall (cadr elem)) | 3400 (when (funcall (cadr elem)) |
2197 (when (and (or (not (memq (car elem) | 3401 (when (and (or (not (memq (car elem) |
2198 message-sent-message-via)) | 3402 message-sent-message-via)) |
2199 (y-or-n-p | 3403 (message-fetch-field "supersedes") |
2200 (format | 3404 (if (or (message-gnksa-enable-p 'multiple-copies) |
2201 "Already sent message via %s; resend? " | 3405 (not (eq (car elem) 'news))) |
2202 (car elem)))) | 3406 (y-or-n-p |
3407 (format | |
3408 "Already sent message via %s; resend? " | |
3409 (car elem))) | |
3410 (error "Denied posting -- multiple copies"))) | |
2203 (setq success (funcall (caddr elem) arg))) | 3411 (setq success (funcall (caddr elem) arg))) |
2204 (setq sent t)))) | 3412 (setq sent t)))) |
2205 (unless (or sent (not success)) | 3413 (unless (or sent |
3414 (not success) | |
3415 (let ((fcc (message-fetch-field "Fcc")) | |
3416 (gcc (message-fetch-field "Gcc"))) | |
3417 (when (or fcc gcc) | |
3418 (or (eq message-allow-no-recipients 'always) | |
3419 (and (not (eq message-allow-no-recipients 'never)) | |
3420 (setq dont-barf-on-no-method | |
3421 (gnus-y-or-n-p | |
3422 (format "No receiver, perform %s anyway? " | |
3423 (cond ((and fcc gcc) "Fcc and Gcc") | |
3424 (fcc "Fcc") | |
3425 (t "Gcc")))))))))) | |
2206 (error "No methods specified to send by")) | 3426 (error "No methods specified to send by")) |
2207 (when (and success sent) | 3427 (when (or dont-barf-on-no-method |
3428 (and success sent)) | |
2208 (message-do-fcc) | 3429 (message-do-fcc) |
2209 (save-excursion | 3430 (save-excursion |
2210 (run-hooks 'message-sent-hook)) | 3431 (run-hooks 'message-sent-hook)) |
2211 (message "Sending...done") | 3432 (message "Sending...done") |
2212 ;; Mark the buffer as unmodified and delete auto-save. | 3433 ;; Mark the buffer as unmodified and delete auto-save. |
2234 ,@forms))) | 3455 ,@forms))) |
2235 | 3456 |
2236 (put 'message-check 'lisp-indent-function 1) | 3457 (put 'message-check 'lisp-indent-function 1) |
2237 (put 'message-check 'edebug-form-spec '(form body)) | 3458 (put 'message-check 'edebug-form-spec '(form body)) |
2238 | 3459 |
3460 (defun message-text-with-property (prop) | |
3461 "Return a list of all points where the text has PROP." | |
3462 (let ((points nil) | |
3463 (point (point-min))) | |
3464 (save-excursion | |
3465 (while (< point (point-max)) | |
3466 (when (get-text-property point prop) | |
3467 (push point points)) | |
3468 (incf point))) | |
3469 (nreverse points))) | |
3470 | |
2239 (defun message-fix-before-sending () | 3471 (defun message-fix-before-sending () |
2240 "Do various things to make the message nice before sending it." | 3472 "Do various things to make the message nice before sending it." |
2241 ;; Make sure there's a newline at the end of the message. | 3473 ;; Make sure there's a newline at the end of the message. |
2242 (goto-char (point-max)) | 3474 (goto-char (point-max)) |
2243 (unless (bolp) | 3475 (unless (bolp) |
2244 (insert "\n")) | 3476 (insert "\n")) |
2245 ;; Delete all invisible text. | 3477 ;; Make the hidden headers visible. |
3478 (let ((points (message-text-with-property 'message-hidden))) | |
3479 (when points | |
3480 (goto-char (car points)) | |
3481 (dolist (point points) | |
3482 (add-text-properties point (1+ point) | |
3483 '(invisible nil intangible nil))))) | |
3484 ;; Make invisible text visible. | |
3485 ;; It doesn't seem as if this is useful, since the invisible property | |
3486 ;; is clobbered by an after-change hook anyhow. | |
2246 (message-check 'invisible-text | 3487 (message-check 'invisible-text |
2247 (when (text-property-any (point-min) (point-max) 'invisible t) | 3488 (let ((points (message-text-with-property 'invisible))) |
2248 (put-text-property (point-min) (point-max) 'invisible nil) | 3489 (when points |
2249 (unless (yes-or-no-p | 3490 (goto-char (car points)) |
2250 "Invisible text found and made visible; continue posting? ") | 3491 (dolist (point points) |
2251 (error "Invisible text found and made visible"))))) | 3492 (put-text-property point (1+ point) 'invisible nil) |
3493 (message-overlay-put (message-make-overlay point (1+ point)) | |
3494 'face 'highlight)) | |
3495 (unless (yes-or-no-p | |
3496 "Invisible text found and made visible; continue sending? ") | |
3497 (error "Invisible text found and made visible"))))) | |
3498 (message-check 'illegible-text | |
3499 (let (found choice) | |
3500 (message-goto-body) | |
3501 (skip-chars-forward mm-7bit-chars) | |
3502 (while (not (eobp)) | |
3503 (when (let ((char (char-after))) | |
3504 (or (< (mm-char-int char) 128) | |
3505 (and (mm-multibyte-p) | |
3506 (memq (char-charset char) | |
3507 '(eight-bit-control eight-bit-graphic | |
3508 control-1)) | |
3509 (not (get-text-property | |
3510 (point) 'untranslated-utf-8))))) | |
3511 (message-overlay-put (message-make-overlay (point) (1+ (point))) | |
3512 'face 'highlight) | |
3513 (setq found t)) | |
3514 (forward-char) | |
3515 (skip-chars-forward mm-7bit-chars)) | |
3516 (when found | |
3517 (setq choice | |
3518 (gnus-multiple-choice | |
3519 "Non-printable characters found. Continue sending?" | |
3520 '((?d "Remove non-printable characters and send") | |
3521 (?r "Replace non-printable characters with dots and send") | |
3522 (?i "Ignore non-printable characters and send") | |
3523 (?e "Continue editing")))) | |
3524 (if (eq choice ?e) | |
3525 (error "Non-printable characters")) | |
3526 (message-goto-body) | |
3527 (skip-chars-forward mm-7bit-chars) | |
3528 (while (not (eobp)) | |
3529 (when (let ((char (char-after))) | |
3530 (or (< (mm-char-int char) 128) | |
3531 (and (mm-multibyte-p) | |
3532 ;; Fixme: Wrong for Emacs 22 and for things | |
3533 ;; like undecable utf-8. Should at least | |
3534 ;; use find-coding-systems-region. | |
3535 (memq (char-charset char) | |
3536 '(eight-bit-control eight-bit-graphic | |
3537 control-1)) | |
3538 (not (get-text-property | |
3539 (point) 'untranslated-utf-8))))) | |
3540 (if (eq choice ?i) | |
3541 (message-kill-all-overlays) | |
3542 (delete-char 1) | |
3543 (when (eq choice ?r) | |
3544 (insert ".")))) | |
3545 (forward-char) | |
3546 (skip-chars-forward mm-7bit-chars)))))) | |
2252 | 3547 |
2253 (defun message-add-action (action &rest types) | 3548 (defun message-add-action (action &rest types) |
2254 "Add ACTION to be performed when doing an exit of type TYPES." | 3549 "Add ACTION to be performed when doing an exit of type TYPES." |
3550 (while types | |
3551 (add-to-list (intern (format "message-%s-actions" (pop types))) | |
3552 action))) | |
3553 | |
3554 (defun message-delete-action (action &rest types) | |
3555 "Delete ACTION from lists of actions performed when doing an exit of type TYPES." | |
2255 (let (var) | 3556 (let (var) |
2256 (while types | 3557 (while types |
2257 (set (setq var (intern (format "message-%s-actions" (pop types)))) | 3558 (set (setq var (intern (format "message-%s-actions" (pop types)))) |
2258 (nconc (symbol-value var) (list action)))))) | 3559 (delq action (symbol-value var)))))) |
2259 | 3560 |
2260 (defun message-do-actions (actions) | 3561 (defun message-do-actions (actions) |
2261 "Perform all actions in ACTIONS." | 3562 "Perform all actions in ACTIONS." |
2262 ;; Now perform actions on successful sending. | 3563 ;; Now perform actions on successful sending. |
2263 (while actions | 3564 (while actions |
2264 (ignore-errors | 3565 (ignore-errors |
2265 (cond | 3566 (cond |
2266 ;; A simple function. | 3567 ;; A simple function. |
2267 ((message-functionp (car actions)) | 3568 ((functionp (car actions)) |
2268 (funcall (car actions))) | 3569 (funcall (car actions))) |
2269 ;; Something to be evaled. | 3570 ;; Something to be evaled. |
2270 (t | 3571 (t |
2271 (eval (car actions))))) | 3572 (eval (car actions))))) |
2272 (pop actions))) | 3573 (pop actions))) |
2273 | 3574 |
2274 (defun message-send-mail-partially () | 3575 (defun message-send-mail-partially () |
2275 "Sendmail as message/partial." | 3576 "Send mail as message/partial." |
2276 ;; replace the header delimiter with a blank line | 3577 ;; replace the header delimiter with a blank line |
2277 (goto-char (point-min)) | 3578 (goto-char (point-min)) |
2278 (re-search-forward | 3579 (re-search-forward |
2279 (concat "^" (regexp-quote mail-header-separator) "\n")) | 3580 (concat "^" (regexp-quote mail-header-separator) "\n")) |
2280 (replace-match "\n") | 3581 (replace-match "\n") |
2318 (message-remove-header "Content-Transfer-Encoding") | 3619 (message-remove-header "Content-Transfer-Encoding") |
2319 (message-remove-header "Message-ID") | 3620 (message-remove-header "Message-ID") |
2320 (message-remove-header "Lines") | 3621 (message-remove-header "Lines") |
2321 (goto-char (point-max)) | 3622 (goto-char (point-max)) |
2322 (insert "Mime-Version: 1.0\n") | 3623 (insert "Mime-Version: 1.0\n") |
2323 (setq header (buffer-substring (point-min) (point-max)))) | 3624 (setq header (buffer-string))) |
2324 (goto-char (point-max)) | 3625 (goto-char (point-max)) |
2325 (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n" | 3626 (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n" |
2326 id n total)) | 3627 id n total)) |
3628 (forward-char -1) | |
2327 (let ((mail-header-separator "")) | 3629 (let ((mail-header-separator "")) |
2328 (when (memq 'Message-ID message-required-mail-headers) | 3630 (when (memq 'Message-ID message-required-mail-headers) |
2329 (insert "Message-ID: " (message-make-message-id) "\n")) | 3631 (insert "Message-ID: " (message-make-message-id) "\n")) |
2330 (when (memq 'Lines message-required-mail-headers) | 3632 (when (memq 'Lines message-required-mail-headers) |
2331 (let ((mail-header-separator "")) | 3633 (insert "Lines: " (message-make-lines) "\n")) |
2332 (insert "Lines: " (message-make-lines) "\n"))) | |
2333 (message-goto-subject) | 3634 (message-goto-subject) |
2334 (end-of-line) | 3635 (end-of-line) |
2335 (insert (format " (%d/%d)" n total)) | 3636 (insert (format " (%d/%d)" n total)) |
2336 (goto-char (point-max)) | |
2337 (insert "\n") | |
2338 (widen) | 3637 (widen) |
2339 (mm-with-unibyte-current-buffer | 3638 (mm-with-unibyte-current-buffer |
2340 (funcall message-send-mail-function))) | 3639 (funcall (or message-send-mail-real-function |
3640 message-send-mail-function)))) | |
2341 (setq n (+ n 1)) | 3641 (setq n (+ n 1)) |
2342 (setq p (pop plist)) | 3642 (setq p (pop plist)) |
2343 (erase-buffer))) | 3643 (erase-buffer))) |
2344 (kill-buffer tembuf)))) | 3644 (kill-buffer tembuf)))) |
2345 | 3645 |
2351 (mailbuf (current-buffer)) | 3651 (mailbuf (current-buffer)) |
2352 (message-this-is-mail t) | 3652 (message-this-is-mail t) |
2353 (message-posting-charset | 3653 (message-posting-charset |
2354 (if (fboundp 'gnus-setup-posting-charset) | 3654 (if (fboundp 'gnus-setup-posting-charset) |
2355 (gnus-setup-posting-charset nil) | 3655 (gnus-setup-posting-charset nil) |
2356 message-posting-charset))) | 3656 message-posting-charset)) |
3657 (headers message-required-mail-headers)) | |
2357 (save-restriction | 3658 (save-restriction |
2358 (message-narrow-to-headers) | 3659 (message-narrow-to-headers) |
3660 ;; Generate the Mail-Followup-To header if the header is not there... | |
3661 (if (and (message-subscribed-p) | |
3662 (not (mail-fetch-field "mail-followup-to"))) | |
3663 (setq headers | |
3664 (cons | |
3665 (cons "Mail-Followup-To" (message-make-mail-followup-to)) | |
3666 message-required-mail-headers)) | |
3667 ;; otherwise, delete the MFT header if the field is empty | |
3668 (when (equal "" (mail-fetch-field "mail-followup-to")) | |
3669 (message-remove-header "^Mail-Followup-To:"))) | |
2359 ;; Insert some headers. | 3670 ;; Insert some headers. |
2360 (let ((message-deletable-headers | 3671 (let ((message-deletable-headers |
2361 (if news nil message-deletable-headers))) | 3672 (if news nil message-deletable-headers))) |
2362 (message-generate-headers message-required-mail-headers)) | 3673 (message-generate-headers headers)) |
2363 ;; Let the user do all of the above. | 3674 ;; Let the user do all of the above. |
2364 (run-hooks 'message-header-hook)) | 3675 (run-hooks 'message-header-hook)) |
2365 (unwind-protect | 3676 (unwind-protect |
2366 (save-excursion | 3677 (save-excursion |
2367 (set-buffer tembuf) | 3678 (set-buffer tembuf) |
2368 (erase-buffer) | 3679 (erase-buffer) |
2369 ;; Avoid copying text props. | 3680 ;; Avoid copying text props (except hard newlines). |
2370 (insert (with-current-buffer mailbuf | 3681 (insert (with-current-buffer mailbuf |
2371 (buffer-substring-no-properties (point-min) (point-max)))) | 3682 (mml-buffer-substring-no-properties-except-hard-newlines |
3683 (point-min) (point-max)))) | |
2372 ;; Remove some headers. | 3684 ;; Remove some headers. |
2373 (message-encode-message-body) | 3685 (message-encode-message-body) |
2374 (save-restriction | 3686 (save-restriction |
2375 (message-narrow-to-headers) | 3687 (message-narrow-to-headers) |
2376 ;; We (re)generate the Lines header. | 3688 ;; We (re)generate the Lines header. |
2382 (mail-encode-encoded-word-buffer))) | 3694 (mail-encode-encoded-word-buffer))) |
2383 (goto-char (point-max)) | 3695 (goto-char (point-max)) |
2384 ;; require one newline at the end. | 3696 ;; require one newline at the end. |
2385 (or (= (preceding-char) ?\n) | 3697 (or (= (preceding-char) ?\n) |
2386 (insert ?\n)) | 3698 (insert ?\n)) |
3699 (message-cleanup-headers) | |
3700 ;; FIXME: we're inserting the courtesy copy after encoding. | |
3701 ;; This is wrong if the courtesy copy string contains | |
3702 ;; non-ASCII characters. -- jh | |
2387 (when | 3703 (when |
2388 (save-restriction | 3704 (save-restriction |
2389 (message-narrow-to-headers) | 3705 (message-narrow-to-headers) |
2390 (and news | 3706 (and news |
2391 (or (message-fetch-field "cc") | 3707 (or (message-fetch-field "cc") |
3708 (message-fetch-field "bcc") | |
2392 (message-fetch-field "to")) | 3709 (message-fetch-field "to")) |
2393 (let ((content-type (message-fetch-field "content-type"))) | 3710 (let ((content-type (message-fetch-field |
2394 (or | 3711 "content-type"))) |
2395 (not content-type) | 3712 (and |
2396 (string= "text/plain" | 3713 (or |
2397 (car | 3714 (not content-type) |
2398 (mail-header-parse-content-type | 3715 (string= "text/plain" |
2399 content-type))))))) | 3716 (car |
3717 (mail-header-parse-content-type | |
3718 content-type)))) | |
3719 (not | |
3720 (string= "base64" | |
3721 (message-fetch-field | |
3722 "content-transfer-encoding"))))))) | |
2400 (message-insert-courtesy-copy)) | 3723 (message-insert-courtesy-copy)) |
2401 (if (or (not message-send-mail-partially-limit) | 3724 (if (or (not message-send-mail-partially-limit) |
2402 (< (point-max) message-send-mail-partially-limit) | 3725 (< (point-max) message-send-mail-partially-limit) |
2403 (not (y-or-n-p "The message size is too large, should it be sent partially? "))) | 3726 (not (message-y-or-n-p |
3727 "The message size is too large, split? " | |
3728 t | |
3729 "\ | |
3730 The message size, " | |
3731 (/ (point-max) 1000) "KB, is too large. | |
3732 | |
3733 Some mail gateways (MTA's) bounce large messages. To avoid the | |
3734 problem, answer `y', and the message will be split into several | |
3735 smaller pieces, the size of each is about " | |
3736 (/ message-send-mail-partially-limit 1000) | |
3737 "KB except the last | |
3738 one. | |
3739 | |
3740 However, some mail readers (MUA's) can't read split messages, i.e., | |
3741 mails in message/partially format. Answer `n', and the message will be | |
3742 sent in one piece. | |
3743 | |
3744 The size limit is controlled by `message-send-mail-partially-limit'. | |
3745 If you always want Gnus to send messages in one piece, set | |
3746 `message-send-mail-partially-limit' to nil. | |
3747 "))) | |
2404 (mm-with-unibyte-current-buffer | 3748 (mm-with-unibyte-current-buffer |
2405 (funcall message-send-mail-function)) | 3749 (message "Sending via mail...") |
3750 (funcall (or message-send-mail-real-function | |
3751 message-send-mail-function))) | |
2406 (message-send-mail-partially))) | 3752 (message-send-mail-partially))) |
2407 (kill-buffer tembuf)) | 3753 (kill-buffer tembuf)) |
2408 (set-buffer mailbuf) | 3754 (set-buffer mailbuf) |
2409 (push 'mail message-sent-message-via))) | 3755 (push 'mail message-sent-message-via))) |
2410 | 3756 |
2413 (let ((errbuf (if message-interactive | 3759 (let ((errbuf (if message-interactive |
2414 (message-generate-new-buffer-clone-locals | 3760 (message-generate-new-buffer-clone-locals |
2415 " sendmail errors") | 3761 " sendmail errors") |
2416 0)) | 3762 0)) |
2417 resend-to-addresses delimline) | 3763 resend-to-addresses delimline) |
2418 (let ((case-fold-search t)) | 3764 (unwind-protect |
2419 (save-restriction | 3765 (progn |
2420 (message-narrow-to-headers) | 3766 (let ((case-fold-search t)) |
2421 (setq resend-to-addresses (message-fetch-field "resent-to"))) | 3767 (save-restriction |
2422 ;; Change header-delimiter to be what sendmail expects. | 3768 (message-narrow-to-headers) |
2423 (goto-char (point-min)) | 3769 (setq resend-to-addresses (message-fetch-field "resent-to"))) |
2424 (re-search-forward | 3770 ;; Change header-delimiter to be what sendmail expects. |
2425 (concat "^" (regexp-quote mail-header-separator) "\n")) | 3771 (goto-char (point-min)) |
2426 (replace-match "\n") | 3772 (re-search-forward |
2427 (backward-char 1) | 3773 (concat "^" (regexp-quote mail-header-separator) "\n")) |
2428 (setq delimline (point-marker)) | 3774 (replace-match "\n") |
2429 (run-hooks 'message-send-mail-hook) | 3775 (backward-char 1) |
2430 ;; Insert an extra newline if we need it to work around | 3776 (setq delimline (point-marker)) |
2431 ;; Sun's bug that swallows newlines. | 3777 (run-hooks 'message-send-mail-hook) |
2432 (goto-char (1+ delimline)) | 3778 ;; Insert an extra newline if we need it to work around |
2433 (when (eval message-mailer-swallows-blank-line) | 3779 ;; Sun's bug that swallows newlines. |
2434 (newline)) | 3780 (goto-char (1+ delimline)) |
2435 (when message-interactive | 3781 (when (eval message-mailer-swallows-blank-line) |
2436 (save-excursion | 3782 (newline)) |
2437 (set-buffer errbuf) | 3783 (when message-interactive |
2438 (erase-buffer)))) | 3784 (save-excursion |
2439 (let ((default-directory "/") | 3785 (set-buffer errbuf) |
2440 (coding-system-for-write message-send-coding-system)) | 3786 (erase-buffer)))) |
2441 (apply 'call-process-region | 3787 (let* ((default-directory "/") |
2442 (append (list (point-min) (point-max) | 3788 (coding-system-for-write message-send-coding-system) |
2443 (if (boundp 'sendmail-program) | 3789 (cpr (apply |
2444 sendmail-program | 3790 'call-process-region |
2445 "/usr/lib/sendmail") | 3791 (append |
2446 nil errbuf nil "-oi") | 3792 (list (point-min) (point-max) |
2447 ;; Always specify who from, | 3793 (if (boundp 'sendmail-program) |
2448 ;; since some systems have broken sendmails. | 3794 sendmail-program |
2449 ;; But some systems are more broken with -f, so | 3795 "/usr/lib/sendmail") |
2450 ;; we'll let users override this. | 3796 nil errbuf nil "-oi") |
2451 (if (null message-sendmail-f-is-evil) | 3797 ;; Always specify who from, |
2452 (list "-f" (message-make-address))) | 3798 ;; since some systems have broken sendmails. |
2453 ;; These mean "report errors by mail" | 3799 ;; But some systems are more broken with -f, so |
2454 ;; and "deliver in background". | 3800 ;; we'll let users override this. |
2455 (if (null message-interactive) '("-oem" "-odb")) | 3801 (if (null message-sendmail-f-is-evil) |
2456 ;; Get the addresses from the message | 3802 (list "-f" (message-sendmail-envelope-from))) |
2457 ;; unless this is a resend. | 3803 ;; These mean "report errors by mail" |
2458 ;; We must not do that for a resend | 3804 ;; and "deliver in background". |
2459 ;; because we would find the original addresses. | 3805 (if (null message-interactive) '("-oem" "-odb")) |
2460 ;; For a resend, include the specific addresses. | 3806 ;; Get the addresses from the message |
2461 (if resend-to-addresses | 3807 ;; unless this is a resend. |
2462 (list resend-to-addresses) | 3808 ;; We must not do that for a resend |
2463 '("-t"))))) | 3809 ;; because we would find the original addresses. |
2464 (when message-interactive | 3810 ;; For a resend, include the specific addresses. |
2465 (save-excursion | 3811 (if resend-to-addresses |
2466 (set-buffer errbuf) | 3812 (list resend-to-addresses) |
2467 (goto-char (point-min)) | 3813 '("-t")))))) |
2468 (while (re-search-forward "\n\n* *" nil t) | 3814 (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) |
2469 (replace-match "; ")) | 3815 (error "Sending...failed with exit value %d" cpr))) |
2470 (if (not (zerop (buffer-size))) | 3816 (when message-interactive |
2471 (error "Sending...failed to %s" | 3817 (save-excursion |
2472 (buffer-substring (point-min) (point-max))))) | 3818 (set-buffer errbuf) |
3819 (goto-char (point-min)) | |
3820 (while (re-search-forward "\n\n* *" nil t) | |
3821 (replace-match "; ")) | |
3822 (if (not (zerop (buffer-size))) | |
3823 (error "Sending...failed to %s" | |
3824 (buffer-string)))))) | |
2473 (when (bufferp errbuf) | 3825 (when (bufferp errbuf) |
2474 (kill-buffer errbuf))))) | 3826 (kill-buffer errbuf))))) |
2475 | 3827 |
2476 (defun message-send-mail-with-qmail () | 3828 (defun message-send-mail-with-qmail () |
2477 "Pass the prepared message buffer to qmail-inject. | 3829 "Pass the prepared message buffer to qmail-inject. |
2504 ;; | 3856 ;; |
2505 ;; all this is way cool coz it lets us keep the arguments entirely | 3857 ;; all this is way cool coz it lets us keep the arguments entirely |
2506 ;; free for -inject-arguments -- a big win for the user and for us | 3858 ;; free for -inject-arguments -- a big win for the user and for us |
2507 ;; since we don't have to play that double-guessing game and the user | 3859 ;; since we don't have to play that double-guessing game and the user |
2508 ;; gets full control (no gestapo'ish -f's, for instance). --sj | 3860 ;; gets full control (no gestapo'ish -f's, for instance). --sj |
2509 message-qmail-inject-args)) | 3861 (if (functionp message-qmail-inject-args) |
3862 (funcall message-qmail-inject-args) | |
3863 message-qmail-inject-args))) | |
2510 ;; qmail-inject doesn't say anything on it's stdout/stderr, | 3864 ;; qmail-inject doesn't say anything on it's stdout/stderr, |
2511 ;; we have to look at the retval instead | 3865 ;; we have to look at the retval instead |
2512 (0 nil) | 3866 (0 nil) |
2513 (1 (error "qmail-inject reported permanent failure")) | 3867 (100 (error "qmail-inject reported permanent failure")) |
2514 (111 (error "qmail-inject reported transient failure")) | 3868 (111 (error "qmail-inject reported transient failure")) |
2515 ;; should never happen | 3869 ;; should never happen |
2516 (t (error "qmail-inject reported unknown failure")))) | 3870 (t (error "qmail-inject reported unknown failure")))) |
2517 | 3871 |
2518 (defun message-send-mail-with-mh () | 3872 (defun message-send-mail-with-mh () |
2531 (pop headers)))) | 3885 (pop headers)))) |
2532 (run-hooks 'message-send-mail-hook) | 3886 (run-hooks 'message-send-mail-hook) |
2533 ;; Pass it on to mh. | 3887 ;; Pass it on to mh. |
2534 (mh-send-letter))) | 3888 (mh-send-letter))) |
2535 | 3889 |
3890 (defun message-smtpmail-send-it () | |
3891 "Send the prepared message buffer with `smtpmail-send-it'. | |
3892 This only differs from `smtpmail-send-it' that this command evaluates | |
3893 `message-send-mail-hook' just before sending a message. It is useful | |
3894 if your ISP requires the POP-before-SMTP authentication. See the Gnus | |
3895 manual for details." | |
3896 (run-hooks 'message-send-mail-hook) | |
3897 (smtpmail-send-it)) | |
3898 | |
3899 (defun message-canlock-generate () | |
3900 "Return a string that is non-trivial to guess. | |
3901 Do not use this for anything important, it is cryptographically weak." | |
3902 (require 'sha1) | |
3903 (let (sha1-maximum-internal-length) | |
3904 (sha1 (concat (message-unique-id) | |
3905 (format "%x%x%x" (random) (random t) (random)) | |
3906 (prin1-to-string (recent-keys)) | |
3907 (prin1-to-string (garbage-collect)))))) | |
3908 | |
3909 (defun message-canlock-password () | |
3910 "The password used by message for cancel locks. | |
3911 This is the value of `canlock-password', if that option is non-nil. | |
3912 Otherwise, generate and save a value for `canlock-password' first." | |
3913 (unless canlock-password | |
3914 (customize-save-variable 'canlock-password (message-canlock-generate)) | |
3915 (setq canlock-password-for-verify canlock-password)) | |
3916 canlock-password) | |
3917 | |
3918 (defun message-insert-canlock () | |
3919 (when message-insert-canlock | |
3920 (message-canlock-password) | |
3921 (canlock-insert-header))) | |
3922 | |
2536 (defun message-send-news (&optional arg) | 3923 (defun message-send-news (&optional arg) |
2537 (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) | 3924 (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) |
2538 (case-fold-search nil) | 3925 (case-fold-search nil) |
2539 (method (if (message-functionp message-post-method) | 3926 (method (if (functionp message-post-method) |
2540 (funcall message-post-method arg) | 3927 (funcall message-post-method arg) |
2541 message-post-method)) | 3928 message-post-method)) |
2542 (group-name-charset (gnus-group-name-charset method "")) | 3929 (newsgroups-field (save-restriction |
3930 (message-narrow-to-headers-or-head) | |
3931 (message-fetch-field "Newsgroups"))) | |
3932 (followup-field (save-restriction | |
3933 (message-narrow-to-headers-or-head) | |
3934 (message-fetch-field "Followup-To"))) | |
3935 ;; BUG: We really need to get the charset for each name in the | |
3936 ;; Newsgroups and Followup-To lines to allow crossposting | |
3937 ;; between group namess with incompatible character sets. | |
3938 ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08. | |
3939 (group-field-charset | |
3940 (gnus-group-name-charset method newsgroups-field)) | |
3941 (followup-field-charset | |
3942 (gnus-group-name-charset method (or followup-field ""))) | |
2543 (rfc2047-header-encoding-alist | 3943 (rfc2047-header-encoding-alist |
2544 (if group-name-charset | 3944 (append (when group-field-charset |
2545 (cons (cons "Newsgroups" group-name-charset) | 3945 (list (cons "Newsgroups" group-field-charset))) |
2546 rfc2047-header-encoding-alist) | 3946 (when followup-field-charset |
2547 rfc2047-header-encoding-alist)) | 3947 (list (cons "Followup-To" followup-field-charset))) |
3948 rfc2047-header-encoding-alist)) | |
2548 (messbuf (current-buffer)) | 3949 (messbuf (current-buffer)) |
2549 (message-syntax-checks | 3950 (message-syntax-checks |
2550 (if arg | 3951 (if (and arg |
3952 (listp message-syntax-checks)) | |
2551 (cons '(existing-newsgroups . disabled) | 3953 (cons '(existing-newsgroups . disabled) |
2552 message-syntax-checks) | 3954 message-syntax-checks) |
2553 message-syntax-checks)) | 3955 message-syntax-checks)) |
2554 (message-this-is-news t) | 3956 (message-this-is-news t) |
2555 (message-posting-charset (gnus-setup-posting-charset | 3957 (message-posting-charset |
2556 (save-restriction | 3958 (gnus-setup-posting-charset newsgroups-field)) |
2557 (message-narrow-to-headers-or-head) | |
2558 (message-fetch-field "Newsgroups")))) | |
2559 result) | 3959 result) |
2560 (if (not (message-check-news-body-syntax)) | 3960 (if (not (message-check-news-body-syntax)) |
2561 nil | 3961 nil |
2562 (save-restriction | 3962 (save-restriction |
2563 (message-narrow-to-headers) | 3963 (message-narrow-to-headers) |
2564 ;; Insert some headers. | 3964 ;; Insert some headers. |
2565 (message-generate-headers message-required-news-headers) | 3965 (message-generate-headers message-required-news-headers) |
3966 (message-insert-canlock) | |
2566 ;; Let the user do all of the above. | 3967 ;; Let the user do all of the above. |
2567 (run-hooks 'message-header-hook)) | 3968 (run-hooks 'message-header-hook)) |
2568 (if group-name-charset | 3969 ;; Note: This check will be disabled by the ".*" default value for |
2569 (setq message-syntax-checks | 3970 ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07. |
3971 (when (and group-field-charset | |
3972 (listp message-syntax-checks)) | |
3973 (setq message-syntax-checks | |
2570 (cons '(valid-newsgroups . disabled) | 3974 (cons '(valid-newsgroups . disabled) |
2571 message-syntax-checks))) | 3975 message-syntax-checks))) |
2572 (message-cleanup-headers) | 3976 (message-cleanup-headers) |
2573 (if (not (message-check-news-syntax)) | 3977 (if (not (let ((message-post-method method)) |
3978 (message-check-news-syntax))) | |
2574 nil | 3979 nil |
2575 (unwind-protect | 3980 (unwind-protect |
2576 (save-excursion | 3981 (save-excursion |
2577 (set-buffer tembuf) | 3982 (set-buffer tembuf) |
2578 (buffer-disable-undo) | 3983 (buffer-disable-undo) |
2579 (erase-buffer) | 3984 (erase-buffer) |
2580 ;; Avoid copying text props. | 3985 ;; Avoid copying text props (except hard newlines). |
2581 (insert (with-current-buffer messbuf | 3986 (insert |
2582 (buffer-substring-no-properties | 3987 (with-current-buffer messbuf |
2583 (point-min) (point-max)))) | 3988 (mml-buffer-substring-no-properties-except-hard-newlines |
3989 (point-min) (point-max)))) | |
2584 (message-encode-message-body) | 3990 (message-encode-message-body) |
2585 ;; Remove some headers. | 3991 ;; Remove some headers. |
2586 (save-restriction | 3992 (save-restriction |
2587 (message-narrow-to-headers) | 3993 (message-narrow-to-headers) |
2588 ;; We (re)generate the Lines header. | 3994 ;; We (re)generate the Lines header. |
2603 (concat "^" (regexp-quote mail-header-separator) "\n")) | 4009 (concat "^" (regexp-quote mail-header-separator) "\n")) |
2604 (replace-match "\n") | 4010 (replace-match "\n") |
2605 (backward-char 1)) | 4011 (backward-char 1)) |
2606 (run-hooks 'message-send-news-hook) | 4012 (run-hooks 'message-send-news-hook) |
2607 (gnus-open-server method) | 4013 (gnus-open-server method) |
4014 (message "Sending news via %s..." (gnus-server-string method)) | |
2608 (setq result (let ((mail-header-separator "")) | 4015 (setq result (let ((mail-header-separator "")) |
2609 (gnus-request-post method)))) | 4016 (gnus-request-post method)))) |
2610 (kill-buffer tembuf)) | 4017 (kill-buffer tembuf)) |
2611 (set-buffer messbuf) | 4018 (set-buffer messbuf) |
2612 (if result | 4019 (if result |
2663 (message-check 'subject-cmsg | 4070 (message-check 'subject-cmsg |
2664 (if (string-match "^cmsg " (message-fetch-field "subject")) | 4071 (if (string-match "^cmsg " (message-fetch-field "subject")) |
2665 (y-or-n-p | 4072 (y-or-n-p |
2666 "The control code \"cmsg\" is in the subject. Really post? ") | 4073 "The control code \"cmsg\" is in the subject. Really post? ") |
2667 t)) | 4074 t)) |
4075 ;; Check long header lines. | |
4076 (message-check 'long-header-lines | |
4077 (let ((start (point)) | |
4078 (header nil) | |
4079 (length 0) | |
4080 found) | |
4081 (while (and (not found) | |
4082 (re-search-forward "^\\([^ \t:]+\\): " nil t)) | |
4083 (if (> (- (point) (match-beginning 0)) 998) | |
4084 (setq found t | |
4085 length (- (point) (match-beginning 0))) | |
4086 (setq header (match-string-no-properties 1))) | |
4087 (setq start (match-beginning 0)) | |
4088 (forward-line 1)) | |
4089 (if found | |
4090 (y-or-n-p (format "Your %s header is too long (%d). Really post? " | |
4091 header length)) | |
4092 t))) | |
2668 ;; Check for multiple identical headers. | 4093 ;; Check for multiple identical headers. |
2669 (message-check 'multiple-headers | 4094 (message-check 'multiple-headers |
2670 (let (found) | 4095 (let (found) |
2671 (while (and (not found) | 4096 (while (and (not found) |
2672 (re-search-forward "^[^ \t:]+: " nil t)) | 4097 (re-search-forward "^[^ \t:]+: " nil t)) |
2701 (not followup-to) | 4126 (not followup-to) |
2702 (not | 4127 (not |
2703 (zerop | 4128 (zerop |
2704 (length | 4129 (length |
2705 (setq to (completing-read | 4130 (setq to (completing-read |
2706 "Followups to: (default all groups) " | 4131 "Followups to (default: no Followup-To header) " |
2707 (mapcar (lambda (g) (list g)) | 4132 (mapcar #'list |
2708 (cons "poster" | 4133 (cons "poster" |
2709 (message-tokenize-header | 4134 (message-tokenize-header |
2710 newsgroups))))))))) | 4135 newsgroups))))))))) |
2711 (goto-char (point-min)) | 4136 (goto-char (point-min)) |
2712 (insert "Followup-To: " to "\n")) | 4137 (insert "Followup-To: " to "\n")) |
2713 t)) | 4138 t)) |
2714 ;; Check "Shoot me". | 4139 ;; Check "Shoot me". |
2715 (message-check 'shoot | 4140 (message-check 'shoot |
2716 (if (re-search-forward | 4141 (if (re-search-forward |
2717 "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t) | 4142 "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t) |
2718 (y-or-n-p "You appear to have a misconfigured system. Really post? ") | 4143 (y-or-n-p "You appear to have a misconfigured system. Really post? ") |
2719 t)) | 4144 t)) |
2720 ;; Check for Approved. | 4145 ;; Check for Approved. |
2721 (message-check 'approved | 4146 (message-check 'approved |
2722 (if (re-search-forward "^Approved:" nil t) | 4147 (if (re-search-forward "^Approved:" nil t) |
2743 (followup-to (message-fetch-field "followup-to")) | 4168 (followup-to (message-fetch-field "followup-to")) |
2744 (groups (message-tokenize-header | 4169 (groups (message-tokenize-header |
2745 (if followup-to | 4170 (if followup-to |
2746 (concat newsgroups "," followup-to) | 4171 (concat newsgroups "," followup-to) |
2747 newsgroups))) | 4172 newsgroups))) |
2748 (hashtb (and (boundp 'gnus-active-hashtb) | 4173 (post-method (if (functionp message-post-method) |
2749 gnus-active-hashtb)) | 4174 (funcall message-post-method) |
4175 message-post-method)) | |
4176 ;; KLUDGE to handle nnvirtual groups. Doing this right | |
4177 ;; would probably involve a new nnoo function. | |
4178 ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17. | |
4179 (method (if (and (consp post-method) | |
4180 (eq (car post-method) 'nnvirtual) | |
4181 gnus-message-group-art) | |
4182 (let ((group (car (nnvirtual-find-group-art | |
4183 (car gnus-message-group-art) | |
4184 (cdr gnus-message-group-art))))) | |
4185 (gnus-find-method-for-group group)) | |
4186 post-method)) | |
4187 (known-groups | |
4188 (mapcar (lambda (n) | |
4189 (gnus-group-name-decode | |
4190 (gnus-group-real-name n) | |
4191 (gnus-group-name-charset method n))) | |
4192 (gnus-groups-from-server method))) | |
2750 errors) | 4193 errors) |
2751 (if (or (not hashtb) | 4194 (while groups |
2752 (not (boundp 'gnus-read-active-file)) | 4195 (when (and (not (equal (car groups) "poster")) |
2753 (not gnus-read-active-file) | 4196 (not (member (car groups) known-groups)) |
2754 (eq gnus-read-active-file 'some)) | 4197 (not (member (car groups) errors))) |
2755 t | 4198 (push (car groups) errors)) |
2756 (while groups | 4199 (pop groups)) |
2757 (when (and (not (boundp (intern (car groups) hashtb))) | 4200 (cond |
2758 (not (equal (car groups) "poster"))) | 4201 ;; Gnus is not running. |
2759 (push (car groups) errors)) | 4202 ((or (not (and (boundp 'gnus-active-hashtb) |
2760 (pop groups)) | 4203 gnus-active-hashtb)) |
2761 (if (not errors) | 4204 (not (boundp 'gnus-read-active-file))) |
2762 t | 4205 t) |
2763 (y-or-n-p | 4206 ;; We don't have all the group names. |
2764 (format | 4207 ((and (or (not gnus-read-active-file) |
2765 "Really post to %s unknown group%s: %s? " | 4208 (eq gnus-read-active-file 'some)) |
2766 (if (= (length errors) 1) "this" "these") | 4209 errors) |
2767 (if (= (length errors) 1) "" "s") | 4210 (y-or-n-p |
2768 (mapconcat 'identity errors ", "))))))) | 4211 (format |
4212 "Really use %s possibly unknown group%s: %s? " | |
4213 (if (= (length errors) 1) "this" "these") | |
4214 (if (= (length errors) 1) "" "s") | |
4215 (mapconcat 'identity errors ", ")))) | |
4216 ;; There were no errors. | |
4217 ((not errors) | |
4218 t) | |
4219 ;; There are unknown groups. | |
4220 (t | |
4221 (y-or-n-p | |
4222 (format | |
4223 "Really post to %s unknown group%s: %s? " | |
4224 (if (= (length errors) 1) "this" "these") | |
4225 (if (= (length errors) 1) "" "s") | |
4226 (mapconcat 'identity errors ", "))))))) | |
4227 ;; Check continuation headers. | |
4228 (message-check 'continuation-headers | |
4229 (goto-char (point-min)) | |
4230 (let ((do-posting t)) | |
4231 (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t) | |
4232 (if (y-or-n-p "Fix continuation lines? ") | |
4233 (progn | |
4234 (goto-char (match-beginning 0)) | |
4235 (insert " ")) | |
4236 (unless (y-or-n-p "Send anyway? ") | |
4237 (setq do-posting nil)))) | |
4238 do-posting)) | |
2769 ;; Check the Newsgroups & Followup-To headers for syntax errors. | 4239 ;; Check the Newsgroups & Followup-To headers for syntax errors. |
2770 (message-check 'valid-newsgroups | 4240 (message-check 'valid-newsgroups |
2771 (let ((case-fold-search t) | 4241 (let ((case-fold-search t) |
2772 (headers '("Newsgroups" "Followup-To")) | 4242 (headers '("Newsgroups" "Followup-To")) |
2773 header error) | 4243 header error) |
2818 nil) | 4288 nil) |
2819 ((or (not (string-match | 4289 ((or (not (string-match |
2820 "@[^\\.]*\\." | 4290 "@[^\\.]*\\." |
2821 (setq ad (nth 1 (mail-extract-address-components | 4291 (setq ad (nth 1 (mail-extract-address-components |
2822 from))))) ;larsi@ifi | 4292 from))))) ;larsi@ifi |
2823 (string-match "\\.\\." ad) ;larsi@ifi..uio | 4293 (string-match "\\.\\." ad) ;larsi@ifi..uio |
2824 (string-match "@\\." ad) ;larsi@.ifi.uio | 4294 (string-match "@\\." ad) ;larsi@.ifi.uio |
2825 (string-match "\\.$" ad) ;larsi@ifi.uio. | 4295 (string-match "\\.$" ad) ;larsi@ifi.uio. |
2826 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio | 4296 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio |
2827 (string-match "(.*).*(.*)" from)) ;(lars) (lars) | 4297 (string-match "(.*).*(.*)" from)) ;(lars) (lars) |
2828 (message | 4298 (message |
2829 "Denied posting -- the From looks strange: \"%s\"." from) | 4299 "Denied posting -- the From looks strange: \"%s\"." from) |
2830 nil) | 4300 nil) |
4301 ((let ((addresses (rfc822-addresses from))) | |
4302 (while (and addresses | |
4303 (not (eq (string-to-char (car addresses)) ?\())) | |
4304 (setq addresses (cdr addresses))) | |
4305 addresses) | |
4306 (message | |
4307 "Denied posting -- bad From address: \"%s\"." from) | |
4308 nil) | |
4309 (t t)))) | |
4310 ;; Check the Reply-To header. | |
4311 (message-check 'reply-to | |
4312 (let* ((case-fold-search t) | |
4313 (reply-to (message-fetch-field "reply-to")) | |
4314 ad) | |
4315 (cond | |
4316 ((not reply-to) | |
4317 t) | |
4318 ((string-match "," reply-to) | |
4319 (y-or-n-p | |
4320 (format "Multiple Reply-To addresses: \"%s\". Really post? " | |
4321 reply-to))) | |
4322 ((or (not (string-match | |
4323 "@[^\\.]*\\." | |
4324 (setq ad (nth 1 (mail-extract-address-components | |
4325 reply-to))))) ;larsi@ifi | |
4326 (string-match "\\.\\." ad) ;larsi@ifi..uio | |
4327 (string-match "@\\." ad) ;larsi@.ifi.uio | |
4328 (string-match "\\.$" ad) ;larsi@ifi.uio. | |
4329 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio | |
4330 (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars) | |
4331 (y-or-n-p | |
4332 (format | |
4333 "The Reply-To looks strange: \"%s\". Really post? " | |
4334 reply-to))) | |
2831 (t t)))))) | 4335 (t t)))))) |
2832 | 4336 |
2833 (defun message-check-news-body-syntax () | 4337 (defun message-check-news-body-syntax () |
2834 (and | 4338 (and |
2835 ;; Check for long lines. | 4339 ;; Check for long lines. |
2836 (message-check 'long-lines | 4340 (message-check 'long-lines |
2837 (goto-char (point-min)) | 4341 (goto-char (point-min)) |
2838 (re-search-forward | 4342 (re-search-forward |
2839 (concat "^" (regexp-quote mail-header-separator) "$")) | 4343 (concat "^" (regexp-quote mail-header-separator) "$")) |
4344 (forward-line 1) | |
2840 (while (and | 4345 (while (and |
2841 (progn | 4346 (or (looking-at |
2842 (end-of-line) | 4347 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)") |
2843 (< (current-column) 80)) | 4348 (let ((p (point))) |
4349 (end-of-line) | |
4350 (< (- (point) p) 80))) | |
2844 (zerop (forward-line 1)))) | 4351 (zerop (forward-line 1)))) |
2845 (or (bolp) | 4352 (or (bolp) |
2846 (eobp) | 4353 (eobp) |
2847 (y-or-n-p | 4354 (y-or-n-p |
2848 "You have lines longer than 79 characters. Really post? "))) | 4355 "You have lines longer than 79 characters. Really post? "))) |
2855 (let ((b (point))) | 4362 (let ((b (point))) |
2856 (goto-char (point-max)) | 4363 (goto-char (point-max)) |
2857 (re-search-backward message-signature-separator nil t) | 4364 (re-search-backward message-signature-separator nil t) |
2858 (beginning-of-line) | 4365 (beginning-of-line) |
2859 (or (re-search-backward "[^ \n\t]" b t) | 4366 (or (re-search-backward "[^ \n\t]" b t) |
2860 (y-or-n-p "Empty article. Really post? ")))) | 4367 (if (message-gnksa-enable-p 'empty-article) |
4368 (y-or-n-p "Empty article. Really post? ") | |
4369 (message "Denied posting -- Empty article.") | |
4370 nil)))) | |
2861 ;; Check for control characters. | 4371 ;; Check for control characters. |
2862 (message-check 'control-chars | 4372 (message-check 'control-chars |
2863 (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t) | 4373 (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t) |
2864 (y-or-n-p | 4374 (y-or-n-p |
2865 "The article contains control characters. Really post? ") | 4375 "The article contains control characters. Really post? ") |
2874 ;; Check whether any new text has been added. | 4384 ;; Check whether any new text has been added. |
2875 (message-check 'new-text | 4385 (message-check 'new-text |
2876 (or | 4386 (or |
2877 (not message-checksum) | 4387 (not message-checksum) |
2878 (not (eq (message-checksum) message-checksum)) | 4388 (not (eq (message-checksum) message-checksum)) |
2879 (y-or-n-p | 4389 (if (message-gnksa-enable-p 'quoted-text-only) |
2880 "It looks like no new text has been added. Really post? "))) | 4390 (y-or-n-p |
4391 "It looks like no new text has been added. Really post? ") | |
4392 (message "Denied posting -- no new text has been added.") | |
4393 nil))) | |
2881 ;; Check the length of the signature. | 4394 ;; Check the length of the signature. |
2882 (message-check 'signature | 4395 (message-check 'signature |
2883 (goto-char (point-max)) | 4396 (goto-char (point-max)) |
2884 (if (> (count-lines (point) (point-max)) 5) | 4397 (if (> (count-lines (point) (point-max)) 5) |
2885 (y-or-n-p | 4398 (y-or-n-p |
2889 t)) | 4402 t)) |
2890 ;; Ensure that text follows last quoted portion. | 4403 ;; Ensure that text follows last quoted portion. |
2891 (message-check 'quoting-style | 4404 (message-check 'quoting-style |
2892 (goto-char (point-max)) | 4405 (goto-char (point-max)) |
2893 (let ((no-problem t)) | 4406 (let ((no-problem t)) |
2894 (when (search-backward-regexp "^>[^\n]*\n>" nil t) | 4407 (when (search-backward-regexp "^>[^\n]*\n" nil t) |
2895 (setq no-problem nil) | 4408 (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t))) |
2896 (while (not (eobp)) | |
2897 (when (and (not (eolp)) (looking-at "[^> \t]")) | |
2898 (setq no-problem t)) | |
2899 (forward-line))) | |
2900 (if no-problem | 4409 (if no-problem |
2901 t | 4410 t |
2902 (y-or-n-p "Your text should follow quoted text. Really post? ")))))) | 4411 (if (message-gnksa-enable-p 'quoted-text-only) |
4412 (y-or-n-p "Your text should follow quoted text. Really post? ") | |
4413 ;; Ensure that | |
4414 (goto-char (point-min)) | |
4415 (re-search-forward | |
4416 (concat "^" (regexp-quote mail-header-separator) "$")) | |
4417 (if (search-forward-regexp "^[ \t]*[^>\n]" nil t) | |
4418 (y-or-n-p "Your text should follow quoted text. Really post? ") | |
4419 (message "Denied posting -- only quoted text.") | |
4420 nil))))))) | |
2903 | 4421 |
2904 (defun message-checksum () | 4422 (defun message-checksum () |
2905 "Return a \"checksum\" for the current buffer." | 4423 "Return a \"checksum\" for the current buffer." |
2906 (let ((sum 0)) | 4424 (let ((sum 0)) |
2907 (save-excursion | 4425 (save-excursion |
2908 (goto-char (point-min)) | 4426 (goto-char (point-min)) |
2909 (re-search-forward | 4427 (re-search-forward |
2910 (concat "^" (regexp-quote mail-header-separator) "$")) | 4428 (concat "^" (regexp-quote mail-header-separator) "$")) |
2911 (while (not (eobp)) | 4429 (while (not (eobp)) |
2912 (when (not (looking-at "[ \t\n]")) | 4430 (when (not (looking-at "[ \t\n]")) |
2913 (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) | 4431 (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) |
2914 (char-after)))) | 4432 (char-after)))) |
2915 (forward-char 1))) | 4433 (forward-char 1))) |
2916 sum)) | 4434 sum)) |
2917 | 4435 |
2918 (defun message-do-fcc () | 4436 (defun message-do-fcc () |
2919 "Process Fcc headers in the current buffer." | 4437 "Process Fcc headers in the current buffer." |
2920 (let ((case-fold-search t) | 4438 (let ((case-fold-search t) |
2921 (buf (current-buffer)) | 4439 (buf (current-buffer)) |
2922 list file) | 4440 list file |
4441 (mml-externalize-attachments message-fcc-externalize-attachments)) | |
2923 (save-excursion | 4442 (save-excursion |
2924 (set-buffer (get-buffer-create " *message temp*")) | |
2925 (erase-buffer) | |
2926 (insert-buffer-substring buf) | |
2927 (save-restriction | 4443 (save-restriction |
2928 (message-narrow-to-headers) | 4444 (message-narrow-to-headers) |
2929 (while (setq file (message-fetch-field "fcc")) | 4445 (setq file (message-fetch-field "fcc" t))) |
2930 (push file list) | 4446 (when file |
2931 (message-remove-header "fcc" nil t))) | 4447 (set-buffer (get-buffer-create " *message temp*")) |
2932 (message-encode-message-body) | 4448 (erase-buffer) |
2933 (save-restriction | 4449 (insert-buffer-substring buf) |
2934 (message-narrow-to-headers) | 4450 (message-encode-message-body) |
2935 (let ((mail-parse-charset message-default-charset) | 4451 (save-restriction |
2936 (rfc2047-header-encoding-alist | 4452 (message-narrow-to-headers) |
2937 (cons '("Newsgroups" . default) | 4453 (while (setq file (message-fetch-field "fcc" t)) |
2938 rfc2047-header-encoding-alist))) | 4454 (push file list) |
2939 (mail-encode-encoded-word-buffer))) | 4455 (message-remove-header "fcc" nil t)) |
2940 (goto-char (point-min)) | 4456 (let ((mail-parse-charset message-default-charset) |
2941 (when (re-search-forward | 4457 (rfc2047-header-encoding-alist |
2942 (concat "^" (regexp-quote mail-header-separator) "$") | 4458 (cons '("Newsgroups" . default) |
2943 nil t) | 4459 rfc2047-header-encoding-alist))) |
2944 (replace-match "" t t )) | 4460 (mail-encode-encoded-word-buffer))) |
2945 ;; Process FCC operations. | 4461 (goto-char (point-min)) |
2946 (while list | 4462 (when (re-search-forward |
2947 (setq file (pop list)) | 4463 (concat "^" (regexp-quote mail-header-separator) "$") |
2948 (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) | 4464 nil t) |
2949 ;; Pipe the article to the program in question. | 4465 (replace-match "" t t )) |
2950 (call-process-region (point-min) (point-max) shell-file-name | 4466 ;; Process FCC operations. |
2951 nil nil nil shell-command-switch | 4467 (while list |
2952 (match-string 1 file)) | 4468 (setq file (pop list)) |
2953 ;; Save the article. | 4469 (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) |
2954 (setq file (expand-file-name file)) | 4470 ;; Pipe the article to the program in question. |
2955 (unless (file-exists-p (file-name-directory file)) | 4471 (call-process-region (point-min) (point-max) shell-file-name |
2956 (make-directory (file-name-directory file) t)) | 4472 nil nil nil shell-command-switch |
2957 (if (and message-fcc-handler-function | 4473 (match-string 1 file)) |
2958 (not (eq message-fcc-handler-function 'rmail-output))) | 4474 ;; Save the article. |
2959 (funcall message-fcc-handler-function file) | 4475 (setq file (expand-file-name file)) |
2960 (if (and (file-readable-p file) (mail-file-babyl-p file)) | 4476 (unless (file-exists-p (file-name-directory file)) |
2961 (rmail-output file 1 nil t) | 4477 (make-directory (file-name-directory file) t)) |
2962 (let ((mail-use-rfc822 t)) | 4478 (if (and message-fcc-handler-function |
2963 (rmail-output file 1 t t)))))) | 4479 (not (eq message-fcc-handler-function 'rmail-output))) |
2964 (kill-buffer (current-buffer))))) | 4480 (funcall message-fcc-handler-function file) |
4481 (if (and (file-readable-p file) (mail-file-babyl-p file)) | |
4482 (rmail-output file 1 nil t) | |
4483 (let ((mail-use-rfc822 t)) | |
4484 (rmail-output file 1 t t)))))) | |
4485 (kill-buffer (current-buffer)))))) | |
2965 | 4486 |
2966 (defun message-output (filename) | 4487 (defun message-output (filename) |
2967 "Append this article to Unix/babyl mail file FILENAME." | 4488 "Append this article to Unix/babyl mail file FILENAME." |
2968 (if (and (file-readable-p filename) | 4489 (if (and (file-readable-p filename) |
2969 (mail-file-babyl-p filename)) | 4490 (mail-file-babyl-p filename)) |
2991 (match-beginning 0) | 4512 (match-beginning 0) |
2992 (forward-line 1) | 4513 (forward-line 1) |
2993 (point))) | 4514 (point))) |
2994 (goto-char (point-min)) | 4515 (goto-char (point-min)) |
2995 (while (re-search-forward "\n[ \t]+" nil t) | 4516 (while (re-search-forward "\n[ \t]+" nil t) |
2996 (replace-match " " t t)) ;No line breaks (too confusing) | 4517 (replace-match " " t t)) ;No line breaks (too confusing) |
2997 (goto-char (point-min)) | 4518 (goto-char (point-min)) |
2998 (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) | 4519 (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) |
2999 (replace-match "," t t)) | 4520 (replace-match "," t t)) |
3000 (goto-char (point-min)) | 4521 (goto-char (point-min)) |
3001 ;; Remove trailing commas. | 4522 ;; Remove trailing commas. |
3010 (sign "+")) | 4531 (sign "+")) |
3011 (when (< zone 0) | 4532 (when (< zone 0) |
3012 (setq sign "-") | 4533 (setq sign "-") |
3013 (setq zone (- zone))) | 4534 (setq zone (- zone))) |
3014 (concat | 4535 (concat |
4536 ;; The day name of the %a spec is locale-specific. Pfff. | |
4537 (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now)) | |
4538 parse-time-weekdays)))) | |
3015 (format-time-string "%d" now) | 4539 (format-time-string "%d" now) |
3016 ;; The month name of the %b spec is locale-specific. Pfff. | 4540 ;; The month name of the %b spec is locale-specific. Pfff. |
3017 (format " %s " | 4541 (format " %s " |
3018 (capitalize (car (rassoc (nth 4 (decode-time now)) | 4542 (capitalize (car (rassoc (nth 4 (decode-time now)) |
3019 parse-time-months)))) | 4543 parse-time-months)))) |
3061 (let ((user (downcase (user-login-name)))) | 4585 (let ((user (downcase (user-login-name)))) |
3062 (while (string-match "[^a-z0-9_]" user) | 4586 (while (string-match "[^a-z0-9_]" user) |
3063 (aset user (match-beginning 0) ?_)) | 4587 (aset user (match-beginning 0) ?_)) |
3064 user) | 4588 user) |
3065 (message-number-base36 (user-uid) -1)) | 4589 (message-number-base36 (user-uid) -1)) |
3066 (message-number-base36 (+ (car tm) | 4590 (message-number-base36 (+ (car tm) |
3067 (lsh (% message-unique-id-char 25) 16)) 4) | 4591 (lsh (% message-unique-id-char 25) 16)) 4) |
3068 (message-number-base36 (+ (nth 1 tm) | 4592 (message-number-base36 (+ (nth 1 tm) |
3069 (lsh (/ message-unique-id-char 25) 16)) 4) | 4593 (lsh (/ message-unique-id-char 25) 16)) 4) |
3070 ;; Append the newsreader name, because while the generated | 4594 ;; Append a given name, because while the generated ID is unique |
3071 ;; ID is unique to this newsreader, other newsreaders might | 4595 ;; to this newsreader, other newsreaders might otherwise generate |
3072 ;; otherwise generate the same ID via another algorithm. | 4596 ;; the same ID via another algorithm. |
3073 ".fsf"))) | 4597 ".fsf"))) |
3074 | 4598 |
3075 (defun message-number-base36 (num len) | 4599 (defun message-number-base36 (num len) |
3076 (if (if (< len 0) | 4600 (if (if (< len 0) |
3077 (<= num 0) | 4601 (<= num 0) |
3083 | 4607 |
3084 (defun message-make-organization () | 4608 (defun message-make-organization () |
3085 "Make an Organization header." | 4609 "Make an Organization header." |
3086 (let* ((organization | 4610 (let* ((organization |
3087 (when message-user-organization | 4611 (when message-user-organization |
3088 (if (message-functionp message-user-organization) | 4612 (if (functionp message-user-organization) |
3089 (funcall message-user-organization) | 4613 (funcall message-user-organization) |
3090 message-user-organization)))) | 4614 message-user-organization)))) |
3091 (save-excursion | 4615 (with-temp-buffer |
3092 (message-set-work-buffer) | 4616 (mm-enable-multibyte) |
3093 (cond ((stringp organization) | 4617 (cond ((stringp organization) |
3094 (insert organization)) | 4618 (insert organization)) |
3095 ((and (eq t organization) | 4619 ((and (eq t organization) |
3096 message-user-organization-file | 4620 message-user-organization-file |
3097 (file-exists-p message-user-organization-file)) | 4621 (file-exists-p message-user-organization-file)) |
3105 (defun message-make-lines () | 4629 (defun message-make-lines () |
3106 "Count the number of lines and return numeric string." | 4630 "Count the number of lines and return numeric string." |
3107 (save-excursion | 4631 (save-excursion |
3108 (save-restriction | 4632 (save-restriction |
3109 (widen) | 4633 (widen) |
3110 (goto-char (point-min)) | 4634 (message-goto-body) |
3111 (re-search-forward | |
3112 (concat "^" (regexp-quote mail-header-separator) "$")) | |
3113 (forward-line 1) | |
3114 (int-to-string (count-lines (point) (point-max)))))) | 4635 (int-to-string (count-lines (point) (point-max)))))) |
4636 | |
4637 (defun message-make-references () | |
4638 "Return the References header for this message." | |
4639 (when message-reply-headers | |
4640 (let ((message-id (mail-header-message-id message-reply-headers)) | |
4641 (references (mail-header-references message-reply-headers)) | |
4642 new-references) | |
4643 (if (or references message-id) | |
4644 (concat (or references "") (and references " ") | |
4645 (or message-id "")) | |
4646 nil)))) | |
3115 | 4647 |
3116 (defun message-make-in-reply-to () | 4648 (defun message-make-in-reply-to () |
3117 "Return the In-Reply-To header for this message." | 4649 "Return the In-Reply-To header for this message." |
3118 (when message-reply-headers | 4650 (when message-reply-headers |
3119 (mail-header-message-id message-reply-headers))) | 4651 (let ((from (mail-header-from message-reply-headers)) |
4652 (date (mail-header-date message-reply-headers)) | |
4653 (msg-id (mail-header-message-id message-reply-headers))) | |
4654 (when from | |
4655 (let ((name (mail-extract-address-components from))) | |
4656 (concat msg-id (if msg-id " (") | |
4657 (or (car name) | |
4658 (nth 1 name)) | |
4659 "'s message of \"" | |
4660 (if (or (not date) (string= date "")) | |
4661 "(unknown date)" date) | |
4662 "\"" (if msg-id ")"))))))) | |
3120 | 4663 |
3121 (defun message-make-distribution () | 4664 (defun message-make-distribution () |
3122 "Make a Distribution header." | 4665 "Make a Distribution header." |
3123 (let ((orig-distribution (message-fetch-reply-field "distribution"))) | 4666 (let ((orig-distribution (message-fetch-reply-field "distribution"))) |
3124 (cond ((message-functionp message-distribution-function) | 4667 (cond ((functionp message-distribution-function) |
3125 (funcall message-distribution-function)) | 4668 (funcall message-distribution-function)) |
3126 (t orig-distribution)))) | 4669 (t orig-distribution)))) |
3127 | 4670 |
3128 (defun message-make-expires () | 4671 (defun message-make-expires () |
3129 "Return an Expires header based on `message-expires'." | 4672 "Return an Expires header based on `message-expires'." |
3152 (or (and (boundp 'user-full-name) | 4695 (or (and (boundp 'user-full-name) |
3153 user-full-name) | 4696 user-full-name) |
3154 (user-full-name)))) | 4697 (user-full-name)))) |
3155 (when (string= fullname "&") | 4698 (when (string= fullname "&") |
3156 (setq fullname (user-login-name))) | 4699 (setq fullname (user-login-name))) |
3157 (save-excursion | 4700 (with-temp-buffer |
3158 (message-set-work-buffer) | 4701 (mm-enable-multibyte) |
3159 (cond | 4702 (cond |
3160 ((or (null style) | 4703 ((or (null style) |
3161 (equal fullname "")) | 4704 (equal fullname "")) |
3162 (insert login)) | 4705 (insert login)) |
3163 ((or (eq style 'angles) | 4706 ((or (eq style 'angles) |
3170 (aset tmp (match-beginning 0) ?-) | 4713 (aset tmp (match-beginning 0) ?-) |
3171 (aset tmp (1- (match-end 0)) ?-)) | 4714 (aset tmp (1- (match-end 0)) ?-)) |
3172 (string-match "[\\()]" tmp))))) | 4715 (string-match "[\\()]" tmp))))) |
3173 (insert fullname) | 4716 (insert fullname) |
3174 (goto-char (point-min)) | 4717 (goto-char (point-min)) |
3175 ;; Look for a character that cannot appear unquoted | 4718 ;; Look for a character that cannot appear unquoted |
3176 ;; according to RFC 822. | 4719 ;; according to RFC 822. |
3177 (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) | 4720 (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) |
3178 ;; Quote fullname, escaping specials. | 4721 ;; Quote fullname, escaping specials. |
3179 (goto-char (point-min)) | 4722 (goto-char (point-min)) |
3180 (insert "\"") | 4723 (insert "\"") |
3181 (while (re-search-forward "[\"\\]" nil 1) | 4724 (while (re-search-forward "[\"\\]" nil 1) |
3182 (replace-match "\\\\\\&" t)) | 4725 (replace-match "\\\\\\&" t)) |
3183 (insert "\"")) | 4726 (insert "\"")) |
3184 (insert " <" login ">")) | 4727 (insert " <" login ">")) |
3185 (t ; 'parens or default | 4728 (t ; 'parens or default |
3186 (insert login " (") | 4729 (insert login " (") |
3187 (let ((fullname-start (point))) | 4730 (let ((fullname-start (point))) |
3188 (insert fullname) | 4731 (insert fullname) |
3214 (or (message-user-mail-address) | 4757 (or (message-user-mail-address) |
3215 (concat (user-login-name) "@" (message-make-domain)))) | 4758 (concat (user-login-name) "@" (message-make-domain)))) |
3216 | 4759 |
3217 (defun message-user-mail-address () | 4760 (defun message-user-mail-address () |
3218 "Return the pertinent part of `user-mail-address'." | 4761 "Return the pertinent part of `user-mail-address'." |
3219 (when user-mail-address | 4762 (when (and user-mail-address |
4763 (string-match "@.*\\." user-mail-address)) | |
3220 (if (string-match " " user-mail-address) | 4764 (if (string-match " " user-mail-address) |
3221 (nth 1 (mail-extract-address-components user-mail-address)) | 4765 (nth 1 (mail-extract-address-components user-mail-address)) |
3222 user-mail-address))) | 4766 user-mail-address))) |
3223 | 4767 |
4768 (defun message-sendmail-envelope-from () | |
4769 "Return the envelope from." | |
4770 (cond ((eq message-sendmail-envelope-from 'header) | |
4771 (nth 1 (mail-extract-address-components | |
4772 (message-fetch-field "from")))) | |
4773 ((stringp message-sendmail-envelope-from) | |
4774 message-sendmail-envelope-from) | |
4775 (t | |
4776 (message-make-address)))) | |
4777 | |
3224 (defun message-make-fqdn () | 4778 (defun message-make-fqdn () |
3225 "Return user's fully qualified domain name." | 4779 "Return user's fully qualified domain name." |
3226 (let ((system-name (system-name)) | 4780 (let* ((system-name (system-name)) |
3227 (user-mail (message-user-mail-address))) | 4781 (user-mail (message-user-mail-address)) |
4782 (user-domain | |
4783 (if (and user-mail | |
4784 (string-match "@\\(.*\\)\\'" user-mail)) | |
4785 (match-string 1 user-mail))) | |
4786 (case-fold-search t)) | |
3228 (cond | 4787 (cond |
3229 ((string-match "[^.]\\.[^.]" system-name) | 4788 ((and message-user-fqdn |
4789 (stringp message-user-fqdn) | |
4790 (string-match message-valid-fqdn-regexp message-user-fqdn) | |
4791 (not (string-match message-bogus-system-names message-user-fqdn))) | |
4792 message-user-fqdn) | |
4793 ;; `message-user-fqdn' seems to be valid | |
4794 ((and (string-match message-valid-fqdn-regexp system-name) | |
4795 (not (string-match message-bogus-system-names system-name))) | |
3230 ;; `system-name' returned the right result. | 4796 ;; `system-name' returned the right result. |
3231 system-name) | 4797 system-name) |
3232 ;; Try `mail-host-address'. | 4798 ;; Try `mail-host-address'. |
3233 ((and (boundp 'mail-host-address) | 4799 ((and (boundp 'mail-host-address) |
3234 (stringp mail-host-address) | 4800 (stringp mail-host-address) |
3235 (string-match "\\." mail-host-address)) | 4801 (string-match message-valid-fqdn-regexp mail-host-address) |
4802 (not (string-match message-bogus-system-names mail-host-address))) | |
3236 mail-host-address) | 4803 mail-host-address) |
3237 ;; We try `user-mail-address' as a backup. | 4804 ;; We try `user-mail-address' as a backup. |
3238 ((and user-mail | 4805 ((and user-domain |
3239 (string-match "\\." user-mail) | 4806 (stringp user-domain) |
3240 (string-match "@\\(.*\\)\\'" user-mail)) | 4807 (string-match message-valid-fqdn-regexp user-domain) |
3241 (match-string 1 user-mail)) | 4808 (not (string-match message-bogus-system-names user-domain))) |
4809 user-domain) | |
3242 ;; Default to this bogus thing. | 4810 ;; Default to this bogus thing. |
3243 (t | 4811 (t |
3244 (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me"))))) | 4812 (concat system-name |
4813 ".i-did-not-set--mail-host-address--so-tickle-me"))))) | |
3245 | 4814 |
3246 (defun message-make-host-name () | 4815 (defun message-make-host-name () |
3247 "Return the name of the host." | 4816 "Return the name of the host." |
3248 (let ((fqdn (message-make-fqdn))) | 4817 (let ((fqdn (message-make-fqdn))) |
3249 (string-match "^[^.]+\\." fqdn) | 4818 (string-match "^[^.]+\\." fqdn) |
3252 (defun message-make-domain () | 4821 (defun message-make-domain () |
3253 "Return the domain name." | 4822 "Return the domain name." |
3254 (or mail-host-address | 4823 (or mail-host-address |
3255 (message-make-fqdn))) | 4824 (message-make-fqdn))) |
3256 | 4825 |
4826 (defun message-to-list-only () | |
4827 "Send a message to the list only. | |
4828 Remove all addresses but the list address from To and Cc headers." | |
4829 (interactive) | |
4830 (let ((listaddr (message-make-mail-followup-to t))) | |
4831 (when listaddr | |
4832 (save-excursion | |
4833 (message-remove-header "to") | |
4834 (message-remove-header "cc") | |
4835 (message-position-on-field "To" "X-Draft-From") | |
4836 (insert listaddr))))) | |
4837 | |
4838 (defun message-make-mail-followup-to (&optional only-show-subscribed) | |
4839 "Return the Mail-Followup-To header. | |
4840 If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the | |
4841 subscribed address (and not the additional To and Cc header contents)." | |
4842 (let* ((case-fold-search t) | |
4843 (to (message-fetch-field "To")) | |
4844 (cc (message-fetch-field "cc")) | |
4845 (msg-recipients (concat to (and to cc ", ") cc)) | |
4846 (recipients | |
4847 (mapcar 'mail-strip-quoted-names | |
4848 (message-tokenize-header msg-recipients))) | |
4849 (file-regexps | |
4850 (if message-subscribed-address-file | |
4851 (let (begin end item re) | |
4852 (save-excursion | |
4853 (with-temp-buffer | |
4854 (insert-file-contents message-subscribed-address-file) | |
4855 (while (not (eobp)) | |
4856 (setq begin (point)) | |
4857 (forward-line 1) | |
4858 (setq end (point)) | |
4859 (if (bolp) (setq end (1- end))) | |
4860 (setq item (regexp-quote (buffer-substring begin end))) | |
4861 (if re (setq re (concat re "\\|" item)) | |
4862 (setq re (concat "\\`\\(" item)))) | |
4863 (and re (list (concat re "\\)\\'")))))))) | |
4864 (mft-regexps (apply 'append message-subscribed-regexps | |
4865 (mapcar 'regexp-quote | |
4866 message-subscribed-addresses) | |
4867 file-regexps | |
4868 (mapcar 'funcall | |
4869 message-subscribed-address-functions)))) | |
4870 (save-match-data | |
4871 (let ((subscribed-lists nil) | |
4872 (list | |
4873 (loop for recipient in recipients | |
4874 when (loop for regexp in mft-regexps | |
4875 when (string-match regexp recipient) return t) | |
4876 return recipient))) | |
4877 (when list | |
4878 (if only-show-subscribed | |
4879 list | |
4880 msg-recipients)))))) | |
4881 | |
4882 (defun message-idna-to-ascii-rhs-1 (header) | |
4883 "Interactively potentially IDNA encode domain names in HEADER." | |
4884 (let ((field (message-fetch-field header)) | |
4885 rhs ace address) | |
4886 (when field | |
4887 (dolist (address (mail-header-parse-addresses field)) | |
4888 (setq address (car address) | |
4889 rhs (downcase (or (cadr (split-string address "@")) "")) | |
4890 ace (downcase (idna-to-ascii rhs))) | |
4891 (when (and (not (equal rhs ace)) | |
4892 (or (not (eq message-use-idna 'ask)) | |
4893 (y-or-n-p (format "Replace %s with %s? " rhs ace)))) | |
4894 (goto-char (point-min)) | |
4895 (while (re-search-forward (concat "^" header ":") nil t) | |
4896 (message-narrow-to-field) | |
4897 (while (search-forward (concat "@" rhs) nil t) | |
4898 (replace-match (concat "@" ace) t t)) | |
4899 (goto-char (point-max)) | |
4900 (widen))))))) | |
4901 | |
4902 (defun message-idna-to-ascii-rhs () | |
4903 "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers. | |
4904 See `message-idna-encode'." | |
4905 (interactive) | |
4906 (when message-use-idna | |
4907 (save-excursion | |
4908 (save-restriction | |
4909 (message-narrow-to-head) | |
4910 (message-idna-to-ascii-rhs-1 "From") | |
4911 (message-idna-to-ascii-rhs-1 "To") | |
4912 (message-idna-to-ascii-rhs-1 "Cc"))))) | |
4913 | |
3257 (defun message-generate-headers (headers) | 4914 (defun message-generate-headers (headers) |
3258 "Prepare article HEADERS. | 4915 "Prepare article HEADERS. |
3259 Headers already prepared in the buffer are not modified." | 4916 Headers already prepared in the buffer are not modified." |
4917 (setq headers (append headers message-required-headers)) | |
3260 (save-restriction | 4918 (save-restriction |
3261 (message-narrow-to-headers) | 4919 (message-narrow-to-headers) |
3262 (let* ((Date (message-make-date)) | 4920 (let* ((Date (message-make-date)) |
3263 (Message-ID (message-make-message-id)) | 4921 (Message-ID (message-make-message-id)) |
3264 (Organization (message-make-organization)) | 4922 (Organization (message-make-organization)) |
3265 (From (message-make-from)) | 4923 (From (message-make-from)) |
3266 (Path (message-make-path)) | 4924 (Path (message-make-path)) |
3267 (Subject nil) | 4925 (Subject nil) |
3268 (Newsgroups nil) | 4926 (Newsgroups nil) |
3269 (In-Reply-To (message-make-in-reply-to)) | 4927 (In-Reply-To (message-make-in-reply-to)) |
4928 (References (message-make-references)) | |
3270 (To nil) | 4929 (To nil) |
3271 (Distribution (message-make-distribution)) | 4930 (Distribution (message-make-distribution)) |
3272 (Lines (message-make-lines)) | 4931 (Lines (message-make-lines)) |
3273 (User-Agent message-newsreader) | 4932 (User-Agent message-newsreader) |
3274 (Expires (message-make-expires)) | 4933 (Expires (message-make-expires)) |
3275 (case-fold-search t) | 4934 (case-fold-search t) |
3276 header value elem) | 4935 (optionalp nil) |
4936 header value elem header-string) | |
3277 ;; First we remove any old generated headers. | 4937 ;; First we remove any old generated headers. |
3278 (let ((headers message-deletable-headers)) | 4938 (let ((headers message-deletable-headers)) |
3279 (unless (buffer-modified-p) | 4939 (unless (buffer-modified-p) |
3280 (setq headers (delq 'Message-ID (copy-sequence headers)))) | 4940 (setq headers (delq 'Message-ID (copy-sequence headers)))) |
3281 (while headers | 4941 (while headers |
3292 (while headers | 4952 (while headers |
3293 (goto-char (point-min)) | 4953 (goto-char (point-min)) |
3294 (setq elem (pop headers)) | 4954 (setq elem (pop headers)) |
3295 (if (consp elem) | 4955 (if (consp elem) |
3296 (if (eq (car elem) 'optional) | 4956 (if (eq (car elem) 'optional) |
3297 (setq header (cdr elem)) | 4957 (setq header (cdr elem) |
4958 optionalp t) | |
3298 (setq header (car elem))) | 4959 (setq header (car elem))) |
3299 (setq header elem)) | 4960 (setq header elem)) |
4961 (setq header-string (if (stringp header) | |
4962 header | |
4963 (symbol-name header))) | |
3300 (when (or (not (re-search-forward | 4964 (when (or (not (re-search-forward |
3301 (concat "^" | 4965 (concat "^" |
3302 (regexp-quote | 4966 (regexp-quote (downcase header-string)) |
3303 (downcase | |
3304 (if (stringp header) | |
3305 header | |
3306 (symbol-name header)))) | |
3307 ":") | 4967 ":") |
3308 nil t)) | 4968 nil t)) |
3309 (progn | 4969 (progn |
3310 ;; The header was found. We insert a space after the | 4970 ;; The header was found. We insert a space after the |
3311 ;; colon, if there is none. | 4971 ;; colon, if there is none. |
3312 (if (/= (char-after) ? ) (insert " ") (forward-char 1)) | 4972 (if (/= (char-after) ? ) (insert " ") (forward-char 1)) |
3313 ;; Find out whether the header is empty... | 4973 ;; Find out whether the header is empty. |
3314 (looking-at "[ \t]*\n[^ \t]"))) | 4974 (looking-at "[ \t]*\n[^ \t]"))) |
3315 ;; So we find out what value we should insert. | 4975 ;; So we find out what value we should insert. |
3316 (setq value | 4976 (setq value |
3317 (cond | 4977 (cond |
3318 ((and (consp elem) (eq (car elem) 'optional)) | 4978 ((and (consp elem) |
4979 (eq (car elem) 'optional) | |
4980 (not (member header-string message-inserted-headers))) | |
3319 ;; This is an optional header. If the cdr of this | 4981 ;; This is an optional header. If the cdr of this |
3320 ;; is something that is nil, then we do not insert | 4982 ;; is something that is nil, then we do not insert |
3321 ;; this header. | 4983 ;; this header. |
3322 (setq header (cdr elem)) | 4984 (setq header (cdr elem)) |
3323 (or (and (fboundp (cdr elem)) (funcall (cdr elem))) | 4985 (or (and (functionp (cdr elem)) |
3324 (and (boundp (cdr elem)) (symbol-value (cdr elem))))) | 4986 (funcall (cdr elem))) |
4987 (and (boundp (cdr elem)) | |
4988 (symbol-value (cdr elem))))) | |
3325 ((consp elem) | 4989 ((consp elem) |
3326 ;; The element is a cons. Either the cdr is a | 4990 ;; The element is a cons. Either the cdr is a |
3327 ;; string to be inserted verbatim, or it is a | 4991 ;; string to be inserted verbatim, or it is a |
3328 ;; function, and we insert the value returned from | 4992 ;; function, and we insert the value returned from |
3329 ;; this function. | 4993 ;; this function. |
3330 (or (and (stringp (cdr elem)) (cdr elem)) | 4994 (or (and (stringp (cdr elem)) |
3331 (and (fboundp (cdr elem)) (funcall (cdr elem))))) | 4995 (cdr elem)) |
3332 ((and (boundp header) (symbol-value header)) | 4996 (and (functionp (cdr elem)) |
4997 (funcall (cdr elem))))) | |
4998 ((and (boundp header) | |
4999 (symbol-value header)) | |
3333 ;; The element is a symbol. We insert the value | 5000 ;; The element is a symbol. We insert the value |
3334 ;; of this symbol, if any. | 5001 ;; of this symbol, if any. |
3335 (symbol-value header)) | 5002 (symbol-value header)) |
3336 ((not (message-check-element header)) | 5003 ((not (message-check-element header)) |
3337 ;; We couldn't generate a value for this header, | 5004 ;; We couldn't generate a value for this header, |
3344 (save-excursion | 5011 (save-excursion |
3345 (if (bolp) | 5012 (if (bolp) |
3346 (progn | 5013 (progn |
3347 ;; This header didn't exist, so we insert it. | 5014 ;; This header didn't exist, so we insert it. |
3348 (goto-char (point-max)) | 5015 (goto-char (point-max)) |
3349 (insert (if (stringp header) header (symbol-name header)) | 5016 (let ((formatter |
3350 ": " value "\n") | 5017 (cdr (assq header message-header-format-alist)))) |
3351 (forward-line -1)) | 5018 (if formatter |
5019 (funcall formatter header value) | |
5020 (insert header-string ": " value)) | |
5021 ;; We check whether the value was ended by a | |
5022 ;; newline. If now, we insert one. | |
5023 (unless (bolp) | |
5024 (insert "\n")) | |
5025 (forward-line -1))) | |
3352 ;; The value of this header was empty, so we clear | 5026 ;; The value of this header was empty, so we clear |
3353 ;; totally and insert the new value. | 5027 ;; totally and insert the new value. |
3354 (delete-region (point) (gnus-point-at-eol)) | 5028 (delete-region (point) (gnus-point-at-eol)) |
3355 (insert value)) | 5029 ;; If the header is optional, and the header was |
5030 ;; empty, we con't insert it anyway. | |
5031 (unless optionalp | |
5032 (push header-string message-inserted-headers) | |
5033 (insert value))) | |
3356 ;; Add the deletable property to the headers that require it. | 5034 ;; Add the deletable property to the headers that require it. |
3357 (and (memq header message-deletable-headers) | 5035 (and (memq header message-deletable-headers) |
3358 (progn (beginning-of-line) (looking-at "[^:]+: ")) | 5036 (progn (beginning-of-line) (looking-at "[^:]+: ")) |
3359 (add-text-properties | 5037 (add-text-properties |
3360 (point) (match-end 0) | 5038 (point) (match-end 0) |
3381 (beginning-of-line) | 5059 (beginning-of-line) |
3382 (insert "Original-") | 5060 (insert "Original-") |
3383 (beginning-of-line)) | 5061 (beginning-of-line)) |
3384 (when (or (message-news-p) | 5062 (when (or (message-news-p) |
3385 (string-match "@.+\\.." secure-sender)) | 5063 (string-match "@.+\\.." secure-sender)) |
3386 (insert "Sender: " secure-sender "\n"))))))) | 5064 (insert "Sender: " secure-sender "\n")))) |
5065 ;; Check for IDNA | |
5066 (message-idna-to-ascii-rhs)))) | |
3387 | 5067 |
3388 (defun message-insert-courtesy-copy () | 5068 (defun message-insert-courtesy-copy () |
3389 "Insert a courtesy message in mail copies of combined messages." | 5069 "Insert a courtesy message in mail copies of combined messages." |
3390 (let (newsgroups) | 5070 (let (newsgroups) |
3391 (save-excursion | 5071 (save-excursion |
3434 (forward-char 1)))) | 5114 (forward-char 1)))) |
3435 (goto-char (point-max)) | 5115 (goto-char (point-max)) |
3436 (widen) | 5116 (widen) |
3437 (forward-line 1))) | 5117 (forward-line 1))) |
3438 | 5118 |
5119 (defun message-split-line () | |
5120 "Split current line, moving portion beyond point vertically down. | |
5121 If the current line has `message-yank-prefix', insert it on the new line." | |
5122 (interactive "*") | |
5123 (condition-case nil | |
5124 (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg. | |
5125 (error | |
5126 (split-line)))) | |
5127 | |
3439 (defun message-fill-header (header value) | 5128 (defun message-fill-header (header value) |
3440 (let ((begin (point)) | 5129 (let ((begin (point)) |
3441 (fill-column 78) | 5130 (fill-column 78) |
3442 (fill-prefix "\t")) | 5131 (fill-prefix "\t")) |
3443 (insert (capitalize (symbol-name header)) | 5132 (insert (capitalize (symbol-name header)) |
3461 "Cut SURPLUS elements out of LIST, beginning with CUTth one." | 5150 "Cut SURPLUS elements out of LIST, beginning with CUTth one." |
3462 (setcdr (nthcdr (- cut 2) list) | 5151 (setcdr (nthcdr (- cut 2) list) |
3463 (nthcdr (+ (- cut 2) surplus 1) list))) | 5152 (nthcdr (+ (- cut 2) surplus 1) list))) |
3464 | 5153 |
3465 (defun message-shorten-references (header references) | 5154 (defun message-shorten-references (header references) |
3466 "Trim REFERENCES to be less than 31 Message-ID long, and fold them. | 5155 "Trim REFERENCES to be 21 Message-ID long or less, and fold them. |
3467 If folding is disallowed, also check that the REFERENCES are less | 5156 If folding is disallowed, also check that the REFERENCES are less |
3468 than 988 characters long, and if they are not, trim them until they are." | 5157 than 988 characters long, and if they are not, trim them until they are." |
3469 (let ((maxcount 31) | 5158 (let ((maxcount 21) |
3470 (count 0) | 5159 (count 0) |
3471 (cut 6) | 5160 (cut 2) |
3472 refs) | 5161 refs) |
3473 (with-temp-buffer | 5162 (with-temp-buffer |
3474 (insert references) | 5163 (insert references) |
3475 (goto-char (point-min)) | 5164 (goto-char (point-min)) |
3476 ;; Cons a list of valid references. | 5165 ;; Cons a list of valid references. |
3532 (forward-line 1) | 5221 (forward-line 1) |
3533 (unless (looking-at "$") | 5222 (unless (looking-at "$") |
3534 (forward-line 2))) | 5223 (forward-line 2))) |
3535 (sit-for 0))) | 5224 (sit-for 0))) |
3536 | 5225 |
5226 (defcustom message-beginning-of-line t | |
5227 "Whether \\<message-mode-map>\\[message-beginning-of-line]\ | |
5228 goes to beginning of header values." | |
5229 :group 'message-buffers | |
5230 :link '(custom-manual "(message)Movement") | |
5231 :type 'boolean) | |
5232 | |
5233 (defun message-beginning-of-line (&optional n) | |
5234 "Move point to beginning of header value or to beginning of line. | |
5235 The prefix argument N is passed directly to `beginning-of-line'. | |
5236 | |
5237 This command is identical to `beginning-of-line' if point is | |
5238 outside the message header or if the option `message-beginning-of-line' | |
5239 is nil. | |
5240 | |
5241 If point is in the message header and on a (non-continued) header | |
5242 line, move point to the beginning of the header value. If point | |
5243 is already there, move point to beginning of line. Therefore, | |
5244 repeated calls will toggle point between beginning of field and | |
5245 beginning of line." | |
5246 (interactive "p") | |
5247 (let ((zrs 'zmacs-region-stays)) | |
5248 (when (and (interactive-p) (boundp zrs)) | |
5249 (set zrs t))) | |
5250 (if (and message-beginning-of-line | |
5251 (message-point-in-header-p)) | |
5252 (let* ((here (point)) | |
5253 (bol (progn (beginning-of-line n) (point))) | |
5254 (eol (gnus-point-at-eol)) | |
5255 (eoh (re-search-forward ": *" eol t))) | |
5256 (if (or (not eoh) (equal here eoh)) | |
5257 (goto-char bol) | |
5258 (goto-char eoh))) | |
5259 (beginning-of-line n))) | |
5260 | |
3537 (defun message-buffer-name (type &optional to group) | 5261 (defun message-buffer-name (type &optional to group) |
3538 "Return a new (unique) buffer name based on TYPE and TO." | 5262 "Return a new (unique) buffer name based on TYPE and TO." |
3539 (cond | 5263 (cond |
3540 ;; Generate a new buffer name The Message Way. | 5264 ;; Generate a new buffer name The Message Way. |
3541 ((eq message-generate-new-buffers 'unique) | 5265 ((eq message-generate-new-buffers 'unique) |
3548 "") | 5272 "") |
3549 (if (and group (not (string= group ""))) (concat " on " group) "") | 5273 (if (and group (not (string= group ""))) (concat " on " group) "") |
3550 "*"))) | 5274 "*"))) |
3551 ;; Check whether `message-generate-new-buffers' is a function, | 5275 ;; Check whether `message-generate-new-buffers' is a function, |
3552 ;; and if so, call it. | 5276 ;; and if so, call it. |
3553 ((message-functionp message-generate-new-buffers) | 5277 ((functionp message-generate-new-buffers) |
3554 (funcall message-generate-new-buffers type to group)) | 5278 (funcall message-generate-new-buffers type to group)) |
3555 ((eq message-generate-new-buffers 'unsent) | 5279 ((eq message-generate-new-buffers 'unsent) |
3556 (generate-new-buffer-name | 5280 (generate-new-buffer-name |
3557 (concat "*unsent " type | 5281 (concat "*unsent " type |
3558 (if to | 5282 (if to |
3585 "Kill old message buffers." | 5309 "Kill old message buffers." |
3586 ;; We might have sent this buffer already. Delete it from the | 5310 ;; We might have sent this buffer already. Delete it from the |
3587 ;; list of buffers. | 5311 ;; list of buffers. |
3588 (setq message-buffer-list (delq (current-buffer) message-buffer-list)) | 5312 (setq message-buffer-list (delq (current-buffer) message-buffer-list)) |
3589 (while (and message-max-buffers | 5313 (while (and message-max-buffers |
3590 message-buffer-list | 5314 message-buffer-list |
3591 (>= (length message-buffer-list) message-max-buffers)) | 5315 (>= (length message-buffer-list) message-max-buffers)) |
3592 ;; Kill the oldest buffer -- unless it has been changed. | 5316 ;; Kill the oldest buffer -- unless it has been changed. |
3593 (let ((buffer (pop message-buffer-list))) | 5317 (let ((buffer (pop message-buffer-list))) |
3594 (when (and (buffer-name buffer) | 5318 (when (and (buffer-name buffer) |
3595 (not (buffer-modified-p buffer))) | 5319 (not (buffer-modified-p buffer))) |
3596 (kill-buffer buffer)))) | 5320 (kill-buffer buffer)))) |
3597 ;; Rename the buffer. | 5321 ;; Rename the buffer. |
3598 (if message-send-rename-function | 5322 (if message-send-rename-function |
3599 (funcall message-send-rename-function) | 5323 (funcall message-send-rename-function) |
3600 (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name)) | 5324 ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus. |
3601 (rename-buffer | 5325 (when (string-match |
3602 (concat "*sent " (substring (buffer-name) (match-end 0))) t))) | 5326 "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to " |
5327 (buffer-name)) | |
5328 (let ((name (match-string 2 (buffer-name))) | |
5329 to group) | |
5330 (if (not (or (null name) | |
5331 (string-equal name "mail") | |
5332 (string-equal name "posting"))) | |
5333 (setq name (concat "*sent " name "*")) | |
5334 (message-narrow-to-headers) | |
5335 (setq to (message-fetch-field "to")) | |
5336 (setq group (message-fetch-field "newsgroups")) | |
5337 (widen) | |
5338 (setq name | |
5339 (cond | |
5340 (to (concat "*sent mail to " | |
5341 (or (car (mail-extract-address-components to)) | |
5342 to) "*")) | |
5343 ((and group (not (string= group ""))) | |
5344 (concat "*sent posting on " group "*")) | |
5345 (t "*sent mail*")))) | |
5346 (unless (string-equal name (buffer-name)) | |
5347 (rename-buffer name t))))) | |
3603 ;; Push the current buffer onto the list. | 5348 ;; Push the current buffer onto the list. |
3604 (when message-max-buffers | 5349 (when message-max-buffers |
3605 (setq message-buffer-list | 5350 (setq message-buffer-list |
3606 (nconc message-buffer-list (list (current-buffer)))))) | 5351 (nconc message-buffer-list (list (current-buffer)))))) |
3607 | 5352 |
3637 (format "%s" (car item)) | 5382 (format "%s" (car item)) |
3638 (cdr item))) | 5383 (cdr item))) |
3639 headers) | 5384 headers) |
3640 nil switch-function yank-action actions))))) | 5385 nil switch-function yank-action actions))))) |
3641 | 5386 |
3642 (eval-when-compile (defvar mc-modes-alist)) | 5387 (defun message-headers-to-generate (headers included-headers excluded-headers) |
5388 "Return a list that includes all headers from HEADERS. | |
5389 If INCLUDED-HEADERS is a list, just include those headers. If if is | |
5390 t, include all headers. In any case, headers from EXCLUDED-HEADERS | |
5391 are not included." | |
5392 (let ((result nil) | |
5393 header-name) | |
5394 (dolist (header headers) | |
5395 (setq header-name (cond | |
5396 ((and (consp header) | |
5397 (eq (car header) 'optional)) | |
5398 ;; On the form (optional . Header) | |
5399 (cdr header)) | |
5400 ((consp header) | |
5401 ;; On the form (Header . function) | |
5402 (car header)) | |
5403 (t | |
5404 ;; Just a Header. | |
5405 header))) | |
5406 (when (and (not (memq header-name excluded-headers)) | |
5407 (or (eq included-headers t) | |
5408 (memq header-name included-headers))) | |
5409 (push header result))) | |
5410 (nreverse result))) | |
5411 | |
3643 (defun message-setup-1 (headers &optional replybuffer actions) | 5412 (defun message-setup-1 (headers &optional replybuffer actions) |
3644 (when (and (boundp 'mc-modes-alist) | |
3645 (not (assq 'message-mode mc-modes-alist))) | |
3646 (push '(message-mode (encrypt . mc-encrypt-message) | |
3647 (sign . mc-sign-message)) | |
3648 mc-modes-alist)) | |
3649 (dolist (action actions) | 5413 (dolist (action actions) |
3650 (condition-case nil | 5414 (condition-case nil |
3651 (add-to-list 'message-send-actions | 5415 (add-to-list 'message-send-actions |
3652 `(apply ',(car action) ',(cdr action))))) | 5416 `(apply ',(car action) ',(cdr action))))) |
3653 (setq message-reply-buffer replybuffer) | 5417 (setq message-reply-buffer replybuffer) |
3677 (when message-default-news-headers | 5441 (when message-default-news-headers |
3678 (insert message-default-news-headers) | 5442 (insert message-default-news-headers) |
3679 (or (bolp) (insert ?\n))) | 5443 (or (bolp) (insert ?\n))) |
3680 (when message-generate-headers-first | 5444 (when message-generate-headers-first |
3681 (message-generate-headers | 5445 (message-generate-headers |
3682 (delq 'Lines | 5446 (message-headers-to-generate |
3683 (delq 'Subject | 5447 (append message-required-news-headers |
3684 (copy-sequence message-required-news-headers)))))) | 5448 message-required-headers) |
5449 message-generate-headers-first | |
5450 '(Lines Subject))))) | |
3685 (when (message-mail-p) | 5451 (when (message-mail-p) |
3686 (when message-default-mail-headers | 5452 (when message-default-mail-headers |
3687 (insert message-default-mail-headers) | 5453 (insert message-default-mail-headers) |
3688 (or (bolp) (insert ?\n))) | 5454 (or (bolp) (insert ?\n))) |
5455 (save-restriction | |
5456 (message-narrow-to-headers) | |
5457 (if message-alternative-emails | |
5458 (message-use-alternative-email-as-from))) | |
3689 (when message-generate-headers-first | 5459 (when message-generate-headers-first |
3690 (message-generate-headers | 5460 (message-generate-headers |
3691 (delq 'Lines | 5461 (message-headers-to-generate |
3692 (delq 'Subject | 5462 (append message-required-mail-headers |
3693 (copy-sequence message-required-mail-headers)))))) | 5463 message-required-headers) |
5464 message-generate-headers-first | |
5465 '(Lines Subject))))) | |
3694 (run-hooks 'message-signature-setup-hook) | 5466 (run-hooks 'message-signature-setup-hook) |
3695 (message-insert-signature) | 5467 (message-insert-signature) |
3696 (save-restriction | 5468 (save-restriction |
3697 (message-narrow-to-headers) | 5469 (message-narrow-to-headers) |
3698 (if message-alternative-emails | |
3699 (message-use-alternative-email-as-from)) | |
3700 (run-hooks 'message-header-setup-hook)) | 5470 (run-hooks 'message-header-setup-hook)) |
3701 (set-buffer-modified-p nil) | 5471 (set-buffer-modified-p nil) |
3702 (setq buffer-undo-list nil) | 5472 (setq buffer-undo-list nil) |
3703 (run-hooks 'message-setup-hook) | 5473 (run-hooks 'message-setup-hook) |
3704 (message-position-point) | 5474 (message-position-point) |
3711 (directory-file-name message-auto-save-directory)) | 5481 (directory-file-name message-auto-save-directory)) |
3712 (make-directory message-auto-save-directory t)) | 5482 (make-directory message-auto-save-directory t)) |
3713 (if (gnus-alive-p) | 5483 (if (gnus-alive-p) |
3714 (setq message-draft-article | 5484 (setq message-draft-article |
3715 (nndraft-request-associate-buffer "drafts")) | 5485 (nndraft-request-associate-buffer "drafts")) |
3716 (setq buffer-file-name (expand-file-name "*message*" | 5486 (setq buffer-file-name (expand-file-name |
3717 message-auto-save-directory)) | 5487 (if (memq system-type |
5488 '(ms-dos ms-windows windows-nt | |
5489 cygwin cygwin32 win32 w32 | |
5490 mswindows)) | |
5491 "message" | |
5492 "*message*") | |
5493 message-auto-save-directory)) | |
3718 (setq buffer-auto-save-file-name (make-auto-save-file-name))) | 5494 (setq buffer-auto-save-file-name (make-auto-save-file-name))) |
3719 (clear-visited-file-modtime) | 5495 (clear-visited-file-modtime) |
3720 (setq buffer-file-coding-system message-draft-coding-system))) | 5496 (setq buffer-file-coding-system message-draft-coding-system))) |
3721 | 5497 |
3722 (defun message-disassociate-draft () | 5498 (defun message-disassociate-draft () |
3773 ;;;###autoload | 5549 ;;;###autoload |
3774 (defun message-news (&optional newsgroups subject) | 5550 (defun message-news (&optional newsgroups subject) |
3775 "Start editing a news article to be sent." | 5551 "Start editing a news article to be sent." |
3776 (interactive) | 5552 (interactive) |
3777 (let ((message-this-is-news t)) | 5553 (let ((message-this-is-news t)) |
3778 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)) | 5554 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)) |
3779 (message-setup `((Newsgroups . ,(or newsgroups "")) | 5555 (message-setup `((Newsgroups . ,(or newsgroups "")) |
3780 (Subject . ,(or subject "")))))) | 5556 (Subject . ,(or subject "")))))) |
3781 | 5557 |
3782 (defun message-get-reply-headers (wide &optional to-address) | 5558 (defun message-get-reply-headers (wide &optional to-address address-headers) |
3783 (let (follow-to mct never-mct from to cc reply-to ccalist) | 5559 (let (follow-to mct never-mct to cc author mft recipients) |
3784 ;; Find all relevant headers we need. | 5560 ;; Find all relevant headers we need. |
3785 (setq from (message-fetch-field "from") | 5561 (save-restriction |
3786 to (message-fetch-field "to") | 5562 (message-narrow-to-headers-or-head) |
3787 cc (message-fetch-field "cc") | 5563 ;; Gmane renames "To". Look at "Original-To", too, if it is present in |
3788 mct (message-fetch-field "mail-copies-to") | 5564 ;; message-header-synonyms. |
3789 reply-to (message-fetch-field "reply-to")) | 5565 (setq to (or (message-fetch-field "to") |
5566 (and (loop for synonym in message-header-synonyms | |
5567 when (memq 'Original-To synonym) | |
5568 return t) | |
5569 (message-fetch-field "original-to"))) | |
5570 cc (message-fetch-field "cc") | |
5571 mct (message-fetch-field "mail-copies-to") | |
5572 author (or (message-fetch-field "mail-reply-to") | |
5573 (message-fetch-field "reply-to") | |
5574 (message-fetch-field "from") | |
5575 "") | |
5576 mft (and message-use-mail-followup-to | |
5577 (message-fetch-field "mail-followup-to")))) | |
3790 | 5578 |
3791 ;; Handle special values of Mail-Copies-To. | 5579 ;; Handle special values of Mail-Copies-To. |
3792 (when mct | 5580 (when mct |
3793 (cond ((or (equal (downcase mct) "never") | 5581 (cond ((or (equal (downcase mct) "never") |
3794 (equal (downcase mct) "nobody")) | 5582 (equal (downcase mct) "nobody")) |
3795 (setq never-mct t) | 5583 (setq never-mct t) |
3796 (setq mct nil)) | 5584 (setq mct nil)) |
3797 ((or (equal (downcase mct) "always") | 5585 ((or (equal (downcase mct) "always") |
3798 (equal (downcase mct) "poster")) | 5586 (equal (downcase mct) "poster")) |
3799 (setq mct (or reply-to from))))) | 5587 (setq mct author)))) |
3800 | 5588 |
3801 (if (or (not wide) | 5589 (save-match-data |
3802 to-address) | 5590 ;; Build (textual) list of new recipient addresses. |
3803 (progn | 5591 (cond |
3804 (setq follow-to (list (cons 'To (or to-address reply-to from)))) | 5592 ((not wide) |
3805 (when (and wide mct) | 5593 (setq recipients (concat ", " author))) |
3806 (push (cons 'Cc mct) follow-to))) | 5594 (address-headers |
3807 (let (ccalist) | 5595 (dolist (header address-headers) |
3808 (save-excursion | 5596 (let ((value (message-fetch-field header))) |
3809 (message-set-work-buffer) | 5597 (when value |
3810 (unless never-mct | 5598 (setq recipients (concat recipients ", " value)))))) |
3811 (insert (or reply-to from ""))) | 5599 ((and mft |
3812 (insert (if to (concat (if (bolp) "" ", ") to "") "")) | 5600 (string-match "[^ \t,]" mft) |
3813 (insert (if mct (concat (if (bolp) "" ", ") mct) "")) | 5601 (or (not (eq message-use-mail-followup-to 'ask)) |
3814 (insert (if cc (concat (if (bolp) "" ", ") cc) "")) | 5602 (message-y-or-n-p "Obey Mail-Followup-To? " t "\ |
3815 (goto-char (point-min)) | 5603 You should normally obey the Mail-Followup-To: header. In this |
3816 (while (re-search-forward "[ \t]+" nil t) | 5604 article, it has the value of |
3817 (replace-match " " t t)) | 5605 |
3818 ;; Remove addresses that match `rmail-dont-reply-to-names'. | 5606 " mft " |
3819 (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) | 5607 |
3820 (insert (prog1 (rmail-dont-reply-to (buffer-string)) | 5608 which directs your response to " (if (string-match "," mft) |
3821 (erase-buffer)))) | 5609 "the specified addresses" |
3822 (goto-char (point-min)) | 5610 "that address only") ". |
3823 ;; Perhaps "Mail-Copies-To: never" removed the only address? | 5611 |
3824 (when (eobp) | 5612 Most commonly, Mail-Followup-To is used by a mailing list poster to |
3825 (insert (or reply-to from ""))) | 5613 express that responses should be sent to just the list, and not the |
3826 (setq ccalist | 5614 poster as well. |
3827 (mapcar | 5615 |
3828 (lambda (addr) | 5616 If a message is posted to several mailing lists, Mail-Followup-To may |
3829 (cons (mail-strip-quoted-names addr) addr)) | 5617 also be used to direct the following discussion to one list only, |
3830 (message-tokenize-header (buffer-string)))) | 5618 because discussions that are spread over several lists tend to be |
3831 (let ((s ccalist)) | 5619 fragmented and very difficult to follow. |
3832 (while s | 5620 |
3833 (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) | 5621 Also, some source/announcement lists are not intended for discussion; |
3834 (setq follow-to (list (cons 'To (cdr (pop ccalist))))) | 5622 responses here are directed to other addresses."))) |
3835 (when ccalist | 5623 (setq recipients (concat ", " mft))) |
3836 (let ((ccs (cons 'Cc (mapconcat | 5624 (to-address |
3837 (lambda (addr) (cdr addr)) ccalist ", ")))) | 5625 (setq recipients (concat ", " to-address)) |
3838 (when (string-match "^ +" (cdr ccs)) | 5626 ;; If the author explicitly asked for a copy, we don't deny it to them. |
3839 (setcdr ccs (substring (cdr ccs) (match-end 0)))) | 5627 (if mct (setq recipients (concat recipients ", " mct)))) |
3840 (push ccs follow-to))))) | 5628 (t |
5629 (setq recipients (if never-mct "" (concat ", " author))) | |
5630 (if to (setq recipients (concat recipients ", " to))) | |
5631 (if cc (setq recipients (concat recipients ", " cc))) | |
5632 (if mct (setq recipients (concat recipients ", " mct))))) | |
5633 (if (>= (length recipients) 2) | |
5634 ;; Strip the leading ", ". | |
5635 (setq recipients (substring recipients 2))) | |
5636 ;; Squeeze whitespace. | |
5637 (while (string-match "[ \t][ \t]+" recipients) | |
5638 (setq recipients (replace-match " " t t recipients))) | |
5639 ;; Remove addresses that match `rmail-dont-reply-to-names'. | |
5640 (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) | |
5641 (setq recipients (rmail-dont-reply-to recipients))) | |
5642 ;; Perhaps "Mail-Copies-To: never" removed the only address? | |
5643 (if (string-equal recipients "") | |
5644 (setq recipients author)) | |
5645 ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...). | |
5646 (setq recipients | |
5647 (mapcar | |
5648 (lambda (addr) | |
5649 (cons (downcase (mail-strip-quoted-names addr)) addr)) | |
5650 (message-tokenize-header recipients))) | |
5651 ;; Remove first duplicates. (Why not all duplicates? Is this a bug?) | |
5652 (let ((s recipients)) | |
5653 (while s | |
5654 (setq recipients (delq (assoc (car (pop s)) s) recipients)))) | |
5655 | |
5656 ;; Remove hierarchical lists that are contained within each other, | |
5657 ;; if message-hierarchical-addresses is defined. | |
5658 (when message-hierarchical-addresses | |
5659 (let ((plain-addrs (mapcar 'car recipients)) | |
5660 subaddrs recip) | |
5661 (while plain-addrs | |
5662 (setq subaddrs (assoc (car plain-addrs) | |
5663 message-hierarchical-addresses) | |
5664 plain-addrs (cdr plain-addrs)) | |
5665 (when subaddrs | |
5666 (setq subaddrs (cdr subaddrs)) | |
5667 (while subaddrs | |
5668 (setq recip (assoc (car subaddrs) recipients) | |
5669 subaddrs (cdr subaddrs)) | |
5670 (if recip | |
5671 (setq recipients (delq recip recipients)))))))) | |
5672 | |
5673 ;; Build the header alist. Allow the user to be asked whether | |
5674 ;; or not to reply to all recipients in a wide reply. | |
5675 (setq follow-to (list (cons 'To (cdr (pop recipients))))) | |
5676 (when (and recipients | |
5677 (or (not message-wide-reply-confirm-recipients) | |
5678 (y-or-n-p "Reply to all recipients? "))) | |
5679 (setq recipients (mapconcat | |
5680 (lambda (addr) (cdr addr)) recipients ", ")) | |
5681 (if (string-match "^ +" recipients) | |
5682 (setq recipients (substring recipients (match-end 0)))) | |
5683 (push (cons 'Cc recipients) follow-to))) | |
3841 follow-to)) | 5684 follow-to)) |
3842 | |
3843 | 5685 |
3844 ;;;###autoload | 5686 ;;;###autoload |
3845 (defun message-reply (&optional to-address wide) | 5687 (defun message-reply (&optional to-address wide) |
3846 "Start editing a reply to the article in the current buffer." | 5688 "Start editing a reply to the article in the current buffer." |
3847 (interactive) | 5689 (interactive) |
3855 (save-restriction | 5697 (save-restriction |
3856 (message-narrow-to-head-1) | 5698 (message-narrow-to-head-1) |
3857 ;; Allow customizations to have their say. | 5699 ;; Allow customizations to have their say. |
3858 (if (not wide) | 5700 (if (not wide) |
3859 ;; This is a regular reply. | 5701 ;; This is a regular reply. |
3860 (if (message-functionp message-reply-to-function) | 5702 (when (functionp message-reply-to-function) |
3861 (setq follow-to (funcall message-reply-to-function))) | 5703 (save-excursion |
5704 (setq follow-to (funcall message-reply-to-function)))) | |
3862 ;; This is a followup. | 5705 ;; This is a followup. |
3863 (if (message-functionp message-wide-reply-to-function) | 5706 (when (functionp message-wide-reply-to-function) |
3864 (save-excursion | 5707 (save-excursion |
3865 (setq follow-to | 5708 (setq follow-to |
3866 (funcall message-wide-reply-to-function))))) | 5709 (funcall message-wide-reply-to-function))))) |
3867 (setq message-id (message-fetch-field "message-id" t) | 5710 (setq message-id (message-fetch-field "message-id" t) |
3868 references (message-fetch-field "references") | 5711 references (message-fetch-field "references") |
3869 date (message-fetch-field "date") | 5712 date (message-fetch-field "date") |
3870 from (message-fetch-field "from") | 5713 from (message-fetch-field "from") |
3871 subject (or (message-fetch-field "subject") "none")) | 5714 subject (or (message-fetch-field "subject") "none")) |
3872 (if gnus-list-identifiers | 5715 (when gnus-list-identifiers |
3873 (setq subject (message-strip-list-identifiers subject))) | 5716 (setq subject (message-strip-list-identifiers subject))) |
3874 (setq subject (concat "Re: " (message-strip-subject-re subject))) | 5717 (setq subject (concat "Re: " (message-strip-subject-re subject))) |
3875 | 5718 (when message-subject-trailing-was-query |
3876 (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) | 5719 (setq subject (message-strip-subject-trailing-was subject))) |
3877 (string-match "<[^>]+>" gnus-warning)) | 5720 |
3878 (setq message-id (match-string 0 gnus-warning))) | 5721 (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) |
3879 | 5722 (string-match "<[^>]+>" gnus-warning)) |
3880 (unless follow-to | 5723 (setq message-id (match-string 0 gnus-warning))) |
3881 (setq follow-to (message-get-reply-headers wide to-address)))) | 5724 |
5725 (unless follow-to | |
5726 (setq follow-to (message-get-reply-headers wide to-address)))) | |
3882 | 5727 |
3883 (unless (message-mail-user-agent) | 5728 (unless (message-mail-user-agent) |
3884 (message-pop-to-buffer | 5729 (message-pop-to-buffer |
3885 (message-buffer-name | 5730 (message-buffer-name |
3886 (if wide "wide reply" "reply") from | 5731 (if wide "wide reply" "reply") from |
3889 (setq message-reply-headers | 5734 (setq message-reply-headers |
3890 (vector 0 subject from date message-id references 0 0 "")) | 5735 (vector 0 subject from date message-id references 0 0 "")) |
3891 | 5736 |
3892 (message-setup | 5737 (message-setup |
3893 `((Subject . ,subject) | 5738 `((Subject . ,subject) |
3894 ,@follow-to | 5739 ,@follow-to) |
3895 ,@(if (or references message-id) | |
3896 `((References . ,(concat (or references "") (and references " ") | |
3897 (or message-id "")))) | |
3898 nil)) | |
3899 cur))) | 5740 cur))) |
3900 | 5741 |
3901 ;;;###autoload | 5742 ;;;###autoload |
3902 (defun message-wide-reply (&optional to-address) | 5743 (defun message-wide-reply (&optional to-address) |
3903 "Make a \"wide\" reply to the message in the current buffer." | 5744 "Make a \"wide\" reply to the message in the current buffer." |
3909 "Follow up to the message in the current buffer. | 5750 "Follow up to the message in the current buffer. |
3910 If TO-NEWSGROUPS, use that as the new Newsgroups line." | 5751 If TO-NEWSGROUPS, use that as the new Newsgroups line." |
3911 (interactive) | 5752 (interactive) |
3912 (require 'gnus-sum) ; for gnus-list-identifiers | 5753 (require 'gnus-sum) ; for gnus-list-identifiers |
3913 (let ((cur (current-buffer)) | 5754 (let ((cur (current-buffer)) |
3914 from subject date reply-to mct | 5755 from subject date reply-to mrt mct |
3915 references message-id follow-to | 5756 references message-id follow-to |
3916 (inhibit-point-motion-hooks t) | 5757 (inhibit-point-motion-hooks t) |
3917 (message-this-is-news t) | 5758 (message-this-is-news t) |
3918 followup-to distribution newsgroups gnus-warning posted-to) | 5759 followup-to distribution newsgroups gnus-warning posted-to) |
3919 (save-restriction | 5760 (save-restriction |
3920 (narrow-to-region | 5761 (narrow-to-region |
3921 (goto-char (point-min)) | 5762 (goto-char (point-min)) |
3922 (if (search-forward "\n\n" nil t) | 5763 (if (search-forward "\n\n" nil t) |
3923 (1- (point)) | 5764 (1- (point)) |
3924 (point-max))) | 5765 (point-max))) |
3925 (when (message-functionp message-followup-to-function) | 5766 (when (functionp message-followup-to-function) |
3926 (setq follow-to | 5767 (setq follow-to |
3927 (funcall message-followup-to-function))) | 5768 (funcall message-followup-to-function))) |
3928 (setq from (message-fetch-field "from") | 5769 (setq from (message-fetch-field "from") |
3929 date (message-fetch-field "date") | 5770 date (message-fetch-field "date") |
3930 subject (or (message-fetch-field "subject") "none") | 5771 subject (or (message-fetch-field "subject") "none") |
3932 message-id (message-fetch-field "message-id" t) | 5773 message-id (message-fetch-field "message-id" t) |
3933 followup-to (message-fetch-field "followup-to") | 5774 followup-to (message-fetch-field "followup-to") |
3934 newsgroups (message-fetch-field "newsgroups") | 5775 newsgroups (message-fetch-field "newsgroups") |
3935 posted-to (message-fetch-field "posted-to") | 5776 posted-to (message-fetch-field "posted-to") |
3936 reply-to (message-fetch-field "reply-to") | 5777 reply-to (message-fetch-field "reply-to") |
5778 mrt (message-fetch-field "mail-reply-to") | |
3937 distribution (message-fetch-field "distribution") | 5779 distribution (message-fetch-field "distribution") |
3938 mct (message-fetch-field "mail-copies-to")) | 5780 mct (message-fetch-field "mail-copies-to")) |
3939 (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) | 5781 (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) |
3940 (string-match "<[^>]+>" gnus-warning)) | 5782 (string-match "<[^>]+>" gnus-warning)) |
3941 (setq message-id (match-string 0 gnus-warning))) | 5783 (setq message-id (match-string 0 gnus-warning))) |
3945 (string-match "world" distribution))) | 5787 (string-match "world" distribution))) |
3946 (setq distribution nil)) | 5788 (setq distribution nil)) |
3947 (if gnus-list-identifiers | 5789 (if gnus-list-identifiers |
3948 (setq subject (message-strip-list-identifiers subject))) | 5790 (setq subject (message-strip-list-identifiers subject))) |
3949 (setq subject (concat "Re: " (message-strip-subject-re subject))) | 5791 (setq subject (concat "Re: " (message-strip-subject-re subject))) |
5792 (when message-subject-trailing-was-query | |
5793 (setq subject (message-strip-subject-trailing-was subject))) | |
3950 (widen)) | 5794 (widen)) |
3951 | 5795 |
3952 (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) | 5796 (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) |
5797 | |
5798 (setq message-reply-headers | |
5799 (vector 0 subject from date message-id references 0 0 "")) | |
3953 | 5800 |
3954 (message-setup | 5801 (message-setup |
3955 `((Subject . ,subject) | 5802 `((Subject . ,subject) |
3956 ,@(cond | 5803 ,@(cond |
3957 (to-newsgroups | 5804 (to-newsgroups |
3969 | 5816 |
3970 A typical situation where `Followup-To: poster' is used is when the poster | 5817 A typical situation where `Followup-To: poster' is used is when the poster |
3971 does not read the newsgroup, so he wouldn't see any replies sent to it.")) | 5818 does not read the newsgroup, so he wouldn't see any replies sent to it.")) |
3972 (progn | 5819 (progn |
3973 (setq message-this-is-news nil) | 5820 (setq message-this-is-news nil) |
3974 (cons 'To (or reply-to from ""))) | 5821 (cons 'To (or mrt reply-to from ""))) |
3975 (cons 'Newsgroups newsgroups))) | 5822 (cons 'Newsgroups newsgroups))) |
3976 (t | 5823 (t |
3977 (if (or (equal followup-to newsgroups) | 5824 (if (or (equal followup-to newsgroups) |
3978 (not (eq message-use-followup-to 'ask)) | 5825 (not (eq message-use-followup-to 'ask)) |
3979 (message-y-or-n-p | 5826 (message-y-or-n-p |
3988 If a message is posted to several newsgroups, Followup-To is often | 5835 If a message is posted to several newsgroups, Followup-To is often |
3989 used to direct the following discussion to one newsgroup only, | 5836 used to direct the following discussion to one newsgroup only, |
3990 because discussions that are spread over several newsgroup tend to | 5837 because discussions that are spread over several newsgroup tend to |
3991 be fragmented and very difficult to follow. | 5838 be fragmented and very difficult to follow. |
3992 | 5839 |
3993 Also, some source/announcement newsgroups are not indented for discussion; | 5840 Also, some source/announcement newsgroups are not intended for discussion; |
3994 responses here are directed to other newsgroups.")) | 5841 responses here are directed to other newsgroups.")) |
3995 (cons 'Newsgroups followup-to) | 5842 (cons 'Newsgroups followup-to) |
3996 (cons 'Newsgroups newsgroups)))))) | 5843 (cons 'Newsgroups newsgroups)))))) |
3997 (posted-to | 5844 (posted-to |
3998 `((Newsgroups . ,posted-to))) | 5845 `((Newsgroups . ,posted-to))) |
3999 (t | 5846 (t |
4000 `((Newsgroups . ,newsgroups)))) | 5847 `((Newsgroups . ,newsgroups)))) |
4001 ,@(and distribution (list (cons 'Distribution distribution))) | 5848 ,@(and distribution (list (cons 'Distribution distribution))) |
4002 ,@(if (or references message-id) | |
4003 `((References . ,(concat (or references "") (and references " ") | |
4004 (or message-id ""))))) | |
4005 ,@(when (and mct | 5849 ,@(when (and mct |
4006 (not (or (equal (downcase mct) "never") | 5850 (not (or (equal (downcase mct) "never") |
4007 (equal (downcase mct) "nobody")))) | 5851 (equal (downcase mct) "nobody")))) |
4008 (list (cons 'Cc (if (or (equal (downcase mct) "always") | 5852 (list (cons 'Cc (if (or (equal (downcase mct) "always") |
4009 (equal (downcase mct) "poster")) | 5853 (equal (downcase mct) "poster")) |
4010 (or reply-to from "") | 5854 (or mrt reply-to from "") |
4011 mct))))) | 5855 mct))))) |
4012 | 5856 |
4013 cur) | 5857 cur))) |
4014 | 5858 |
4015 (setq message-reply-headers | 5859 (defun message-is-yours-p () |
4016 (vector 0 subject from date message-id references 0 0 "")))) | 5860 "Non-nil means current article is yours. |
4017 | 5861 If you have added 'cancel-messages to 'message-shoot-gnksa-feet', all articles |
5862 are yours except those that have Cancel-Lock header not belonging to you. | |
5863 Instead of shooting GNKSA feet, you should modify 'message-alternative-emails' | |
5864 regexp to match all of yours addresses." | |
5865 ;; Canlock-logic as suggested by Per Abrahamsen | |
5866 ;; <abraham@dina.kvl.dk> | |
5867 ;; | |
5868 ;; IF article has cancel-lock THEN | |
5869 ;; IF we can verify it THEN | |
5870 ;; issue cancel | |
5871 ;; ELSE | |
5872 ;; error: cancellock: article is not yours | |
5873 ;; ELSE | |
5874 ;; Use old rules, comparing sender... | |
5875 (save-excursion | |
5876 (save-restriction | |
5877 (message-narrow-to-head-1) | |
5878 (if (message-fetch-field "Cancel-Lock") | |
5879 (if (null (canlock-verify)) | |
5880 t | |
5881 (error "Failed to verify Cancel-lock: This article is not yours")) | |
5882 (let (sender from) | |
5883 (or | |
5884 (message-gnksa-enable-p 'cancel-messages) | |
5885 (and (setq sender (message-fetch-field "sender")) | |
5886 (string-equal (downcase sender) | |
5887 (downcase (message-make-sender)))) | |
5888 ;; Email address in From field equals to our address | |
5889 (and (setq from (message-fetch-field "from")) | |
5890 (string-equal | |
5891 (downcase (cadr (mail-extract-address-components from))) | |
5892 (downcase (cadr (mail-extract-address-components | |
5893 (message-make-from)))))) | |
5894 ;; Email address in From field matches | |
5895 ;; 'message-alternative-emails' regexp | |
5896 (and from | |
5897 message-alternative-emails | |
5898 (string-match | |
5899 message-alternative-emails | |
5900 (cadr (mail-extract-address-components from)))))))))) | |
4018 | 5901 |
4019 ;;;###autoload | 5902 ;;;###autoload |
4020 (defun message-cancel-news (&optional arg) | 5903 (defun message-cancel-news (&optional arg) |
4021 "Cancel an article you posted. | 5904 "Cancel an article you posted. |
4022 If ARG, allow editing of the cancellation message." | 5905 If ARG, allow editing of the cancellation message." |
4023 (interactive "P") | 5906 (interactive "P") |
4024 (unless (message-news-p) | 5907 (unless (message-news-p) |
4025 (error "This is not a news article; canceling is impossible")) | 5908 (error "This is not a news article; canceling is impossible")) |
4026 (when (yes-or-no-p "Do you really want to cancel this article? ") | 5909 (let (from newsgroups message-id distribution buf) |
4027 (let (from newsgroups message-id distribution buf sender) | 5910 (save-excursion |
4028 (save-excursion | 5911 ;; Get header info from original article. |
4029 ;; Get header info from original article. | 5912 (save-restriction |
4030 (save-restriction | 5913 (message-narrow-to-head-1) |
4031 (message-narrow-to-head-1) | 5914 (setq from (message-fetch-field "from") |
4032 (setq from (message-fetch-field "from") | 5915 newsgroups (message-fetch-field "newsgroups") |
4033 sender (message-fetch-field "sender") | 5916 message-id (message-fetch-field "message-id" t) |
4034 newsgroups (message-fetch-field "newsgroups") | 5917 distribution (message-fetch-field "distribution"))) |
4035 message-id (message-fetch-field "message-id" t) | 5918 ;; Make sure that this article was written by the user. |
4036 distribution (message-fetch-field "distribution"))) | 5919 (unless (message-is-yours-p) |
4037 ;; Make sure that this article was written by the user. | 5920 (error "This article is not yours")) |
4038 (unless (or (and sender | 5921 (when (yes-or-no-p "Do you really want to cancel this article? ") |
4039 (string-equal | |
4040 (downcase sender) | |
4041 (downcase (message-make-sender)))) | |
4042 (string-equal | |
4043 (downcase (cadr (mail-extract-address-components from))) | |
4044 (downcase (cadr (mail-extract-address-components | |
4045 (message-make-from)))))) | |
4046 (error "This article is not yours")) | |
4047 ;; Make control message. | 5922 ;; Make control message. |
4048 (if arg | 5923 (if arg |
4049 (message-news) | 5924 (message-news) |
4050 (setq buf (set-buffer (get-buffer-create " *message cancel*")))) | 5925 (setq buf (set-buffer (get-buffer-create " *message cancel*")))) |
4051 (erase-buffer) | 5926 (erase-buffer) |
4052 (insert "Newsgroups: " newsgroups "\n" | 5927 (insert "Newsgroups: " newsgroups "\n" |
4053 "From: " from "\n" | 5928 "From: " from "\n" |
4054 "Subject: cmsg cancel " message-id "\n" | 5929 "Subject: cmsg cancel " message-id "\n" |
4055 "Control: cancel " message-id "\n" | 5930 "Control: cancel " message-id "\n" |
4056 (if distribution | 5931 (if distribution |
4057 (concat "Distribution: " distribution "\n") | 5932 (concat "Distribution: " distribution "\n") |
4058 "") | 5933 "") |
4071 (defun message-supersede () | 5946 (defun message-supersede () |
4072 "Start composing a message to supersede the current message. | 5947 "Start composing a message to supersede the current message. |
4073 This is done simply by taking the old article and adding a Supersedes | 5948 This is done simply by taking the old article and adding a Supersedes |
4074 header line with the old Message-ID." | 5949 header line with the old Message-ID." |
4075 (interactive) | 5950 (interactive) |
4076 (let ((cur (current-buffer)) | 5951 (let ((cur (current-buffer))) |
4077 (sender (message-fetch-field "sender")) | |
4078 (from (message-fetch-field "from"))) | |
4079 ;; Check whether the user owns the article that is to be superseded. | 5952 ;; Check whether the user owns the article that is to be superseded. |
4080 (unless (or (and sender | 5953 (unless (message-is-yours-p) |
4081 (string-equal | |
4082 (downcase sender) | |
4083 (downcase (message-make-sender)))) | |
4084 (string-equal | |
4085 (downcase (cadr (mail-extract-address-components from))) | |
4086 (downcase (cadr (mail-extract-address-components | |
4087 (message-make-from)))))) | |
4088 (error "This article is not yours")) | 5954 (error "This article is not yours")) |
4089 ;; Get a normal message buffer. | 5955 ;; Get a normal message buffer. |
4090 (message-pop-to-buffer (message-buffer-name "supersede")) | 5956 (message-pop-to-buffer (message-buffer-name "supersede")) |
4091 (insert-buffer-substring cur) | 5957 (insert-buffer-substring cur) |
4092 (mime-to-mml) | 5958 (mime-to-mml) |
4159 ;;; Forwarding messages. | 6025 ;;; Forwarding messages. |
4160 | 6026 |
4161 (defvar message-forward-decoded-p nil | 6027 (defvar message-forward-decoded-p nil |
4162 "Non-nil means the original message is decoded.") | 6028 "Non-nil means the original message is decoded.") |
4163 | 6029 |
6030 (defun message-forward-subject-name-subject (subject) | |
6031 "Generate a SUBJECT for a forwarded message. | |
6032 The form is: [Source] Subject, where if the original message was mail, | |
6033 Source is the name of the sender, and if the original message was | |
6034 news, Source is the list of newsgroups is was posted to." | |
6035 (let* ((group (message-fetch-field "newsgroups")) | |
6036 (from (message-fetch-field "from")) | |
6037 (prefix | |
6038 (if group | |
6039 (gnus-group-decoded-name group) | |
6040 (or (and from (car (gnus-extract-address-components from))) | |
6041 "(nowhere)")))) | |
6042 (concat "[" | |
6043 (if message-forward-decoded-p | |
6044 prefix | |
6045 (mail-decode-encoded-word-string prefix)) | |
6046 "] " subject))) | |
6047 | |
4164 (defun message-forward-subject-author-subject (subject) | 6048 (defun message-forward-subject-author-subject (subject) |
4165 "Generate a SUBJECT for a forwarded message. | 6049 "Generate a SUBJECT for a forwarded message. |
4166 The form is: [Source] Subject, where if the original message was mail, | 6050 The form is: [Source] Subject, where if the original message was mail, |
4167 Source is the sender, and if the original message was news, Source is | 6051 Source is the sender, and if the original message was news, Source is |
4168 the list of newsgroups is was posted to." | 6052 the list of newsgroups is was posted to." |
4169 (concat "[" | 6053 (let* ((group (message-fetch-field "newsgroups")) |
4170 (let ((prefix | 6054 (prefix |
4171 (or (message-fetch-field "newsgroups") | 6055 (if group |
4172 (message-fetch-field "from") | 6056 (gnus-group-decoded-name group) |
4173 "(nowhere)"))) | 6057 (or (message-fetch-field "from") |
4174 (if message-forward-decoded-p | 6058 "(nowhere)")))) |
4175 prefix | 6059 (concat "[" |
4176 (mail-decode-encoded-word-string prefix))) | 6060 (if message-forward-decoded-p |
4177 "] " subject)) | 6061 prefix |
6062 (mail-decode-encoded-word-string prefix)) | |
6063 "] " subject))) | |
4178 | 6064 |
4179 (defun message-forward-subject-fwd (subject) | 6065 (defun message-forward-subject-fwd (subject) |
4180 "Generate a SUBJECT for a forwarded message. | 6066 "Generate a SUBJECT for a forwarded message. |
4181 The form is: Fwd: Subject, where Subject is the original subject of | 6067 The form is: Fwd: Subject, where Subject is the original subject of |
4182 the message." | 6068 the message." |
4183 (concat "Fwd: " subject)) | 6069 (if (string-match "^Fwd: " subject) |
6070 subject | |
6071 (concat "Fwd: " subject))) | |
4184 | 6072 |
4185 (defun message-make-forward-subject () | 6073 (defun message-make-forward-subject () |
4186 "Return a Subject header suitable for the message in the current buffer." | 6074 "Return a Subject header suitable for the message in the current buffer." |
4187 (save-excursion | 6075 (save-excursion |
4188 (save-restriction | 6076 (save-restriction |
4202 (not (listp funcs)) | 6090 (not (listp funcs)) |
4203 (setq funcs (list funcs))) | 6091 (setq funcs (list funcs))) |
4204 ;; Apply funcs in order, passing subject generated by previous | 6092 ;; Apply funcs in order, passing subject generated by previous |
4205 ;; func to the next one. | 6093 ;; func to the next one. |
4206 (while funcs | 6094 (while funcs |
4207 (when (message-functionp (car funcs)) | 6095 (when (functionp (car funcs)) |
4208 (setq subject (funcall (car funcs) subject))) | 6096 (setq subject (funcall (car funcs) subject))) |
4209 (setq funcs (cdr funcs))) | 6097 (setq funcs (cdr funcs))) |
4210 subject)))) | 6098 subject)))) |
4211 | 6099 |
4212 (eval-when-compile | 6100 (eval-when-compile |
4228 (if news | 6116 (if news |
4229 (message-news nil subject) | 6117 (message-news nil subject) |
4230 (message-mail nil subject)) | 6118 (message-mail nil subject)) |
4231 (message-forward-make-body cur digest))) | 6119 (message-forward-make-body cur digest))) |
4232 | 6120 |
6121 (defun message-forward-make-body-plain (forward-buffer) | |
6122 (insert | |
6123 "\n-------------------- Start of forwarded message --------------------\n") | |
6124 (let ((b (point)) e) | |
6125 (insert | |
6126 (with-temp-buffer | |
6127 (mm-disable-multibyte) | |
6128 (insert | |
6129 (with-current-buffer forward-buffer | |
6130 (mm-with-unibyte-current-buffer (buffer-string)))) | |
6131 (mm-enable-multibyte) | |
6132 (mime-to-mml) | |
6133 (goto-char (point-min)) | |
6134 (when (looking-at "From ") | |
6135 (replace-match "X-From-Line: ")) | |
6136 (buffer-string))) | |
6137 (setq e (point)) | |
6138 (insert | |
6139 "\n-------------------- End of forwarded message --------------------\n") | |
6140 (when (and (not current-prefix-arg) | |
6141 message-forward-ignored-headers) | |
6142 (save-restriction | |
6143 (narrow-to-region b e) | |
6144 (goto-char b) | |
6145 (narrow-to-region (point) | |
6146 (or (search-forward "\n\n" nil t) (point))) | |
6147 (message-remove-header message-forward-ignored-headers t))))) | |
6148 | |
6149 (defun message-forward-make-body-mime (forward-buffer) | |
6150 (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") | |
6151 (let ((b (point)) e) | |
6152 (save-restriction | |
6153 (narrow-to-region (point) (point)) | |
6154 (mml-insert-buffer forward-buffer) | |
6155 (goto-char (point-min)) | |
6156 (when (looking-at "From ") | |
6157 (replace-match "X-From-Line: ")) | |
6158 (goto-char (point-max))) | |
6159 (setq e (point)) | |
6160 (insert "<#/part>\n"))) | |
6161 | |
6162 (defun message-forward-make-body-mml (forward-buffer) | |
6163 (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") | |
6164 (let ((b (point)) e) | |
6165 (if (not message-forward-decoded-p) | |
6166 (insert | |
6167 (with-temp-buffer | |
6168 (mm-disable-multibyte) | |
6169 (insert | |
6170 (with-current-buffer forward-buffer | |
6171 (mm-with-unibyte-current-buffer (buffer-string)))) | |
6172 (mm-enable-multibyte) | |
6173 (mime-to-mml) | |
6174 (goto-char (point-min)) | |
6175 (when (looking-at "From ") | |
6176 (replace-match "X-From-Line: ")) | |
6177 (buffer-string))) | |
6178 (save-restriction | |
6179 (narrow-to-region (point) (point)) | |
6180 (mml-insert-buffer forward-buffer) | |
6181 (goto-char (point-min)) | |
6182 (when (looking-at "From ") | |
6183 (replace-match "X-From-Line: ")) | |
6184 (goto-char (point-max)))) | |
6185 (setq e (point)) | |
6186 (insert "<#/mml>\n") | |
6187 (when (and (not current-prefix-arg) | |
6188 message-forward-ignored-headers) | |
6189 (save-restriction | |
6190 (narrow-to-region b e) | |
6191 (goto-char b) | |
6192 (narrow-to-region (point) | |
6193 (or (search-forward "\n\n" nil t) (point))) | |
6194 (message-remove-header message-forward-ignored-headers t))))) | |
6195 | |
6196 (defun message-forward-make-body-digest-plain (forward-buffer) | |
6197 (insert | |
6198 "\n-------------------- Start of forwarded message --------------------\n") | |
6199 (let ((b (point)) e) | |
6200 (mml-insert-buffer forward-buffer) | |
6201 (setq e (point)) | |
6202 (insert | |
6203 "\n-------------------- End of forwarded message --------------------\n"))) | |
6204 | |
6205 (defun message-forward-make-body-digest-mime (forward-buffer) | |
6206 (insert "\n<#multipart type=digest>\n") | |
6207 (let ((b (point)) e) | |
6208 (insert-buffer-substring forward-buffer) | |
6209 (setq e (point)) | |
6210 (insert "<#/multipart>\n") | |
6211 (save-restriction | |
6212 (narrow-to-region b e) | |
6213 (goto-char b) | |
6214 (narrow-to-region (point) | |
6215 (or (search-forward "\n\n" nil t) (point))) | |
6216 (delete-region (point-min) (point-max))))) | |
6217 | |
6218 (defun message-forward-make-body-digest (forward-buffer) | |
6219 (if message-forward-as-mime | |
6220 (message-forward-make-body-digest-mime forward-buffer) | |
6221 (message-forward-make-body-digest-plain forward-buffer))) | |
6222 | |
4233 ;;;###autoload | 6223 ;;;###autoload |
4234 (defun message-forward-make-body (forward-buffer &optional digest) | 6224 (defun message-forward-make-body (forward-buffer &optional digest) |
4235 ;; Put point where we want it before inserting the forwarded | 6225 ;; Put point where we want it before inserting the forwarded |
4236 ;; message. | 6226 ;; message. |
4237 (if message-forward-before-signature | 6227 (if message-forward-before-signature |
4238 (message-goto-body) | 6228 (message-goto-body) |
4239 (goto-char (point-max))) | 6229 (goto-char (point-max))) |
4240 (if message-forward-as-mime | 6230 (if digest |
4241 (if digest | 6231 (message-forward-make-body-digest forward-buffer) |
4242 (insert "\n<#multipart type=digest>\n") | |
4243 (if message-forward-show-mml | |
4244 (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") | |
4245 (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n"))) | |
4246 (insert "\n-------------------- Start of forwarded message --------------------\n")) | |
4247 (let ((b (point)) e) | |
4248 (if digest | |
4249 (if message-forward-as-mime | |
4250 (insert-buffer-substring forward-buffer) | |
4251 (mml-insert-buffer forward-buffer)) | |
4252 (if (and message-forward-show-mml | |
4253 (not message-forward-decoded-p)) | |
4254 (insert | |
4255 (with-temp-buffer | |
4256 (mm-disable-multibyte) ;; Must copy buffer in unibyte mode | |
4257 (insert | |
4258 (with-current-buffer forward-buffer | |
4259 (mm-string-as-unibyte (buffer-string)))) | |
4260 (mm-enable-multibyte) | |
4261 (mime-to-mml) | |
4262 (goto-char (point-min)) | |
4263 (when (looking-at "From ") | |
4264 (replace-match "X-From-Line: ")) | |
4265 (buffer-string))) | |
4266 (save-restriction | |
4267 (narrow-to-region (point) (point)) | |
4268 (mml-insert-buffer forward-buffer) | |
4269 (goto-char (point-min)) | |
4270 (when (looking-at "From ") | |
4271 (replace-match "X-From-Line: ")) | |
4272 (goto-char (point-max))))) | |
4273 (setq e (point)) | |
4274 (if message-forward-as-mime | 6232 (if message-forward-as-mime |
4275 (if digest | 6233 (if (and message-forward-show-mml |
4276 (insert "<#/multipart>\n") | 6234 (not (and (eq message-forward-show-mml 'best) |
4277 (if message-forward-show-mml | 6235 (with-current-buffer forward-buffer |
4278 (insert "<#/mml>\n") | 6236 (goto-char (point-min)) |
4279 (insert "<#/part>\n"))) | 6237 (re-search-forward |
4280 (insert "\n-------------------- End of forwarded message --------------------\n")) | 6238 "Content-Type: *multipart/\\(signed\\|encrypted\\)" |
4281 (if (and digest message-forward-as-mime) | 6239 nil t))))) |
4282 (save-restriction | 6240 (message-forward-make-body-mml forward-buffer) |
4283 (narrow-to-region b e) | 6241 (message-forward-make-body-mime forward-buffer)) |
4284 (goto-char b) | 6242 (message-forward-make-body-plain forward-buffer))) |
4285 (narrow-to-region (point) | |
4286 (or (search-forward "\n\n" nil t) (point))) | |
4287 (delete-region (point-min) (point-max))) | |
4288 (when (and (not current-prefix-arg) | |
4289 message-forward-ignored-headers) | |
4290 (save-restriction | |
4291 (narrow-to-region b e) | |
4292 (goto-char b) | |
4293 (narrow-to-region (point) | |
4294 (or (search-forward "\n\n" nil t) (point))) | |
4295 (message-remove-header message-forward-ignored-headers t))))) | |
4296 (message-position-point)) | 6243 (message-position-point)) |
4297 | 6244 |
4298 ;;;###autoload | 6245 ;;;###autoload |
4299 (defun message-forward-rmail-make-body (forward-buffer) | 6246 (defun message-forward-rmail-make-body (forward-buffer) |
4300 (save-window-excursion | 6247 (save-window-excursion |
4301 (set-buffer forward-buffer) | 6248 (set-buffer forward-buffer) |
6249 ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs | |
6250 ;; 20. FIXIT, or we drop support for rmail in Emacs 20. | |
4302 (if (rmail-msg-is-pruned) | 6251 (if (rmail-msg-is-pruned) |
4303 (rmail-msg-restore-non-pruned-header))) | 6252 (rmail-msg-restore-non-pruned-header))) |
4304 (message-forward-make-body forward-buffer)) | 6253 (message-forward-make-body forward-buffer)) |
4305 | 6254 |
6255 (eval-when-compile (defvar rmail-enable-mime-composing)) | |
6256 | |
6257 ;; Fixme: Should have defcustom. | |
4306 ;;;###autoload | 6258 ;;;###autoload |
4307 (defun message-insinuate-rmail () | 6259 (defun message-insinuate-rmail () |
4308 "Let RMAIL uses message to forward." | 6260 "Let RMAIL use message to forward." |
4309 (interactive) | 6261 (interactive) |
4310 (setq rmail-enable-mime-composing t) | 6262 (setq rmail-enable-mime-composing t) |
4311 (setq rmail-insert-mime-forwarded-message-function | 6263 (setq rmail-insert-mime-forwarded-message-function |
4312 'message-forward-rmail-make-body)) | 6264 'message-forward-rmail-make-body)) |
4313 | 6265 |
4322 beg) | 6274 beg) |
4323 ;; We first set up a normal mail buffer. | 6275 ;; We first set up a normal mail buffer. |
4324 (unless (message-mail-user-agent) | 6276 (unless (message-mail-user-agent) |
4325 (set-buffer (get-buffer-create " *message resend*")) | 6277 (set-buffer (get-buffer-create " *message resend*")) |
4326 (erase-buffer)) | 6278 (erase-buffer)) |
4327 (let ((message-this-is-mail t)) | 6279 (let ((message-this-is-mail t) |
6280 message-setup-hook) | |
4328 (message-setup `((To . ,address)))) | 6281 (message-setup `((To . ,address)))) |
4329 ;; Insert our usual headers. | 6282 ;; Insert our usual headers. |
4330 (message-generate-headers '(From Date To)) | 6283 (message-generate-headers '(From Date To Message-ID)) |
4331 (message-narrow-to-headers) | 6284 (message-narrow-to-headers) |
6285 ;; Remove X-Draft-From header etc. | |
6286 (message-remove-header message-ignored-mail-headers t) | |
4332 ;; Rename them all to "Resent-*". | 6287 ;; Rename them all to "Resent-*". |
6288 (goto-char (point-min)) | |
4333 (while (re-search-forward "^[A-Za-z]" nil t) | 6289 (while (re-search-forward "^[A-Za-z]" nil t) |
4334 (forward-char -1) | 6290 (forward-char -1) |
4335 (insert "Resent-")) | 6291 (insert "Resent-")) |
4336 (widen) | 6292 (widen) |
4337 (forward-line) | 6293 (forward-line) |
4378 ;; This is a non-MIME bounce, so we try to remove things | 6334 ;; This is a non-MIME bounce, so we try to remove things |
4379 ;; manually. | 6335 ;; manually. |
4380 (mm-insert-part handles) | 6336 (mm-insert-part handles) |
4381 (undo-boundary) | 6337 (undo-boundary) |
4382 (goto-char (point-min)) | 6338 (goto-char (point-min)) |
4383 (search-forward "\n\n" nil t) | 6339 (re-search-forward "\n\n+" nil t) |
4384 (or (and (re-search-forward message-unsent-separator nil t) | 6340 (setq boundary (point)) |
4385 (forward-line 1)) | |
4386 (re-search-forward "^Return-Path:.*\n" nil t)) | |
4387 ;; We remove everything before the bounced mail. | 6341 ;; We remove everything before the bounced mail. |
4388 (delete-region | 6342 (if (or (re-search-forward message-unsent-separator nil t) |
4389 (point-min) | 6343 (progn |
4390 (if (re-search-forward "^[^ \n\t]+:" nil t) | 6344 (search-forward "\n\n" nil 'move) |
4391 (match-beginning 0) | 6345 (re-search-backward "^Return-Path:.*\n" boundary t))) |
4392 (point)))) | 6346 (progn |
6347 (forward-line 1) | |
6348 (delete-region (point-min) | |
6349 (if (re-search-forward "^[^ \n\t]+:" nil t) | |
6350 (match-beginning 0) | |
6351 (point)))) | |
6352 (goto-char boundary) | |
6353 (when (re-search-backward "^.?From .*\n" nil t) | |
6354 (delete-region (match-beginning 0) (match-end 0))))) | |
4393 (mm-enable-multibyte) | 6355 (mm-enable-multibyte) |
4394 (mime-to-mml) | |
4395 (save-restriction | 6356 (save-restriction |
4396 (message-narrow-to-head-1) | 6357 (message-narrow-to-head-1) |
4397 (message-remove-header message-ignored-bounced-headers t) | 6358 (message-remove-header message-ignored-bounced-headers t) |
4398 (goto-char (point-max)) | 6359 (goto-char (point-max)) |
4399 (insert mail-header-separator)) | 6360 (insert mail-header-separator)) |
4440 (let ((pop-up-windows t) | 6401 (let ((pop-up-windows t) |
4441 (special-display-buffer-names nil) | 6402 (special-display-buffer-names nil) |
4442 (special-display-regexps nil) | 6403 (special-display-regexps nil) |
4443 (same-window-buffer-names nil) | 6404 (same-window-buffer-names nil) |
4444 (same-window-regexps nil)) | 6405 (same-window-regexps nil)) |
4445 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) | 6406 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))) |
4446 (let ((message-this-is-news t)) | 6407 (let ((message-this-is-news t)) |
4447 (message-setup `((Newsgroups . ,(or newsgroups "")) | 6408 (message-setup `((Newsgroups . ,(or newsgroups "")) |
4448 (Subject . ,(or subject "")))))) | 6409 (Subject . ,(or subject "")))))) |
4449 | 6410 |
4450 ;;;###autoload | 6411 ;;;###autoload |
4454 (let ((pop-up-frames t) | 6415 (let ((pop-up-frames t) |
4455 (special-display-buffer-names nil) | 6416 (special-display-buffer-names nil) |
4456 (special-display-regexps nil) | 6417 (special-display-regexps nil) |
4457 (same-window-buffer-names nil) | 6418 (same-window-buffer-names nil) |
4458 (same-window-regexps nil)) | 6419 (same-window-regexps nil)) |
4459 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) | 6420 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))) |
4460 (let ((message-this-is-news t)) | 6421 (let ((message-this-is-news t)) |
4461 (message-setup `((Newsgroups . ,(or newsgroups "")) | 6422 (message-setup `((Newsgroups . ,(or newsgroups "")) |
4462 (Subject . ,(or subject "")))))) | 6423 (Subject . ,(or subject "")))))) |
4463 | 6424 |
4464 ;;; underline.el | 6425 ;;; underline.el |
4493 (goto-char (min start end)) | 6454 (goto-char (min start end)) |
4494 (while (re-search-forward "\b" end1 t) | 6455 (while (re-search-forward "\b" end1 t) |
4495 (if (eq (char-after) (char-after (- (point) 2))) | 6456 (if (eq (char-after) (char-after (- (point) 2))) |
4496 (delete-char -2)))))) | 6457 (delete-char -2)))))) |
4497 | 6458 |
4498 (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) | 6459 (defun message-exchange-point-and-mark () |
6460 "Exchange point and mark, but don't activate region if it was inactive." | |
6461 (unless (prog1 | |
6462 (message-mark-active-p) | |
6463 (exchange-point-and-mark)) | |
6464 (setq mark-active nil))) | |
6465 | |
6466 (defalias 'message-make-overlay 'make-overlay) | |
6467 (defalias 'message-delete-overlay 'delete-overlay) | |
6468 (defalias 'message-overlay-put 'overlay-put) | |
6469 (defun message-kill-all-overlays () | |
6470 (if (featurep 'xemacs) | |
6471 (map-extents (lambda (extent ignore) (delete-extent extent))) | |
6472 (mapcar #'delete-overlay (overlays-in (point-min) (point-max))))) | |
4499 | 6473 |
4500 ;; Support for toolbar | 6474 ;; Support for toolbar |
4501 (eval-when-compile (defvar tool-bar-map)) | 6475 (eval-when-compile |
4502 (if (featurep 'xemacs) | 6476 (defvar tool-bar-map) |
4503 (require 'messagexmas) | 6477 (defvar tool-bar-mode)) |
4504 (when (and | 6478 |
4505 (condition-case nil (require 'tool-bar) (error nil)) | 6479 (defun message-tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props) |
4506 (fboundp 'tool-bar-add-item-from-menu) | 6480 ;; We need to make tool bar entries in local keymaps with |
4507 tool-bar-mode) | 6481 ;; `tool-bar-local-item-from-menu' in Emacs > 21.3 |
4508 (defvar message-tool-bar-map | 6482 (if (fboundp 'tool-bar-local-item-from-menu) |
4509 (let ((tool-bar-map (copy-keymap tool-bar-map))) | 6483 ;; This is for Emacs 21.3 |
4510 ;; Zap some items which aren't so relevant and take up space. | 6484 (tool-bar-local-item-from-menu command icon in-map from-map props) |
4511 (dolist (key '(print-buffer kill-buffer save-buffer write-file | 6485 (tool-bar-add-item-from-menu command icon from-map props))) |
4512 dired open-file)) | 6486 |
4513 (define-key tool-bar-map (vector key) nil)) | 6487 (defun message-tool-bar-map () |
4514 | 6488 (or message-tool-bar-map |
4515 (tool-bar-add-item-from-menu | 6489 (setq message-tool-bar-map |
4516 'message-send-and-exit "mail_send" message-mode-map) | 6490 (and |
4517 (tool-bar-add-item-from-menu | 6491 (condition-case nil (require 'tool-bar) (error nil)) |
4518 'message-kill-buffer "close" message-mode-map) | 6492 (fboundp 'tool-bar-add-item-from-menu) |
4519 (tool-bar-add-item-from-menu | 6493 tool-bar-mode |
4520 'message-dont-send "cancel" message-mode-map) | 6494 (let ((tool-bar-map (copy-keymap tool-bar-map)) |
4521 (tool-bar-add-item-from-menu | 6495 (load-path (mm-image-load-path))) |
4522 'mml-attach-file "attach" message-mode-map) | 6496 ;; Zap some items which aren't so relevant and take |
4523 (tool-bar-add-item-from-menu | 6497 ;; up space. |
4524 'ispell-message "spell" message-mode-map) | 6498 (dolist (key '(print-buffer kill-buffer save-buffer |
4525 tool-bar-map)))) | 6499 write-file dired open-file)) |
6500 (define-key tool-bar-map (vector key) nil)) | |
6501 (message-tool-bar-local-item-from-menu | |
6502 'message-send-and-exit "mail_send" tool-bar-map message-mode-map) | |
6503 (message-tool-bar-local-item-from-menu | |
6504 'message-kill-buffer "close" tool-bar-map message-mode-map) | |
6505 (message-tool-bar-local-item-from-menu | |
6506 'message-dont-send "cancel" tool-bar-map message-mode-map) | |
6507 (message-tool-bar-local-item-from-menu | |
6508 'mml-attach-file "attach" tool-bar-map mml-mode-map) | |
6509 (message-tool-bar-local-item-from-menu | |
6510 'ispell-message "spell" tool-bar-map message-mode-map) | |
6511 (message-tool-bar-local-item-from-menu | |
6512 'mml-preview "preview" | |
6513 tool-bar-map mml-mode-map) | |
6514 (message-tool-bar-local-item-from-menu | |
6515 'message-insert-importance-high "important" | |
6516 tool-bar-map message-mode-map) | |
6517 (message-tool-bar-local-item-from-menu | |
6518 'message-insert-importance-low "unimportant" | |
6519 tool-bar-map message-mode-map) | |
6520 (message-tool-bar-local-item-from-menu | |
6521 'message-insert-disposition-notification-to "receipt" | |
6522 tool-bar-map message-mode-map) | |
6523 tool-bar-map))))) | |
4526 | 6524 |
4527 ;;; Group name completion. | 6525 ;;; Group name completion. |
4528 | 6526 |
4529 (defvar message-newgroups-header-regexp | 6527 (defcustom message-newgroups-header-regexp |
4530 "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):" | 6528 "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):" |
4531 "Regexp that match headers that lists groups.") | 6529 "Regexp that match headers that lists groups." |
6530 :group 'message | |
6531 :type 'regexp) | |
6532 | |
6533 (defcustom message-completion-alist | |
6534 (list (cons message-newgroups-header-regexp 'message-expand-group) | |
6535 '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name) | |
6536 '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" | |
6537 . message-expand-name) | |
6538 '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):" | |
6539 . message-expand-name)) | |
6540 "Alist of (RE . FUN). Use FUN for completion on header lines matching RE." | |
6541 :group 'message | |
6542 :type '(alist :key-type regexp :value-type function)) | |
6543 | |
6544 (defcustom message-tab-body-function nil | |
6545 "*Function to execute when `message-tab' (TAB) is executed in the body. | |
6546 If nil, the function bound in `text-mode-map' or `global-map' is executed." | |
6547 :group 'message | |
6548 :link '(custom-manual "(message)Various Commands") | |
6549 :type 'function) | |
4532 | 6550 |
4533 (defun message-tab () | 6551 (defun message-tab () |
4534 "Expand group names in Newsgroups and Followup-To headers. | 6552 "Complete names according to `message-completion-alist'. |
4535 Do a `tab-to-tab-stop' if not in those headers." | 6553 Execute function specified by `message-tab-body-function' when not in |
6554 those headers." | |
4536 (interactive) | 6555 (interactive) |
4537 (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp)) | 6556 (let ((alist message-completion-alist)) |
4538 (mail-abbrev-in-expansion-header-p)) | 6557 (while (and alist |
4539 (message-expand-group) | 6558 (let ((mail-abbrev-mode-regexp (caar alist))) |
4540 (tab-to-tab-stop))) | 6559 (not (mail-abbrev-in-expansion-header-p)))) |
6560 (setq alist (cdr alist))) | |
6561 (funcall (or (cdar alist) message-tab-body-function | |
6562 (lookup-key text-mode-map "\t") | |
6563 (lookup-key global-map "\t") | |
6564 'indent-relative)))) | |
4541 | 6565 |
4542 (defun message-expand-group () | 6566 (defun message-expand-group () |
4543 "Expand the group name under point." | 6567 "Expand the group name under point." |
4544 (let* ((b (save-excursion | 6568 (let* ((b (save-excursion |
4545 (save-restriction | 6569 (save-restriction |
4579 (let ((standard-output (current-buffer))) | 6603 (let ((standard-output (current-buffer))) |
4580 (display-completion-list (sort completions 'string<))) | 6604 (display-completion-list (sort completions 'string<))) |
4581 (goto-char (point-min)) | 6605 (goto-char (point-min)) |
4582 (delete-region (point) (progn (forward-line 3) (point)))))))))) | 6606 (delete-region (point) (progn (forward-line 3) (point)))))))))) |
4583 | 6607 |
6608 (defun message-expand-name () | |
6609 (if (fboundp 'bbdb-complete-name) | |
6610 (bbdb-complete-name) | |
6611 (expand-abbrev))) | |
6612 | |
4584 ;;; Help stuff. | 6613 ;;; Help stuff. |
4585 | 6614 |
4586 (defun message-talkative-question (ask question show &rest text) | 6615 (defun message-talkative-question (ask question show &rest text) |
4587 "Call FUNCTION with argument QUESTION; optionally display TEXT... args. | 6616 "Call FUNCTION with argument QUESTION; optionally display TEXT... args. |
4588 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer. | 6617 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer. |
4608 (apply 'append (mapcar 'message-flatten-list list))) | 6637 (apply 'append (mapcar 'message-flatten-list list))) |
4609 (list | 6638 (list |
4610 (list list)))) | 6639 (list list)))) |
4611 | 6640 |
4612 (defun message-generate-new-buffer-clone-locals (name &optional varstr) | 6641 (defun message-generate-new-buffer-clone-locals (name &optional varstr) |
4613 "Create and return a buffer with name based on NAME using `generate-new-buffer.' | 6642 "Create and return a buffer with name based on NAME using `generate-new-buffer'. |
4614 Then clone the local variables and values from the old buffer to the | 6643 Then clone the local variables and values from the old buffer to the |
4615 new one, cloning only the locals having a substring matching the | 6644 new one, cloning only the locals having a substring matching the |
4616 regexp varstr." | 6645 regexp VARSTR." |
4617 (let ((oldbuf (current-buffer))) | 6646 (let ((oldbuf (current-buffer))) |
4618 (save-excursion | 6647 (save-excursion |
4619 (set-buffer (generate-new-buffer name)) | 6648 (set-buffer (generate-new-buffer name)) |
4620 (message-clone-locals oldbuf varstr) | 6649 (message-clone-locals oldbuf varstr) |
4621 (current-buffer)))) | 6650 (current-buffer)))) |
4669 (goto-char (point-max)) | 6698 (goto-char (point-max)) |
4670 (insert "MIME-Version: 1.0\n") | 6699 (insert "MIME-Version: 1.0\n") |
4671 (when lines | 6700 (when lines |
4672 (insert lines)) | 6701 (insert lines)) |
4673 (setq content-type-p | 6702 (setq content-type-p |
4674 (re-search-backward "^Content-Type:" nil t))) | 6703 (or mml-boundary |
6704 (re-search-backward "^Content-Type:" nil t)))) | |
4675 (save-restriction | 6705 (save-restriction |
4676 (message-narrow-to-headers-or-head) | 6706 (message-narrow-to-headers-or-head) |
4677 (message-remove-first-header "Content-Type") | 6707 (message-remove-first-header "Content-Type") |
4678 (message-remove-first-header "Content-Transfer-Encoding")) | 6708 (message-remove-first-header "Content-Transfer-Encoding")) |
4679 ;; We always make sure that the message has a Content-Type header. | 6709 ;; We always make sure that the message has a Content-Type |
4680 ;; This is because some broken MTAs and MUAs get awfully confused | 6710 ;; header. This is because some broken MTAs and MUAs get |
4681 ;; when confronted with a message with a MIME-Version header and | 6711 ;; awfully confused when confronted with a message with a |
4682 ;; without a Content-Type header. For instance, Solaris' | 6712 ;; MIME-Version header and without a Content-Type header. For |
4683 ;; /usr/bin/mail. | 6713 ;; instance, Solaris' /usr/bin/mail. |
4684 (unless content-type-p | 6714 (unless content-type-p |
4685 (goto-char (point-min)) | 6715 (goto-char (point-min)) |
4686 ;; For unknown reason, MIME-Version doesn't exist. | 6716 ;; For unknown reason, MIME-Version doesn't exist. |
4687 (when (re-search-forward "^MIME-Version:" nil t) | 6717 (when (re-search-forward "^MIME-Version:" nil t) |
4688 (forward-line 1) | 6718 (forward-line 1) |
4689 (insert "Content-Type: text/plain; charset=us-ascii\n")))))) | 6719 (insert "Content-Type: text/plain; charset=us-ascii\n")))))) |
4690 | 6720 |
4691 (defun message-read-from-minibuffer (prompt) | 6721 (defun message-read-from-minibuffer (prompt &optional initial-contents) |
4692 "Read from the minibuffer while providing abbrev expansion." | 6722 "Read from the minibuffer while providing abbrev expansion." |
4693 (if (fboundp 'mail-abbrevs-setup) | 6723 (if (fboundp 'mail-abbrevs-setup) |
4694 (let ((mail-abbrev-mode-regexp "") | 6724 (let ((mail-abbrev-mode-regexp "") |
4695 (minibuffer-setup-hook 'mail-abbrevs-setup)) | 6725 (minibuffer-setup-hook 'mail-abbrevs-setup) |
4696 (read-from-minibuffer prompt)) | 6726 (minibuffer-local-map message-minibuffer-local-map)) |
4697 (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) | 6727 (read-from-minibuffer prompt initial-contents)) |
4698 (read-string prompt)))) | 6728 (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook) |
6729 (minibuffer-local-map message-minibuffer-local-map)) | |
6730 (read-string prompt initial-contents)))) | |
4699 | 6731 |
4700 (defun message-use-alternative-email-as-from () | 6732 (defun message-use-alternative-email-as-from () |
4701 (require 'mail-utils) | 6733 (require 'mail-utils) |
4702 (let* ((fields '("To" "Cc")) | 6734 (let* ((fields '("To" "Cc")) |
4703 (emails | 6735 (emails |
4713 (pop emails)) | 6745 (pop emails)) |
4714 (unless (or (not email) (equal email user-mail-address)) | 6746 (unless (or (not email) (equal email user-mail-address)) |
4715 (goto-char (point-max)) | 6747 (goto-char (point-max)) |
4716 (insert "From: " email "\n")))) | 6748 (insert "From: " email "\n")))) |
4717 | 6749 |
6750 (defun message-options-get (symbol) | |
6751 (cdr (assq symbol message-options))) | |
6752 | |
6753 (defun message-options-set (symbol value) | |
6754 (let ((the-cons (assq symbol message-options))) | |
6755 (if the-cons | |
6756 (if value | |
6757 (setcdr the-cons value) | |
6758 (setq message-options (delq the-cons message-options))) | |
6759 (and value | |
6760 (push (cons symbol value) message-options)))) | |
6761 value) | |
6762 | |
6763 (defun message-options-set-recipient () | |
6764 (save-restriction | |
6765 (message-narrow-to-headers-or-head) | |
6766 (message-options-set 'message-sender | |
6767 (mail-strip-quoted-names | |
6768 (message-fetch-field "from"))) | |
6769 (message-options-set 'message-recipients | |
6770 (mail-strip-quoted-names | |
6771 (let ((to (message-fetch-field "to")) | |
6772 (cc (message-fetch-field "cc")) | |
6773 (bcc (message-fetch-field "bcc"))) | |
6774 (concat | |
6775 (or to "") | |
6776 (if (and to cc) ", ") | |
6777 (or cc "") | |
6778 (if (and (or to cc) bcc) ", ") | |
6779 (or bcc ""))))))) | |
6780 | |
6781 (defun message-hide-headers () | |
6782 "Hide headers based on the `message-hidden-headers' variable." | |
6783 (let ((regexps (if (stringp message-hidden-headers) | |
6784 (list message-hidden-headers) | |
6785 message-hidden-headers)) | |
6786 (inhibit-point-motion-hooks t) | |
6787 (after-change-functions nil)) | |
6788 (when regexps | |
6789 (save-excursion | |
6790 (save-restriction | |
6791 (message-narrow-to-headers) | |
6792 (goto-char (point-min)) | |
6793 (while (not (eobp)) | |
6794 (if (not (message-hide-header-p regexps)) | |
6795 (message-next-header) | |
6796 (let ((begin (point))) | |
6797 (message-next-header) | |
6798 (add-text-properties | |
6799 begin (point) | |
6800 '(invisible t message-hidden t)))))))))) | |
6801 | |
6802 (defun message-hide-header-p (regexps) | |
6803 (let ((result nil) | |
6804 (reverse nil)) | |
6805 (when (eq (car regexps) 'not) | |
6806 (setq reverse t) | |
6807 (pop regexps)) | |
6808 (dolist (regexp regexps) | |
6809 (setq result (or result (looking-at regexp)))) | |
6810 (if reverse | |
6811 (not result) | |
6812 result))) | |
6813 | |
6814 (when (featurep 'xemacs) | |
6815 (require 'messagexmas) | |
6816 (message-xmas-redefine)) | |
6817 | |
4718 (provide 'message) | 6818 (provide 'message) |
4719 | 6819 |
4720 (run-hooks 'message-load-hook) | 6820 (run-hooks 'message-load-hook) |
4721 | 6821 |
4722 ;; Local Variables: | 6822 ;; Local Variables: |