83d83b124d570f3d6116fb608d9afa4b32b4fdfa
[elisp/gnus.git-] / lisp / message.el
1 ;;; message.el --- composing mail and news messages
2 ;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;;      Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
7 ;;      Keiichi Suzuki   <kei-suzu@mail.wbs.ne.jp>
8 ;;      Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
9 ;;      Katsumi Yamaoka  <yamaoka@jpl.org>
10 ;;      Kiyokazu SUTO    <suto@merry.xmath.ous.ac.jp>
11 ;; Keywords: mail, news, MIME
12
13 ;; This file is part of GNU Emacs.
14
15 ;; GNU Emacs is free software; you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; any later version.
19
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 ;; GNU General Public License for more details.
24
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
28 ;; Boston, MA 02111-1307, USA.
29
30 ;;; Commentary:
31
32 ;; This mode provides mail-sending facilities from within Emacs.  It
33 ;; consists mainly of large chunks of code from the sendmail.el,
34 ;; gnus-msg.el and rnewspost.el files.
35
36 ;;; Code:
37
38 (eval-when-compile
39   (require 'cl)
40   (require 'smtp)
41   )
42
43 (require 'mailheader)
44 (require 'nnheader)
45 (require 'easymenu)
46 (require 'custom)
47 (if (string-match "XEmacs\\|Lucid" emacs-version)
48     (require 'mail-abbrevs)
49   (require 'mailabbrev))
50 (require 'mime-edit)
51 (eval-when-compile (require 'static))
52
53 ;; Avoid byte-compile warnings.
54 (eval-when-compile
55   (require 'mail-parse)
56   (require 'mm-bodies)
57   (require 'mm-encode)
58   (require 'mml)
59   )
60
61 (defgroup message '((user-mail-address custom-variable)
62                     (user-full-name custom-variable))
63   "Mail and news message composing."
64   :link '(custom-manual "(message)Top")
65   :group 'mail
66   :group 'news)
67
68 (put 'user-mail-address 'custom-type 'string)
69 (put 'user-full-name 'custom-type 'string)
70
71 (defgroup message-various nil
72   "Various Message Variables"
73   :link '(custom-manual "(message)Various Message Variables")
74   :group 'message)
75
76 (defgroup message-buffers nil
77   "Message Buffers"
78   :link '(custom-manual "(message)Message Buffers")
79   :group 'message)
80
81 (defgroup message-sending nil
82   "Message Sending"
83   :link '(custom-manual "(message)Sending Variables")
84   :group 'message)
85
86 (defgroup message-interface nil
87   "Message Interface"
88   :link '(custom-manual "(message)Interface")
89   :group 'message)
90
91 (defgroup message-forwarding nil
92   "Message Forwarding"
93   :link '(custom-manual "(message)Forwarding")
94   :group 'message-interface)
95
96 (defgroup message-insertion nil
97   "Message Insertion"
98   :link '(custom-manual "(message)Insertion")
99   :group 'message)
100
101 (defgroup message-headers nil
102   "Message Headers"
103   :link '(custom-manual "(message)Message Headers")
104   :group 'message)
105
106 (defgroup message-news nil
107   "Composing News Messages"
108   :group 'message)
109
110 (defgroup message-mail nil
111   "Composing Mail Messages"
112   :group 'message)
113
114 (defgroup message-faces nil
115   "Faces used for message composing."
116   :group 'message
117   :group 'faces)
118
119 (defgroup message-frames nil
120   "Message frames"
121   :group 'message)
122
123 (defcustom message-directory "~/Mail/"
124   "*Directory from which all other mail file variables are derived."
125   :group 'message-various
126   :type 'directory)
127
128 (defcustom message-max-buffers 10
129   "*How many buffers to keep before starting to kill them off."
130   :group 'message-buffers
131   :type 'integer)
132
133 (defcustom message-send-rename-function nil
134   "Function called to rename the buffer after sending it."
135   :group 'message-buffers
136   :type 'function)
137
138 (defcustom message-fcc-handler-function 'message-output
139   "*A function called to save outgoing articles.
140 This function will be called with the name of the file to store the
141 article in.  The default function is `message-output' which saves in Unix
142 mailbox format."
143   :type '(radio (function-item message-output)
144                 (function :tag "Other"))
145   :group 'message-sending)
146
147 (defcustom message-encode-function 'message-maybe-encode
148   "*A function called to encode messages."
149   :group 'message-sending
150   :type 'function)
151
152 (defcustom message-8bit-encoding-list '(8bit binary)
153   "*8bit encoding type in Content-Transfer-Encoding field."
154   :group 'message-sending
155   :type '(repeat (symbol :tag "Type")))
156
157 (defcustom message-courtesy-message
158   "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"
159   "*This is inserted at the start of a mailed copy of a posted message.
160 If the string contains the format spec \"%s\", the Newsgroups
161 the article has been posted to will be inserted there.
162 If this variable is nil, no such courtesy message will be added."
163   :group 'message-sending
164   :type 'string)
165
166 (defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
167   "*Regexp that matches headers to be removed in resent bounced mail."
168   :group 'message-interface
169   :type 'regexp)
170
171 (defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit
172   "Function to setup a re-sending bounced message."
173   :group 'message-sending
174   :type 'function)
175
176 ;;;###autoload
177 (defcustom message-from-style 'default
178   "*Specifies how \"From\" headers look.
179
180 If `nil', they contain just the return address like:
181         king@grassland.com
182 If `parens', they look like:
183         king@grassland.com (Elvis Parsley)
184 If `angles', they look like:
185         Elvis Parsley <king@grassland.com>
186
187 Otherwise, most addresses look like `angles', but they look like
188 `parens' if `angles' would need quoting and `parens' would not."
189   :type '(choice (const :tag "simple" nil)
190                  (const parens)
191                  (const angles)
192                  (const default))
193   :group 'message-headers)
194
195 (defcustom message-syntax-checks nil
196   ; Guess this one shouldn't be easy to customize...
197   "*Controls what syntax checks should not be performed on outgoing posts.
198 To disable checking of long signatures, for instance, add
199  `(signature . disabled)' to this list.
200
201 Don't touch this variable unless you really know what you're doing.
202
203 Checks include subject-cmsg multiple-headers sendsys message-id from
204 long-lines control-chars size new-text redirected-followup signature
205 approved sender empty empty-headers message-id from subject
206 shorten-followup-to existing-newsgroups buffer-file-name unchanged
207 newsgroups."
208   :group 'message-news)
209
210 (defcustom message-required-news-headers
211   '(From Newsgroups Subject Date Message-ID
212          (optional . Organization) Lines
213          (optional . User-Agent))
214   "*Headers to be generated or prompted for when posting an article.
215 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
216 Message-ID.  Organization, Lines, In-Reply-To, Expires, and
217 User-Agent are optional.  If don't you want message to insert some
218 header, remove it from this list."
219   :group 'message-news
220   :group 'message-headers
221   :type '(repeat sexp))
222
223 (defcustom message-required-mail-headers
224   '(From Subject Date (optional . In-Reply-To) Message-ID Lines
225          (optional . User-Agent))
226   "*Headers to be generated or prompted for when mailing a message.
227 RFC822 required that From, Date, To, Subject and Message-ID be
228 included.  Organization, Lines and User-Agent are optional."
229   :group 'message-mail
230   :group 'message-headers
231   :type '(repeat sexp))
232
233 (defcustom message-deletable-headers '(Message-ID Date Lines)
234   "Headers to be deleted if they already exist and were generated by message previously."
235   :group 'message-headers
236   :type 'sexp)
237
238 (defcustom message-ignored-news-headers
239   "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:"
240   "*Regexp of headers to be removed unconditionally before posting."
241   :group 'message-news
242   :group 'message-headers
243   :type 'regexp)
244
245 (defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:"
246   "*Regexp of headers to be removed unconditionally before mailing."
247   :group 'message-mail
248   :group 'message-headers
249   :type 'regexp)
250
251 (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:"
252   "*Header lines matching this regexp will be deleted before posting.
253 It's best to delete old Path and Date headers before posting to avoid
254 any confusion."
255   :group 'message-interface
256   :type 'regexp)
257
258 (defcustom message-supersede-setup-function
259   'message-supersede-setup-for-mime-edit
260   "Function to setup a supersede message."
261   :group 'message-sending
262   :type 'function)
263
264 (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"
265   "*Regexp matching \"Re: \" in the subject line."
266   :group 'message-various
267   :type 'regexp)
268
269 ;;; Some sender agents encode the whole subject including leading "Re: ".
270 ;;; And if followup agent does not decode it for some reason (e.g. unknown
271 ;;; charset) and just add a new "Re: " in front of the encoded-word, the
272 ;;; result will contain multiple "Re: "'s.
273 (defcustom message-subject-encoded-re-regexp
274   (concat
275    "^[ \t]*"
276    (regexp-quote "=?")
277    "[-!#$%&'*+0-9A-Z^_`a-z{|}~]+" ; charset
278    (regexp-quote "?")
279    "\\("
280    "[Bb]" (regexp-quote "?") ; B encoding
281    "\\(\\(CQk\\|CSA\\|IAk\\|ICA\\)[Jg]\\)*" ; \([ \t][ \t][ \t]\)*
282    "\\("
283    "[Uc][km]U6" ; [Rr][Ee]:
284    "\\|"
285    "\\(C[VX]\\|I[FH]\\)J[Fl]O[g-v]" ; [ \t][Rr][Ee]:
286    "\\|"
287    "\\(CQl\\|CSB\\|IAl\\|ICB\\)[Sy][RZ]T[o-r]" ; [ \t][ \t][Rr][Ee]:
288    "\\)"
289    "\\|"
290    "[Qb]" (regexp-quote "?") ; Q encoding
291    "\\(_\\|=09\\|=20\\)*"
292    "\\([Rr]\\|=[57]2\\)\\([Ee]\\|=[46]5\\)\\(:\\|=3[Aa]\\)"
293    "\\)"
294    )
295   "*Regexp matching \"Re: \" in the subject line.
296 Unlike `message-subject-re-regexp', this regexp matches \"Re: \" within
297 an encoded-word."
298   :group 'message-various
299   :type 'regexp)
300
301 (defcustom message-use-subject-re t
302   "*If t, remove any (buggy) \"Re: \"'s from the subject of the precursor
303 and add a new \"Re: \".  If it is nil, use the subject \"as-is\".  If it
304 is the symbol `guess', try to detect \"Re: \" within an encoded-word."
305   :group 'message-various
306   :type '(choice (const :tag "off" nil)
307                  (const :tag "on" t)
308                  (const guess)))
309
310 ;;;###autoload
311 (defcustom message-signature-separator "^-- *$"
312   "Regexp matching the signature separator."
313   :type 'regexp
314   :group 'message-various)
315
316 (defcustom message-elide-elipsis "\n[...]\n\n"
317   "*The string which is inserted for elided text."
318   :type 'string
319   :group 'message-various)
320
321 (defcustom message-interactive nil
322   "Non-nil means when sending a message wait for and display errors.
323 nil means let mailer mail back a message to report errors."
324   :group 'message-sending
325   :group 'message-mail
326   :type 'boolean)
327
328 (defcustom message-generate-new-buffers 'unique
329   "*Non-nil means that a new message buffer will be created whenever `message-setup' is called.
330 If this is a function, call that function with three parameters:  The type,
331 the to address and the group name.  (Any of these may be nil.)  The function
332 should return the new buffer name."
333   :group 'message-buffers
334   :type '(choice (const :tag "off" nil)
335                  (const :tag "unique" unique)
336                  (const :tag "unsent" unsent)
337                  (function fun)))
338
339 (defcustom message-kill-buffer-on-exit nil
340   "*Non-nil means that the message buffer will be killed after sending a message."
341   :group 'message-buffers
342   :type 'boolean)
343
344 (defcustom message-kill-buffer-query-function 'yes-or-no-p
345   "*A function called to query the user whether to kill buffer anyway or not.
346 If it is t, the buffer will be killed peremptorily."
347   :type '(radio (function-item yes-or-no-p)
348                 (function-item y-or-n-p)
349                 (function-item nnheader-Y-or-n-p)
350                 (function :tag "Other" t))
351   :group 'message-buffers)
352
353 (defvar gnus-local-organization)
354 (defcustom message-user-organization
355   (or (and (boundp 'gnus-local-organization)
356            (stringp gnus-local-organization)
357            gnus-local-organization)
358       (getenv "ORGANIZATION")
359       t)
360   "*String to be used as an Organization header.
361 If t, use `message-user-organization-file'."
362   :group 'message-headers
363   :type '(choice string
364                  (const :tag "consult file" t)))
365
366 ;;;###autoload
367 (defcustom message-user-organization-file "/usr/lib/news/organization"
368   "*Local news organization file."
369   :type 'file
370   :group 'message-headers)
371
372 (defcustom message-forward-start-separator
373   (concat (mime-make-tag "message" "rfc822") "\n")
374   "*Delimiter inserted before forwarded messages."
375   :group 'message-forwarding
376   :type 'string)
377
378 (defcustom message-forward-end-separator
379   (concat (mime-make-tag "text" "plain") "\n")
380   "*Delimiter inserted after forwarded messages."
381   :group 'message-forwarding
382   :type 'string)
383
384 (defcustom message-signature-before-forwarded-message t
385   "*If non-nil, put the signature before any included forwarded message."
386   :group 'message-forwarding
387   :type 'boolean)
388
389 (defcustom message-included-forward-headers
390   "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-\\|^MIME-Version:"
391   "*Regexp matching headers to be included in forwarded messages."
392   :group 'message-forwarding
393   :type 'regexp)
394
395 (defcustom message-make-forward-subject-function
396   'message-forward-subject-author-subject
397  "*A list of functions that are called to generate a subject header for forwarded messages.
398 The subject generated by the previous function is passed into each
399 successive function.
400
401 The provided functions are:
402
403 * message-forward-subject-author-subject (Source of article (author or
404       newsgroup)), in brackets followed by the subject
405 * message-forward-subject-fwd (Subject of article with 'Fwd:' prepended
406       to it."
407  :group 'message-forwarding
408  :type '(radio (function-item message-forward-subject-author-subject)
409                (function-item message-forward-subject-fwd)))
410
411 (defcustom message-wash-forwarded-subjects nil
412   "*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."
413   :group 'message-forwarding
414   :type 'boolean)
415
416 (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"
417   "*All headers that match this regexp will be deleted when resending a message."
418   :group 'message-interface
419   :type 'regexp)
420
421 (defcustom message-ignored-cited-headers "."
422   "*Delete these headers from the messages you yank."
423   :group 'message-insertion
424   :type 'regexp)
425
426 (defcustom message-cancel-message "I am canceling my own article."
427   "Message to be inserted in the cancel message."
428   :group 'message-interface
429   :type 'string)
430
431 ;; Useful to set in site-init.el
432 ;;;###autoload
433 (defcustom message-send-mail-function 'message-send-mail-with-sendmail
434   "Function to call to send the current buffer as mail.
435 The headers should be delimited by a line whose contents match the
436 variable `mail-header-separator'.
437
438 Valid values include `message-send-mail-with-sendmail' (the default),
439 `message-send-mail-with-mh', `message-send-mail-with-qmail' and
440 `message-send-mail-with-smtp'."
441   :type '(radio (function-item message-send-mail-with-sendmail)
442                 (function-item message-send-mail-with-mh)
443                 (function-item message-send-mail-with-qmail)
444                 (function-item message-send-mail-with-smtp)
445                 (function :tag "Other"))
446   :group 'message-sending
447   :group 'message-mail)
448
449 ;; 1997-09-29 by MORIOKA Tomohiko
450 (defcustom message-send-news-function 'message-send-news-with-gnus
451   "Function to call to send the current buffer as news.
452 The headers should be delimited by a line whose contents match the
453 variable `mail-header-separator'."
454   :group 'message-sending
455   :group 'message-news
456   :type 'function)
457
458 (defcustom message-reply-to-function nil
459   "Function that should return a list of headers.
460 This function should pick out addresses from the To, Cc, and From headers
461 and respond with new To and Cc headers."
462   :group 'message-interface
463   :type 'function)
464
465 (defcustom message-wide-reply-to-function nil
466   "Function that should return a list of headers.
467 This function should pick out addresses from the To, Cc, and From headers
468 and respond with new To and Cc headers."
469   :group 'message-interface
470   :type 'function)
471
472 (defcustom message-followup-to-function nil
473   "Function that should return a list of headers.
474 This function should pick out addresses from the To, Cc, and From headers
475 and respond with new To and Cc headers."
476   :group 'message-interface
477   :type 'function)
478
479 (defcustom message-use-followup-to 'ask
480   "*Specifies what to do with Followup-To header.
481 If nil, always ignore the header.  If it is t, use its value, but
482 query before using the \"poster\" value.  If it is the symbol `ask',
483 always query the user whether to use the value.  If it is the symbol
484 `use', always use the value."
485   :group 'message-interface
486   :type '(choice (const :tag "ignore" nil)
487                  (const :tag "maybe" t)
488                  (const :tag "always" use)
489                  (const :tag "ask" ask)))
490
491 (defcustom message-use-mail-copies-to 'ask
492   "*Specifies what to do with Mail-Copies-To header.
493 If nil, always ignore the header.  If it is t, use its value, but
494 query before using the value other than \"always\" or \"never\".
495 If it is the symbol `ask', always query the user whether to use
496 the value.  If it is the symbol `use', always use the value."
497   :group 'message-interface
498   :type '(choice (const :tag "ignore" nil)
499                  (const :tag "maybe" t)
500                  (const :tag "always" use)
501                  (const :tag "ask" ask)))
502
503 (defcustom message-use-mail-followup-to 'ask
504   "*Specifies what to do with Mail-Followup-To header.
505 If nil, always ignore the header.  If it is the symbol `ask', always
506 query the user whether to use the value.  If it is t or the symbol
507 `use', always use the value."
508   :group 'message-interface
509   :type '(choice (const :tag "ignore" nil)
510                  (const :tag "maybe" t)
511                  (const :tag "always" use)
512                  (const :tag "ask" ask)))
513
514 ;;; XXX: 'ask and 'use are not implemented yet.
515 (defcustom message-use-mail-reply-to 'ask
516   "*Specifies what to do with Mail-Reply-To/Reply-To header.
517 If nil, always ignore the header.  If it is t or the symbol `use', use
518 its value.  If it is the symbol `ask', always query the user whether to
519 use the value.  Note that if \"Reply-To\" is marked as \"broken\", its value
520 is never used."
521   :group 'message-interface
522   :type '(choice (const :tag "ignore" nil)
523                  (const :tag "maybe" t)
524                  (const :tag "always" use)
525                  (const :tag "ask" ask)))
526
527 ;; stuff relating to broken sendmail in MMDF
528 (defcustom message-sendmail-f-is-evil nil
529   "*Non-nil means that \"-f username\" should not be added to the sendmail
530 command line, because it is even more evil than leaving it out."
531   :group 'message-sending
532   :type 'boolean)
533
534 ;; qmail-related stuff
535 (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
536   "Location of the qmail-inject program."
537   :group 'message-sending
538   :type 'file)
539
540 (defcustom message-qmail-inject-args nil
541   "Arguments passed to qmail-inject programs.
542 This should be a list of strings, one string for each argument.
543
544 For e.g., if you wish to set the envelope sender address so that bounces
545 go to the right place or to deal with listserv's usage of that address, you
546 might set this variable to '(\"-f\" \"you@some.where\")."
547   :group 'message-sending
548   :type '(repeat string))
549
550 (defvar gnus-post-method)
551 (defvar gnus-select-method)
552 (defcustom message-post-method
553   (cond ((and (boundp 'gnus-post-method)
554               (listp gnus-post-method)
555               gnus-post-method)
556          gnus-post-method)
557         ((boundp 'gnus-select-method)
558          gnus-select-method)
559         (t '(nnspool "")))
560   "*Method used to post news.
561 Note that when posting from inside Gnus, for instance, this
562 variable isn't used."
563   :group 'message-news
564   :group 'message-sending
565   ;; This should be the `gnus-select-method' widget, but that might
566   ;; create a dependence to `gnus.el'.
567   :type 'sexp)
568
569 (defcustom message-generate-headers-first nil
570   "*If non-nil, generate all possible headers before composing."
571   :group 'message-headers
572   :type 'boolean)
573
574 (defcustom message-setup-hook '(turn-on-mime-edit)
575   "Normal hook, run each time a new outgoing message is initialized.
576 The function `message-setup' runs this hook."
577   :group 'message-various
578   :type 'hook)
579
580 (defcustom message-cancel-hook nil
581   "Hook run when cancelling articles."
582   :group 'message-various
583   :type 'hook)
584
585 (defcustom message-signature-setup-hook nil
586   "Normal hook, run each time a new outgoing message is initialized.
587 It is run after the headers have been inserted and before
588 the signature is inserted."
589   :group 'message-various
590   :type 'hook)
591
592 (defcustom message-bounce-setup-hook nil
593   "Normal hook, run each time a re-sending bounced message is initialized.
594 The function `message-bounce' runs this hook."
595   :group 'message-various
596   :type 'hook)
597
598 (defcustom message-supersede-setup-hook nil
599   "Normal hook, run each time a supersede message is initialized.
600 The function `message-supersede' runs this hook."
601   :group 'message-various
602   :type 'hook)
603
604 (defcustom message-mode-hook nil
605   "Hook run in message mode buffers."
606   :group 'message-various
607   :type 'hook)
608
609 (defcustom message-header-hook '((lambda () (eword-encode-header t)))
610   "Hook run in a message mode buffer narrowed to the headers."
611   :group 'message-various
612   :type 'hook)
613
614 (defcustom message-header-setup-hook nil
615   "Hook called narrowed to the headers when setting up a message buffer."
616   :group 'message-various
617   :type 'hook)
618
619 ;;;###autoload
620 (defcustom message-citation-line-function 'message-insert-citation-line
621   "*Function called to insert the \"Whomever writes:\" line."
622   :type 'function
623   :group 'message-insertion)
624
625 ;;;###autoload
626 (defcustom message-yank-prefix "> "
627   "*Prefix inserted on the lines of yanked messages."
628   :type 'string
629   :group 'message-insertion)
630
631 (defcustom message-yank-add-new-references t
632   "*Non-nil means new IDs will be added to \"References\" field when an
633 article is yanked by the command `message-yank-original' interactively."
634   :type 'boolean
635   :group 'message-insertion)
636
637 (defcustom message-indentation-spaces 3
638   "*Number of spaces to insert at the beginning of each cited line.
639 Used by `message-yank-original' via `message-yank-cite'."
640   :group 'message-insertion
641   :type 'integer)
642
643 ;;;###autoload
644 (defcustom message-cite-function 'message-cite-original
645   "*Function for citing an original message.
646 Predefined functions include `message-cite-original' and
647 `message-cite-original-without-signature'.
648 Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil."
649   :type '(radio (function-item message-cite-original)
650                 (function-item message-cite-original-without-signature)
651                 (function-item mu-cite/cite-original)
652                 (function-item sc-cite-original)
653                 (function :tag "Other"))
654   :group 'message-insertion)
655
656 ;;;###autoload
657 (defcustom message-indent-citation-function 'message-indent-citation
658   "*Function for modifying a citation just inserted in the mail buffer.
659 This can also be a list of functions.  Each function can find the
660 citation between (point) and (mark t).  And each function should leave
661 point and mark around the citation text as modified."
662   :type 'function
663   :group 'message-insertion)
664
665 (defvar message-abbrevs-loaded nil)
666
667 ;;;###autoload
668 (defcustom message-signature t
669   "*String to be inserted at the end of the message buffer.
670 If t, the `message-signature-file' file will be inserted instead.
671 If a function, the result from the function will be used instead.
672 If a form, the result from the form will be used instead."
673   :type 'sexp
674   :group 'message-insertion)
675
676 ;;;###autoload
677 (defcustom message-signature-file "~/.signature"
678   "*File containing the text inserted at end of message buffer."
679   :type 'file
680   :group 'message-insertion)
681
682 (defcustom message-distribution-function nil
683   "*Function called to return a Distribution header."
684   :group 'message-news
685   :group 'message-headers
686   :type 'function)
687
688 (defcustom message-expires 14
689   "Number of days before your article expires."
690   :group 'message-news
691   :group 'message-headers
692   :link '(custom-manual "(message)News Headers")
693   :type 'integer)
694
695 (defcustom message-user-path nil
696   "If nil, use the NNTP server name in the Path header.
697 If stringp, use this; if non-nil, use no host name (user name only)."
698   :group 'message-news
699   :group 'message-headers
700   :link '(custom-manual "(message)News Headers")
701   :type '(choice (const :tag "nntp" nil)
702                  (string :tag "name")
703                  (sexp :tag "none" :format "%t" t)))
704
705 (defvar message-reply-buffer nil)
706 (defvar message-reply-headers nil)
707 (defvar message-sent-message-via nil)
708 (defvar message-checksum nil)
709 (defvar message-send-actions nil
710   "A list of actions to be performed upon successful sending of a message.")
711 (defvar message-exit-actions nil
712   "A list of actions to be performed upon exiting after sending a message.")
713 (defvar message-kill-actions nil
714   "A list of actions to be performed before killing a message buffer.")
715 (defvar message-postpone-actions nil
716   "A list of actions to be performed after postponing a message.")
717 (defvar message-original-frame nil)
718 (defvar message-parameter-alist nil)
719 (defvar message-startup-parameter-alist nil)
720
721 (define-widget 'message-header-lines 'text
722   "All header lines must be LFD terminated."
723   :format "%t:%n%v"
724   :valid-regexp "^\\'"
725   :error "All header lines must be newline terminated")
726
727 (defcustom message-default-headers ""
728   "*A string containing header lines to be inserted in outgoing messages.
729 It is inserted before you edit the message, so you can edit or delete
730 these lines."
731   :group 'message-headers
732   :type 'message-header-lines)
733
734 (defcustom message-default-mail-headers ""
735   "*A string of header lines to be inserted in outgoing mails."
736   :group 'message-headers
737   :group 'message-mail
738   :type 'message-header-lines)
739
740 (defcustom message-default-news-headers ""
741   "*A string of header lines to be inserted in outgoing news
742 articles."
743   :group 'message-headers
744   :group 'message-news
745   :type 'message-header-lines)
746
747 ;; Note: could use /usr/ucb/mail instead of sendmail;
748 ;; options -t, and -v if not interactive.
749 (defcustom message-mailer-swallows-blank-line
750   (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
751                          system-configuration)
752            (file-readable-p "/etc/sendmail.cf")
753            (let ((buffer (get-buffer-create " *temp*")))
754              (unwind-protect
755                  (save-excursion
756                    (set-buffer buffer)
757                    (insert-file-contents "/etc/sendmail.cf")
758                    (goto-char (point-min))
759                    (let ((case-fold-search nil))
760                      (re-search-forward "^OR\\>" nil t)))
761                (kill-buffer buffer))))
762       ;; According to RFC822, "The field-name must be composed of printable
763       ;; ASCII characters (i. e., characters that have decimal values between
764       ;; 33 and 126, except colon)", i. e., any chars except ctl chars,
765       ;; space, or colon.
766       '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
767   "*Set this non-nil if the system's mailer runs the header and body together.
768 \(This problem exists on Sunos 4 when sendmail is run in remote mode.)
769 The value should be an expression to test whether the problem will
770 actually occur."
771   :group 'message-sending
772   :type 'sexp)
773
774 ;;; XXX: This symbol is overloaded!  See below.
775 (defvar message-user-agent nil
776   "String of the form of PRODUCT/VERSION.  Used for User-Agent header field.")
777
778 ;; Ignore errors in case this is used in Emacs 19.
779 ;; Don't use ignore-errors because this is copied into loaddefs.el.
780 ;;;###autoload
781 (ignore-errors
782   (define-mail-user-agent 'message-user-agent
783     'message-mail 'message-send-and-exit
784     'message-kill-buffer 'message-send-hook))
785
786 (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
787   "If non-nil, delete the deletable headers before feeding to mh.")
788
789 (defvar message-send-method-alist
790   '((news message-news-p message-send-via-news)
791     (mail message-mail-p message-send-via-mail))
792   "Alist of ways to send outgoing messages.
793 Each element has the form
794
795   \(TYPE PREDICATE FUNCTION)
796
797 where TYPE is a symbol that names the method; PREDICATE is a function
798 called without any parameters to determine whether the message is
799 a message of type TYPE; and FUNCTION is a function to be called if
800 PREDICATE returns non-nil.  FUNCTION is called with one parameter --
801 the prefix.")
802
803 (defvar message-mail-alias-type 'abbrev
804   "*What alias expansion type to use in Message buffers.
805 The default is `abbrev', which uses mailabbrev.  nil switches
806 mail aliases off.")
807
808 (defcustom message-auto-save-directory
809   (nnheader-concat message-directory "drafts/")
810   "*Directory where Message auto-saves buffers if Gnus isn't running.
811 If nil, Message won't auto-save."
812   :group 'message-buffers
813   :type 'directory)
814
815 (defcustom message-buffer-naming-style 'unique
816   "*The way new message buffers are named.
817 Valid valued are `unique' and `unsent'."
818   :group 'message-buffers
819   :type '(choice (const :tag "unique" unique)
820                  (const :tag "unsent" unsent)))
821
822 (defcustom message-default-charset nil
823   "Default charset used in non-MULE XEmacsen."
824   :group 'message
825   :type 'symbol)
826
827 ;;; Internal variables.
828 ;;; Well, not really internal.
829
830 (defvar message-mode-syntax-table
831   (let ((table (copy-syntax-table text-mode-syntax-table)))
832     (modify-syntax-entry ?% ". " table)
833     (modify-syntax-entry ?> ". " table)
834     (modify-syntax-entry ?< ". " table)
835     table)
836   "Syntax table used while in Message mode.")
837
838 (defvar message-mode-abbrev-table text-mode-abbrev-table
839   "Abbrev table used in Message mode buffers.
840 Defaults to `text-mode-abbrev-table'.")
841 (defgroup message-headers nil
842   "Message headers."
843   :link '(custom-manual "(message)Variables")
844   :group 'message)
845
846 (defface message-header-to-face
847   '((((class color)
848       (background dark))
849      (:foreground "green2" :bold t))
850     (((class color)
851       (background light))
852      (:foreground "MidnightBlue" :bold t))
853     (t
854      (:bold t :italic t)))
855   "Face used for displaying From headers."
856   :group 'message-faces)
857
858 (defface message-header-cc-face
859   '((((class color)
860       (background dark))
861      (:foreground "green4" :bold t))
862     (((class color)
863       (background light))
864      (:foreground "MidnightBlue"))
865     (t
866      (:bold t)))
867   "Face used for displaying Cc headers."
868   :group 'message-faces)
869
870 (defface message-header-subject-face
871   '((((class color)
872       (background dark))
873      (:foreground "green3"))
874     (((class color)
875       (background light))
876      (:foreground "navy blue" :bold t))
877     (t
878      (:bold t)))
879   "Face used for displaying subject headers."
880   :group 'message-faces)
881
882 (defface message-header-newsgroups-face
883   '((((class color)
884       (background dark))
885      (:foreground "yellow" :bold t :italic t))
886     (((class color)
887       (background light))
888      (:foreground "blue4" :bold t :italic t))
889     (t
890      (:bold t :italic t)))
891   "Face used for displaying newsgroups headers."
892   :group 'message-faces)
893
894 (defface message-header-other-face
895   '((((class color)
896       (background dark))
897      (:foreground "#b00000"))
898     (((class color)
899       (background light))
900      (:foreground "steel blue"))
901     (t
902      (:bold t :italic t)))
903   "Face used for displaying newsgroups headers."
904   :group 'message-faces)
905
906 (defface message-header-name-face
907   '((((class color)
908       (background dark))
909      (:foreground "DarkGreen"))
910     (((class color)
911       (background light))
912      (:foreground "cornflower blue"))
913     (t
914      (:bold t)))
915   "Face used for displaying header names."
916   :group 'message-faces)
917
918 (defface message-header-xheader-face
919   '((((class color)
920       (background dark))
921      (:foreground "blue"))
922     (((class color)
923       (background light))
924      (:foreground "blue"))
925     (t
926      (:bold t)))
927   "Face used for displaying X-Header headers."
928   :group 'message-faces)
929
930 (defface message-separator-face
931   '((((class color)
932       (background dark))
933      (:foreground "blue3"))
934     (((class color)
935       (background light))
936      (:foreground "brown"))
937     (t
938      (:bold t)))
939   "Face used for displaying the separator."
940   :group 'message-faces)
941
942 (defface message-cited-text-face
943   '((((class color)
944       (background dark))
945      (:foreground "red"))
946     (((class color)
947       (background light))
948      (:foreground "red"))
949     (t
950      (:bold t)))
951   "Face used for displaying cited text names."
952   :group 'message-faces)
953
954 (defface message-mml-face
955   '((((class color)
956       (background dark))
957      (:foreground "ForestGreen"))
958     (((class color)
959       (background light))
960      (:foreground "ForestGreen"))
961     (t
962      (:bold t)))
963   "Face used for displaying MML."
964   :group 'message-faces)
965
966 (defvar message-font-lock-keywords
967   (let* ((cite-prefix "A-Za-z")
968          (cite-suffix (concat cite-prefix "0-9_.@-"))
969          (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)"))
970     `((,(concat "^\\([Tt]o:\\)" content)
971        (1 'message-header-name-face)
972        (2 'message-header-to-face nil t))
973       (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
974                 "[Mm]ail-[Cc]opies-[Tt]o:\\|"
975                 "[Mm]ail-[Rr]eply-[Tt]o:\\|"
976                 "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content)
977        (1 'message-header-name-face)
978        (2 'message-header-cc-face nil t))
979       (,(concat "^\\([Ss]ubject:\\)" content)
980        (1 'message-header-name-face)
981        (2 'message-header-subject-face nil t))
982       (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
983        (1 'message-header-name-face)
984        (2 'message-header-newsgroups-face nil t))
985       (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
986        (1 'message-header-name-face)
987        (2 'message-header-other-face nil t))
988       (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
989        (1 'message-header-name-face)
990        (2 'message-header-name-face))
991       ,@(if (and mail-header-separator
992                  (not (equal mail-header-separator "")))
993             `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
994                1 'message-separator-face))
995           nil)
996       (,(concat "^[ \t]*"
997                 "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
998                 "[:>|}].*")
999        (0 'message-cited-text-face))
1000       ("<#/?\\(multipart\\|part\\|external\\).*>"
1001        (0 'message-mml-face))))
1002   "Additional expressions to highlight in Message mode.")
1003
1004 ;; XEmacs does it like this.  For Emacs, we have to set the
1005 ;; `font-lock-defaults' buffer-local variable.
1006 (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
1007
1008 (defvar message-face-alist
1009   '((bold . bold-region)
1010     (underline . underline-region)
1011     (default . (lambda (b e)
1012                  (unbold-region b e)
1013                  (ununderline-region b e))))
1014   "Alist of mail and news faces for facemenu.
1015 The cdr of ech entry is a function for applying the face to a region.")
1016
1017 (defcustom message-send-hook nil
1018   "Hook run before sending messages."
1019   :group 'message-various
1020   :options '(ispell-message)
1021   :type 'hook)
1022
1023 (defcustom message-send-mail-hook nil
1024   "Hook run before sending mail messages."
1025   :group 'message-various
1026   :type 'hook)
1027
1028 (defcustom message-send-news-hook nil
1029   "Hook run before sending news messages."
1030   :group 'message-various
1031   :type 'hook)
1032
1033 (defcustom message-sent-hook nil
1034   "Hook run after sending messages."
1035   :group 'message-various
1036   :type 'hook)
1037
1038 (defcustom message-use-multi-frames nil
1039   "Make new frame when sending messages."
1040   :group 'message-frames
1041   :type 'boolean)
1042
1043 (defcustom message-delete-frame-on-exit nil
1044   "Delete frame after sending messages."
1045   :group 'message-frames
1046   :type '(choice (const :tag "off" nil)
1047                  (const :tag "always" t)
1048                  (const :tag "ask" ask)))
1049
1050 (defvar message-draft-coding-system
1051   (cond
1052    ((boundp 'MULE) '*junet*)
1053    ((not (fboundp 'find-coding-system)) nil)
1054    ((find-coding-system 'emacs-mule)
1055     (if (string-match "nt\\|windows" system-configuration)
1056         'emacs-mule-dos 'emacs-mule))
1057    ((find-coding-system 'escape-quoted) 'escape-quoted)
1058    ((find-coding-system 'no-conversion) 'no-conversion)
1059    (t nil))
1060   "Coding system to compose mail.")
1061
1062 ;;; Internal variables.
1063
1064 (defvar message-buffer-list nil)
1065 (defvar message-this-is-news nil)
1066 (defvar message-this-is-mail nil)
1067 (defvar message-draft-article nil)
1068 (defvar message-mime-part nil)
1069 (defvar message-posting-charset nil)
1070
1071 ;; Byte-compiler warning
1072 (defvar gnus-active-hashtb)
1073 (defvar gnus-read-active-file)
1074
1075 ;;; Regexp matching the delimiter of messages in UNIX mail format
1076 ;;; (UNIX From lines), minus the initial ^.  It should be a copy
1077 ;;; of rmail.el's rmail-unix-mail-delimiter.
1078 (defvar message-unix-mail-delimiter
1079   (let ((time-zone-regexp
1080          (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
1081                  "\\|[-+]?[0-9][0-9][0-9][0-9]"
1082                  "\\|"
1083                  "\\) *")))
1084     (concat
1085      "From "
1086
1087      ;; Many things can happen to an RFC 822 mailbox before it is put into
1088      ;; a `From' line.  The leading phrase can be stripped, e.g.
1089      ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'.  The <> can be stripped, e.g.
1090      ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'.  Everything starting with a CRLF
1091      ;; can be removed, e.g.
1092      ;;         From: joe@y.z (Joe      K
1093      ;;                 User)
1094      ;; can yield `From joe@y.z (Joe    K Fri Mar 22 08:11:15 1996', and
1095      ;;         From: Joe User
1096      ;;                 <joe@y.z>
1097      ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.
1098      ;; The mailbox can be removed or be replaced by white space, e.g.
1099      ;;         From: "Joe User"{space}{tab}
1100      ;;                 <joe@y.z>
1101      ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996',
1102      ;; where {space} and {tab} represent the Ascii space and tab characters.
1103      ;; We want to match the results of any of these manglings.
1104      ;; The following regexp rejects names whose first characters are
1105      ;; obviously bogus, but after that anything goes.
1106      "\\([^\0-\b\n-\r\^?].*\\)? "
1107
1108      ;; The time the message was sent.
1109      "\\([^\0-\r \^?]+\\) +"                            ; day of the week
1110      "\\([^\0-\r \^?]+\\) +"                            ; month
1111      "\\([0-3]?[0-9]\\) +"                              ; day of month
1112      "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *"  ; time of day
1113
1114      ;; Perhaps a time zone, specified by an abbreviation, or by a
1115      ;; numeric offset.
1116      time-zone-regexp
1117
1118      ;; The year.
1119      " \\([0-9][0-9]+\\) *"
1120
1121      ;; On some systems the time zone can appear after the year, too.
1122      time-zone-regexp
1123
1124      ;; Old uucp cruft.
1125      "\\(remote from .*\\)?"
1126
1127      "\n"))
1128   "Regexp matching the delimiter of messages in UNIX mail format.")
1129
1130 (defvar message-unsent-separator
1131   (concat "^ *---+ +Unsent message follows +---+ *$\\|"
1132           "^ *---+ +Returned message +---+ *$\\|"
1133           "^Start of returned message$\\|"
1134           "^ *---+ +Original message +---+ *$\\|"
1135           "^ *--+ +begin message +--+ *$\\|"
1136           "^ *---+ +Original message follows +---+ *$\\|"
1137           "^|? *---+ +Message text follows: +---+ *|?$")
1138   "A regexp that matches the separator before the text of a failed message.")
1139
1140 (defvar message-header-format-alist
1141   `((Newsgroups)
1142     (To . message-fill-address)
1143     (Cc . message-fill-address)
1144     (Subject)
1145     (In-Reply-To)
1146     (Fcc)
1147     (Bcc)
1148     (Date)
1149     (Organization)
1150     (Distribution)
1151     (Lines)
1152     (Expires)
1153     (Message-ID)
1154     (References . message-shorten-references)
1155     (User-Agent))
1156   "Alist used for formatting headers.")
1157
1158 (eval-and-compile
1159   (autoload 'message-setup-toolbar "messagexmas")
1160   (autoload 'mh-new-draft-name "mh-comp")
1161   (autoload 'mh-send-letter "mh-comp")
1162   (autoload 'gnus-point-at-eol "gnus-util")
1163   (autoload 'gnus-point-at-bol "gnus-util")
1164   (autoload 'gnus-output-to-mail "gnus-util")
1165   (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")
1166   (autoload 'nndraft-request-associate-buffer "nndraft")
1167   (autoload 'nndraft-request-expire-articles "nndraft")
1168   (autoload 'gnus-open-server "gnus-int")
1169   (autoload 'gnus-request-post "gnus-int")
1170   (autoload 'gnus-copy-article-buffer "gnus-msg")
1171   (autoload 'gnus-alive-p "gnus-util")
1172   (autoload 'rmail-output "rmail")
1173   (autoload 'mu-cite/cite-original "mu-cite"))
1174
1175 \f
1176
1177 ;;;
1178 ;;; Utility functions.
1179 ;;;
1180 (defun message-eval-parameter (parameter)
1181   (condition-case ()
1182       (if (symbolp parameter)
1183           (if (functionp parameter)
1184               (funcall parameter)
1185             (eval parameter))
1186         parameter)
1187     (error nil)))
1188
1189 (defsubst message-get-parameter (key &optional alist)
1190   (unless alist
1191     (setq alist message-parameter-alist))
1192   (cdr (assq key alist)))
1193
1194 (defmacro message-get-parameter-with-eval (key &optional alist)
1195   `(message-eval-parameter (message-get-parameter ,key ,alist)))
1196
1197 (defmacro message-y-or-n-p (question show &rest text)
1198   "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW"
1199   `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
1200
1201 ;; Delete the current line (and the next N lines.);
1202 (defmacro message-delete-line (&optional n)
1203   `(delete-region (progn (beginning-of-line) (point))
1204                   (progn (forward-line ,(or n 1)) (point))))
1205
1206 (defun message-tokenize-header (header &optional separator)
1207   "Split HEADER into a list of header elements.
1208 \",\" is used as the separator."
1209   (if (not header)
1210       nil
1211     (let ((regexp (format "[%s]+" (or separator ",")))
1212           (beg 1)
1213           (first t)
1214           quoted elems paren)
1215       (save-excursion
1216         (message-set-work-buffer)
1217         (insert header)
1218         (goto-char (point-min))
1219         (while (not (eobp))
1220           (if first
1221               (setq first nil)
1222             (forward-char 1))
1223           (cond ((and (> (point) beg)
1224                       (or (eobp)
1225                           (and (looking-at regexp)
1226                                (not quoted)
1227                                (not paren))))
1228                  (push (buffer-substring beg (point)) elems)
1229                  (setq beg (match-end 0)))
1230                 ((eq (char-after) ?\")
1231                  (setq quoted (not quoted)))
1232                 ((and (eq (char-after) ?\()
1233                       (not quoted))
1234                  (setq paren t))
1235                 ((and (eq (char-after) ?\))
1236                       (not quoted))
1237                  (setq paren nil))))
1238         (nreverse elems)))))
1239
1240 (defun message-mail-file-mbox-p (file)
1241   "Say whether FILE looks like a Unix mbox file."
1242   (when (and (file-exists-p file)
1243              (file-readable-p file)
1244              (file-regular-p file))
1245     (with-temp-buffer
1246       (nnheader-insert-file-contents file)
1247       (goto-char (point-min))
1248       (looking-at message-unix-mail-delimiter))))
1249
1250 (defun message-fetch-field (header &optional not-all)
1251   "The same as `mail-fetch-field', only remove all newlines."
1252   (let* ((inhibit-point-motion-hooks t)
1253          (value (mail-fetch-field header nil (not not-all))))
1254     (when value
1255       (while (string-match "\n[\t ]+" value)
1256         (setq value (replace-match " " t t value)))
1257       ;; We remove all text props.delete-region
1258       (format "%s" value))))
1259
1260 (defun message-narrow-to-field ()
1261   "Narrow the buffer to the header on the current line."
1262   (beginning-of-line)
1263   (narrow-to-region
1264    (point)
1265    (progn
1266      (forward-line 1)
1267      (if (re-search-forward "^[^ \n\t]" nil t)
1268          (progn
1269            (beginning-of-line)
1270            (point))
1271        (point-max))))
1272   (goto-char (point-min)))
1273
1274 (defun message-add-header (&rest headers)
1275   "Add the HEADERS to the message header, skipping those already present."
1276   (while headers
1277     (let (hclean)
1278       (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers))
1279         (error "Invalid header `%s'" (car headers)))
1280       (setq hclean (match-string 1 (car headers)))
1281     (save-restriction
1282       (message-narrow-to-headers)
1283       (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
1284         (insert (car headers) ?\n))))
1285     (setq headers (cdr headers))))
1286
1287 (defun message-fetch-reply-field (header)
1288   "Fetch FIELD from the message we're replying to."
1289   (let ((buffer (message-eval-parameter message-reply-buffer)))
1290     (when (and buffer
1291                (buffer-name buffer))
1292       (save-excursion
1293         (set-buffer buffer)
1294         (message-fetch-field header)))))
1295
1296 (defun message-set-work-buffer ()
1297   (if (get-buffer " *message work*")
1298       (progn
1299         (set-buffer " *message work*")
1300         (erase-buffer))
1301     (set-buffer (get-buffer-create " *message work*"))
1302     (kill-all-local-variables)))
1303
1304 (defun message-functionp (form)
1305   "Return non-nil if FORM is funcallable."
1306   (or (and (symbolp form) (fboundp form))
1307       (and (listp form) (eq (car form) 'lambda))
1308       (byte-code-function-p form)))
1309
1310 (defun message-strip-subject-re (subject)
1311   "Remove \"Re:\" from subject lines."
1312   (if (string-match message-subject-re-regexp subject)
1313       (substring subject (match-end 0))
1314     subject))
1315
1316 (defun message-remove-header (header &optional is-regexp first reverse)
1317   "Remove HEADER in the narrowed buffer.
1318 If REGEXP, HEADER is a regular expression.
1319 If FIRST, only remove the first instance of the header.
1320 Return the number of headers removed."
1321   (goto-char (point-min))
1322   (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":")))
1323         (number 0)
1324         (case-fold-search t)
1325         last)
1326     (while (and (not (eobp))
1327                 (not last))
1328       (if (if reverse
1329               (not (looking-at regexp))
1330             (looking-at regexp))
1331           (progn
1332             (incf number)
1333             (when first
1334               (setq last t))
1335             (delete-region
1336              (point)
1337              ;; There might be a continuation header, so we have to search
1338              ;; until we find a new non-continuation line.
1339              (progn
1340                (forward-line 1)
1341                (if (re-search-forward "^[^ \t]" nil t)
1342                    (goto-char (match-beginning 0))
1343                  (point-max)))))
1344         (forward-line 1)
1345         (if (re-search-forward "^[^ \t]" nil t)
1346             (goto-char (match-beginning 0))
1347           (goto-char (point-max)))))
1348     number))
1349
1350 (defun message-remove-first-header (header)
1351   "Remove the first instance of HEADER if there is more than one."
1352   (let ((count 0)
1353         (regexp (concat "^" (regexp-quote header) ":")))
1354     (save-excursion
1355       (goto-char (point-min))
1356       (while (re-search-forward regexp nil t)
1357         (incf count)))
1358     (while (> count 1)
1359       (message-remove-header header nil t)
1360       (decf count))))
1361
1362 (defun message-narrow-to-headers ()
1363   "Narrow the buffer to the head of the message."
1364   (widen)
1365   (narrow-to-region
1366    (goto-char (point-min))
1367    (if (re-search-forward
1368         (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1369        (match-beginning 0)
1370      (point-max)))
1371   (goto-char (point-min)))
1372
1373 (defun message-narrow-to-head ()
1374   "Narrow the buffer to the head of the message.
1375 Point is left at the beginning of the narrowed-to region."
1376   (widen)
1377   (narrow-to-region
1378    (goto-char (point-min))
1379    (if (search-forward "\n\n" nil 1)
1380        (1- (point))
1381      (point-max)))
1382   (goto-char (point-min)))
1383
1384 (defun message-narrow-to-headers-or-head ()
1385   "Narrow the buffer to the head of the message."
1386   (widen)
1387   (narrow-to-region
1388    (goto-char (point-min))
1389    (cond
1390     ((re-search-forward
1391       (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1392      (match-beginning 0))
1393     ((search-forward "\n\n" nil t)
1394      (1- (point)))
1395     (t
1396      (point-max))))
1397   (goto-char (point-min)))
1398
1399 (defun message-news-p ()
1400   "Say whether the current buffer contains a news message."
1401   (and (not message-this-is-mail)
1402        (or message-this-is-news
1403            (save-excursion
1404              (save-restriction
1405                (message-narrow-to-headers)
1406                (and (message-fetch-field "newsgroups")
1407                     (not (message-fetch-field "posted-to"))))))))
1408
1409 (defun message-mail-p ()
1410   "Say whether the current buffer contains a mail message."
1411   (and (not message-this-is-news)
1412        (or message-this-is-mail
1413            (save-excursion
1414              (save-restriction
1415                (message-narrow-to-headers)
1416                (or (message-fetch-field "to")
1417                    (message-fetch-field "cc")
1418                    (message-fetch-field "bcc")))))))
1419
1420 (defun message-next-header ()
1421   "Go to the beginning of the next header."
1422   (beginning-of-line)
1423   (or (eobp) (forward-char 1))
1424   (not (if (re-search-forward "^[^ \t]" nil t)
1425            (beginning-of-line)
1426          (goto-char (point-max)))))
1427
1428 (defun message-sort-headers-1 ()
1429   "Sort the buffer as headers using `message-rank' text props."
1430   (goto-char (point-min))
1431   (require 'sort)
1432   (sort-subr
1433    nil 'message-next-header
1434    (lambda ()
1435      (message-next-header)
1436      (unless (bobp)
1437        (forward-char -1)))
1438    (lambda ()
1439      (or (get-text-property (point) 'message-rank)
1440          10000))))
1441
1442 (defun message-sort-headers ()
1443   "Sort the headers of the current message according to `message-header-format-alist'."
1444   (interactive)
1445   (save-excursion
1446     (save-restriction
1447       (let ((max (1+ (length message-header-format-alist)))
1448             rank)
1449         (message-narrow-to-headers)
1450         (while (re-search-forward "^[^ \n]+:" nil t)
1451           (put-text-property
1452            (match-beginning 0) (1+ (match-beginning 0))
1453            'message-rank
1454            (if (setq rank (length (memq (assq (intern (buffer-substring
1455                                                        (match-beginning 0)
1456                                                        (1- (match-end 0))))
1457                                               message-header-format-alist)
1458                                         message-header-format-alist)))
1459                (- max rank)
1460              (1+ max)))))
1461       (message-sort-headers-1))))
1462
1463 \f
1464
1465 ;;;
1466 ;;; Message mode
1467 ;;;
1468
1469 ;;; Set up keymap.
1470
1471 (defvar message-mode-map nil)
1472
1473 (unless message-mode-map
1474   (setq message-mode-map (make-keymap))
1475   (set-keymap-parent message-mode-map text-mode-map)
1476   (define-key message-mode-map "\C-c?" 'describe-mode)
1477
1478   (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
1479   (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
1480   (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
1481   (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
1482   (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
1483   ;; (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
1484   (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-mail-reply-to)
1485   (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
1486   (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
1487   (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
1488   (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
1489   (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
1490   (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
1491   (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
1492   (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
1493
1494   (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
1495   (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
1496
1497   (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
1498   (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
1499   (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
1500   (define-key message-mode-map "\C-c\M-h" 'message-insert-headers)
1501   (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
1502   (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
1503   (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
1504
1505   (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
1506   (define-key message-mode-map "\C-c\C-s" 'message-send)
1507   (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
1508   (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
1509
1510   (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
1511   (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
1512   (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
1513   (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
1514
1515   (define-key message-mode-map "\t" 'message-tab)
1516
1517   (define-key message-mode-map "\C-x\C-s" 'message-save-drafts)
1518   (define-key message-mode-map "\C-xk" 'message-mimic-kill-buffer))
1519
1520 (easy-menu-define
1521  message-mode-menu message-mode-map "Message Menu."
1522  '("Message"
1523    ["Sort Headers" message-sort-headers t]
1524    ["Yank Original" message-yank-original t]
1525    ["Fill Yanked Message" message-fill-yanked-message t]
1526    ["Insert Signature" message-insert-signature t]
1527    ["Caesar (rot13) Message" message-caesar-buffer-body t]
1528    ["Caesar (rot13) Region" message-caesar-region (mark t)]
1529    ["Elide Region" message-elide-region (mark t)]
1530    ["Delete Outside Region" message-delete-not-region (mark t)]
1531    ["Kill To Signature" message-kill-to-signature t]
1532    ["Newline and Reformat" message-newline-and-reformat t]
1533    ["Rename buffer" message-rename-buffer t]
1534    ["Spellcheck" ispell-message t]
1535    ["Attach file as MIME" mime-edit-insert-file t]
1536    "----"
1537    ["Send Message" message-send-and-exit t]
1538    ["Abort Message" message-dont-send t]
1539    ["Kill Message" message-kill-buffer t]))
1540
1541 (easy-menu-define
1542  message-mode-field-menu message-mode-map ""
1543  '("Field"
1544    ["Fetch To" message-insert-to t]
1545    ["Fetch Newsgroups" message-insert-newsgroups t]
1546    "----"
1547    ["To" message-goto-to t]
1548    ["Subject" message-goto-subject t]
1549    ["Cc" message-goto-cc t]
1550    ["Reply-To" message-goto-reply-to t]
1551    ["Mail-Reply-To" message-goto-mail-reply-to t]
1552    ["Mail-Followup-To" message-goto-mail-followup-to t]
1553    ["Mail-Copies-To" message-goto-mail-copies-to t]
1554    ["Summary" message-goto-summary t]
1555    ["Keywords" message-goto-keywords t]
1556    ["Newsgroups" message-goto-newsgroups t]
1557    ["Followup-To" message-goto-followup-to t]
1558    ["Distribution" message-goto-distribution t]
1559    ["Body" message-goto-body t]
1560    ["Signature" message-goto-signature t]))
1561
1562 (defvar facemenu-add-face-function)
1563 (defvar facemenu-remove-face-function)
1564
1565 ;;;###autoload
1566 (defun message-mode ()
1567   "Major mode for editing mail and news to be sent.
1568 Like Text Mode but with these additional commands:
1569 C-c C-s  message-send (send the message)    C-c C-c  message-send-and-exit
1570 C-c C-d  Pospone sending the message        C-c C-k  Kill the message
1571 C-c C-f  move to a header field (and create it if there isn't):
1572          C-c C-f C-t  move to To        C-c C-f C-s  move to Subject
1573          C-c C-f C-c  move to Cc        C-c C-f C-b  move to Bcc
1574          C-c C-f C-w  move to Fcc       C-c C-f C-r  move to Reply-To
1575          C-c C-f C-u  move to Summary   C-c C-f C-n  move to Newsgroups
1576          C-c C-f C-k  move to Keywords  C-c C-f C-d  move to Distribution
1577          C-c C-f C-m  move to Mail-Followup-To
1578          C-c C-f C-f  move to Followup-To
1579 C-c C-t  message-insert-to (add a To header to a news followup)
1580 C-c C-n  message-insert-newsgroups (add a Newsgroup header to a news reply)
1581 C-c C-b  message-goto-body (move to beginning of message text).
1582 C-c C-i  message-goto-signature (move to the beginning of the signature).
1583 C-c C-w  message-insert-signature (insert `message-signature-file' file).
1584 C-c C-y  message-yank-original (insert current message, if any).
1585 C-c C-q  message-fill-yanked-message (fill what was yanked).
1586 C-c C-e  message-elide-region (elide the text between point and mark).
1587 C-c C-v  message-delete-not-region (remove the text outside the region).
1588 C-c C-z  message-kill-to-signature (kill the text up to the signature).
1589 C-c C-r  message-caesar-buffer-body (rot13 the message body)."
1590   (interactive)
1591   (kill-all-local-variables)
1592   (set (make-local-variable 'message-reply-buffer) nil)
1593   (make-local-variable 'message-send-actions)
1594   (make-local-variable 'message-exit-actions)
1595   (make-local-variable 'message-kill-actions)
1596   (make-local-variable 'message-postpone-actions)
1597   (make-local-variable 'message-draft-article)
1598   (make-local-hook 'kill-buffer-hook)
1599   (set-syntax-table message-mode-syntax-table)
1600   (use-local-map message-mode-map)
1601   (setq local-abbrev-table message-mode-abbrev-table)
1602   (setq major-mode 'message-mode)
1603   (setq mode-name "Message")
1604   (setq buffer-offer-save t)
1605   (make-local-variable 'facemenu-add-face-function)
1606   (make-local-variable 'facemenu-remove-face-function)
1607   (setq facemenu-add-face-function
1608         (lambda (face end)
1609           (let ((face-fun (cdr (assq face message-face-alist))))
1610             (if face-fun
1611                 (funcall face-fun (point) end)
1612               (error "Face %s not configured for %s mode" face mode-name)))
1613           "")
1614         facemenu-remove-face-function t)
1615   (make-local-variable 'paragraph-separate)
1616   (make-local-variable 'paragraph-start)
1617   ;; `-- ' precedes the signature.  `-----' appears at the start of the
1618   ;; lines that delimit forwarded messages.
1619   ;; Lines containing just >= 3 dashes, perhaps after whitespace,
1620   ;; are also sometimes used and should be separators.
1621   (setq paragraph-start
1622         (concat (regexp-quote mail-header-separator)
1623                 "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|"
1624                 "-- $\\|---+$\\|"
1625                 page-delimiter
1626                 ;;!!! Uhm... shurely this can't be right?
1627                 "[> " (regexp-quote message-yank-prefix) "]+$"))
1628   (setq paragraph-separate paragraph-start)
1629   (make-local-variable 'message-reply-headers)
1630   (setq message-reply-headers nil)
1631   (make-local-variable 'message-user-agent)
1632   (make-local-variable 'message-post-method)
1633   (set (make-local-variable 'message-sent-message-via) nil)
1634   (set (make-local-variable 'message-checksum) nil)
1635   (make-local-variable 'message-parameter-alist)
1636   (setq message-parameter-alist
1637         (copy-sequence message-startup-parameter-alist))
1638   ;;(when (fboundp 'mail-hist-define-keys)
1639   ;;  (mail-hist-define-keys))
1640   (when (string-match "XEmacs\\|Lucid" emacs-version)
1641     (message-setup-toolbar))
1642   (easy-menu-add message-mode-menu message-mode-map)
1643   (easy-menu-add message-mode-field-menu message-mode-map)
1644   ;; Allow mail alias things.
1645   (when (eq message-mail-alias-type 'abbrev)
1646     (if (fboundp 'mail-abbrevs-setup)
1647         (mail-abbrevs-setup)
1648       (mail-aliases-setup)))
1649   (message-set-auto-save-file-name)
1650   (unless (string-match "XEmacs" emacs-version)
1651     (set (make-local-variable 'font-lock-defaults)
1652          '(message-font-lock-keywords t)))
1653   (make-local-variable 'adaptive-fill-regexp)
1654   (setq adaptive-fill-regexp
1655         (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp))
1656   (unless (boundp 'adaptive-fill-first-line-regexp)
1657     (setq adaptive-fill-first-line-regexp nil))
1658   (make-local-variable 'adaptive-fill-first-line-regexp)
1659   (setq adaptive-fill-first-line-regexp
1660         (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|"
1661                 adaptive-fill-first-line-regexp))
1662   (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
1663   (setq indent-tabs-mode nil)
1664   (run-hooks 'text-mode-hook 'message-mode-hook))
1665
1666 \f
1667
1668 ;;;
1669 ;;; Message mode commands
1670 ;;;
1671
1672 ;;; Movement commands
1673
1674 (defun message-goto-to ()
1675   "Move point to the To header."
1676   (interactive)
1677   (message-position-on-field "To"))
1678
1679 (defun message-goto-subject ()
1680   "Move point to the Subject header."
1681   (interactive)
1682   (message-position-on-field "Subject"))
1683
1684 (defun message-goto-cc ()
1685   "Move point to the Cc header."
1686   (interactive)
1687   (message-position-on-field "Cc" "To"))
1688
1689 (defun message-goto-bcc ()
1690   "Move point to the Bcc  header."
1691   (interactive)
1692   (message-position-on-field "Bcc" "Cc" "To"))
1693
1694 (defun message-goto-fcc ()
1695   "Move point to the Fcc header."
1696   (interactive)
1697   (message-position-on-field "Fcc" "To" "Newsgroups"))
1698
1699 (defun message-goto-reply-to ()
1700   "Move point to the Reply-To header."
1701   (interactive)
1702   (message-position-on-field "Reply-To" "Subject"))
1703
1704 (defun message-goto-mail-reply-to ()
1705   "Move point to the Mail-Reply-To header."
1706   (interactive)
1707   (message-position-on-field "Mail-Reply-To" "Subject"))
1708
1709 (defun message-goto-mail-followup-to ()
1710   "Move point to the Mail-Followup-To header."
1711   (interactive)
1712   (message-position-on-field "Mail-Followup-To" "Subject"))
1713
1714 (defun message-goto-mail-copies-to ()
1715   "Move point to the Mail-Copies-To header."
1716   (interactive)
1717   (message-position-on-field "Mail-Copies-To" "Subject"))
1718
1719 (defun message-goto-newsgroups ()
1720   "Move point to the Newsgroups header."
1721   (interactive)
1722   (message-position-on-field "Newsgroups"))
1723
1724 (defun message-goto-distribution ()
1725   "Move point to the Distribution header."
1726   (interactive)
1727   (message-position-on-field "Distribution"))
1728
1729 (defun message-goto-followup-to ()
1730   "Move point to the Followup-To header."
1731   (interactive)
1732   (message-position-on-field "Followup-To" "Newsgroups"))
1733
1734 (defun message-goto-keywords ()
1735   "Move point to the Keywords header."
1736   (interactive)
1737   (message-position-on-field "Keywords" "Subject"))
1738
1739 (defun message-goto-summary ()
1740   "Move point to the Summary header."
1741   (interactive)
1742   (message-position-on-field "Summary" "Subject"))
1743
1744 (defun message-goto-body ()
1745   "Move point to the beginning of the message body."
1746   (interactive)
1747   (if (looking-at "[ \t]*\n") (expand-abbrev))
1748   (goto-char (point-min))
1749   (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
1750       (search-forward "\n\n" nil t)))
1751
1752 (defun message-goto-eoh ()
1753   "Move point to the end of the headers."
1754   (interactive)
1755   (message-goto-body)
1756   (forward-line -2))
1757
1758 (defun message-goto-signature ()
1759   "Move point to the beginning of the message signature.
1760 If there is no signature in the article, go to the end and
1761 return nil."
1762   (interactive)
1763   (goto-char (point-min))
1764   (if (re-search-forward message-signature-separator nil t)
1765       (forward-line 1)
1766     (goto-char (point-max))
1767     nil))
1768
1769 \f
1770
1771 (defun message-insert-to (&optional force)
1772   "Insert a To header that points to the author of the article being replied to.
1773 If the original author requested not to be sent mail, the function signals
1774 an error.
1775 With the prefix argument FORCE, insert the header anyway."
1776   (interactive "P")
1777   (let ((co (message-fetch-reply-field "mail-copies-to")))
1778     (when (and (null force)
1779                co
1780                (or (equal (downcase co) "never")
1781                    (equal (downcase co) "nobody")))
1782       (error "The user has requested not to have copies sent via mail")))
1783   (when (and (message-position-on-field "To")
1784              (mail-fetch-field "to")
1785              (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
1786     (insert ", "))
1787   (insert (or (message-fetch-reply-field "reply-to")
1788               (message-fetch-reply-field "from") "")))
1789
1790 (defun message-insert-newsgroups ()
1791   "Insert the Newsgroups header from the article being replied to."
1792   (interactive)
1793   (when (and (message-position-on-field "Newsgroups")
1794              (mail-fetch-field "newsgroups")
1795              (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
1796     (insert ","))
1797   (insert (or (message-fetch-reply-field "newsgroups") "")))
1798
1799 \f
1800
1801 ;;; Various commands
1802
1803 (defun message-delete-not-region (beg end)
1804   "Delete everything in the body of the current message that is outside of the region."
1805   (interactive "r")
1806   (save-excursion
1807     (goto-char end)
1808     (delete-region (point) (if (not (message-goto-signature))
1809                                (point)
1810                              (forward-line -2)
1811                              (point)))
1812     (insert "\n")
1813     (goto-char beg)
1814     (delete-region beg (progn (message-goto-body)
1815                               (forward-line 2)
1816                               (point))))
1817   (when (message-goto-signature)
1818     (forward-line -2)))
1819
1820 (defun message-kill-to-signature ()
1821   "Deletes all text up to the signature."
1822   (interactive)
1823   (let ((point (point)))
1824     (message-goto-signature)
1825     (unless (eobp)
1826       (forward-line -2))
1827     (kill-region point (point))
1828     (unless (bolp)
1829       (insert "\n"))))
1830
1831 (defun message-newline-and-reformat ()
1832   "Insert four newlines, and then reformat if inside quoted text."
1833   (interactive)
1834   (let ((point (point))
1835         quoted)
1836     (save-excursion
1837       (beginning-of-line)
1838       (setq quoted (looking-at (regexp-quote message-yank-prefix))))
1839     (insert "\n\n\n\n")
1840     (when quoted
1841       (insert message-yank-prefix))
1842     (fill-paragraph nil)
1843     (goto-char point)
1844     (forward-line 2)))
1845
1846 (defun message-insert-signature (&optional force)
1847   "Insert a signature.  See documentation for the `message-signature' variable."
1848   (interactive (list 0))
1849   (let* ((signature
1850           (cond
1851            ((and (null message-signature)
1852                  (eq force 0))
1853             (save-excursion
1854               (goto-char (point-max))
1855               (not (re-search-backward message-signature-separator nil t))))
1856            ((and (null message-signature)
1857                  force)
1858             t)
1859            ((message-functionp message-signature)
1860             (funcall message-signature))
1861            ((listp message-signature)
1862             (eval message-signature))
1863            (t message-signature)))
1864          (signature
1865           (cond ((stringp signature)
1866                  signature)
1867                 ((and (eq t signature)
1868                       message-signature-file
1869                       (file-exists-p message-signature-file))
1870                  signature))))
1871     (when signature
1872       (goto-char (point-max))
1873       ;; Insert the signature.
1874       (unless (bolp)
1875         (insert "\n"))
1876       (insert "\n-- \n")
1877       (if (eq signature t)
1878           (insert-file-contents message-signature-file)
1879         (insert signature))
1880       (goto-char (point-max))
1881       (or (bolp) (insert "\n")))))
1882
1883 (defun message-elide-region (b e)
1884   "Elide the text between point and mark.
1885 An ellipsis (from `message-elide-elipsis') will be inserted where the
1886 text was killed."
1887   (interactive "r")
1888   (kill-region b e)
1889   (unless (bolp)
1890     (insert "\n"))
1891   (insert message-elide-elipsis))
1892
1893 (defvar message-caesar-translation-table nil)
1894
1895 (defun message-caesar-region (b e &optional n)
1896   "Caesar rotation of region by N, default 13, for decrypting netnews."
1897   (interactive
1898    (list
1899     (min (point) (or (mark t) (point)))
1900     (max (point) (or (mark t) (point)))
1901     (when current-prefix-arg
1902       (prefix-numeric-value current-prefix-arg))))
1903
1904   (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
1905   (unless (or (zerop n)                 ; no action needed for a rot of 0
1906               (= b e))                  ; no region to rotate
1907     ;; We build the table, if necessary.
1908     (when (or (not message-caesar-translation-table)
1909               (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
1910         (setq message-caesar-translation-table
1911               (message-make-caesar-translation-table n)))
1912     ;; Then we translate the region.  Do it this way to retain
1913     ;; text properties.
1914     (while (< b e)
1915       (when (< (char-after b) 255)
1916         (subst-char-in-region
1917          b (1+ b) (char-after b)
1918          (aref message-caesar-translation-table (char-after b))))
1919       (incf b))))
1920
1921 (defun message-make-caesar-translation-table (n)
1922   "Create a rot table with offset N."
1923   (let ((i -1)
1924         (table (make-string 256 0)))
1925     (while (< (incf i) 256)
1926       (aset table i i))
1927     (concat
1928      (substring table 0 ?A)
1929      (substring table (+ ?A n) (+ ?A n (- 26 n)))
1930      (substring table ?A (+ ?A n))
1931      (substring table (+ ?A 26) ?a)
1932      (substring table (+ ?a n) (+ ?a n (- 26 n)))
1933      (substring table ?a (+ ?a n))
1934      (substring table (+ ?a 26) 255))))
1935
1936 (defun message-caesar-buffer-body (&optional rotnum)
1937   "Caesar rotates all letters in the current buffer by 13 places.
1938 Used to encode/decode possiblyun offensive messages (commonly in net.jokes).
1939 With prefix arg, specifies the number of places to rotate each letter forward.
1940 Mail and USENET news headers are not rotated."
1941   (interactive (if current-prefix-arg
1942                    (list (prefix-numeric-value current-prefix-arg))
1943                  (list nil)))
1944   (save-excursion
1945     (save-restriction
1946       (when (message-goto-body)
1947         (narrow-to-region (point) (point-max)))
1948       (message-caesar-region (point-min) (point-max) rotnum))))
1949
1950 (defun message-pipe-buffer-body (program)
1951   "Pipe the message body in the current buffer through PROGRAM."
1952   (save-excursion
1953     (save-restriction
1954       (when (message-goto-body)
1955         (narrow-to-region (point) (point-max)))
1956       (let ((body (buffer-substring (point-min) (point-max))))
1957         (unless (equal 0 (call-process-region
1958                            (point-min) (point-max) program t t))
1959             (insert body)
1960             (message "%s failed." program))))))
1961
1962 (defun message-rename-buffer (&optional enter-string)
1963   "Rename the *message* buffer to \"*message* RECIPIENT\".
1964 If the function is run with a prefix, it will ask for a new buffer
1965 name, rather than giving an automatic name."
1966   (interactive "Pbuffer name: ")
1967   (save-excursion
1968     (save-restriction
1969       (goto-char (point-min))
1970       (narrow-to-region (point)
1971                         (search-forward mail-header-separator nil 'end))
1972       (let* ((mail-to (or
1973                        (if (message-news-p) (message-fetch-field "Newsgroups")
1974                          (message-fetch-field "To"))
1975                        ""))
1976              (mail-trimmed-to
1977               (if (string-match "," mail-to)
1978                   (concat (substring mail-to 0 (match-beginning 0)) ", ...")
1979                 mail-to))
1980              (name-default (concat "*message* " mail-trimmed-to))
1981              (name (if enter-string
1982                        (read-string "New buffer name: " name-default)
1983                      name-default)))
1984         (rename-buffer name t)))))
1985
1986 (defun message-fill-yanked-message (&optional justifyp)
1987   "Fill the paragraphs of a message yanked into this one.
1988 Numeric argument means justify as well."
1989   (interactive "P")
1990   (save-excursion
1991     (goto-char (point-min))
1992     (search-forward (concat "\n" mail-header-separator "\n") nil t)
1993     (let ((fill-prefix message-yank-prefix))
1994       (fill-individual-paragraphs (point) (point-max) justifyp))))
1995
1996 (defun message-indent-citation ()
1997   "Modify text just inserted from a message to be cited.
1998 The inserted text should be the region.
1999 When this function returns, the region is again around the modified text.
2000
2001 Normally, indent each nonblank line `message-indentation-spaces' spaces.
2002 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
2003   (let ((start (point)))
2004     ;; Remove unwanted headers.
2005     (when message-ignored-cited-headers
2006       (let (all-removed)
2007         (save-restriction
2008           (narrow-to-region
2009            (goto-char start)
2010            (if (search-forward "\n\n" nil t)
2011                (1- (point))
2012              (point)))
2013           (message-remove-header message-ignored-cited-headers t)
2014           (when (= (point-min) (point-max))
2015             (setq all-removed t))
2016           (goto-char (point-max)))
2017         (if all-removed
2018             (goto-char start)
2019           (forward-line 1))))
2020     ;; Delete blank lines at the start of the buffer.
2021     (while (and (point-min)
2022                 (eolp)
2023                 (not (eobp)))
2024       (message-delete-line))
2025     ;; Delete blank lines at the end of the buffer.
2026     (goto-char (point-max))
2027     (unless (eolp)
2028       (insert "\n"))
2029     (while (and (zerop (forward-line -1))
2030                 (looking-at "$"))
2031       (message-delete-line))
2032     ;; Do the indentation.
2033     (if (null message-yank-prefix)
2034         (indent-rigidly start (mark t) message-indentation-spaces)
2035       (save-excursion
2036         (goto-char start)
2037         (while (< (point) (mark t))
2038           (insert message-yank-prefix)
2039           (forward-line 1))))
2040     (goto-char start)))
2041
2042 (defun message-list-references (refs-list &rest refs-strs)
2043   "Add `Message-ID's which appear in REFS-STRS but not in REFS-LIST,
2044 to REFS-LIST."
2045   (let (refs ref id)
2046     (while refs-strs
2047       (setq refs (car refs-strs)
2048             refs-strs (cdr refs-strs))
2049       (when refs
2050         (setq refs (std11-parse-msg-ids (std11-lexical-analyze refs)))
2051         (while refs
2052           (setq ref (car refs)
2053                 refs (cdr refs))
2054           (when (eq (car ref) 'msg-id)
2055             (setq id (concat "<"
2056                              (mapconcat
2057                               (function (lambda (p) (cdr p)))
2058                               (cdr ref) "")
2059                              ">"))
2060             (or (member id refs-list)
2061                 (push id refs-list))))))
2062     refs-list))
2063
2064 (defvar gnus-article-copy)
2065 (defun message-yank-original (&optional arg)
2066   "Insert the message being replied to, if any.
2067 Puts point before the text and mark after.
2068 Normally indents each nonblank line ARG spaces (default 3).  However,
2069 if `message-yank-prefix' is non-nil, insert that prefix on each line.
2070
2071 This function uses `message-cite-function' to do the actual citing.
2072
2073 Just \\[universal-argument] as argument means don't indent, insert no
2074 prefix, and don't delete any headers.
2075
2076 In addition, if `message-yank-add-new-references' is non-nil and this
2077 command is called interactively, new IDs from the yanked article will
2078 be added to \"References\" field."
2079   (interactive "P")
2080   (let ((modified (buffer-modified-p))
2081         (buffer (message-eval-parameter message-reply-buffer))
2082         start end refs)
2083     (when (and buffer
2084                message-cite-function)
2085       (delete-windows-on buffer t)
2086       (insert-buffer buffer) ; mark will be set at the end of article.
2087       (setq start (point)
2088             end (mark t))
2089
2090       ;; Add new IDs to References field.
2091       (when (and message-yank-add-new-references (interactive-p))
2092         (save-excursion
2093           (save-restriction
2094             (message-narrow-to-headers)
2095             (setq refs (message-list-references
2096                         nil
2097                         (message-fetch-field "References")))
2098             (widen)
2099             (narrow-to-region start end)
2100             (std11-narrow-to-header)
2101             (when (setq refs (message-list-references
2102                               refs
2103                               (or (message-fetch-field "References")
2104                                   (message-fetch-field "In-Reply-To"))
2105                               (message-fetch-field "Message-ID")))
2106               (widen)
2107               (message-narrow-to-headers)
2108               (goto-char (point-min))
2109               (let ((case-fold-search t))
2110                 (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t)
2111                     (replace-match "")
2112                   (goto-char (point-max))))
2113               (mail-header-format
2114                (list (or (assq 'References message-header-format-alist)
2115                          '(References . message-fill-references)))
2116                (list (cons 'References
2117                            (mapconcat 'identity (nreverse refs) " "))))
2118               (backward-delete-char 1)))))
2119
2120       (funcall message-cite-function)
2121       (message-exchange-point-and-mark)
2122       (unless (bolp)
2123         (insert ?\n))
2124       (unless modified
2125         (setq message-checksum (message-checksum))))))
2126
2127 (defun message-cite-original-without-signature ()
2128   "Cite function in the standard Message manner."
2129   (let ((start (point))
2130         (end (mark t))
2131         (functions
2132          (when message-indent-citation-function
2133            (if (listp message-indent-citation-function)
2134                message-indent-citation-function
2135              (list message-indent-citation-function)))))
2136     (goto-char end)
2137     (when (re-search-backward message-signature-separator start t)
2138       ;; Also peel off any blank lines before the signature.
2139       (forward-line -1)
2140       (while (looking-at "^[ \t]*$")
2141         (forward-line -1))
2142       (forward-line 1)
2143       (delete-region (point) end))
2144     (goto-char start)
2145     (while functions
2146       (funcall (pop functions)))
2147     (when message-citation-line-function
2148       (unless (bolp)
2149         (insert "\n"))
2150       (funcall message-citation-line-function))))
2151
2152 (defvar mail-citation-hook)             ;Compiler directive
2153 (defun message-cite-original ()
2154   "Cite function in the standard Message manner."
2155   (if (and (boundp 'mail-citation-hook)
2156            mail-citation-hook)
2157       (run-hooks 'mail-citation-hook)
2158     (let ((start (point))
2159           (end (mark t))
2160           (functions
2161            (when message-indent-citation-function
2162              (if (listp message-indent-citation-function)
2163                  message-indent-citation-function
2164                (list message-indent-citation-function)))))
2165       (goto-char start)
2166       (while functions
2167         (funcall (pop functions)))
2168       (when message-citation-line-function
2169         (unless (bolp)
2170           (insert "\n"))
2171         (funcall message-citation-line-function)))))
2172
2173 (defun message-insert-citation-line ()
2174   "Function that inserts a simple citation line."
2175   (when message-reply-headers
2176     (insert (mail-header-from message-reply-headers) " writes:\n\n")))
2177
2178 (defun message-position-on-field (header &rest afters)
2179   (let ((case-fold-search t))
2180     (save-restriction
2181       (narrow-to-region
2182        (goto-char (point-min))
2183        (progn
2184          (re-search-forward
2185           (concat "^" (regexp-quote mail-header-separator) "$"))
2186          (match-beginning 0)))
2187       (goto-char (point-min))
2188       (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
2189           (progn
2190             (re-search-forward "^[^ \t]" nil 'move)
2191             (beginning-of-line)
2192             (skip-chars-backward "\n")
2193             t)
2194         (while (and afters
2195                     (not (re-search-forward
2196                           (concat "^" (regexp-quote (car afters)) ":")
2197                           nil t)))
2198           (pop afters))
2199         (when afters
2200           (re-search-forward "^[^ \t]" nil 'move)
2201           (beginning-of-line))
2202         (insert header ": \n")
2203         (forward-char -1)
2204         nil))))
2205
2206 (defun message-remove-signature ()
2207   "Remove the signature from the text between point and mark.
2208 The text will also be indented the normal way."
2209   (save-excursion
2210     (let ((start (point))
2211           mark)
2212       (if (not (re-search-forward message-signature-separator (mark t) t))
2213           ;; No signature here, so we just indent the cited text.
2214           (message-indent-citation)
2215         ;; Find the last non-empty line.
2216         (forward-line -1)
2217         (while (looking-at "[ \t]*$")
2218           (forward-line -1))
2219         (forward-line 1)
2220         (setq mark (set-marker (make-marker) (point)))
2221         (goto-char start)
2222         (message-indent-citation)
2223         ;; Enable undoing the deletion.
2224         (undo-boundary)
2225         (delete-region mark (mark t))
2226         (set-marker mark nil)))))
2227
2228 \f
2229
2230 ;;;
2231 ;;; Sending messages
2232 ;;;
2233
2234 ;; Avoid byte-compile warning.
2235 (defvar message-encoding-buffer nil)
2236 (defvar message-edit-buffer nil)
2237 (defvar message-mime-mode nil)
2238
2239 (defun message-send-and-exit (&optional arg)
2240   "Send message like `message-send', then, if no errors, exit from mail buffer."
2241   (interactive "P")
2242   (let ((buf (current-buffer))
2243         (actions message-exit-actions)
2244         (frame (selected-frame))
2245         (org-frame message-original-frame))
2246     (when (and (message-send arg)
2247                (buffer-name buf))
2248       (if message-kill-buffer-on-exit
2249           (kill-buffer buf)
2250         (bury-buffer buf)
2251         (when (eq buf (current-buffer))
2252           (message-bury buf)))
2253       (message-do-actions actions)
2254       (message-delete-frame frame org-frame)
2255       t)))
2256
2257 (defun message-dont-send ()
2258   "Don't send the message you have been editing."
2259   (interactive)
2260   (message-save-drafts)
2261   (let ((actions message-postpone-actions)
2262         (frame (selected-frame))
2263         (org-frame message-original-frame))
2264     (message-bury (current-buffer))
2265     (message-do-actions actions)
2266     (message-delete-frame frame org-frame)))
2267
2268 (defun message-kill-buffer ()
2269   "Kill the current buffer."
2270   (interactive)
2271   (when (or (not (buffer-modified-p))
2272             (eq t message-kill-buffer-query-function)
2273             (funcall message-kill-buffer-query-function
2274                      "The buffer modified; kill anyway? "))
2275     (let ((actions message-kill-actions)
2276           (frame (selected-frame))
2277           (org-frame message-original-frame))
2278       (setq buffer-file-name nil)
2279       (kill-buffer (current-buffer))
2280       (message-do-actions actions)
2281       (message-delete-frame frame org-frame)))
2282   (message ""))
2283
2284 (defun message-mimic-kill-buffer ()
2285   "Kill the current buffer with query."
2286   (interactive)
2287   (unless (eq 'message-mode major-mode)
2288     (error "%s must be invoked from a message buffer." this-command))
2289   (let ((command this-command)
2290         (bufname (read-buffer (format "Kill buffer: (default %s) "
2291                                       (buffer-name)))))
2292     (if (or (not bufname)
2293             (string-equal bufname "")
2294             (string-equal bufname (buffer-name)))
2295         (message-kill-buffer)
2296       (message "%s must be invoked only for the current buffer." command))))
2297
2298 (defun message-delete-frame (frame org-frame)
2299   "Delete frame for editing message."
2300   (when (and (or (static-if (featurep 'xemacs)
2301                      (device-on-window-system-p)
2302                    window-system)
2303                  (>= emacs-major-version 20))
2304              (or (and (eq message-delete-frame-on-exit t)
2305                       (select-frame frame)
2306                       (or (eq frame org-frame)
2307                           (prog1
2308                               (y-or-n-p "Delete this frame?")
2309                             (message ""))))
2310                  (and (eq message-delete-frame-on-exit 'ask)
2311                       (select-frame frame)
2312                       (prog1
2313                           (y-or-n-p "Delete this frame?")
2314                         (message "")))))
2315     (delete-frame frame)))
2316
2317 (defun message-bury (buffer)
2318   "Bury this mail buffer."
2319   (let ((newbuf (other-buffer buffer)))
2320     (bury-buffer buffer)
2321     (if (and (fboundp 'frame-parameters)
2322              (cdr (assq 'dedicated (frame-parameters)))
2323              (not (null (delq (selected-frame) (visible-frame-list)))))
2324         (delete-frame (selected-frame))
2325       (switch-to-buffer newbuf))))
2326
2327 (defun message-send (&optional arg)
2328   "Send the message in the current buffer.
2329 If `message-interactive' is non-nil, wait for success indication
2330 or error messages, and inform user.
2331 Otherwise any failure is reported in a message back to
2332 the user from the mailer."
2333   (interactive "P")
2334   ;; Disabled test.
2335   (when (or (buffer-modified-p)
2336             (message-check-element 'unchanged)
2337             (y-or-n-p "No changes in the buffer; really send? "))
2338     ;; Make it possible to undo the coming changes.
2339     (undo-boundary)
2340     (let ((inhibit-read-only t))
2341       (put-text-property (point-min) (point-max) 'read-only nil))
2342     (run-hooks 'message-send-hook)
2343     (message "Sending...")
2344     (let ((message-encoding-buffer
2345            (message-generate-new-buffer-clone-locals " message encoding"))
2346           (message-edit-buffer (current-buffer))
2347           (message-mime-mode mime-edit-mode-flag)
2348           (alist message-send-method-alist)
2349           (success t)
2350           elem sent)
2351       (save-excursion
2352         (set-buffer message-encoding-buffer)
2353         (erase-buffer)
2354         (insert-buffer message-edit-buffer)
2355         (funcall message-encode-function)
2356         (message-fix-before-sending)
2357         (while (and success
2358                     (setq elem (pop alist)))
2359           (when (and (or (not (funcall (cadr elem)))
2360                          (and (or (not (memq (car elem)
2361                                              message-sent-message-via))
2362                                   (y-or-n-p
2363                                    (format
2364                                     "Already sent message via %s; resend? "
2365                                     (car elem))))
2366                               (setq success (funcall (caddr elem) arg)))))
2367             (setq sent t))))
2368       (unless sent
2369         (error "No methods specified to send by"))
2370       (prog1
2371           (when (and success sent)
2372             (message-do-fcc)
2373             ;;(when (fboundp 'mail-hist-put-headers-into-history)
2374             ;; (mail-hist-put-headers-into-history))
2375             (save-excursion
2376               (run-hooks 'message-sent-hook))
2377             (message "Sending...done")
2378             ;; Mark the buffer as unmodified and delete autosave.
2379             (set-buffer-modified-p nil)
2380             (delete-auto-save-file-if-necessary t)
2381             (message-disassociate-draft)
2382             ;; Delete other mail buffers and stuff.
2383             (message-do-send-housekeeping)
2384             (message-do-actions message-send-actions)
2385             ;; Return success.
2386             t)
2387         (kill-buffer message-encoding-buffer)))))
2388
2389 (defun message-send-via-mail (arg)
2390   "Send the current message via mail."
2391   (message-send-mail arg))
2392
2393 (defun message-send-via-news (arg)
2394   "Send the current message via news."
2395   (message-send-news arg))
2396
2397 (defmacro message-check (type &rest forms)
2398   "Eval FORMS if TYPE is to be checked."
2399   `(or (message-check-element ,type)
2400        (save-excursion
2401          ,@forms)))
2402
2403 (put 'message-check 'lisp-indent-function 1)
2404 (put 'message-check 'edebug-form-spec '(form body))
2405
2406 (defun message-fix-before-sending ()
2407   "Do various things to make the message nice before sending it."
2408   ;; Make sure there's a newline at the end of the message.
2409   (goto-char (point-max))
2410   (unless (bolp)
2411     (insert "\n"))
2412   ;; Delete all invisible text.
2413   (message-check 'invisible-text
2414     (when (text-property-any (point-min) (point-max) 'invisible t)
2415       (put-text-property (point-min) (point-max) 'invisible nil)
2416       (unless (yes-or-no-p
2417                "Invisible text found and made visible; continue posting? ")
2418         (error "Invisible text found and made visible")))))
2419
2420 (defun message-add-action (action &rest types)
2421   "Add ACTION to be performed when doing an exit of type TYPES."
2422   (let (var)
2423     (while types
2424       (set (setq var (intern (format "message-%s-actions" (pop types))))
2425            (nconc (symbol-value var) (list action))))))
2426
2427 (defun message-do-actions (actions)
2428   "Perform all actions in ACTIONS."
2429   ;; Now perform actions on successful sending.
2430   (while actions
2431     (ignore-errors
2432       (cond
2433        ;; A simple function.
2434        ((message-functionp (car actions))
2435         (funcall (car actions)))
2436        ;; Something to be evaled.
2437        (t
2438         (eval (car actions)))))
2439     (pop actions)))
2440
2441 (defsubst message-maybe-split-and-send-mail ()
2442   "Split a message if necessary, and send it via mail.
2443 Returns nil if sending succeeded, returns any string if sending failed.
2444 This sub function is for exclusive use of `message-send-mail'."
2445   (let ((mime-edit-split-ignored-field-regexp
2446          mime-edit-split-ignored-field-regexp)
2447         (case-fold-search t)
2448         failure)
2449     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
2450       (setq mime-edit-split-ignored-field-regexp
2451             (concat (substring mime-edit-split-ignored-field-regexp
2452                                0 (match-beginning 0))
2453                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
2454                     "_so_don't_rape_it!"
2455                     (substring mime-edit-split-ignored-field-regexp
2456                                (match-end 0)))))
2457     (setq failure
2458           (or
2459            (catch 'message-sending-mail-failure
2460              (mime-edit-maybe-split-and-send
2461               (function
2462                (lambda ()
2463                  (interactive)
2464                  (save-restriction
2465                    (std11-narrow-to-header mail-header-separator)
2466                    (goto-char (point-min))
2467                    (when (re-search-forward "^Message-ID:" nil t)
2468                      (delete-region (match-end 0) (std11-field-end))
2469                      (insert " " (message-make-message-id))))
2470                  (condition-case err
2471                      (funcall message-send-mail-function)
2472                    (error
2473                     (throw 'message-sending-mail-failure err))))))
2474              nil)
2475            (condition-case err
2476                (progn
2477                  (funcall message-send-mail-function)
2478                  nil)
2479              (error err))))
2480     (when failure
2481       (if (eq 'error (car failure))
2482           (cadr failure)
2483         (prin1-to-string failure)))))
2484
2485 (defun message-send-mail (&optional arg)
2486   (require 'mail-utils)
2487   (let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
2488         (case-fold-search nil)
2489         (news (message-news-p))
2490         failure)
2491     (save-restriction
2492       (message-narrow-to-headers)
2493       ;; Insert some headers.
2494       (let ((message-deletable-headers
2495              (if news nil message-deletable-headers)))
2496         (message-generate-headers message-required-mail-headers))
2497       ;; Let the user do all of the above.
2498       (run-hooks 'message-header-hook))
2499     (if (not (message-check-mail-syntax))
2500         (progn
2501           (message "")
2502           nil)
2503       (unwind-protect
2504           (save-excursion
2505             (set-buffer tembuf)
2506             (erase-buffer)
2507             (insert-buffer message-encoding-buffer)
2508             ;; Remove some headers.
2509             (save-restriction
2510               (message-narrow-to-headers)
2511 ;; We Semi-gnus people have no use for it.
2512 ;;            ;; We (re)generate the Lines header.
2513 ;;            (when (memq 'Lines message-required-mail-headers)
2514 ;;              (message-generate-headers '(Lines)))
2515               ;; Remove some headers.
2516               (message-remove-header message-ignored-mail-headers t))
2517             (goto-char (point-max))
2518             ;; require one newline at the end.
2519             (or (= (preceding-char) ?\n)
2520                 (insert ?\n))
2521             (when (and news
2522                        (or (message-fetch-field "cc")
2523                            (message-fetch-field "to")))
2524               (message-insert-courtesy-copy))
2525             (setq failure (message-maybe-split-and-send-mail)))
2526         (kill-buffer tembuf))
2527       (set-buffer message-edit-buffer)
2528       (if failure
2529           (progn
2530             (message "Couldn't send message via mail: %s" failure)
2531             nil)
2532         (push 'mail message-sent-message-via)))))
2533
2534 (defun message-send-mail-with-sendmail ()
2535   "Send off the prepared buffer with sendmail."
2536   (let ((errbuf (if message-interactive
2537                     (generate-new-buffer " sendmail errors")
2538                   0))
2539         resend-to-addresses delimline)
2540     (let ((case-fold-search t))
2541       (save-restriction
2542         (message-narrow-to-headers)
2543         (setq resend-to-addresses (message-fetch-field "resent-to")))
2544       ;; Change header-delimiter to be what sendmail expects.
2545       (goto-char (point-min))
2546       (re-search-forward
2547        (concat "^" (regexp-quote mail-header-separator) "\n"))
2548       (replace-match "\n")
2549       (backward-char 1)
2550       (setq delimline (point-marker))
2551       (run-hooks 'message-send-mail-hook)
2552       ;; Insert an extra newline if we need it to work around
2553       ;; Sun's bug that swallows newlines.
2554       (goto-char (1+ delimline))
2555       (when (eval message-mailer-swallows-blank-line)
2556         (newline))
2557       (when message-interactive
2558         (save-excursion
2559           (set-buffer errbuf)
2560           (erase-buffer))))
2561     (let ((default-directory "/"))
2562       (as-binary-process
2563        (apply 'call-process-region
2564               (append (list (point-min) (point-max)
2565                             (if (boundp 'sendmail-program)
2566                                 sendmail-program
2567                               "/usr/lib/sendmail")
2568                             nil errbuf nil "-oi")
2569                       ;; Always specify who from,
2570                       ;; since some systems have broken sendmails.
2571                       ;; But some systems are more broken with -f, so
2572                       ;; we'll let users override this.
2573                       (if (null message-sendmail-f-is-evil)
2574                           (list "-f" (user-login-name)))
2575                       ;; These mean "report errors by mail"
2576                       ;; and "deliver in background".
2577                       (if (null message-interactive) '("-oem" "-odb"))
2578                       ;; Get the addresses from the message
2579                       ;; unless this is a resend.
2580                       ;; We must not do that for a resend
2581                       ;; because we would find the original addresses.
2582                       ;; For a resend, include the specific addresses.
2583                       (if resend-to-addresses
2584                           (list resend-to-addresses)
2585                         '("-t"))))))
2586     (when message-interactive
2587       (save-excursion
2588         (set-buffer errbuf)
2589         (goto-char (point-min))
2590         (while (re-search-forward "\n\n* *" nil t)
2591           (replace-match "; "))
2592         (if (not (zerop (buffer-size)))
2593             (error "Sending...failed to %s"
2594                    (buffer-substring (point-min) (point-max)))))
2595       (when (bufferp errbuf)
2596         (kill-buffer errbuf)))))
2597
2598 (defun message-send-mail-with-qmail ()
2599   "Pass the prepared message buffer to qmail-inject.
2600 Refer to the documentation for the variable `message-send-mail-function'
2601 to find out how to use this."
2602   ;; replace the header delimiter with a blank line
2603   (goto-char (point-min))
2604   (re-search-forward
2605    (concat "^" (regexp-quote mail-header-separator) "\n"))
2606   (replace-match "\n")
2607   (backward-char 1)
2608   (run-hooks 'message-send-mail-hook)
2609   ;; send the message
2610   (case
2611       (as-binary-process
2612        (apply
2613         'call-process-region 1 (point-max) message-qmail-inject-program
2614         nil nil nil
2615         ;; qmail-inject's default behaviour is to look for addresses on the
2616         ;; command line; if there're none, it scans the headers.
2617         ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
2618         ;;
2619         ;; in general, ALL of qmail-inject's defaults are perfect for simply
2620         ;; reading a formatted (i. e., at least a To: or Resent-To header)
2621         ;; message from stdin.
2622         ;;
2623         ;; qmail also has the advantage of not having been raped by
2624         ;; various vendors, so we don't have to allow for that, either --
2625         ;; compare this with message-send-mail-with-sendmail and weep
2626         ;; for sendmail's lost innocence.
2627         ;;
2628         ;; all this is way cool coz it lets us keep the arguments entirely
2629         ;; free for -inject-arguments -- a big win for the user and for us
2630         ;; since we don't have to play that double-guessing game and the user
2631         ;; gets full control (no gestapo'ish -f's, for instance).  --sj
2632         message-qmail-inject-args))
2633     ;; qmail-inject doesn't say anything on it's stdout/stderr,
2634     ;; we have to look at the retval instead
2635     (0 nil)
2636     (1   (error "qmail-inject reported permanent failure"))
2637     (111 (error "qmail-inject reported transient failure"))
2638     ;; should never happen
2639     (t   (error "qmail-inject reported unknown failure"))))
2640
2641 (defun message-send-mail-with-mh ()
2642   "Send the prepared message buffer with mh."
2643   (let ((mh-previous-window-config nil)
2644         (name (mh-new-draft-name)))
2645     (setq buffer-file-name name)
2646     ;; MH wants to generate these headers itself.
2647     (when message-mh-deletable-headers
2648       (let ((headers message-mh-deletable-headers))
2649         (while headers
2650           (goto-char (point-min))
2651           (and (re-search-forward
2652                 (concat "^" (symbol-name (car headers)) ": *") nil t)
2653                (message-delete-line))
2654           (pop headers))))
2655     (run-hooks 'message-send-mail-hook)
2656     ;; Pass it on to mh.
2657     (mh-send-letter)))
2658
2659 (defun message-send-mail-with-smtp ()
2660   "Send off the prepared buffer with SMTP."
2661   (require 'smtp) ; XXX
2662   (let ((case-fold-search t)
2663         recipients)
2664     (save-restriction
2665       (message-narrow-to-headers)
2666       (setq recipients
2667             ;; XXX: Should be replaced by better one.
2668             (smtp-deduce-address-list (current-buffer)
2669                                       (point-min) (point-max)))
2670       ;; Remove BCC lines.
2671       (message-remove-header "bcc"))
2672     ;; replace the header delimiter with a blank line.
2673     (goto-char (point-min))
2674     (re-search-forward
2675      (concat "^" (regexp-quote mail-header-separator) "\n"))
2676     (replace-match "\n")
2677     (backward-char 1)
2678     (run-hooks 'message-send-mail-hook)
2679     (if recipients
2680         (let ((result (smtp-via-smtp user-mail-address
2681                                      recipients
2682                                      (current-buffer))))
2683           (unless (eq result t)
2684             (error "Sending failed; " result)))
2685       (error "Sending failed; no recipients"))))
2686
2687 (defsubst message-maybe-split-and-send-news (method)
2688   "Split a message if necessary, and send it via news.
2689 Returns nil if sending succeeded, returns t if sending failed.
2690 This sub function is for exclusive use of `message-send-news'."
2691   (let ((mime-edit-split-ignored-field-regexp
2692          mime-edit-split-ignored-field-regexp)
2693         (case-fold-search t))
2694     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
2695       (setq mime-edit-split-ignored-field-regexp
2696             (concat (substring mime-edit-split-ignored-field-regexp
2697                                0 (match-beginning 0))
2698                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
2699                     "_so_don't_rape_it!"
2700                     (substring mime-edit-split-ignored-field-regexp
2701                                (match-end 0)))))
2702     (or
2703      (catch 'message-sending-news-failure
2704        (mime-edit-maybe-split-and-send
2705         (function
2706          (lambda ()
2707            (interactive)
2708            (save-restriction
2709              (std11-narrow-to-header mail-header-separator)
2710              (goto-char (point-min))
2711              (when (re-search-forward "^Message-ID:" nil t)
2712                (delete-region (match-end 0) (std11-field-end))
2713                (insert " " (message-make-message-id))))
2714            (unless (funcall message-send-news-function method)
2715              (throw 'message-sending-news-failure t)))))
2716        nil)
2717      (not (funcall message-send-news-function method)))))
2718
2719 (defun message-send-news (&optional arg)
2720   (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
2721         (case-fold-search nil)
2722         (method (if (message-functionp message-post-method)
2723                     (funcall message-post-method arg)
2724                   message-post-method))
2725         (message-syntax-checks
2726          (if arg
2727              (cons '(existing-newsgroups . disabled)
2728                    message-syntax-checks)
2729            message-syntax-checks))
2730         result)
2731     (save-restriction
2732       (message-narrow-to-headers)
2733       ;; Insert some headers.
2734       (message-generate-headers message-required-news-headers)
2735       ;; Let the user do all of the above.
2736       (run-hooks 'message-header-hook))
2737     (message-cleanup-headers)
2738     (if (not (message-check-news-syntax))
2739         nil
2740       (unwind-protect
2741           (save-excursion
2742             (set-buffer tembuf)
2743             (buffer-disable-undo)
2744             (erase-buffer)
2745             (insert-buffer message-encoding-buffer)
2746             ;; Remove some headers.
2747             (save-restriction
2748               (message-narrow-to-headers)
2749 ;; We Semi-gnus people have no use for it.
2750 ;;            ;; We (re)generate the Lines header.
2751 ;;            (when (memq 'Lines message-required-mail-headers)
2752 ;;              (message-generate-headers '(Lines)))
2753               ;; Remove some headers.
2754               (message-remove-header message-ignored-news-headers t))
2755             (goto-char (point-max))
2756             ;; require one newline at the end.
2757             (or (= (preceding-char) ?\n)
2758                 (insert ?\n))
2759             (setq result (message-maybe-split-and-send-news method)))
2760         (kill-buffer tembuf))
2761       (set-buffer message-edit-buffer)
2762       (if result
2763           (progn
2764             (message "Couldn't send message via news: %s"
2765                      (nnheader-get-report (car method)))
2766             nil)
2767         (push 'news message-sent-message-via)))))
2768
2769 ;; 1997-09-29 by MORIOKA Tomohiko
2770 (defun message-send-news-with-gnus (method)
2771   (let ((case-fold-search t))
2772     ;; Remove the delimiter.
2773     (goto-char (point-min))
2774     (re-search-forward
2775      (concat "^" (regexp-quote mail-header-separator) "\n"))
2776     (replace-match "\n")
2777     (backward-char 1)
2778     (run-hooks 'message-send-news-hook)
2779     (gnus-open-server method)
2780     (gnus-request-post method)
2781     ))
2782
2783 ;;;
2784 ;;; Header generation & syntax checking.
2785 ;;;
2786
2787 (defun message-check-element (type)
2788   "Returns non-nil if this type is not to be checked."
2789   (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
2790       t
2791     (let ((able (assq type message-syntax-checks)))
2792       (and (consp able)
2793            (eq (cdr able) 'disabled)))))
2794
2795 (defun message-check-news-syntax ()
2796   "Check the syntax of the message."
2797   (save-excursion
2798     (save-restriction
2799       (widen)
2800       (and
2801        ;; We narrow to the headers and check them first.
2802        (save-excursion
2803          (save-restriction
2804            (message-narrow-to-headers)
2805            (message-check-news-header-syntax)))
2806        ;; Check the body.
2807        (save-excursion
2808          (set-buffer message-edit-buffer)
2809          (message-check-news-body-syntax))))))
2810
2811 (defun message-check-news-header-syntax ()
2812   (and
2813    ;; Check Newsgroups header.
2814    (message-check 'newsgroyps
2815      (let ((group (message-fetch-field "newsgroups")))
2816        (or
2817         (and group
2818              (not (string-match "\\`[ \t]*\\'" group)))
2819         (ignore
2820          (message
2821           "The newsgroups field is empty or missing.  Posting is denied.")))))
2822    ;; Check the Subject header.
2823    (message-check 'subject
2824      (let* ((case-fold-search t)
2825             (subject (message-fetch-field "subject")))
2826        (or
2827         (and subject
2828              (not (string-match "\\`[ \t]*\\'" subject)))
2829         (ignore
2830          (message
2831           "The subject field is empty or missing.  Posting is denied.")))))
2832    ;; Check for commands in Subject.
2833    (message-check 'subject-cmsg
2834      (if (string-match "^cmsg " (message-fetch-field "subject"))
2835          (y-or-n-p
2836           "The control code \"cmsg\" is in the subject.  Really post? ")
2837        t))
2838    ;; Check for multiple identical headers.
2839    (message-check 'multiple-headers
2840      (let (found)
2841        (while (and (not found)
2842                    (re-search-forward "^[^ \t:]+: " nil t))
2843          (save-excursion
2844            (or (re-search-forward
2845                 (concat "^"
2846                         (regexp-quote
2847                          (setq found
2848                                (buffer-substring
2849                                 (match-beginning 0) (- (match-end 0) 2))))
2850                         ":")
2851                 nil t)
2852                (setq found nil))))
2853        (if found
2854            (y-or-n-p (format "Multiple %s headers.  Really post? " found))
2855          t)))
2856    ;; Check for Version and Sendsys.
2857    (message-check 'sendsys
2858      (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
2859          (y-or-n-p
2860           (format "The article contains a %s command.  Really post? "
2861                   (buffer-substring (match-beginning 0)
2862                                     (1- (match-end 0)))))
2863        t))
2864    ;; See whether we can shorten Followup-To.
2865    (message-check 'shorten-followup-to
2866      (let ((newsgroups (message-fetch-field "newsgroups"))
2867            (followup-to (message-fetch-field "followup-to"))
2868            to)
2869        (when (and newsgroups
2870                   (string-match "," newsgroups)
2871                   (not followup-to)
2872                   (not
2873                    (zerop
2874                     (length
2875                      (setq to (completing-read
2876                                "Followups to: (default all groups) "
2877                                (mapcar (lambda (g) (list g))
2878                                        (cons "poster"
2879                                              (message-tokenize-header
2880                                               newsgroups)))))))))
2881          (goto-char (point-min))
2882          (insert "Followup-To: " to "\n"))
2883        t))
2884    ;; Check "Shoot me".
2885    (message-check 'shoot
2886      (if (re-search-forward
2887           "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
2888          (y-or-n-p "You appear to have a misconfigured system.  Really post? ")
2889        t))
2890    ;; Check for Approved.
2891    (message-check 'approved
2892      (if (re-search-forward "^Approved:" nil t)
2893          (y-or-n-p "The article contains an Approved header.  Really post? ")
2894        t))
2895    ;; Check the Message-ID header.
2896    (message-check 'message-id
2897      (let* ((case-fold-search t)
2898             (message-id (message-fetch-field "message-id" t)))
2899        (or (not message-id)
2900            ;; Is there an @ in the ID?
2901            (and (string-match "@" message-id)
2902                 ;; Is there a dot in the ID?
2903                 (string-match "@[^.]*\\." message-id)
2904                 ;; Does the ID end with a dot?
2905                 (not (string-match "\\.>" message-id)))
2906            (y-or-n-p
2907             (format "The Message-ID looks strange: \"%s\".  Really post? "
2908                     message-id)))))
2909    ;; Check the Newsgroups & Followup-To headers.
2910    (message-check 'existing-newsgroups
2911      (let* ((case-fold-search t)
2912             (newsgroups (message-fetch-field "newsgroups"))
2913             (followup-to (message-fetch-field "followup-to"))
2914             (groups (message-tokenize-header
2915                      (if followup-to
2916                          (concat newsgroups "," followup-to)
2917                        newsgroups)))
2918             (hashtb (and (boundp 'gnus-active-hashtb)
2919                          gnus-active-hashtb))
2920             errors)
2921        (if (or (not hashtb)
2922                (not (boundp 'gnus-read-active-file))
2923                (not gnus-read-active-file)
2924                (eq gnus-read-active-file 'some))
2925            t
2926          (while groups
2927            (when (and (not (boundp (intern (car groups) hashtb)))
2928                       (not (equal (car groups) "poster")))
2929              (push (car groups) errors))
2930            (pop groups))
2931          (if (not errors)
2932              t
2933            (y-or-n-p
2934             (format
2935              "Really post to %s unknown group%s: %s "
2936              (if (= (length errors) 1) "this" "these")
2937              (if (= (length errors) 1) "" "s")
2938              (mapconcat 'identity errors ", ")))))))
2939    ;; Check the Newsgroups & Followup-To headers for syntax errors.
2940    (message-check 'valid-newsgroups
2941      (let ((case-fold-search t)
2942            (headers '("Newsgroups" "Followup-To"))
2943            header error)
2944        (while (and headers (not error))
2945          (when (setq header (mail-fetch-field (car headers)))
2946            (if (or
2947                 (not
2948                  (string-match
2949                   "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
2950                   header))
2951                 (memq
2952                  nil (mapcar
2953                       (lambda (g)
2954                         (not (string-match "\\.\\'\\|\\.\\." g)))
2955                       (message-tokenize-header header ","))))
2956                (setq error t)))
2957          (unless error
2958            (pop headers)))
2959        (if (not error)
2960            t
2961          (y-or-n-p
2962           (format "The %s header looks odd: \"%s\".  Really post? "
2963                   (car headers) header)))))
2964    (message-check 'repeated-newsgroups
2965      (let ((case-fold-search t)
2966            (headers '("Newsgroups" "Followup-To"))
2967            header error groups group)
2968        (while (and headers
2969                    (not error))
2970          (when (setq header (mail-fetch-field (pop headers)))
2971            (setq groups (message-tokenize-header header ","))
2972            (while (setq group (pop groups))
2973              (when (member group groups)
2974                (setq error group
2975                      groups nil)))))
2976        (if (not error)
2977            t
2978          (y-or-n-p
2979           (format "Group %s is repeated in headers.  Really post? " error)))))
2980    ;; Check the From header.
2981    (message-check 'from
2982      (let* ((case-fold-search t)
2983             (from (message-fetch-field "from"))
2984             ad)
2985        (cond
2986         ((not from)
2987          (message "There is no From line.  Posting is denied.")
2988          nil)
2989         ((or (not (string-match
2990                    "@[^\\.]*\\."
2991                    (setq ad (nth 1 (mail-extract-address-components
2992                                     from))))) ;larsi@ifi
2993              (string-match "\\.\\." ad) ;larsi@ifi..uio
2994              (string-match "@\\." ad)   ;larsi@.ifi.uio
2995              (string-match "\\.$" ad)   ;larsi@ifi.uio.
2996              (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
2997              (string-match "(.*).*(.*)" from)) ;(lars) (lars)
2998          (message
2999           "Denied posting -- the From looks strange: \"%s\"." from)
3000          nil)
3001         (t t))))))
3002
3003 (defun message-check-news-body-syntax ()
3004   (and
3005    ;; Check for long lines.
3006    (message-check 'long-lines
3007      (goto-char (point-min))
3008      (re-search-forward
3009       (concat "^" (regexp-quote mail-header-separator) "$"))
3010      (while (and
3011              (progn
3012                (end-of-line)
3013                (< (current-column) 80))
3014              (zerop (forward-line 1))))
3015      (or (bolp)
3016          (eobp)
3017          (y-or-n-p
3018           "You have lines longer than 79 characters.  Really post? ")))
3019    ;; Check whether the article is empty.
3020    (message-check 'empty
3021      (goto-char (point-min))
3022      (re-search-forward
3023       (concat "^" (regexp-quote mail-header-separator) "$"))
3024      (forward-line 1)
3025      (let ((b (point)))
3026        (goto-char (point-max))
3027        (re-search-backward message-signature-separator nil t)
3028        (beginning-of-line)
3029        (or (re-search-backward "[^ \n\t]" b t)
3030            (y-or-n-p "Empty article.  Really post? "))))
3031    ;; Check for control characters.
3032    (message-check 'control-chars
3033      (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
3034          (y-or-n-p
3035           "The article contains control characters.  Really post? ")
3036        t))
3037    ;; Check 8bit characters.
3038    (message-check '8bit
3039      (message-check-8bit))
3040    ;; Check excessive size.
3041    (message-check 'size
3042      (if (> (buffer-size) 60000)
3043          (y-or-n-p
3044           (format "The article is %d octets long.  Really post? "
3045                   (buffer-size)))
3046        t))
3047    ;; Check whether any new text has been added.
3048    (message-check 'new-text
3049      (or
3050       (not message-checksum)
3051       (not (eq (message-checksum) message-checksum))
3052       (y-or-n-p
3053        "It looks like no new text has been added.  Really post? ")))
3054    ;; Check the length of the signature.
3055    (message-check 'signature
3056      (goto-char (point-max))
3057      (if (> (count-lines (point) (point-max)) 5)
3058          (y-or-n-p
3059           (format
3060            "Your .sig is %d lines; it should be max 4.  Really post? "
3061            (1- (count-lines (point) (point-max)))))
3062        t))))
3063
3064 (defun message-check-mail-syntax ()
3065   "Check the syntax of the message."
3066   (save-excursion
3067     (save-restriction
3068       (widen)
3069       (and
3070        ;; We narrow to the headers and check them first.
3071        (save-excursion
3072          (save-restriction
3073            (message-narrow-to-headers)
3074            (message-check-mail-header-syntax)))
3075        ;; Check the body.
3076        (save-excursion
3077          (set-buffer message-edit-buffer)
3078          (message-check-mail-body-syntax))))))
3079
3080 (defun message-check-mail-header-syntax ()
3081   t)
3082
3083 (defun message-check-mail-body-syntax ()
3084   (and
3085    ;; Check 8bit characters.
3086    (message-check '8bit
3087      (message-check-8bit)
3088      )))
3089
3090 (defun message-check-8bit ()
3091   "Check the article contains 8bit characters."
3092   (save-excursion
3093     (set-buffer message-encoding-buffer)
3094     (message-narrow-to-headers)
3095     (let* ((case-fold-search t)
3096            (field-value (message-fetch-field "content-transfer-encoding")))
3097       (if (and field-value
3098                (member (downcase field-value) message-8bit-encoding-list))
3099           t
3100         (widen)
3101         (set-buffer (get-buffer-create " message syntax"))
3102         (erase-buffer)
3103         (goto-char (point-min))
3104         (set-buffer-multibyte nil)
3105         (insert-buffer message-encoding-buffer)
3106         (goto-char (point-min))
3107         (if (re-search-forward "[^\x00-\x7f]" nil t)
3108             (y-or-n-p
3109              "The article contains 8bit characters.  Really post? ")
3110           t)))))
3111
3112 (defun message-checksum ()
3113   "Return a \"checksum\" for the current buffer."
3114   (let ((sum 0))
3115     (save-excursion
3116       (goto-char (point-min))
3117       (re-search-forward
3118        (concat "^" (regexp-quote mail-header-separator) "$"))
3119       (while (not (eobp))
3120         (when (not (looking-at "[ \t\n]"))
3121           (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
3122                             (char-after))))
3123         (forward-char 1)))
3124     sum))
3125
3126 (defun message-do-fcc ()
3127   "Process Fcc headers in the current buffer."
3128   (let ((case-fold-search t)
3129         (coding-system-for-write 'raw-text)
3130         (output-coding-system 'raw-text)
3131         list file)
3132     (save-excursion
3133       (set-buffer (get-buffer-create " *message temp*"))
3134       (erase-buffer)
3135       (insert-buffer-substring message-encoding-buffer)
3136       (save-restriction
3137         (message-narrow-to-headers)
3138         (while (setq file (message-fetch-field "fcc"))
3139           (push file list)
3140           (message-remove-header "fcc" nil t)))
3141       (goto-char (point-min))
3142       (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
3143       (replace-match "" t t)
3144       ;; Process FCC operations.
3145       (while list
3146         (setq file (pop list))
3147         (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
3148             ;; Pipe the article to the program in question.
3149             (call-process-region (point-min) (point-max) shell-file-name
3150                                  nil nil nil shell-command-switch
3151                                  (match-string 1 file))
3152           ;; Save the article.
3153           (setq file (expand-file-name file))
3154           (unless (file-exists-p (file-name-directory file))
3155             (make-directory (file-name-directory file) t))
3156           (if (and message-fcc-handler-function
3157                    (not (eq message-fcc-handler-function 'rmail-output)))
3158               (funcall message-fcc-handler-function file)
3159             (if (and (file-readable-p file) (mail-file-babyl-p file))
3160                 (rmail-output file 1 nil t)
3161               (let ((mail-use-rfc822 t))
3162                 (rmail-output file 1 t t))))))
3163       (kill-buffer (current-buffer)))))
3164
3165 (defun message-output (filename)
3166   "Append this article to Unix/babyl mail file.."
3167   (if (and (file-readable-p filename)
3168            (mail-file-babyl-p filename))
3169       (rmail-output-to-rmail-file filename t)
3170     (gnus-output-to-mail filename t)))
3171
3172 (defun message-cleanup-headers ()
3173   "Do various automatic cleanups of the headers."
3174   ;; Remove empty lines in the header.
3175   (save-restriction
3176     (message-narrow-to-headers)
3177     ;; Remove blank lines.
3178     (while (re-search-forward "^[ \t]*\n" nil t)
3179       (replace-match "" t t))
3180
3181     ;; Correct Newsgroups and Followup-To headers:  Change sequence of
3182     ;; spaces to comma and eliminate spaces around commas.  Eliminate
3183     ;; embedded line breaks.
3184     (goto-char (point-min))
3185     (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
3186       (save-restriction
3187         (narrow-to-region
3188          (point)
3189          (if (re-search-forward "^[^ \t]" nil t)
3190              (match-beginning 0)
3191            (forward-line 1)
3192            (point)))
3193         (goto-char (point-min))
3194         (while (re-search-forward "\n[ \t]+" nil t)
3195           (replace-match " " t t))      ;No line breaks (too confusing)
3196         (goto-char (point-min))
3197         (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
3198           (replace-match "," t t))
3199         (goto-char (point-min))
3200         ;; Remove trailing commas.
3201         (when (re-search-forward ",+$" nil t)
3202           (replace-match "" t t))))))
3203
3204 (defun message-make-date (&optional now)
3205   "Make a valid data header.
3206 If NOW, use that time instead."
3207   (let* ((now (or now (current-time)))
3208          (zone (nth 8 (decode-time now)))
3209          (sign "+"))
3210     (when (< zone 0)
3211       (setq sign "-")
3212       (setq zone (- zone)))
3213     (concat
3214      (format-time-string "%d" now)
3215      ;; The month name of the %b spec is locale-specific.  Pfff.
3216      (format " %s "
3217              (capitalize (car (rassoc (nth 4 (decode-time now))
3218                                       parse-time-months))))
3219      (format-time-string "%Y %H:%M:%S " now)
3220      ;; We do all of this because XEmacs doesn't have the %z spec.
3221      (format "%s%02d%02d" sign (/ zone 3600) (% zone 3600)))))
3222
3223 (defun message-make-followup-subject (subject)
3224   "Make a followup Subject."
3225   (cond
3226    ((and (eq message-use-subject-re 'guess)
3227          (string-match message-subject-encoded-re-regexp subject))
3228     subject)
3229    (message-use-subject-re
3230     (concat "Re: " (message-strip-subject-re subject)))
3231    (t subject)))
3232
3233 (defun message-make-message-id ()
3234   "Make a unique Message-ID."
3235   (concat "<" (message-unique-id)
3236           (let ((psubject (save-excursion (message-fetch-field "subject")))
3237                 (psupersedes
3238                  (save-excursion (message-fetch-field "supersedes"))))
3239             (if (or
3240                  (and message-reply-headers
3241                       (mail-header-references message-reply-headers)
3242                       (mail-header-subject message-reply-headers)
3243                       psubject
3244                       (mail-header-subject message-reply-headers)
3245                       (not (string=
3246                             (message-strip-subject-re
3247                              (mail-header-subject message-reply-headers))
3248                             (message-strip-subject-re psubject))))
3249                  (and psupersedes
3250                       (string-match "_-_@" psupersedes)))
3251                 "_-_" ""))
3252           "@" (message-make-fqdn) ">"))
3253
3254 (defvar message-unique-id-char nil)
3255
3256 ;; If you ever change this function, make sure the new version
3257 ;; cannot generate IDs that the old version could.
3258 ;; You might for example insert a "." somewhere (not next to another dot
3259 ;; or string boundary), or modify the "fsf" string.
3260 (defun message-unique-id ()
3261   ;; Don't use microseconds from (current-time), they may be unsupported.
3262   ;; Instead we use this randomly inited counter.
3263   (setq message-unique-id-char
3264         (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
3265            ;; (current-time) returns 16-bit ints,
3266            ;; and 2^16*25 just fits into 4 digits i base 36.
3267            (* 25 25)))
3268   (let ((tm (current-time)))
3269     (concat
3270      (if (memq system-type '(ms-dos emx vax-vms))
3271          (let ((user (downcase (user-login-name))))
3272            (while (string-match "[^a-z0-9_]" user)
3273              (aset user (match-beginning 0) ?_))
3274            user)
3275        (message-number-base36 (user-uid) -1))
3276      (message-number-base36 (+ (car   tm)
3277                                (lsh (% message-unique-id-char 25) 16)) 4)
3278      (message-number-base36 (+ (nth 1 tm)
3279                                (lsh (/ message-unique-id-char 25) 16)) 4)
3280      ;; Append the newsreader name, because while the generated
3281      ;; ID is unique to this newsreader, other newsreaders might
3282      ;; otherwise generate the same ID via another algorithm.
3283      ".fsf")))
3284
3285 (defun message-number-base36 (num len)
3286   (if (if (< len 0)
3287           (<= num 0)
3288         (= len 0))
3289       ""
3290     (concat (message-number-base36 (/ num 36) (1- len))
3291             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
3292                                   (% num 36))))))
3293
3294 (defun message-make-organization ()
3295   "Make an Organization header."
3296   (let* ((organization
3297           (when message-user-organization
3298                 (if (message-functionp message-user-organization)
3299                     (funcall message-user-organization)
3300                   message-user-organization))))
3301     (save-excursion
3302       (message-set-work-buffer)
3303       (cond ((stringp organization)
3304              (insert organization))
3305             ((and (eq t organization)
3306                   message-user-organization-file
3307                   (file-exists-p message-user-organization-file))
3308              (insert-file-contents message-user-organization-file)))
3309       (goto-char (point-min))
3310       (while (re-search-forward "[\t\n]+" nil t)
3311         (replace-match "" t t))
3312       (unless (zerop (buffer-size))
3313         (buffer-string)))))
3314
3315 (defun message-make-lines ()
3316   "Count the number of lines and return numeric string."
3317   (save-excursion
3318     (save-restriction
3319       (widen)
3320       (goto-char (point-min))
3321       (re-search-forward
3322        (concat "^" (regexp-quote mail-header-separator) "$"))
3323       (forward-line 1)
3324       (int-to-string (count-lines (point) (point-max))))))
3325
3326 (defun message-make-in-reply-to ()
3327   "Return the In-Reply-To header for this message."
3328   (when message-reply-headers
3329     (let ((mid (mail-header-message-id message-reply-headers))
3330           (from (mail-header-from message-reply-headers))
3331           (date (mail-header-date message-reply-headers)))
3332       (when mid
3333         (concat mid
3334                 (when from
3335                   (let ((pair (std11-extract-address-components from)))
3336                     (concat "\n ("
3337                             (or (car pair) (cadr pair))
3338                             "'s message of \""
3339                             (if (or (not date) (string= date ""))
3340                                 "(unknown date)" date)
3341                             "\")"))))))))
3342
3343 (defun message-make-distribution ()
3344   "Make a Distribution header."
3345   (let ((orig-distribution (message-fetch-reply-field "distribution")))
3346     (cond ((message-functionp message-distribution-function)
3347            (funcall message-distribution-function))
3348           (t orig-distribution))))
3349
3350 (defun message-make-expires ()
3351   "Return an Expires header based on `message-expires'."
3352   (let ((current (current-time))
3353         (future (* 1.0 message-expires 60 60 24)))
3354     ;; Add the future to current.
3355     (setcar current (+ (car current) (round (/ future (expt 2 16)))))
3356     (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
3357     (message-make-date current)))
3358
3359 (defun message-make-path ()
3360   "Return uucp path."
3361   (let ((login-name (user-login-name)))
3362     (cond ((null message-user-path)
3363            (concat (system-name) "!" login-name))
3364           ((stringp message-user-path)
3365            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
3366            (concat message-user-path "!" login-name))
3367           (t login-name))))
3368
3369 (defun message-make-from ()
3370   "Make a From header."
3371   (let* ((style message-from-style)
3372          (login (message-make-address))
3373          (fullname
3374           (or (and (boundp 'user-full-name)
3375                    user-full-name)
3376               (user-full-name))))
3377     (when (string= fullname "&")
3378       (setq fullname (user-login-name)))
3379     (save-excursion
3380       (message-set-work-buffer)
3381       (cond
3382        ((or (null style)
3383             (equal fullname ""))
3384         (insert login))
3385        ((or (eq style 'angles)
3386             (and (not (eq style 'parens))
3387                  ;; Use angles if no quoting is needed, or if parens would
3388                  ;; need quoting too.
3389                  (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
3390                      (let ((tmp (concat fullname nil)))
3391                        (while (string-match "([^()]*)" tmp)
3392                          (aset tmp (match-beginning 0) ?-)
3393                          (aset tmp (1- (match-end 0)) ?-))
3394                        (string-match "[\\()]" tmp)))))
3395         (insert fullname)
3396         (goto-char (point-min))
3397         ;; Look for a character that cannot appear unquoted
3398         ;; according to RFC 822.
3399         (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
3400           ;; Quote fullname, escaping specials.
3401           (goto-char (point-min))
3402           (insert "\"")
3403           (while (re-search-forward "[\"\\]" nil 1)
3404             (replace-match "\\\\\\&" t))
3405           (insert "\""))
3406         (insert " <" login ">"))
3407        (t                               ; 'parens or default
3408         (insert login " (")
3409         (let ((fullname-start (point)))
3410           (insert fullname)
3411           (goto-char fullname-start)
3412           ;; RFC 822 says \ and nonmatching parentheses
3413           ;; must be escaped in comments.
3414           ;; Escape every instance of ()\ ...
3415           (while (re-search-forward "[()\\]" nil 1)
3416             (replace-match "\\\\\\&" t))
3417           ;; ... then undo escaping of matching parentheses,
3418           ;; including matching nested parentheses.
3419           (goto-char fullname-start)
3420           (while (re-search-forward
3421                   "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
3422                   nil 1)
3423             (replace-match "\\1(\\3)" t)
3424             (goto-char fullname-start)))
3425         (insert ")")))
3426       (buffer-string))))
3427
3428 (defun message-make-sender ()
3429   "Return the \"real\" user address.
3430 This function tries to ignore all user modifications, and
3431 give as trustworthy answer as possible."
3432   (concat (user-login-name) "@" (system-name)))
3433
3434 (defun message-make-address ()
3435   "Make the address of the user."
3436   (or (message-user-mail-address)
3437       (concat (user-login-name) "@" (message-make-domain))))
3438
3439 (defun message-user-mail-address ()
3440   "Return the pertinent part of `user-mail-address'."
3441   (when user-mail-address
3442     (if (string-match " " user-mail-address)
3443         (nth 1 (std11-extract-address-components user-mail-address))
3444       user-mail-address)))
3445
3446 (defun message-make-fqdn ()
3447   "Return user's fully qualified domain name."
3448   (let ((system-name (system-name))
3449         (user-mail (message-user-mail-address)))
3450     (cond
3451      ((string-match "[^.]\\.[^.]" system-name)
3452       ;; `system-name' returned the right result.
3453       system-name)
3454      ;; Try `mail-host-address'.
3455      ((and (boundp 'mail-host-address)
3456            (stringp mail-host-address)
3457            (string-match "\\." mail-host-address))
3458       mail-host-address)
3459      ;; We try `user-mail-address' as a backup.
3460      ((and user-mail
3461            (string-match "\\." user-mail)
3462            (string-match "@\\(.*\\)\\'" user-mail))
3463       (match-string 1 user-mail))
3464      ;; Default to this bogus thing.
3465      (t
3466       (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me")))))
3467
3468 (defun message-make-host-name ()
3469   "Return the name of the host."
3470   (let ((fqdn (message-make-fqdn)))
3471     (string-match "^[^.]+\\." fqdn)
3472     (substring fqdn 0 (1- (match-end 0)))))
3473
3474 (defun message-make-domain ()
3475   "Return the domain name."
3476   (or mail-host-address
3477       (message-make-fqdn)))
3478
3479 ;; Dummy to avoid byte-compile warning.
3480 (defvar mule-version)
3481 (defvar emacs-beta-version)
3482 (defvar xemacs-codename)
3483 (defvar gnus-inviolable-extended-version)
3484
3485 (defun message-make-user-agent ()
3486   "Return user-agent info if the value `message-user-agent' is non-nil. If the
3487 \"User-Agent\" field has already exist, it's value will be added in the return
3488 string."
3489   (when message-user-agent
3490     (save-excursion
3491       (goto-char (point-min))
3492       (let ((case-fold-search t)
3493             user-agent start p end)
3494         (if (re-search-forward "^User-Agent:[\t ]*" nil t)
3495             (progn
3496               (setq start (match-beginning 0)
3497                     p (match-end 0)
3498                     end (std11-field-end)
3499                     user-agent (buffer-substring-no-properties p end))
3500               (delete-region start (1+ end))
3501               (concat message-user-agent " " user-agent))
3502           message-user-agent)))))
3503
3504 (defun message-generate-headers (headers)
3505   "Prepare article HEADERS.
3506 Headers already prepared in the buffer are not modified."
3507   (save-restriction
3508     (message-narrow-to-headers)
3509     (let* ((Date (message-make-date))
3510            (Message-ID (message-make-message-id))
3511            (Organization (message-make-organization))
3512            (From (message-make-from))
3513            (Path (message-make-path))
3514            (Subject nil)
3515            (Newsgroups nil)
3516            (In-Reply-To (message-make-in-reply-to))
3517            (To nil)
3518            (Distribution (message-make-distribution))
3519            (Lines (message-make-lines))
3520            (User-Agent (message-make-user-agent))
3521            (Expires (message-make-expires))
3522            (case-fold-search t)
3523            header value elem)
3524       ;; First we remove any old generated headers.
3525       (let ((headers message-deletable-headers))
3526         (unless (buffer-modified-p)
3527           (setq headers (delq 'Message-ID (copy-sequence headers))))
3528         (while headers
3529           (goto-char (point-min))
3530           (and (re-search-forward
3531                 (concat "^" (symbol-name (car headers)) ": *") nil t)
3532                (get-text-property (1+ (match-beginning 0)) 'message-deletable)
3533                (message-delete-line))
3534           (pop headers)))
3535       ;; Go through all the required headers and see if they are in the
3536       ;; articles already.  If they are not, or are empty, they are
3537       ;; inserted automatically - except for Subject, Newsgroups and
3538       ;; Distribution.
3539       (while headers
3540         (goto-char (point-min))
3541         (setq elem (pop headers))
3542         (if (consp elem)
3543             (if (eq (car elem) 'optional)
3544                 (setq header (cdr elem))
3545               (setq header (car elem)))
3546           (setq header elem))
3547         (when (or (not (re-search-forward
3548                         (concat "^"
3549                                 (regexp-quote
3550                                  (downcase
3551                                   (if (stringp header)
3552                                       header
3553                                     (symbol-name header))))
3554                                 ":")
3555                         nil t))
3556                   (progn
3557                     ;; The header was found.  We insert a space after the
3558                     ;; colon, if there is none.
3559                     (if (/= (char-after) ? ) (insert " ") (forward-char 1))
3560                     ;; Find out whether the header is empty...
3561                     (looking-at "[ \t]*\n[^ \t]")))
3562           ;; So we find out what value we should insert.
3563           (setq value
3564                 (cond
3565                  ((and (consp elem) (eq (car elem) 'optional))
3566                   ;; This is an optional header.  If the cdr of this
3567                   ;; is something that is nil, then we do not insert
3568                   ;; this header.
3569                   (setq header (cdr elem))
3570                   (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
3571                       (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
3572                  ((consp elem)
3573                   ;; The element is a cons.  Either the cdr is a
3574                   ;; string to be inserted verbatim, or it is a
3575                   ;; function, and we insert the value returned from
3576                   ;; this function.
3577                   (or (and (stringp (cdr elem)) (cdr elem))
3578                       (and (fboundp (cdr elem)) (funcall (cdr elem)))))
3579                  ((and (boundp header) (symbol-value header))
3580                   ;; The element is a symbol.  We insert the value
3581                   ;; of this symbol, if any.
3582                   (symbol-value header))
3583                  (t
3584                   ;; We couldn't generate a value for this header,
3585                   ;; so we just ask the user.
3586                   (read-from-minibuffer
3587                    (format "Empty header for %s; enter value: " header)))))
3588           ;; Finally insert the header.
3589           (when (and value
3590                      (not (equal value "")))
3591             (save-excursion
3592               (if (bolp)
3593                   (progn
3594                     ;; This header didn't exist, so we insert it.
3595                     (goto-char (point-max))
3596                     (insert (if (stringp header) header (symbol-name header))
3597                             ": " value "\n")
3598                     (forward-line -1))
3599                 ;; The value of this header was empty, so we clear
3600                 ;; totally and insert the new value.
3601                 (delete-region (point) (gnus-point-at-eol))
3602                 (insert value))
3603               ;; Add the deletable property to the headers that require it.
3604               (and (memq header message-deletable-headers)
3605                    (progn (beginning-of-line) (looking-at "[^:]+: "))
3606                    (add-text-properties
3607                     (point) (match-end 0)
3608                     '(message-deletable t face italic) (current-buffer)))))))
3609       ;; Insert new Sender if the From is strange.
3610       (let ((from (message-fetch-field "from"))
3611             (sender (message-fetch-field "sender"))
3612             (secure-sender (message-make-sender)))
3613         (when (and from
3614                    (not (message-check-element 'sender))
3615                    (not (string=
3616                          (downcase
3617                           (cadr (std11-extract-address-components from)))
3618                          (downcase secure-sender)))
3619                    (or (null sender)
3620                        (not
3621                         (string=
3622                          (downcase
3623                           (cadr (std11-extract-address-components sender)))
3624                          (downcase secure-sender)))))
3625           (goto-char (point-min))
3626           ;; Rename any old Sender headers to Original-Sender.
3627           (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
3628             (beginning-of-line)
3629             (insert "Original-")
3630             (beginning-of-line))
3631           (when (or (message-news-p)
3632                     (string-match "@.+\\.." secure-sender))
3633             (insert "Sender: " secure-sender "\n")))))))
3634
3635 (defun message-insert-courtesy-copy ()
3636   "Insert a courtesy message in mail copies of combined messages."
3637   (let (newsgroups)
3638     (save-excursion
3639       (save-restriction
3640         (message-narrow-to-headers)
3641         (when (setq newsgroups (message-fetch-field "newsgroups"))
3642           (goto-char (point-max))
3643           (insert "Posted-To: " newsgroups "\n")))
3644       (forward-line 1)
3645       (when message-courtesy-message
3646         (cond
3647          ((string-match "%s" message-courtesy-message)
3648           (insert (format message-courtesy-message newsgroups)))
3649          (t
3650           (insert message-courtesy-message)))))))
3651
3652 ;;;
3653 ;;; Setting up a message buffer
3654 ;;;
3655
3656 (defun message-fill-address (header value)
3657   (save-restriction
3658     (narrow-to-region (point) (point))
3659     (insert (capitalize (symbol-name header))
3660             ": "
3661             (if (consp value) (car value) value)
3662             "\n")
3663     (narrow-to-region (point-min) (1- (point-max)))
3664     (let (quoted last)
3665       (goto-char (point-min))
3666       (while (not (eobp))
3667         (skip-chars-forward "^,\"" (point-max))
3668         (if (or (eq (char-after) ?,)
3669                 (eobp))
3670             (when (not quoted)
3671               (if (and (> (current-column) 78)
3672                        last)
3673                   (save-excursion
3674                     (goto-char last)
3675                     (looking-at "[ \t]*")
3676                     (replace-match "\n " t t)))
3677               (setq last (1+ (point))))
3678           (setq quoted (not quoted)))
3679         (unless (eobp)
3680           (forward-char 1))))
3681     (goto-char (point-max))
3682     (widen)
3683     (forward-line 1)))
3684
3685 (defun message-fill-references (header value)
3686   (insert (capitalize (symbol-name header))
3687           ": "
3688           (std11-fill-msg-id-list-string
3689           (if (consp value) (car value) value))
3690           "\n"))
3691
3692 (defun message-fill-header (header value)
3693   (let ((begin (point))
3694         (fill-column 78)
3695         (fill-prefix " "))
3696     (insert (capitalize (symbol-name header))
3697             ": "
3698             (if (consp value) (car value) value)
3699             "\n")
3700     (save-restriction
3701       (narrow-to-region begin (point))
3702       (fill-region-as-paragraph begin (point))
3703       ;; Tapdance around looong Message-IDs.
3704       (forward-line -1)
3705       (when (looking-at "[ \t]*$")
3706         (message-delete-line))
3707       (goto-char begin)
3708       (re-search-forward ":" nil t)
3709       (when (looking-at "\n[ \t]+")
3710         (replace-match " " t t))
3711       (goto-char (point-max)))))
3712
3713 (defun message-shorten-references (header references)
3714   "Limit REFERENCES to be shorter than 988 characters."
3715   (let ((max 988)
3716         (cut 4)
3717         refs)
3718     (with-temp-buffer
3719       (insert references)
3720       (goto-char (point-min))
3721       (while (re-search-forward "<[^>]+>" nil t)
3722         (push (match-string 0) refs))
3723       (setq refs (nreverse refs))
3724       (while (> (length (mapconcat 'identity refs " ")) max)
3725         (when (< (length refs) (1+ cut))
3726           (decf cut))
3727         (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs)))))
3728     (insert (capitalize (symbol-name header)) ": "
3729             (mapconcat 'identity refs " ") "\n")))
3730
3731 (defun message-position-point ()
3732   "Move point to where the user probably wants to find it."
3733   (message-narrow-to-headers)
3734   (cond
3735    ((re-search-forward "^[^:]+:[ \t]*$" nil t)
3736     (search-backward ":" )
3737     (widen)
3738     (forward-char 1)
3739     (if (eq (char-after) ? )
3740         (forward-char 1)
3741       (insert " ")))
3742    (t
3743     (goto-char (point-max))
3744     (widen)
3745     (forward-line 1)
3746     (unless (looking-at "$")
3747       (forward-line 2)))
3748    (sit-for 0)))
3749
3750 (defun message-buffer-name (type &optional to group)
3751   "Return a new (unique) buffer name based on TYPE and TO."
3752   (cond
3753    ;; Generate a new buffer name The Message Way.
3754    ((eq message-generate-new-buffers 'unique)
3755     (generate-new-buffer-name
3756      (concat "*" type
3757              (if to
3758                  (concat " to "
3759                          (or (car (std11-extract-address-components to))
3760                              to) "")
3761                "")
3762              (if (and group (not (string= group ""))) (concat " on " group) "")
3763              "*")))
3764    ;; Check whether `message-generate-new-buffers' is a function,
3765    ;; and if so, call it.
3766    ((message-functionp message-generate-new-buffers)
3767     (funcall message-generate-new-buffers type to group))
3768    ((eq message-generate-new-buffers 'unsent)
3769     (generate-new-buffer-name
3770      (concat "*unsent " type
3771              (if to
3772                  (concat " to "
3773                          (or (car (mail-extract-address-components to))
3774                              to) "")
3775                "")
3776              (if (and group (not (string= group ""))) (concat " on " group) "")
3777              "*")))
3778    ;; Use standard name.
3779    (t
3780     (format "*%s message*" type))))
3781
3782 (defmacro message-pop-to-buffer-1 (buffer)
3783   `(if pop-up-frames
3784        (let (special-display-buffer-names
3785              special-display-regexps
3786              same-window-buffer-names
3787              same-window-regexps)
3788          (pop-to-buffer ,buffer))
3789      (pop-to-buffer ,buffer)))
3790
3791 (defun message-pop-to-buffer (name)
3792   "Pop to buffer NAME, and warn if it already exists and is modified."
3793   (let ((buffer (get-buffer name))
3794         (pop-up-frames (and (or (static-if (featurep 'xemacs)
3795                                     (device-on-window-system-p)
3796                                   window-system)
3797                                 (>= emacs-major-version 20))
3798                             message-use-multi-frames)))
3799     (if (and buffer
3800              (buffer-name buffer))
3801         (progn
3802           (message-pop-to-buffer-1 buffer)
3803           (when (and (buffer-modified-p)
3804                      (not (y-or-n-p
3805                            "Message already being composed; erase? ")))
3806             (error "Message being composed")))
3807       (message-pop-to-buffer-1 name))
3808     (erase-buffer)
3809     (message-mode)
3810     (when pop-up-frames
3811       (set (make-local-variable 'message-original-frame) (selected-frame)))))
3812
3813 (defun message-do-send-housekeeping ()
3814   "Kill old message buffers."
3815   ;; We might have sent this buffer already.  Delete it from the
3816   ;; list of buffers.
3817   (setq message-buffer-list (delq (current-buffer) message-buffer-list))
3818   (while (and message-max-buffers
3819               message-buffer-list
3820               (>= (length message-buffer-list) message-max-buffers))
3821     ;; Kill the oldest buffer -- unless it has been changed.
3822     (let ((buffer (pop message-buffer-list)))
3823       (when (and (buffer-name buffer)
3824                  (not (buffer-modified-p buffer)))
3825         (kill-buffer buffer))))
3826   ;; Rename the buffer.
3827   (if message-send-rename-function
3828       (funcall message-send-rename-function)
3829     (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name))
3830       (rename-buffer
3831        (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
3832   ;; Push the current buffer onto the list.
3833   (when message-max-buffers
3834     (setq message-buffer-list
3835           (nconc message-buffer-list (list (current-buffer))))))
3836
3837 (defvar mc-modes-alist)
3838 (defun message-setup (headers &optional replybuffer actions)
3839   (when (and (boundp 'mc-modes-alist)
3840              (not (assq 'message-mode mc-modes-alist)))
3841     (push '(message-mode (encrypt . mc-encrypt-message)
3842                          (sign . mc-sign-message))
3843           mc-modes-alist))
3844   (when actions
3845     (setq message-send-actions actions))
3846   (setq message-reply-buffer
3847         (or (message-get-parameter 'reply-buffer)
3848             replybuffer))
3849   (goto-char (point-min))
3850   ;; Insert all the headers.
3851   (mail-header-format
3852    (let ((h headers)
3853          (alist message-header-format-alist))
3854      (while h
3855        (unless (assq (caar h) message-header-format-alist)
3856          (push (list (caar h)) alist))
3857        (pop h))
3858      alist)
3859    headers)
3860   (delete-region (point) (progn (forward-line -1) (point)))
3861   (when message-default-headers
3862     (insert message-default-headers)
3863     (or (bolp) (insert ?\n)))
3864   (put-text-property
3865    (point)
3866    (progn
3867      (insert mail-header-separator "\n")
3868      (1- (point)))
3869    'read-only nil)
3870   (forward-line -1)
3871   (when (message-news-p)
3872     (when message-default-news-headers
3873       (insert message-default-news-headers)
3874       (or (bolp) (insert ?\n)))
3875     (when message-generate-headers-first
3876       (message-generate-headers
3877        (delq 'Lines
3878              (delq 'Subject
3879                    (copy-sequence message-required-news-headers))))))
3880   (when (message-mail-p)
3881     (when message-default-mail-headers
3882       (insert message-default-mail-headers)
3883       (or (bolp) (insert ?\n)))
3884     (when message-generate-headers-first
3885       (message-generate-headers
3886        (delq 'Lines
3887              (delq 'Subject
3888                    (copy-sequence message-required-mail-headers))))))
3889   (run-hooks 'message-signature-setup-hook)
3890   (message-insert-signature)
3891   (save-restriction
3892     (message-narrow-to-headers)
3893     (run-hooks 'message-header-setup-hook))
3894   (set-buffer-modified-p nil)
3895   (setq buffer-undo-list nil)
3896   (run-hooks 'message-setup-hook)
3897   (message-position-point)
3898   (undo-boundary))
3899
3900 (defun message-set-auto-save-file-name ()
3901   "Associate the message buffer with a file in the drafts directory."
3902   (when message-auto-save-directory
3903     (if (gnus-alive-p)
3904         (setq message-draft-article
3905               (nndraft-request-associate-buffer "drafts"))
3906       (setq buffer-file-name (expand-file-name "*message*"
3907                                                message-auto-save-directory))
3908       (setq buffer-auto-save-file-name (make-auto-save-file-name)))
3909     (clear-visited-file-modtime)
3910     (static-if (boundp 'MULE)
3911         (set-file-coding-system message-draft-coding-system)
3912       (setq buffer-file-coding-system message-draft-coding-system))))
3913
3914 (defun message-disassociate-draft ()
3915   "Disassociate the message buffer from the drafts directory."
3916   (when message-draft-article
3917     (nndraft-request-expire-articles
3918      (list message-draft-article) "drafts" nil t)))
3919
3920 (defun message-insert-headers ()
3921   "Generate the headers for the article."
3922   (interactive)
3923   (save-excursion
3924     (save-restriction
3925       (message-narrow-to-headers)
3926       (when (message-news-p)
3927         (message-generate-headers
3928          (delq 'Lines
3929                (delq 'Subject
3930                      (copy-sequence message-required-news-headers)))))
3931       (when (message-mail-p)
3932         (message-generate-headers
3933          (delq 'Lines
3934                (delq 'Subject
3935                      (copy-sequence message-required-mail-headers))))))))
3936
3937 \f
3938
3939 ;;;
3940 ;;; Commands for interfacing with message
3941 ;;;
3942
3943 ;;;###autoload
3944 (defun message-mail (&optional to subject
3945                                other-headers continue switch-function
3946                                yank-action send-actions)
3947   "Start editing a mail message to be sent.
3948 OTHER-HEADERS is an alist of header/value pairs."
3949   (interactive)
3950   (let ((message-this-is-mail t))
3951     (message-pop-to-buffer (message-buffer-name "mail" to))
3952     (message-setup
3953      (nconc
3954       `((To . ,(or to "")) (Subject . ,(or subject "")))
3955       (when other-headers other-headers)))))
3956
3957 ;;;###autoload
3958 (defun message-news (&optional newsgroups subject)
3959   "Start editing a news article to be sent."
3960   (interactive)
3961   (let ((message-this-is-news t))
3962     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
3963     (message-setup `((Newsgroups . ,(or newsgroups ""))
3964                      (Subject . ,(or subject ""))))))
3965
3966 ;;;###autoload
3967 (defun message-reply (&optional to-address wide)
3968   "Start editing a reply to the article in the current buffer."
3969   (interactive)
3970   (let ((cur (current-buffer))
3971         from subject date to cc
3972         references message-id follow-to
3973         (inhibit-point-motion-hooks t)
3974         (message-this-is-mail t)
3975         mct never-mct mft mrt gnus-warning in-reply-to)
3976     (save-restriction
3977       (message-narrow-to-head)
3978       ;; Allow customizations to have their say.
3979       (if (not wide)
3980           ;; This is a regular reply.
3981           (if (message-functionp message-reply-to-function)
3982               (setq follow-to (funcall message-reply-to-function)))
3983         ;; This is a followup.
3984         (if (message-functionp message-wide-reply-to-function)
3985             (save-excursion
3986               (setq follow-to
3987                     (funcall message-wide-reply-to-function)))))
3988       ;; Find all relevant headers we need.
3989       (setq from (message-fetch-field "from")
3990             date (message-fetch-field "date" t)
3991             subject (or (message-fetch-field "subject") "none")
3992             references (message-fetch-field "references")
3993             message-id (message-fetch-field "message-id" t)
3994             to (message-fetch-field "to")
3995             cc (message-fetch-field "cc")
3996             mct (when (and wide message-use-mail-copies-to)
3997                   (message-fetch-field "mail-copies-to"))
3998             mft (when (and wide message-use-mail-followup-to)
3999                   (message-fetch-field "mail-followup-to"))
4000             mrt (when message-use-mail-reply-to
4001                   (or (message-fetch-field "mail-reply-to")
4002                       (message-fetch-field "reply-to")))
4003             gnus-warning (message-fetch-field "gnus-warning"))
4004       (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
4005         (setq message-id (match-string 0 gnus-warning)))
4006       ;; Get the references from "In-Reply-To" field if there were
4007       ;; no references and "In-Reply-To" field looks promising.
4008       (unless references
4009         (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
4010                    (string-match "<[^>]+>" in-reply-to))
4011           (setq references (match-string 0 in-reply-to))))
4012       ;; Remove any (buggy) Re:'s that are present and make a
4013       ;; proper one.
4014       (setq subject (message-make-followup-subject subject))
4015       (widen))
4016
4017     ;; Handle special values of Mail-Copies-To.
4018     (when mct
4019       (cond
4020        ((and (or (equal (downcase mct) "never")
4021                  (equal (downcase mct) "nobody"))
4022              (or (not (eq message-use-mail-copies-to 'ask))
4023                  (message-y-or-n-p
4024                   (concat "Obey Mail-Copies-To: never? ") t "\
4025 You should normally obey the Mail-Copies-To: header.
4026
4027         `Mail-Copies-To: never'
4028 directs you not to send your response to the author.")))
4029         (setq never-mct t)
4030         (setq mct nil))
4031        ((and (or (equal (downcase mct) "always")
4032                  (equal (downcase mct) "poster"))
4033              (or (not (eq message-use-mail-copies-to 'ask))
4034                  (message-y-or-n-p
4035                   (concat "Obey Mail-Copies-To: always? ") t "\
4036 You should normally obey the Mail-Copies-To: header.
4037
4038         `Mail-Copies-To: always'
4039 sends a copy of your response to the author.")))
4040         (setq mct (or mrt from)))
4041        ((and (eq message-use-mail-copies-to 'ask)
4042              (not
4043               (message-y-or-n-p
4044                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
4045 You should normally obey the Mail-Copies-To: header.
4046
4047         `Mail-Copies-To: " mct "'
4048 sends a copy of your response to " (if (string-match "," mct)
4049                                        "the specified addresses"
4050                                      "that address") ".")))
4051         (setq mct nil))
4052        ))
4053
4054     (unless follow-to
4055       (cond
4056        (to-address (setq follow-to (list (cons 'To to-address))))
4057        ((not wide) (setq follow-to (list (cons 'To (or mrt from)))))
4058        ;; Handle Mail-Followup-To.
4059        ((and mft
4060              (or (not (eq message-use-mail-followup-to 'ask))
4061                  (message-y-or-n-p
4062                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
4063 You should normally obey the Mail-Followup-To: header.
4064
4065         `Mail-Followup-To: " mft "'
4066 directs your response to " (if (string-match "," mft)
4067                                "the specified addresses"
4068                              "that address only") ".
4069
4070 A typical situation where Mail-Followup-To is used is when the author thinks
4071 that further discussion should take place only in "
4072                   (if (string-match "," mft)
4073                       "the specified mailing lists"
4074                     "that mailing list") ".")))
4075         (setq follow-to (list (cons 'To mft)))
4076         (when mct
4077           (push (cons 'Cc mct) follow-to)))
4078        (t
4079         (let (ccalist)
4080           (save-excursion
4081             (message-set-work-buffer)
4082             (unless never-mct
4083               (insert (or mrt from "")))
4084             (insert (if to (concat (if (bolp) "" ", ") to "") ""))
4085             (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
4086             (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
4087             (goto-char (point-min))
4088             (while (re-search-forward "[ \t]+" nil t)
4089               (replace-match " " t t))
4090             ;; Remove addresses that match `rmail-dont-reply-to-names'.
4091             (insert (prog1 (rmail-dont-reply-to (buffer-string))
4092                       (erase-buffer)))
4093             (goto-char (point-min))
4094             ;; Perhaps Mail-Copies-To: never removed the only address?
4095             (when (eobp)
4096               (insert (or mrt from "")))
4097             (setq ccalist
4098                   (mapcar
4099                    (lambda (addr)
4100                      (cons (mail-strip-quoted-names addr) addr))
4101                    (message-tokenize-header (buffer-string))))
4102             (let ((s ccalist))
4103               (while s
4104                 (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
4105           (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
4106           (when ccalist
4107             (let ((ccs (cons 'Cc (mapconcat
4108                                   (lambda (addr) (cdr addr)) ccalist ", "))))
4109               (when (string-match "^ +" (cdr ccs))
4110                 (setcdr ccs (substring (cdr ccs) (match-end 0))))
4111               (push ccs follow-to)))))))
4112
4113     (message-pop-to-buffer (message-buffer-name
4114                             (if wide "wide reply" "reply") from
4115                             (if wide to-address nil)))
4116
4117     (setq message-reply-headers
4118           (make-full-mail-header-from-decoded-header
4119            0 subject from date message-id references 0 0 ""))
4120
4121     (message-setup
4122      `((Subject . ,subject)
4123        ,@follow-to
4124        ,@(if (or references message-id)
4125              `((References . ,(concat (or references "") (and references " ")
4126                                       (or message-id ""))))))
4127      cur)))
4128
4129 ;;;###autoload
4130 (defun message-wide-reply (&optional to-address)
4131   "Make a \"wide\" reply to the message in the current buffer."
4132   (interactive)
4133   (message-reply to-address t))
4134
4135 ;;;###autoload
4136 (defun message-followup (&optional to-newsgroups)
4137   "Follow up to the message in the current buffer.
4138 If TO-NEWSGROUPS, use that as the new Newsgroups line."
4139   (interactive)
4140   (let ((cur (current-buffer))
4141         from subject date mct
4142         references message-id follow-to
4143         (inhibit-point-motion-hooks t)
4144         (message-this-is-news t)
4145         followup-to distribution newsgroups gnus-warning posted-to mft mrt)
4146     (save-restriction
4147       (message-narrow-to-head)
4148       (when (message-functionp message-followup-to-function)
4149         (setq follow-to
4150               (funcall message-followup-to-function)))
4151       (setq from (message-fetch-field "from")
4152             date (message-fetch-field "date" t)
4153             subject (or (message-fetch-field "subject") "none")
4154             references (message-fetch-field "references")
4155             message-id (message-fetch-field "message-id" t)
4156             followup-to (when message-use-followup-to
4157                           (message-fetch-field "followup-to"))
4158             distribution (message-fetch-field "distribution")
4159             newsgroups (message-fetch-field "newsgroups")
4160             posted-to (message-fetch-field "posted-to")
4161             mct (when message-use-mail-copies-to
4162                   (message-fetch-field "mail-copies-to"))
4163             mft (when message-use-mail-followup-to
4164                   (message-fetch-field "mail-followup-to"))
4165             mrt (when message-use-mail-reply-to
4166                   (or (message-fetch-field "mail-reply-to")
4167                       (message-fetch-field "reply-to")))
4168             gnus-warning (message-fetch-field "gnus-warning"))
4169       (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
4170         (setq message-id (match-string 0 gnus-warning)))
4171       ;; Remove bogus distribution.
4172       (when (and (stringp distribution)
4173                  (let ((case-fold-search t))
4174                    (string-match "world" distribution)))
4175         (setq distribution nil))
4176       ;; Remove any (buggy) Re:'s that are present and make a
4177       ;; proper one.
4178       (setq subject (message-make-followup-subject subject))
4179       (widen))
4180
4181     ;; Handle special values of Mail-Copies-To.
4182     (when mct
4183       (cond
4184        ((and (or (equal (downcase mct) "never")
4185                  (equal (downcase mct) "nobody"))
4186              (or (not (eq message-use-mail-copies-to 'ask))
4187                  (message-y-or-n-p
4188                   (concat "Obey Mail-Copies-To: never? ") t "\
4189 You should normally obey the Mail-Copies-To: header.
4190
4191         `Mail-Copies-To: never'
4192 directs you not to send your response to the author.")))
4193         (setq mct nil))
4194        ((and (or (equal (downcase mct) "always")
4195                  (equal (downcase mct) "poster"))
4196              (or (not (eq message-use-mail-copies-to 'ask))
4197                  (message-y-or-n-p
4198                   (concat "Obey Mail-Copies-To: always? ") t "\
4199 You should normally obey the Mail-Copies-To: header.
4200
4201         `Mail-Copies-To: always'
4202 sends a copy of your response to the author.")))
4203         (setq mct (or mrt from)))
4204        ((and (eq message-use-mail-copies-to 'ask)
4205              (not
4206               (message-y-or-n-p
4207                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
4208 You should normally obey the Mail-Copies-To: header.
4209
4210         `Mail-Copies-To: " mct "'
4211 sends a copy of your response to " (if (string-match "," mct)
4212                                        "the specified addresses"
4213                                      "that address") ".")))
4214         (setq mct nil))
4215        ))
4216
4217     (unless follow-to
4218       (cond
4219        (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups))))
4220        ;; Handle Followup-To.
4221        (followup-to
4222         (cond
4223          ((equal (downcase followup-to) "poster")
4224           (if (or (eq message-use-followup-to 'use)
4225                   (message-y-or-n-p "Obey Followup-To: poster? " t "\
4226 You should normally obey the Followup-To: header.
4227
4228         `Followup-To: poster'
4229 sends your response via e-mail instead of news.
4230
4231 A typical situation where `Followup-To: poster' is used is when the author
4232 does not read the newsgroup, so he wouldn't see any replies sent to it."))
4233               (setq message-this-is-news nil
4234                     distribution nil
4235                     follow-to (list (cons 'To (or mrt from ""))))
4236             (setq follow-to (list (cons 'Newsgroups newsgroups)))))
4237          (t
4238           (if (or (equal followup-to newsgroups)
4239                   (not (eq message-use-followup-to 'ask))
4240                   (message-y-or-n-p
4241                    (concat "Obey Followup-To: " followup-to "? ") t "\
4242 You should normally obey the Followup-To: header.
4243
4244         `Followup-To: " followup-to "'
4245 directs your response to " (if (string-match "," followup-to)
4246                                "the specified newsgroups"
4247                              "that newsgroup only") ".
4248
4249 If a message is posted to several newsgroups, Followup-To is often
4250 used to direct the following discussion to one newsgroup only,
4251 because discussions that are spread over several newsgroup tend to
4252 be fragmented and very difficult to follow.
4253
4254 Also, some source/announcement newsgroups are not indented for discussion;
4255 responses here are directed to other newsgroups."))
4256               (setq follow-to (list (cons 'Newsgroups followup-to)))
4257             (setq follow-to (list (cons 'Newsgroups newsgroups)))))))
4258        ;; Handle Mail-Followup-To, followup via e-mail.
4259        ((and mft
4260              (or (not (eq message-use-mail-followup-to 'ask))
4261                  (message-y-or-n-p
4262                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
4263 You should normally obey the Mail-Followup-To: header.
4264
4265         `Mail-Followup-To: " mft "'
4266 directs your response to " (if (string-match "," mft)
4267                                "the specified addresses"
4268                              "that address only") " instead of news.
4269
4270 A typical situation where Mail-Followup-To is used is when the author thinks
4271 that further discussion should take place only in "
4272                              (if (string-match "," mft)
4273                                  "the specified mailing lists"
4274                                "that mailing list") ".")))
4275         (setq message-this-is-news nil
4276               distribution nil
4277               follow-to (list (cons 'To mft))))
4278        (posted-to (setq follow-to (list (cons 'Newsgroups posted-to))))
4279        (t
4280         (setq follow-to (list (cons 'Newsgroups newsgroups))))))
4281
4282     (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
4283
4284     (setq message-reply-headers
4285           (make-full-mail-header-from-decoded-header
4286            0 subject from date message-id references 0 0 ""))
4287
4288     (message-setup
4289      `((Subject . ,subject)
4290        ,@follow-to
4291        ,@(and mct (list (cons 'Cc mct)))
4292        ,@(and distribution (list (cons 'Distribution distribution)))
4293        ,@(if (or references message-id)
4294              `((References . ,(concat (or references "") (and references " ")
4295                                       (or message-id ""))))))
4296      cur)))
4297
4298 ;;;###autoload
4299 (defun message-cancel-news ()
4300   "Cancel an article you posted."
4301   (interactive)
4302   (unless (message-news-p)
4303     (error "This is not a news article; canceling is impossible"))
4304   (when (yes-or-no-p "Do you really want to cancel this article? ")
4305     (let (from newsgroups message-id distribution buf sender)
4306       (save-excursion
4307         ;; Get header info. from original article.
4308         (save-restriction
4309           (message-narrow-to-head)
4310           (setq from (message-fetch-field "from")
4311                 sender (message-fetch-field "sender")
4312                 newsgroups (message-fetch-field "newsgroups")
4313                 message-id (message-fetch-field "message-id" t)
4314                 distribution (message-fetch-field "distribution")))
4315         ;; Make sure that this article was written by the user.
4316         (unless (or (and sender
4317                          (string-equal
4318                           (downcase sender)
4319                           (downcase (message-make-sender))))
4320                     (string-equal
4321                      (downcase (cadr (std11-extract-address-components
4322                                       from)))
4323                      (downcase (cadr (std11-extract-address-components
4324                                       (message-make-from))))))
4325           (error "This article is not yours"))
4326         ;; Make control message.
4327         (setq buf (set-buffer (get-buffer-create " *message cancel*")))
4328         (erase-buffer)
4329         (insert "Newsgroups: " newsgroups "\n"
4330                 "From: " (message-make-from) "\n"
4331                 "Subject: cmsg cancel " message-id "\n"
4332                 "Control: cancel " message-id "\n"
4333                 (if distribution
4334                     (concat "Distribution: " distribution "\n")
4335                   "")
4336                 mail-header-separator "\n"
4337                 message-cancel-message)
4338         (run-hooks 'message-cancel-hook)
4339         (message "Canceling your article...")
4340         (if (let ((message-syntax-checks
4341                    'dont-check-for-anything-just-trust-me)
4342                   (message-encoding-buffer (current-buffer))
4343                   (message-edit-buffer (current-buffer)))
4344               (message-send-news))
4345             (message "Canceling your article...done"))
4346         (kill-buffer buf)))))
4347
4348 (defun message-supersede-setup-for-mime-edit ()
4349   (set (make-local-variable 'message-setup-hook) nil)
4350   (mime-edit-again))
4351
4352 ;;;###autoload
4353 (defun message-supersede ()
4354   "Start composing a message to supersede the current message.
4355 This is done simply by taking the old article and adding a Supersedes
4356 header line with the old Message-ID."
4357   (interactive)
4358   (let ((cur (current-buffer))
4359         (sender (message-fetch-field "sender"))
4360         (from (message-fetch-field "from")))
4361     ;; Check whether the user owns the article that is to be superseded.
4362     (unless (or (and sender
4363                      (string-equal
4364                       (downcase sender)
4365                       (downcase (message-make-sender))))
4366                 (string-equal
4367                  (downcase (cadr (std11-extract-address-components from)))
4368                  (downcase (cadr (std11-extract-address-components
4369                                   (message-make-from))))))
4370       (error "This article is not yours"))
4371     ;; Get a normal message buffer.
4372     (message-pop-to-buffer (message-buffer-name "supersede"))
4373     (insert-buffer-substring cur)
4374     (message-narrow-to-head)
4375     ;; Remove unwanted headers.
4376     (when message-ignored-supersedes-headers
4377       (message-remove-header message-ignored-supersedes-headers t))
4378     (goto-char (point-min))
4379     (if (not (re-search-forward "^Message-ID: " nil t))
4380         (error "No Message-ID in this article")
4381       (replace-match "Supersedes: " t t))
4382     (goto-char (point-max))
4383     (insert mail-header-separator)
4384     (widen)
4385     (when message-supersede-setup-function
4386       (funcall message-supersede-setup-function))
4387     (run-hooks 'message-supersede-setup-hook)
4388     (goto-char (point-min))
4389     (search-forward (concat "\n" mail-header-separator "\n") nil t)))
4390
4391 ;;;###autoload
4392 (defun message-recover ()
4393   "Reread contents of current buffer from its last auto-save file."
4394   (interactive)
4395   (let ((file-name (make-auto-save-file-name)))
4396     (cond ((save-window-excursion
4397              (if (not (eq system-type 'vax-vms))
4398                  (with-output-to-temp-buffer "*Directory*"
4399                    (buffer-disable-undo standard-output)
4400                    (let ((default-directory "/"))
4401                      (call-process
4402                       "ls" nil standard-output nil "-l" file-name))))
4403              (yes-or-no-p (format "Recover auto save file %s? " file-name)))
4404            (let ((buffer-read-only nil))
4405              (erase-buffer)
4406              (insert-file-contents file-name nil)))
4407           (t (error "message-recover cancelled")))))
4408
4409 ;;; Washing Subject:
4410
4411 (defun message-wash-subject (subject)
4412   "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc."
4413   (with-temp-buffer
4414     (insert-string subject)
4415     (goto-char (point-min))
4416     ;; strip Re/Fwd stuff off the beginning
4417     (while (re-search-forward
4418             "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
4419       (replace-match ""))
4420
4421     ;; and gnus-style forwards [foo@bar.com] subject
4422     (goto-char (point-min))
4423     (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
4424       (replace-match ""))
4425
4426     ;; and off the end
4427     (goto-char (point-max))
4428     (while (re-search-backward "([Ff][Ww][Dd])" nil t)
4429       (replace-match ""))
4430
4431     ;; and finally, any whitespace that was left-over
4432     (goto-char (point-min))
4433     (while (re-search-forward "^[ \t]+" nil t)
4434       (replace-match ""))
4435     (goto-char (point-max))
4436     (while (re-search-backward "[ \t]+$" nil t)
4437       (replace-match ""))
4438
4439     (buffer-string)))
4440
4441 ;;; Forwarding messages.
4442
4443 (defun message-forward-subject-author-subject (subject)
4444   "Generate a subject for a forwarded message.
4445 The form is: [Source] Subject, where if the original message was mail,
4446 Source is the sender, and if the original message was news, Source is
4447 the list of newsgroups is was posted to."
4448   (concat "["
4449           (or (message-fetch-field
4450                (if (message-news-p) "newsgroups" "from"))
4451               "(nowhere)")
4452           "] " subject))
4453
4454 (defun message-forward-subject-fwd (subject)
4455   "Generate a subject for a forwarded message.
4456 The form is: Fwd: Subject, where Subject is the original subject of
4457 the message."
4458   (concat "Fwd: " subject))
4459
4460 (defun message-make-forward-subject ()
4461   "Return a Subject header suitable for the message in the current buffer."
4462   (save-excursion
4463     (save-restriction
4464       (current-buffer)
4465       (message-narrow-to-head)
4466       (let ((funcs message-make-forward-subject-function)
4467             (subject (message-fetch-field "Subject")))
4468         (setq subject
4469               (if subject
4470                   (if message-wash-forwarded-subjects
4471                       (message-wash-subject
4472                        (nnheader-decode-subject subject))
4473                     (nnheader-decode-subject subject))
4474                 "(none)"))
4475         ;; Make sure funcs is a list.
4476         (and funcs
4477              (not (listp funcs))
4478              (setq funcs (list funcs)))
4479         ;; Apply funcs in order, passing subject generated by previous
4480         ;; func to the next one.
4481         (while funcs
4482           (when (message-functionp (car funcs))
4483             (setq subject (funcall (car funcs) subject)))
4484           (setq funcs (cdr funcs)))
4485         subject))))
4486
4487 ;;;###autoload
4488 (defun message-forward (&optional news)
4489   "Forward the current message via mail.
4490 Optional NEWS will use news to forward instead of mail."
4491   (interactive "P")
4492   (let ((cur (current-buffer))
4493         (subject (message-make-forward-subject))
4494         art-beg)
4495     (if news
4496         (message-news nil subject)
4497       (message-mail nil subject))
4498     ;; Put point where we want it before inserting the forwarded
4499     ;; message.
4500     (if message-signature-before-forwarded-message
4501         (goto-char (point-max))
4502       (message-goto-body))
4503     ;; Make sure we're at the start of the line.
4504     (unless (eolp)
4505       (insert "\n"))
4506     ;; Narrow to the area we are to insert.
4507     (narrow-to-region (point) (point))
4508     ;; Insert the separators and the forwarded buffer.
4509     (insert message-forward-start-separator)
4510     (setq art-beg (point))
4511     (insert-buffer-substring cur)
4512     (goto-char (point-max))
4513     (insert message-forward-end-separator)
4514     (set-text-properties (point-min) (point-max) nil)
4515     ;; Remove all unwanted headers.
4516     (goto-char art-beg)
4517     (narrow-to-region (point) (if (search-forward "\n\n" nil t)
4518                                   (1- (point))
4519                                 (point)))
4520     (goto-char (point-min))
4521     (message-remove-header message-included-forward-headers t nil t)
4522     (widen)
4523     (message-position-point)))
4524
4525 ;;;###autoload
4526 (defun message-resend (address)
4527   "Resend the current article to ADDRESS."
4528   (interactive "sResend message to: ")
4529   (message "Resending message to %s..." address)
4530   (save-excursion
4531     (let ((cur (current-buffer))
4532           beg)
4533       ;; We first set up a normal mail buffer.
4534       (set-buffer (get-buffer-create " *message resend*"))
4535       (erase-buffer)
4536       ;; avoid to turn-on-mime-edit
4537       (let (message-setup-hook)
4538         (message-setup `((To . ,address)))
4539         )
4540       ;; Insert our usual headers.
4541       (message-generate-headers '(From Date To))
4542       (message-narrow-to-headers)
4543       ;; Rename them all to "Resent-*".
4544       (while (re-search-forward "^[A-Za-z]" nil t)
4545         (forward-char -1)
4546         (insert "Resent-"))
4547       (widen)
4548       (forward-line)
4549       (delete-region (point) (point-max))
4550       (setq beg (point))
4551       ;; Insert the message to be resent.
4552       (insert-buffer-substring cur)
4553       (goto-char (point-min))
4554       (search-forward "\n\n")
4555       (forward-char -1)
4556       (save-restriction
4557         (narrow-to-region beg (point))
4558         (message-remove-header message-ignored-resent-headers t)
4559         (goto-char (point-max)))
4560       (insert mail-header-separator)
4561       ;; Rename all old ("Also-")Resent headers.
4562       (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
4563         (beginning-of-line)
4564         (insert "Also-"))
4565       ;; Quote any "From " lines at the beginning.
4566       (goto-char beg)
4567       (when (looking-at "From ")
4568         (replace-match "X-From-Line: "))
4569       ;; Send it.
4570       (let ((message-encoding-buffer (current-buffer))
4571             (message-edit-buffer (current-buffer)))
4572         (let (message-required-mail-headers)
4573           (message-send-mail)))
4574       (kill-buffer (current-buffer)))
4575     (message "Resending message to %s...done" address)))
4576
4577 (defun message-bounce-setup-for-mime-edit ()
4578   (set (make-local-variable 'message-setup-hook) nil)
4579   (mime-edit-again))
4580
4581 ;;;###autoload
4582 (defun message-bounce ()
4583   "Re-mail the current message.
4584 This only makes sense if the current message is a bounce message than
4585 contains some mail you have written which has been bounced back to
4586 you."
4587   (interactive)
4588   (let ((cur (current-buffer))
4589         boundary)
4590     (message-pop-to-buffer (message-buffer-name "bounce"))
4591     (insert-buffer-substring cur)
4592     (undo-boundary)
4593     (message-narrow-to-head)
4594     (if (and (message-fetch-field "MIME-Version")
4595              (setq boundary (message-fetch-field "Content-Type")))
4596         (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
4597             (setq boundary (concat (match-string 1 boundary) " *\n"
4598                                    "Content-Type: message/rfc822"))
4599           (setq boundary nil)))
4600     (widen)
4601     (goto-char (point-min))
4602     (search-forward "\n\n" nil t)
4603     (or (and boundary
4604              (re-search-forward boundary nil t)
4605              (forward-line 2))
4606         (and (re-search-forward message-unsent-separator nil t)
4607              (forward-line 1))
4608         (re-search-forward "^Return-Path:.*\n" nil t))
4609     ;; We remove everything before the bounced mail.
4610     (delete-region
4611      (point-min)
4612      (if (re-search-forward "^[^ \n\t]+:" nil t)
4613          (match-beginning 0)
4614        (point)))
4615     (save-restriction
4616       (message-narrow-to-head)
4617       (message-remove-header message-ignored-bounced-headers t)
4618       (goto-char (point-max))
4619       (insert mail-header-separator))
4620     (when message-bounce-setup-function
4621       (funcall message-bounce-setup-function))
4622     (run-hooks 'message-bounce-setup-hook)
4623     (message-position-point)))
4624
4625 ;;;
4626 ;;; Interactive entry points for new message buffers.
4627 ;;;
4628
4629 ;;;###autoload
4630 (defun message-mail-other-window (&optional to subject)
4631   "Like `message-mail' command, but display mail buffer in another window."
4632   (interactive)
4633   (let ((pop-up-windows t)
4634         (special-display-buffer-names nil)
4635         (special-display-regexps nil)
4636         (same-window-buffer-names nil)
4637         (same-window-regexps nil))
4638     (message-pop-to-buffer (message-buffer-name "mail" to)))
4639   (let ((message-this-is-mail t))
4640     (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
4641
4642 ;;;###autoload
4643 (defun message-mail-other-frame (&optional to subject)
4644   "Like `message-mail' command, but display mail buffer in another frame."
4645   (interactive)
4646   (let ((pop-up-frames t)
4647         (special-display-buffer-names nil)
4648         (special-display-regexps nil)
4649         (same-window-buffer-names nil)
4650         (same-window-regexps nil))
4651     (message-pop-to-buffer (message-buffer-name "mail" to)))
4652   (let ((message-this-is-mail t))
4653     (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
4654
4655 ;;;###autoload
4656 (defun message-news-other-window (&optional newsgroups subject)
4657   "Start editing a news article to be sent."
4658   (interactive)
4659   (let ((pop-up-windows t)
4660         (special-display-buffer-names nil)
4661         (special-display-regexps nil)
4662         (same-window-buffer-names nil)
4663         (same-window-regexps nil))
4664     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
4665   (let ((message-this-is-news t))
4666     (message-setup `((Newsgroups . ,(or newsgroups ""))
4667                      (Subject . ,(or subject ""))))))
4668
4669 ;;;###autoload
4670 (defun message-news-other-frame (&optional newsgroups subject)
4671   "Start editing a news article to be sent."
4672   (interactive)
4673   (let ((pop-up-frames t)
4674         (special-display-buffer-names nil)
4675         (special-display-regexps nil)
4676         (same-window-buffer-names nil)
4677         (same-window-regexps nil))
4678     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
4679   (let ((message-this-is-news t))
4680     (message-setup `((Newsgroups . ,(or newsgroups ""))
4681                      (Subject . ,(or subject ""))))))
4682
4683 ;;; underline.el
4684
4685 ;; This code should be moved to underline.el (from which it is stolen).
4686
4687 ;;;###autoload
4688 (defun bold-region (start end)
4689   "Bold all nonblank characters in the region.
4690 Works by overstriking characters.
4691 Called from program, takes two arguments START and END
4692 which specify the range to operate on."
4693   (interactive "r")
4694   (save-excursion
4695     (let ((end1 (make-marker)))
4696       (move-marker end1 (max start end))
4697       (goto-char (min start end))
4698       (while (< (point) end1)
4699         (or (looking-at "[_\^@- ]")
4700             (insert (char-after) "\b"))
4701         (forward-char 1)))))
4702
4703 ;;;###autoload
4704 (defun unbold-region (start end)
4705   "Remove all boldness (overstruck characters) in the region.
4706 Called from program, takes two arguments START and END
4707 which specify the range to operate on."
4708   (interactive "r")
4709   (save-excursion
4710     (let ((end1 (make-marker)))
4711       (move-marker end1 (max start end))
4712       (goto-char (min start end))
4713       (while (re-search-forward "\b" end1 t)
4714         (if (eq (char-after) (char-after (- (point) 2)))
4715             (delete-char -2))))))
4716
4717 (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
4718
4719 ;; Support for toolbar
4720 (when (string-match "XEmacs\\|Lucid" emacs-version)
4721   (require 'messagexmas))
4722
4723 ;;; Group name completion.
4724
4725 (defvar message-newgroups-header-regexp
4726   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
4727   "Regexp that match headers that lists groups.")
4728
4729 (defun message-tab ()
4730   "Expand group names in Newsgroups and Followup-To headers.
4731 Do a `tab-to-tab-stop' if not in those headers."
4732   (interactive)
4733   (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
4734         (mail-abbrev-in-expansion-header-p))
4735       (message-expand-group)
4736     (tab-to-tab-stop)))
4737
4738 (defvar gnus-active-hashtb)
4739 (defun message-expand-group ()
4740   "Expand the group name under point."
4741   (let* ((b (save-excursion
4742               (save-restriction
4743                 (narrow-to-region
4744                  (save-excursion
4745                    (beginning-of-line)
4746                    (skip-chars-forward "^:")
4747                    (1+ (point)))
4748                  (point))
4749                 (skip-chars-backward "^, \t\n") (point))))
4750          (completion-ignore-case t)
4751          (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
4752                                             (point))))
4753          (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
4754          (completions (all-completions string hashtb))
4755          comp)
4756     (delete-region b (point))
4757     (cond
4758      ((= (length completions) 1)
4759       (if (string= (car completions) string)
4760           (progn
4761             (insert string)
4762             (message "Only matching group"))
4763         (insert (car completions))))
4764      ((and (setq comp (try-completion string hashtb))
4765            (not (string= comp string)))
4766       (insert comp))
4767      (t
4768       (insert string)
4769       (if (not comp)
4770           (message "No matching groups")
4771         (save-selected-window
4772           (pop-to-buffer "*Completions*")
4773           (buffer-disable-undo)
4774           (let ((buffer-read-only nil))
4775             (erase-buffer)
4776             (let ((standard-output (current-buffer)))
4777               (display-completion-list (sort completions 'string<)))
4778             (goto-char (point-min))
4779             (delete-region (point) (progn (forward-line 3) (point))))))))))
4780
4781 ;;; Help stuff.
4782
4783 (defun message-talkative-question (ask question show &rest text)
4784   "Call FUNCTION with argument QUESTION; optionally display TEXT... args.
4785 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer.
4786 The following arguments may contain lists of values."
4787   (if (and show
4788            (setq text (message-flatten-list text)))
4789       (save-window-excursion
4790         (save-excursion
4791           (with-output-to-temp-buffer " *MESSAGE information message*"
4792             (set-buffer " *MESSAGE information message*")
4793             (mapcar 'princ text)
4794             (goto-char (point-min))))
4795         (funcall ask question))
4796     (funcall ask question)))
4797
4798 (defun message-flatten-list (list)
4799   "Return a new, flat list that contains all elements of LIST.
4800
4801 \(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
4802 => (1 2 3 4 5 6 7)"
4803   (cond ((consp list)
4804          (apply 'append (mapcar 'message-flatten-list list)))
4805         (list
4806          (list list))))
4807
4808 (defun message-generate-new-buffer-clone-locals (name &optional varstr)
4809   "Create and return a buffer with a name based on NAME using generate-new-buffer.
4810 Then clone the local variables and values from the old buffer to the
4811 new one, cloning only the locals having a substring matching the
4812 regexp varstr."
4813   (let ((oldbuf (current-buffer)))
4814     (save-excursion
4815       (set-buffer (generate-new-buffer name))
4816       (message-clone-locals oldbuf)
4817       (current-buffer))))
4818
4819 (defun message-clone-locals (buffer)
4820   "Clone the local variables from BUFFER to the current buffer."
4821   (let ((locals (save-excursion
4822                   (set-buffer buffer)
4823                   (buffer-local-variables)))
4824         (regexp
4825          "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
4826     (mapcar
4827      (lambda (local)
4828        (when (and (consp local)
4829                   (car local)
4830                   (string-match regexp (symbol-name (car local))))
4831          (ignore-errors
4832            (set (make-local-variable (car local))
4833                 (cdr local)))))
4834      locals)))
4835
4836
4837 ;;; @ for MIME Edit mode
4838 ;;;
4839
4840 (defun message-maybe-encode ()
4841   (when message-mime-mode
4842     ;; Inherit the buffer local variable `mime-edit-pgp-processing'.
4843     (let ((pgp-processing (with-current-buffer message-edit-buffer
4844                             mime-edit-pgp-processing)))
4845       (setq mime-edit-pgp-processing pgp-processing))
4846     (run-hooks 'mime-edit-translate-hook)
4847     (if (catch 'mime-edit-error
4848           (save-excursion
4849             (mime-edit-pgp-enclose-buffer)
4850             (mime-edit-translate-body)
4851             ))
4852         (error "Translation error!")
4853       )
4854     (end-of-invisible)
4855     (run-hooks 'mime-edit-exit-hook)
4856     ))
4857
4858 (defun message-mime-insert-article (&optional full-headers)
4859   (interactive "P")
4860   (let ((message-cite-function 'mime-edit-inserted-message-filter)
4861         (message-reply-buffer
4862          (message-get-parameter-with-eval 'original-buffer))
4863         (start (point)))
4864     (message-yank-original nil)
4865     (save-excursion
4866       (narrow-to-region (goto-char start)
4867                         (if (search-forward "\n\n" nil t)
4868                             (1- (point))
4869                           (point-max)))
4870       (goto-char (point-min))
4871       (let ((message-included-forward-headers
4872              (if full-headers "" message-included-forward-headers)))
4873         (message-remove-header message-included-forward-headers t nil t))
4874       (widen))))
4875
4876 (set-alist 'mime-edit-message-inserter-alist
4877            'message-mode (function message-mime-insert-article))
4878
4879 ;;; Miscellaneous functions
4880
4881 ;; stolen (and renamed) from nnheader.el
4882 (defun message-replace-chars-in-string (string from to)
4883   "Replace characters in STRING from FROM to TO."
4884   (let ((string (substring string 0))   ;Copy string.
4885         (len (length string))
4886         (idx 0))
4887     ;; Replace all occurrences of FROM with TO.
4888     (while (< idx len)
4889       (when (= (aref string idx) from)
4890         (aset string idx to))
4891       (setq idx (1+ idx)))
4892     string))
4893
4894 ;;;
4895 ;;; MIME functions
4896 ;;;
4897
4898 (defvar message-inhibit-body-encoding t)
4899
4900 (defun message-encode-message-body ()
4901   (unless message-inhibit-body-encoding
4902     (let ((mail-parse-charset (or mail-parse-charset
4903                                   message-default-charset
4904                                   message-posting-charset))
4905           (case-fold-search t)
4906           lines content-type-p)
4907       (message-goto-body)
4908       (save-restriction
4909         (narrow-to-region (point) (point-max))
4910         (let ((new (mml-generate-mime)))
4911           (when new
4912             (delete-region (point-min) (point-max))
4913             (insert new)
4914             (goto-char (point-min))
4915             (if (eq (aref new 0) ?\n)
4916                 (delete-char 1)
4917               (search-forward "\n\n")
4918               (setq lines (buffer-substring (point-min) (1- (point))))
4919               (delete-region (point-min)  (point))))))
4920       (save-restriction
4921         (message-narrow-to-headers-or-head)
4922         (message-remove-header "Mime-Version")
4923         (goto-char (point-max))
4924         (insert "MIME-Version: 1.0\n")
4925         (when lines
4926           (insert lines))
4927         (setq content-type-p
4928               (re-search-backward "^Content-Type:" nil t)))
4929       (save-restriction
4930         (message-narrow-to-headers-or-head)
4931         (message-remove-first-header "Content-Type")
4932         (message-remove-first-header "Content-Transfer-Encoding"))
4933       ;; We always make sure that the message has a Content-Type header.
4934       ;; This is because some broken MTAs and MUAs get awfully confused
4935       ;; when confronted with a message with a MIME-Version header and
4936       ;; without a Content-Type header.  For instance, Solaris'
4937       ;; /usr/bin/mail.
4938       (unless content-type-p
4939         (goto-char (point-min))
4940         (re-search-forward "^MIME-Version:")
4941         (forward-line 1)
4942         (insert "Content-Type: text/plain; charset=us-ascii\n")))))
4943
4944 (defvar message-save-buffer " *encoding")
4945 (defun message-save-drafts ()
4946   (interactive)
4947   (if (not (get-buffer message-save-buffer))
4948       (get-buffer-create message-save-buffer))
4949   (let ((filename buffer-file-name)
4950         (buffer (current-buffer)))
4951     (set-buffer message-save-buffer)
4952     (erase-buffer)
4953     (insert-buffer buffer)
4954     (mime-edit-translate-buffer)
4955     (write-region (point-min) (point-max) filename)
4956     (set-buffer buffer)
4957     (set-buffer-modified-p nil)))
4958
4959 (provide 'message)
4960
4961 (run-hooks 'message-load-hook)
4962
4963 ;;; message.el ends here