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