*** empty log message ***
[gnus] / lisp / message.el
1 ;;; message.el --- composing mail and news messages
2 ;; Copyright (C) 1996 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: mail, news
6
7 ;; This file is part of GNU Emacs.
8
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;; This mode provides mail-sending facilities from within Emacs.  It
27 ;; consists mainly of large chunks of code from the sendmail.el,
28 ;; gnus-msg.el and rnewspost.el files.
29
30 ;;; Code:
31
32 (eval-when-compile 
33   (require 'cl))
34 (require 'mailheader)
35 (require 'rmail)
36 (require 'nnheader)
37 (require 'timezone)
38 (require 'easymenu)
39 (if (string-match "XEmacs\\|Lucid" emacs-version)
40     (require 'mail-abbrevs)
41   (require 'mailabbrev))
42
43 ;;;###autoload
44 (defvar message-directory "~/Mail/"
45   "*Directory from which all other mail file variables are derived.")
46
47 (defvar message-max-buffers 10
48   "*How many buffers to keep before starting to kill them off.")
49
50 (defvar message-send-rename-function nil
51   "Function called to rename the buffer after sending it.")
52
53 ;;;###autoload
54 (defvar message-fcc-handler-function 'rmail-output
55   "*A function called to save outgoing articles.
56 This function will be called with the name of the file to store the
57 article in. The default function is `rmail-output' which saves in Unix
58 mailbox format.")
59
60 ;;;###autoload
61 (defvar message-courtesy-message
62   "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
63   "*This is inserted at the start of a mailed copy of a posted message.
64 If this variable is nil, no such courtesy message will be added.")
65
66 ;;;###autoload
67 (defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
68   "*Regexp that matches headers to be removed in resent bounced mail.")
69
70 ;;;###autoload
71 (defvar message-from-style 'default
72   "*Specifies how \"From\" headers look.
73
74 If `nil', they contain just the return address like:
75         king@grassland.com
76 If `parens', they look like:
77         king@grassland.com (Elvis Parsley)
78 If `angles', they look like:
79         Elvis Parsley <king@grassland.com>
80
81 Otherwise, most addresses look like `angles', but they look like
82 `parens' if `angles' would need quoting and `parens' would not.")
83
84 ;;;###autoload
85 (defvar message-syntax-checks nil
86   "Controls what syntax checks should not be performed on outgoing posts.
87 To disable checking of long signatures, for instance, add
88  `(signature . disabled)' to this list.
89
90 Don't touch this variable unless you really know what you're doing.
91
92 Checks include subject-cmsg multiple-headers sendsys message-id from
93 long-lines control-chars size new-text redirected-followup signature
94 approved sender empty empty-headers message-id from subject.")
95
96 ;;;###autoload
97 (defvar message-required-news-headers
98   '(From Newsgroups Subject Date Message-ID 
99          (optional . Organization) Lines 
100          (optional . X-Newsreader))
101   "*Headers to be generated or prompted for when posting an article.
102 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
103 Message-ID.  Organization, Lines, In-Reply-To, Expires, and
104 X-Newsreader are optional.  If don't you want message to insert some
105 header, remove it from this list.")
106
107 ;;;###autoload
108 (defvar message-required-mail-headers 
109   '(From Subject Date (optional . In-Reply-To) Message-ID Lines
110          (optional . X-Mailer))
111   "*Headers to be generated or prompted for when mailing a message.
112 RFC822 required that From, Date, To, Subject and Message-ID be
113 included.  Organization, Lines and X-Mailer are optional.")
114
115 ;;;###autoload
116 (defvar message-deletable-headers '(Message-ID Date)
117   "*Headers to be deleted if they already exist and were generated by message previously.")
118
119 ;;;###autoload
120 (defvar message-ignored-news-headers 
121   "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:"
122   "*Regexp of headers to be removed unconditionally before posting.")
123
124 ;;;###autoload
125 (defvar message-ignored-mail-headers "^Gcc:\\|^Fcc:"
126   "*Regexp of headers to be removed unconditionally before mailing.")
127
128 ;;;###autoload
129 (defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:"
130   "*Header lines matching this regexp will be deleted before posting.
131 It's best to delete old Path and Date headers before posting to avoid
132 any confusion.")
133
134 ;;;###autoload
135 (defvar message-signature-separator "^-- *$"
136   "Regexp matching the signature separator.")
137
138 ;;;###autoload
139 (defvar message-interactive nil 
140   "Non-nil means when sending a message wait for and display errors.
141 nil means let mailer mail back a message to report errors.")
142
143 ;;;###autoload
144 (defvar message-generate-new-buffers t
145   "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.
146 If this is a function, call that function with three parameters:  The type,
147 the to address and the group name.  (Any of these may be nil.)  The function
148 should return the new buffer name.")
149
150 ;;;###autoload
151 (defvar message-kill-buffer-on-exit nil
152   "*Non-nil means that the message buffer will be killed after sending a message.")
153
154 (defvar gnus-local-organization)
155 ;;;###autoload
156 (defvar message-user-organization 
157   (or (and (boundp 'gnus-local-organization)
158            gnus-local-organization)
159       (getenv "ORGANIZATION")
160       t)
161   "*String to be used as an Organization header.
162 If t, use `message-user-organization-file'.")
163
164 ;;;###autoload
165 (defvar message-user-organization-file "/usr/lib/news/organization"
166   "*Local news organization file.")
167
168 ;;;###autoload
169 (defvar message-autosave-directory
170   (concat (file-name-as-directory message-directory) "drafts/")
171   "*Directory where message autosaves buffers.
172 If nil, message won't autosave.")
173
174 (defvar message-forward-start-separator 
175   "------- Start of forwarded message -------\n"
176   "*Delimiter inserted before forwarded messages.")
177
178 (defvar message-forward-end-separator
179   "------- End of forwarded message -------\n"
180   "*Delimiter inserted after forwarded messages.")
181
182 ;;;###autoload
183 (defvar message-signature-before-forwarded-message t
184   "*If non-nil, put the signature before any included forwarded message.")
185
186 ;;;###autoload
187 (defvar message-included-forward-headers 
188   "^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:"
189   "*Regexp matching headers to be included in forwarded messages.")
190
191 ;;;###autoload
192 (defvar message-ignored-resent-headers "^Return-receipt"
193   "*All headers that match this regexp will be deleted when resending a message.")
194
195 ;;;###autoload
196 (defvar message-ignored-cited-headers "."
197   "Delete these headers from the messages you yank.")
198
199 ;; Useful to set in site-init.el
200 ;;;###autoload
201 (defvar message-send-mail-function 'message-send-mail-with-sendmail
202   "Function to call to send the current buffer as mail.
203 The headers should be delimited by a line whose contents match the
204 variable `mail-header-separator'.
205
206 Legal values include `message-send-mail-with-mh' and
207 `message-send-mail-with-sendmail', which is the default.")
208
209 ;;;###autoload
210 (defvar message-send-news-function 'message-send-news
211   "Function to call to send the current buffer as news.
212 The headers should be delimited by a line whose contents match the
213 variable `mail-header-separator'.")
214
215 ;;;###autoload
216 (defvar message-reply-to-function nil
217   "Function that should return a list of headers.
218 This function should pick out addresses from the To, Cc, and From headers
219 and respond with new To and Cc headers.")
220
221 ;;;###autoload
222 (defvar message-wide-reply-to-function nil
223   "Function that should return a list of headers.
224 This function should pick out addresses from the To, Cc, and From headers
225 and respond with new To and Cc headers.")
226
227 ;;;###autoload
228 (defvar message-followup-to-function nil
229   "Function that should return a list of headers.
230 This function should pick out addresses from the To, Cc, and From headers
231 and respond with new To and Cc headers.")
232
233 ;;;###autoload
234 (defvar message-use-followup-to 'ask
235   "*Specifies what to do with Followup-To header.
236 If nil, ignore the header. If it is t, use its value, but query before
237 using the \"poster\" value.  If it is the symbol `ask', query the user
238 whether to ignore the \"poster\" value.  If it is the symbol `use',
239 always use the value.")
240
241 (defvar gnus-post-method)
242 (defvar gnus-select-method)
243 ;;;###autoload
244 (defvar message-post-method 
245   (cond ((and (boundp 'gnus-post-method)
246               gnus-post-method)
247          gnus-post-method)
248         ((boundp 'gnus-select-method)
249          gnus-select-method)
250         (t '(nnspool "")))
251   "Method used to post news.")
252
253 ;;;###autoload
254 (defvar message-generate-headers-first nil
255   "*If non-nil, generate all possible headers before composing.")
256
257 (defvar message-setup-hook nil
258   "Normal hook, run each time a new outgoing message is initialized.
259 The function `message-setup' runs this hook.")
260
261 (defvar message-signature-setup-hook nil
262   "Normal hook, run each time a new outgoing message is initialized.
263 It is run after the headers have been inserted and before 
264 the signature is inserted.")
265
266 (defvar message-mode-hook nil
267   "Hook run in message mode buffers.")
268
269 (defvar message-header-hook nil
270   "Hook run in a message mode buffer narrowed to the headers.")
271
272 (defvar message-header-setup-hook nil
273   "Hook called narrowed to the headers when setting up a message buffer.")
274
275 ;;;###autoload
276 (defvar message-citation-line-function 'message-insert-citation-line
277   "*Function called to insert the \"Whomever writes:\" line.")
278
279 ;;;###autoload
280 (defvar message-yank-prefix "> "
281   "*Prefix inserted on the lines of yanked messages.
282 nil means use indentation.")
283
284 (defvar message-indentation-spaces 3
285   "*Number of spaces to insert at the beginning of each cited line.
286 Used by `message-yank-original' via `message-yank-cite'.")
287
288 ;;;###autoload
289 (defvar message-cite-function 'message-cite-original
290   "*Function for citing an original message.")
291
292 ;;;###autoload
293 (defvar message-indent-citation-function 'message-indent-citation
294   "*Function for modifying a citation just inserted in the mail buffer.
295 This can also be a list of functions.  Each function can find the
296 citation between (point) and (mark t).  And each function should leave
297 point and mark around the citation text as modified.")
298
299 (defvar message-abbrevs-loaded nil)
300
301 ;;;###autoload
302 (defvar message-signature t
303   "*String to be inserted at the end of the message buffer.
304 If t, the `message-signature-file' file will be inserted instead.
305 If a function, the result from the function will be used instead.
306 If a form, the result from the form will be used instead.")
307
308 ;;;###autoload
309 (defvar message-signature-file "~/.signature"
310   "*File containing the text inserted at end of message. buffer.")
311
312 (defvar message-distribution-function nil
313   "*Function called to return a Distribution header.")
314
315 (defvar message-expires 14
316   "*Number of days before your article expires.")
317
318 (defvar message-user-path nil
319   "If nil, use the NNTP server name in the Path header.
320 If stringp, use this; if non-nil, use no host name (user name only).")
321
322 (defvar message-reply-buffer nil)
323 (defvar message-reply-headers nil)
324 (defvar message-newsreader nil)
325 (defvar message-mailer nil)
326 (defvar message-sent-message-via nil)
327 (defvar message-checksum nil)
328 (defvar message-send-actions nil
329   "A list of actions to be performed upon successful sending of a message.")
330 (defvar message-exit-actions nil
331   "A list of actions to be performed upon exiting after sending a message.")
332 (defvar message-kill-actions nil
333   "A list of actions to be performed before killing a message buffer.")
334 (defvar message-postpone-actions nil
335   "A list of actions to be performed after postponing a message.")
336
337 ;;;###autoload
338 (defvar message-default-headers nil
339   "*A string containing header lines to be inserted in outgoing messages.
340 It is inserted before you edit the message, so you can edit or delete
341 these lines.")
342
343 ;;;###autoload
344 (defvar message-default-mail-headers nil
345   "*A string of header lines to be inserted in outgoing mails.")
346
347 ;;;###autoload
348 (defvar message-default-news-headers nil
349   "*A string of header lines to be inserted in outgoing news articles.")
350
351 ;; Note: could use /usr/ucb/mail instead of sendmail;
352 ;; options -t, and -v if not interactive.
353 (defvar message-mailer-swallows-blank-line
354   (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" 
355                          system-configuration)
356            (file-readable-p "/etc/sendmail.cf")
357            (let ((buffer (get-buffer-create " *temp*")))
358              (unwind-protect
359                  (save-excursion
360                    (set-buffer buffer)
361                    (insert-file-contents "/etc/sendmail.cf")
362                    (goto-char (point-min))
363                    (let ((case-fold-search nil))
364                      (re-search-forward "^OR\\>" nil t)))
365                (kill-buffer buffer))))
366       ;; According to RFC822, "The field-name must be composed of printable
367       ;; ASCII characters (i.e. characters that have decimal values between
368       ;; 33 and 126, except colon)", i.e. any chars except ctl chars,
369       ;; space, or colon.
370       '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
371   "Set this non-nil if the system's mailer runs the header and body together.
372 \(This problem exists on Sunos 4 when sendmail is run in remote mode.)
373 The value should be an expression to test whether the problem will
374 actually occur.")
375
376 (defvar message-mode-syntax-table 
377   (let ((table (copy-syntax-table text-mode-syntax-table)))
378     (modify-syntax-entry ?% ". " table)
379     table)
380   "Syntax table used while in Message mode.")
381
382 (defvar message-font-lock-keywords
383   (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")))
384     (list '("^To:" . font-lock-function-name-face)
385           '("^[GBF]?[Cc][Cc]:\\|^Reply-To:" . font-lock-keyword-face)
386           '("^\\(Subject:\\)[ \t]*\\(.+\\)?"
387             (1 font-lock-comment-face) (2 font-lock-type-face nil t))
388           (list (concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
389                 1 'font-lock-comment-face)
390           (cons (concat "^[ \t]*"
391                         "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
392                         "[>|}].*")
393                 'font-lock-reference-face)
394           '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*"
395             . font-lock-string-face)))
396   "Additional expressions to highlight in Message mode.")
397
398 (defvar message-face-alist
399   '((bold . bold-region)
400     (underline . underline-region)
401     (default . (lambda (b e) 
402                  (unbold-region b e)
403                  (ununderline-region b e))))
404   "Alist of mail and news faces for facemenu.
405 The cdr of ech entry is a function for applying the face to a region.")
406
407 (defvar message-send-hook nil
408   "Hook run before sending messages.")
409
410 (defvar message-sent-hook nil
411   "Hook run after sending messages.")
412
413 ;;; Internal variables.
414
415 (defvar message-buffer-list nil)
416
417 ;;; Regexp matching the delimiter of messages in UNIX mail format
418 ;;; (UNIX From lines), minus the initial ^.  
419 (defvar message-unix-mail-delimiter
420   (let ((time-zone-regexp
421          (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
422                  "\\|[-+]?[0-9][0-9][0-9][0-9]"
423                  "\\|"
424                  "\\) *")))
425     (concat
426      "From "
427
428      ;; Username, perhaps with a quoted section that can contain spaces.
429      "\\("
430      "[^ \n]*"
431      "\\(\\|\".*\"[^ \n]*\\)"
432      "\\|<[^<>\n]+>"
433      "\\)  ?"
434
435      ;; The time the message was sent.
436      "\\([^ \n]*\\) *"                  ; day of the week
437      "\\([^ ]*\\) *"                    ; month
438      "\\([0-9]*\\) *"                   ; day of month
439      "\\([0-9:]*\\) *"                  ; time of day
440
441      ;; Perhaps a time zone, specified by an abbreviation, or by a
442      ;; numeric offset.
443      time-zone-regexp
444
445      ;; The year.
446      " [0-9][0-9]\\([0-9]*\\) *"
447
448      ;; On some systems the time zone can appear after the year, too.
449      time-zone-regexp
450
451      ;; Old uucp cruft.
452      "\\(remote from .*\\)?"
453
454      "\n")))
455
456 (defvar message-unsent-separator
457   (concat "^ *---+ +Unsent message follows +---+ *$\\|"
458           "^ *---+ +Returned message +---+ *$\\|"
459           "^Start of returned message$\\|"
460           "^ *---+ +Original message +---+ *$\\|"
461           "^ *--+ +begin message +--+ *$\\|"
462           "^ *---+ +Original message follows +---+ *$\\|"
463           "^|? *---+ +Message text follows: +---+ *|?$")
464   "A regexp that matches the separator before the text of a failed message.")
465
466 (defvar message-header-format-alist 
467   `((Newsgroups)
468     (To . message-fill-address) 
469     (Cc . message-fill-address)
470     (Subject)
471     (In-Reply-To)
472     (Fcc)
473     (Bcc)
474     (Date)
475     (Organization)
476     (Distribution)
477     (Lines)
478     (Expires)
479     (Message-ID)
480     (References . message-fill-header)
481     (X-Mailer)
482     (X-Newsreader))
483   "Alist used for formatting headers.")
484
485 (eval-and-compile
486   (autoload 'message-setup-toolbar "messagexmas")
487   (autoload 'mh-send-letter "mh-comp"))
488
489 \f
490
491 ;;; 
492 ;;; Utility functions.
493 ;;;
494
495 (defun message-point-at-bol ()
496   "Return point at the beginning of the line."
497   (let ((p (point)))
498     (beginning-of-line)
499     (prog1
500         (point)
501       (goto-char p))))
502
503 (defun message-point-at-eol ()
504   "Return point at the end of the line."
505   (let ((p (point)))
506     (end-of-line)
507     (prog1
508         (point)
509       (goto-char p))))
510
511 ;; Delete the current line (and the next N lines.);
512 (defmacro message-delete-line (&optional n)
513   `(delete-region (progn (beginning-of-line) (point))
514                   (progn (forward-line ,(or n 1)) (point))))
515
516 (defun message-tokenize-header (header &optional separator)
517   "Split HEADER into a list of header elements.
518 \",\" is used as the separator."
519   (let ((regexp (format "[%s]+" (or separator ",")))
520         (beg 1)
521         quoted elems)
522     (save-excursion
523       (message-set-work-buffer)
524       (insert header)
525       (goto-char (point-min))
526       (while (not (eobp))
527         (forward-char 1)
528         (cond ((and (> (point) beg)
529                     (or (eobp)
530                         (and (looking-at regexp)
531                              (not quoted))))
532                (push (buffer-substring beg (point)) elems)
533                (setq beg (match-end 0)))
534               ((= (following-char) ?\")
535                (setq quoted (not quoted)))))
536       (nreverse elems))))
537
538 (defun message-fetch-field (header)
539   "The same as `mail-fetch-field', only remove all newlines."
540   (let ((value (mail-fetch-field header)))
541     (when value
542       (nnheader-replace-chars-in-string value ?\n ? ))))
543
544 (defun message-fetch-reply-field (header)
545   "Fetch FIELD from the message we're replying to."
546   (when (and message-reply-buffer
547              (buffer-name message-reply-buffer))
548     (save-excursion
549       (set-buffer message-reply-buffer)
550       (message-fetch-field header))))
551
552 (defun message-set-work-buffer ()
553   (if (get-buffer " *message work*")
554       (progn
555         (set-buffer " *message work*")
556         (erase-buffer))
557     (set-buffer (get-buffer-create " *message work*"))
558     (kill-all-local-variables)
559     (buffer-disable-undo (current-buffer))))
560
561 (defun message-functionp (form)
562   "Return non-nil if FORM is funcallable."
563   (or (and (symbolp form) (fboundp form))
564       (and (listp form) (eq (car form) 'lambda))))
565
566 (defun message-strip-subject-re (subject)
567   "Remove \"Re:\" from subject lines."
568   (if (string-match "^[Rr][Ee]: *" subject)
569       (substring subject (match-end 0))
570     subject))
571
572 (defun message-remove-header (header &optional is-regexp first reverse)
573   "Remove HEADER in the narrowed buffer.
574 If REGEXP, HEADER is a regular expression.
575 If FIRST, only remove the first instance of the header.
576 Return the number of headers removed."
577   (goto-char (point-min))
578   (let ((regexp (if is-regexp header (concat "^" header ":")))
579         (number 0)
580         (case-fold-search t)
581         last)
582     (while (and (not (eobp))
583                 (not last))
584       (if (if reverse
585               (not (looking-at regexp))
586             (looking-at regexp))
587           (progn
588             (incf number)
589             (when first
590               (setq last t))
591             (delete-region
592              (point)
593              ;; There might be a continuation header, so we have to search
594              ;; until we find a new non-continuation line.
595              (progn
596                (forward-line 1)
597                (if (re-search-forward "^[^ \t]" nil t)
598                    (goto-char (match-beginning 0))
599                  (point-max)))))
600         (forward-line 1)
601         (if (re-search-forward "^[^ \t]" nil t)
602             (goto-char (match-beginning 0))
603           (point-max))))
604     number))
605
606 (defun message-narrow-to-headers ()
607   "Narrow the buffer to the head of the message."
608   (widen)
609   (narrow-to-region
610    (goto-char (point-min))
611    (if (re-search-forward
612         (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
613        (match-beginning 0)
614      (point-max)))
615   (goto-char (point-min)))
616
617 (defun message-narrow-to-head ()
618   "Narrow the buffer to the head of the message."
619   (widen)
620   (narrow-to-region
621    (goto-char (point-min))
622    (if (search-forward "\n\n" nil 1)
623        (1- (point))
624      (point-max)))
625   (goto-char (point-min)))
626
627 (defun message-news-p ()
628   "Say whether the current buffer contains a news message."
629   (save-excursion
630     (save-restriction
631       (message-narrow-to-headers)
632       (message-fetch-field "newsgroups"))))
633
634 (defun message-mail-p ()
635   "Say whether the current buffer contains a mail message."
636   (save-excursion
637     (save-restriction
638       (message-narrow-to-headers)
639       (or (message-fetch-field "to")
640           (message-fetch-field "cc")
641           (message-fetch-field "bcc")))))
642
643 (defun message-next-header ()
644   "Go to the beginning of the next header."
645   (beginning-of-line)
646   (or (eobp) (forward-char 1))
647   (not (if (re-search-forward "^[^ \t]" nil t)
648            (beginning-of-line)
649          (goto-char (point-max)))))
650     
651 (defun message-sort-headers-1 ()
652   "Sort the buffer as headers using `message-rank' text props."
653   (goto-char (point-min))
654   (sort-subr 
655    nil 'message-next-header 
656    (lambda ()
657      (message-next-header)
658      (unless (bobp)
659        (forward-char -1)))
660    (lambda ()
661      (or (get-text-property (point) 'message-rank)
662          0))))
663
664 (defun message-sort-headers ()
665   "Sort the headers of the current message according to `message-header-format-alist'."
666   (interactive)
667   (save-excursion
668     (save-restriction
669       (let ((max (1+ (length message-header-format-alist)))
670             rank)
671         (message-narrow-to-headers)
672         (while (re-search-forward "^[^ \n]+:" nil t)
673           (put-text-property
674            (match-beginning 0) (1+ (match-beginning 0))
675            'message-rank
676            (if (setq rank (length (memq (assq (intern (buffer-substring
677                                                        (match-beginning 0)
678                                                        (1- (match-end 0))))
679                                               message-header-format-alist)
680                                         message-header-format-alist)))
681                (- max rank)
682              (1+ max)))))
683       (message-sort-headers-1))))
684
685 \f
686
687 ;;;
688 ;;; Message mode
689 ;;;
690
691 ;;; Set up keymap.
692
693 (defvar message-mode-map nil)
694
695 (unless message-mode-map
696   (setq message-mode-map (copy-keymap text-mode-map))
697   (define-key message-mode-map "\C-c?" 'describe-mode)
698
699   (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
700   (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
701   (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
702   (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
703   (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
704   (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
705   (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
706   (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
707   (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
708   (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
709   (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
710   (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
711   (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
712
713   (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
714   (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
715   
716   (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
717   (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
718   (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
719   (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
720   (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
721   (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
722
723   (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
724   (define-key message-mode-map "\C-c\C-s" 'message-send)
725   (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
726   (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
727
728   (define-key message-mode-map "\t" 'message-tab))
729
730 (easy-menu-define message-mode-menu message-mode-map
731   "Message Menu."
732   '("Message"
733     "Go to Field:"
734     "----"
735     ["To" message-goto-to t]
736     ["Subject" message-goto-subject t]
737     ["Cc" message-goto-cc t]
738     ["Reply-to" message-goto-reply-to t]
739     ["Summary" message-goto-summary t]
740     ["Keywords" message-goto-keywords t]
741     ["Newsgroups" message-goto-newsgroups t]
742     ["Followup-To" message-goto-followup-to t]
743     ["Distribution" message-goto-distribution t]
744     ["Body" message-goto-body t]
745     ["Signature" message-goto-signature t]
746     "----"
747     "Miscellaneous Commands:"
748     "----"
749     ["Sort Headers" message-sort-headers t]
750     ["Yank Original" message-yank-original t]
751     ["Fill Yanked Message" message-fill-yanked-message t]
752     ["Insert Signature" message-insert-signature t]
753     ["Caesar (rot13) Message" message-caesar-buffer-body t]
754     ["Rename buffer" message-rename-buffer t]
755     ["Spellcheck" ispell-message t]
756     "----"
757     ["Send Message" message-send-and-exit t]
758     ["Abort Message" message-dont-send t]))
759
760 (defvar facemenu-add-face-function)
761 (defvar facemenu-remove-face-function)
762
763 ;;;###autoload
764 (defun message-mode ()
765   "Major mode for editing mail and news to be sent.
766 Like Text Mode but with these additional commands:
767 C-c C-s  message-send (send the message)    C-c C-c  message-send-and-exit
768 C-c C-f  move to a header field (and create it if there isn't):
769          C-c C-f C-t  move to To        C-c C-f C-s  move to Subject
770          C-c C-f C-c  move to Cc        C-c C-f C-b  move to Bcc
771          C-c C-f C-f  move to Fcc       C-c C-f C-r  move to Reply-To
772          C-c C-f C-u  move to Summary   C-c C-f C-n  move to Newsgroups
773          C-c C-f C-k  move to Keywords  C-c C-f C-d  move to Distribution
774          C-c C-f C-o  move to Followup-To
775 C-c C-t  message-insert-to (add a To header to a news followup)
776 C-c C-n  message-insert-newsgroups (add a Newsgroup header to a news reply)
777 C-c C-b  message-goto-body (move to beginning of message text).
778 C-c C-i  message-goto-signature (move to the beginning of the signature).
779 C-c C-w  message-insert-signature (insert `message-signature-file' file).
780 C-c C-y  message-yank-original (insert current message, if any).
781 C-c C-q  message-fill-yanked-message (fill what was yanked).
782 C-c C-r  message-ceasar-buffer-body (rot13 the message body)."
783   (interactive)
784   (kill-all-local-variables)
785   (make-local-variable 'message-reply-buffer)
786   (setq message-reply-buffer nil)
787   (make-local-variable 'message-send-actions)
788   (make-local-variable 'message-exit-actions)
789   (make-local-variable 'message-kill-actions)
790   (make-local-variable 'message-postpone-actions)
791   (set-syntax-table message-mode-syntax-table)
792   (use-local-map message-mode-map)
793   (setq local-abbrev-table text-mode-abbrev-table)
794   (setq major-mode 'message-mode)
795   (setq mode-name "Message")
796   (setq buffer-offer-save t)
797   (make-local-variable 'font-lock-defaults)
798   (setq font-lock-defaults '(message-font-lock-keywords t))
799   (make-local-variable 'facemenu-add-face-function)
800   (make-local-variable 'facemenu-remove-face-function)
801   (setq facemenu-add-face-function
802         (lambda (face end)
803           (let ((face-fun (cdr (assq face message-face-alist))))
804             (if face-fun
805                 (funcall face-fun (point) end)
806               (error "Face %s not configured for %s mode" face mode-name)))
807           "")
808         facemenu-remove-face-function t)
809   (make-local-variable 'paragraph-separate)
810   (make-local-variable 'paragraph-start)
811   (setq paragraph-start (concat (regexp-quote mail-header-separator)
812                                 "$\\|[ \t]*[-_][-_][-_]+$\\|"
813                                 "-- $\\|"
814                                 paragraph-start))
815   (setq paragraph-separate (concat (regexp-quote mail-header-separator)
816                                    "$\\|[ \t]*[-_][-_][-_]+$\\|"
817                                    "-- $\\|"
818                                    paragraph-separate))
819   (make-local-variable 'message-reply-headers)
820   (setq message-reply-headers nil)
821   (make-local-variable 'message-newsreader)
822   (make-local-variable 'message-mailer)
823   (make-local-variable 'message-post-method)
824   (make-local-variable 'message-sent-message-via)
825   (setq message-sent-message-via nil)
826   (make-local-variable 'message-checksum)
827   (setq message-checksum nil)
828   (when (fboundp 'mail-hist-define-keys)
829     (mail-hist-define-keys))
830   (when (string-match "XEmacs\\|Lucid" emacs-version)
831     (message-setup-toolbar))
832   (easy-menu-add message-mode-menu message-mode-map)
833   ;; Allow mail alias things.
834   (if (fboundp 'mail-abbrevs-setup)
835       (mail-abbrevs-setup)
836     (funcall (intern "mail-aliases-setup")))
837   (define-key message-mode-map "\C-n" 'abbrev-hacking-next-line)
838   (define-key message-mode-map "\M->" 'abbrev-hacking-end-of-buffer)
839   (run-hooks 'text-mode-hook 'message-mode-hook))
840
841 \f
842
843 ;;;
844 ;;; Message mode commands
845 ;;;
846
847 ;;; Movement commands
848
849 (defun message-goto-to ()
850   "Move point to the To header."
851   (interactive)
852   (message-position-on-field "To"))
853
854 (defun message-goto-subject ()
855   "Move point to the Subject header."
856   (interactive)
857   (message-position-on-field "Subject"))
858
859 (defun message-goto-cc ()
860   "Move point to the Cc header."
861   (interactive)
862   (message-position-on-field "Cc" "To"))
863
864 (defun message-goto-bcc ()
865   "Move point to the Bcc  header."
866   (interactive)
867   (message-position-on-field "Bcc" "Cc" "To"))
868
869 (defun message-goto-fcc ()
870   "Move point to the Fcc header."
871   (interactive)
872   (message-position-on-field "Fcc" "To" "Newsgroups"))
873
874 (defun message-goto-reply-to ()
875   "Move point to the Reply-To header."
876   (interactive)
877   (message-position-on-field "Reply-To" "Subject"))
878
879 (defun message-goto-newsgroups ()
880   "Move point to the Newsgroups header."
881   (interactive)
882   (message-position-on-field "Newsgroups"))
883
884 (defun message-goto-distribution ()
885   "Move point to the Distribution header."
886   (interactive)
887   (message-position-on-field "Distribution"))
888
889 (defun message-goto-followup-to ()
890   "Move point to the Followup-To header."
891   (interactive)
892   (message-position-on-field "Followup-To" "Newsgroups"))
893
894 (defun message-goto-keywords ()
895   "Move point to the Keywords header."
896   (interactive)
897   (message-position-on-field "Keywords" "Subject"))
898
899 (defun message-goto-summary ()
900   "Move point to the Summary header."
901   (interactive)
902   (message-position-on-field "Summary" "Subject"))
903
904 (defun message-goto-body ()
905   "Move point to the beginning of the message body."
906   (interactive)
907   (if (looking-at "[ \t]*\n") (expand-abbrev))
908   (goto-char (point-min))
909   (search-forward (concat "\n" mail-header-separator "\n") nil t))
910
911 (defun message-goto-signature ()
912   "Move point to the beginning of the message signature."
913   (interactive)
914   (goto-char (point-min))
915   (or (re-search-forward message-signature-separator nil t)
916       (goto-char (point-max))))
917
918 \f
919
920 (defun message-insert-to ()
921   "Insert a To header that points to the author of the article being replied to."
922   (interactive)
923   (when (and (message-position-on-field "To")
924              (mail-fetch-field "to")
925              (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
926     (insert ", "))
927   (insert (or (message-fetch-reply-field "reply-to")
928               (message-fetch-reply-field "from") "")))
929
930 (defun message-insert-newsgroups ()
931   "Insert the Newsgroups header from the article being replied to."
932   (interactive)
933   (when (and (message-position-on-field "Newsgroups")
934              (mail-fetch-field "newsgroups")
935              (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
936     (insert ","))
937   (insert (or (message-fetch-reply-field "newsgroups") "")))
938
939 \f
940
941 ;;; Various commands
942
943 (defun message-insert-signature (&optional force)
944   "Insert a signature.  See documentation for the `message-signature' variable."
945   (interactive (list 0))
946   (let* ((signature 
947           (cond ((and (null message-signature)
948                       (eq force 0))
949                  (save-excursion
950                    (goto-char (point-max))
951                    (not (re-search-backward
952                          message-signature-separator nil t))))
953                 ((and (null message-signature)
954                       force)
955                  t)
956                 ((message-functionp message-signature)
957                  (funcall message-signature))
958                 ((listp message-signature)
959                  (eval message-signature))
960                 (t message-signature)))
961          (signature
962           (cond ((stringp signature)
963                  signature)
964                 ((and (eq t signature)
965                       message-signature-file
966                       (file-exists-p message-signature-file))
967                  signature))))
968     (when signature
969 ;      ;; Remove blank lines at the end of the message.
970       (goto-char (point-max))
971 ;      (skip-chars-backward " \t\n")
972 ;      (delete-region (point) (point-max))
973       ;; Insert the signature.
974       (unless (bolp)
975         (insert "\n"))
976       (insert "\n-- \n")
977       (if (eq signature t)
978           (insert-file-contents message-signature-file)
979         (insert signature))
980       (goto-char (point-max))
981       (or (bolp) (insert "\n")))))
982
983 (defvar message-caesar-translation-table nil)
984
985 (defun message-caesar-region (b e &optional n)
986   "Caesar rotation of region by N, default 13, for decrypting netnews."
987   (interactive
988    (list
989     (min (point) (or (mark t) (point)))
990     (max (point) (or (mark t) (point)))
991     (when current-prefix-arg
992       (prefix-numeric-value current-prefix-arg))))
993
994   (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
995   (unless (or (zerop n)                 ; no action needed for a rot of 0
996               (= b e))                  ; no region to rotate
997     ;; We build the table, if necessary.
998     (when (or (not message-caesar-translation-table)
999               (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
1000       (let ((i -1) 
1001             (table (make-string 256 0)))
1002         (while (< (incf i) 256)
1003           (aset table i i))
1004         (setq table
1005               (concat
1006                (substring table 0 ?A)
1007                (substring table (+ ?A n) (+ ?A n (- 26 n)))
1008                (substring table ?A (+ ?A n))
1009                (substring table (+ ?A 26) ?a)
1010                (substring table (+ ?a n) (+ ?a n (- 26 n)))
1011                (substring table ?a (+ ?a n))
1012                (substring table (+ ?a 26) 255)))
1013         (setq message-caesar-translation-table table)))
1014     ;; Then we translate the region.  Do it this way to retain 
1015     ;; text properties.
1016     (while (< b e)
1017       (subst-char-in-region 
1018        b (1+ b) (char-after b)
1019        (aref message-caesar-translation-table (char-after b)))
1020       (incf b))))
1021
1022 (defun message-caesar-buffer-body (&optional rotnum)
1023   "Caesar rotates all letters in the current buffer by 13 places.
1024 Used to encode/decode possibly offensive messages (commonly in net.jokes).
1025 With prefix arg, specifies the number of places to rotate each letter forward.
1026 Mail and USENET news headers are not rotated."
1027   (interactive (if current-prefix-arg
1028                    (list (prefix-numeric-value current-prefix-arg))
1029                  (list nil)))
1030   (save-excursion
1031     (save-restriction
1032       (when (message-goto-body)
1033         (narrow-to-region (point) (point-max)))
1034       (message-caesar-region (point-min) (point-max) rotnum))))
1035
1036 (defun message-rename-buffer (&optional enter-string)
1037   "Rename the *message* buffer to \"*message* RECIPIENT\".  
1038 If the function is run with a prefix, it will ask for a new buffer
1039 name, rather than giving an automatic name."
1040   (interactive "Pbuffer name: ")
1041   (save-excursion
1042     (save-restriction
1043       (goto-char (point-min))
1044       (narrow-to-region (point) 
1045                         (search-forward mail-header-separator nil 'end))
1046       (let* ((mail-to (if (message-news-p) (message-fetch-field "Newsgroups")
1047                         (message-fetch-field "To")))
1048              (mail-trimmed-to
1049               (if (string-match "," mail-to)
1050                   (concat (substring mail-to 0 (match-beginning 0)) ", ...")
1051                 mail-to))
1052              (name-default (concat "*message* " mail-trimmed-to))
1053              (name (if enter-string
1054                        (read-string "New buffer name: " name-default)
1055                      name-default)))
1056         (rename-buffer name t)))))
1057
1058 (defun message-fill-yanked-message (&optional justifyp)
1059   "Fill the paragraphs of a message yanked into this one.
1060 Numeric argument means justify as well."
1061   (interactive "P")
1062   (save-excursion
1063     (goto-char (point-min))
1064     (search-forward (concat "\n" mail-header-separator "\n") nil t)
1065     (let ((fill-prefix message-yank-prefix))
1066       (fill-individual-paragraphs (point) (point-max) justifyp t))))
1067
1068 (defun message-indent-citation ()
1069   "Modify text just inserted from a message to be cited.
1070 The inserted text should be the region.
1071 When this function returns, the region is again around the modified text.
1072
1073 Normally, indent each nonblank line `message-indentation-spaces' spaces.
1074 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
1075   (let ((start (point)))
1076     ;; Remove unwanted headers.
1077     (when message-ignored-cited-headers
1078       (save-restriction
1079         (narrow-to-region 
1080          (goto-char start)
1081          (if (search-forward "\n\n" nil t)
1082              (1- (point))
1083            (point)))
1084         (message-remove-header message-ignored-cited-headers t)))
1085     ;; Do the indentation.
1086     (if (null message-yank-prefix)
1087         (indent-rigidly start (mark t) message-indentation-spaces)
1088       (save-excursion
1089         (goto-char start)
1090         (while (< (point) (mark t))
1091           (insert message-yank-prefix)
1092           (forward-line 1)))
1093       (goto-char start))))
1094
1095 (defun message-yank-original (&optional arg)
1096   "Insert the message being replied to, if any.
1097 Puts point before the text and mark after.
1098 Normally indents each nonblank line ARG spaces (default 3).  However,
1099 if `message-yank-prefix' is non-nil, insert that prefix on each line.
1100
1101 Just \\[universal-argument] as argument means don't indent, insert no
1102 prefix, and don't delete any headers."
1103   (interactive "P")
1104   (let ((modified (buffer-modified-p)))
1105     (when (and message-reply-buffer
1106                message-cite-function)
1107       (delete-windows-on message-reply-buffer t)
1108       (insert-buffer message-reply-buffer)
1109       (funcall message-cite-function)
1110       (message-exchange-point-and-mark)
1111       (unless (bolp)
1112         (insert ?\n))
1113       (unless modified
1114         (setq message-checksum (cons (message-checksum) (buffer-size)))))))
1115
1116 (defun message-cite-original ()    
1117   (let ((start (point))
1118         (functions 
1119          (when message-indent-citation-function
1120            (if (listp message-indent-citation-function)
1121                message-indent-citation-function
1122              (list message-indent-citation-function)))))
1123     (goto-char start)
1124     (while functions
1125       (funcall (pop functions)))
1126     (when message-citation-line-function
1127       (unless (bolp)
1128         (insert "\n"))
1129       (funcall message-citation-line-function))))
1130
1131 (defun message-insert-citation-line ()
1132   "Function that inserts a simple citation line."
1133   (when message-reply-headers
1134     (insert (mail-header-from message-reply-headers) " writes:\n\n")))
1135
1136 (defun message-position-on-field (header &rest afters)
1137   (let ((case-fold-search t))
1138     (save-restriction
1139       (narrow-to-region
1140        (goto-char (point-min))
1141        (progn
1142          (re-search-forward 
1143           (concat "^" (regexp-quote mail-header-separator) "$"))
1144          (match-beginning 0)))
1145       (goto-char (point-min))
1146       (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
1147           (progn
1148             (re-search-forward "^[^ \t]" nil 'move)
1149             (beginning-of-line)
1150             (skip-chars-backward "\n")
1151             t)
1152         (while (and afters
1153                     (not (re-search-forward 
1154                           (concat "^" (regexp-quote (car afters)) ":")
1155                           nil t)))
1156           (pop afters))
1157         (when afters
1158           (re-search-forward "^[^ \t]" nil 'move)
1159           (beginning-of-line))
1160         (insert header ": \n")
1161         (forward-char -1)
1162         nil))))
1163
1164 (defun message-remove-signature ()
1165   "Remove the signature from the text between point and mark.
1166 The text will also be indented the normal way."
1167   (save-excursion
1168     (let ((start (point))
1169           mark)
1170     (if (not (re-search-forward message-signature-separator (mark t) t))
1171         ;; No signature here, so we just indent the cited text.
1172         (message-indent-citation)
1173       ;; Find the last non-empty line.
1174       (forward-line -1)
1175       (while (looking-at "[ \t]*$")
1176         (forward-line -1))
1177       (forward-line 1)
1178       (setq mark (set-marker (make-marker) (point)))
1179       (goto-char start)
1180       (message-indent-citation)
1181       ;; Enable undoing the deletion.
1182       (undo-boundary)
1183       (delete-region mark (mark t))
1184       (set-marker mark nil)))))
1185
1186 \f
1187
1188 ;;;
1189 ;;; Sending messages
1190 ;;;
1191
1192 (defun message-send-and-exit (&optional arg)
1193   "Send message like `message-send', then, if no errors, exit from mail buffer."
1194   (interactive "P")
1195   (let ((buf (current-buffer))
1196         (actions message-exit-actions))
1197     (when (and (message-send arg)
1198                (buffer-name buf))
1199       (if message-kill-buffer-on-exit
1200           (kill-buffer buf)
1201         (bury-buffer buf)
1202         (when (eq buf (current-buffer))
1203           (message-bury buf)))
1204       (message-do-actions actions))))
1205
1206 (defun message-dont-send ()
1207   "Don't send the message you have been editing."
1208   (interactive)
1209   (message-bury (current-buffer))
1210   (message-do-actions message-postpone-actions))
1211
1212 (defun message-kill-buffer ()
1213   "Kill the current buffer."
1214   (interactive)
1215   (let ((actions message-kill-actions))
1216     (kill-buffer (current-buffer))
1217     (message-do-actions actions)))
1218
1219 (defun message-bury (buffer)
1220   "Bury this mail buffer."
1221   (let ((newbuf (other-buffer buffer)))
1222     (bury-buffer buffer)
1223     (if (and (fboundp 'frame-parameters)
1224              (cdr (assq 'dedicated (frame-parameters)))
1225              (not (null (delq (selected-frame) (visible-frame-list)))))
1226         (delete-frame (selected-frame))
1227       (switch-to-buffer newbuf))))
1228
1229 (defun message-send (&optional arg)
1230   "Send the message in the current buffer.
1231 If `message-interactive' is non-nil, wait for success indication
1232 or error messages, and inform user.
1233 Otherwise any failure is reported in a message back to
1234 the user from the mailer."
1235   (interactive "P")
1236   (when (if buffer-file-name
1237             (y-or-n-p (format "Send buffer contents as %s message? "
1238                               (if (message-mail-p)
1239                                   (if (message-news-p) "mail and news" "mail")
1240                                 "news")))
1241           (or (buffer-modified-p)
1242               (y-or-n-p "No changes in the buffer; really send? ")))
1243     ;; Make it possible to undo the coming changes.
1244     (undo-boundary)
1245     (let ((inhibit-read-only t))
1246       (put-text-property (point-min) (point-max) 'read-only nil))
1247     (message-fix-before-sending)
1248     (run-hooks 'message-send-hook)
1249     (message "Sending...")
1250     (when (and (or (not (message-news-p))
1251                    (and (or (not (memq 'news message-sent-message-via))
1252                             (y-or-n-p
1253                              "Already sent message via news; resend? "))
1254                         (funcall message-send-news-function arg)))
1255                (or (not (message-mail-p))
1256                    (and (or (not (memq 'mail message-sent-message-via))
1257                             (y-or-n-p
1258                              "Already sent message via mail; resend? "))
1259                         (message-send-mail arg))))
1260       (message-do-fcc)
1261       (when (fboundp 'mail-hist-put-headers-into-history)
1262         (mail-hist-put-headers-into-history))
1263       (run-hooks 'message-sent-hook)
1264       (message "Sending...done")
1265       ;; If buffer has no file, mark it as unmodified and delete autosave.
1266       (unless buffer-file-name
1267         (set-buffer-modified-p nil)
1268         (delete-auto-save-file-if-necessary t))
1269       ;; Delete other mail buffers and stuff.
1270       (message-do-send-housekeeping)
1271       (message-do-actions message-send-actions)
1272       ;; Return success.
1273       t)))
1274
1275 (defun message-fix-before-sending ()
1276   "Do various things to make the message nice before sending it."
1277   ;; Make sure there's a newline at the end of the message.
1278   (goto-char (point-max))
1279   (unless (bolp)
1280     (insert "\n")))
1281
1282 (defun message-add-action (action &rest types)
1283   "Add ACTION to be performed when doing an exit of type TYPES."
1284   (let (var)
1285     (while types
1286       (set (setq var (intern (format "message-%s-actions" (pop types))))
1287            (nconc (symbol-value var) (list action))))))
1288
1289 (defun message-do-actions (actions)
1290   "Perform all actions in ACTIONS."
1291   ;; Now perform actions on successful sending.
1292   (while actions
1293     (condition-case nil
1294         (cond 
1295          ;; A simple function.
1296          ((message-functionp (car actions))
1297           (funcall (car actions)))
1298          ;; Something to be evaled.
1299          (t
1300           (eval (car actions))))
1301       (error))
1302     (pop actions)))
1303
1304 (defun message-send-mail (&optional arg)
1305   (require 'mail-utils)
1306   (let ((tembuf (generate-new-buffer " message temp"))
1307         (case-fold-search nil)
1308         (news (message-news-p))
1309         (mailbuf (current-buffer)))
1310     (save-restriction
1311       (message-narrow-to-headers)
1312       ;; Insert some headers.
1313       (let ((message-deletable-headers
1314              (if news nil message-deletable-headers)))
1315         (message-generate-headers message-required-mail-headers))
1316       ;; Let the user do all of the above.
1317       (run-hooks 'message-header-hook))
1318     (unwind-protect
1319         (save-excursion
1320           (set-buffer tembuf)
1321           (erase-buffer)
1322           (insert-buffer-substring mailbuf)
1323           ;; Remove some headers.
1324           (save-restriction
1325             (message-narrow-to-headers)
1326             ;; Remove some headers.
1327             (message-remove-header message-ignored-mail-headers t))
1328           (goto-char (point-max))
1329           ;; require one newline at the end.
1330           (or (= (preceding-char) ?\n)
1331               (insert ?\n))
1332           (when (and news
1333                      (or (message-fetch-field "cc")
1334                          (message-fetch-field "to")))
1335             (message-insert-courtesy-copy))
1336           (funcall message-send-mail-function))
1337       (kill-buffer tembuf))
1338     (set-buffer mailbuf)
1339     (push 'mail message-sent-message-via)))
1340
1341 (defun message-send-mail-with-sendmail ()
1342   "Send off the prepared buffer with sendmail."
1343   (let ((errbuf (if message-interactive
1344                     (generate-new-buffer " sendmail errors")
1345                   0))
1346         resend-to-addresses delimline)
1347     (let ((case-fold-search t))
1348       (save-restriction
1349         (message-narrow-to-headers)
1350         (setq resend-to-addresses (message-fetch-field "resent-to")))
1351       ;; Change header-delimiter to be what sendmail expects.
1352       (goto-char (point-min))
1353       (re-search-forward
1354        (concat "^" (regexp-quote mail-header-separator) "\n"))
1355       (replace-match "\n")
1356       (backward-char 1)
1357       (setq delimline (point-marker))
1358       ;; Insert an extra newline if we need it to work around
1359       ;; Sun's bug that swallows newlines.
1360       (goto-char (1+ delimline))
1361       (when (eval message-mailer-swallows-blank-line)
1362         (newline))
1363       (when message-interactive
1364         (save-excursion
1365           (set-buffer errbuf)
1366           (erase-buffer))))
1367     (let ((default-directory "/"))
1368       (apply 'call-process-region
1369              (append (list (point-min) (point-max)
1370                            (if (boundp 'sendmail-program)
1371                                sendmail-program
1372                              "/usr/lib/sendmail")
1373                            nil errbuf nil "-oi")
1374                      ;; Always specify who from,
1375                      ;; since some systems have broken sendmails.
1376                      (list "-f" (user-login-name))
1377                      ;; These mean "report errors by mail"
1378                      ;; and "deliver in background".
1379                      (if (null message-interactive) '("-oem" "-odb"))
1380                      ;; Get the addresses from the message
1381                      ;; unless this is a resend.
1382                      ;; We must not do that for a resend
1383                      ;; because we would find the original addresses.
1384                      ;; For a resend, include the specific addresses.
1385                      (if resend-to-addresses
1386                          (list resend-to-addresses)
1387                        '("-t")))))
1388     (when message-interactive
1389       (save-excursion
1390         (set-buffer errbuf)
1391         (goto-char (point-min))
1392         (while (re-search-forward "\n\n* *" nil t)
1393           (replace-match "; "))
1394         (if (not (zerop (buffer-size)))
1395             (error "Sending...failed to %s"
1396                    (buffer-substring (point-min) (point-max)))))
1397       (when (bufferp errbuf)
1398         (kill-buffer errbuf)))))
1399
1400 (defun message-send-mail-with-mh ()
1401   "Send the prepared message buffer with mh."
1402   (let ((mh-previous-window-config nil)
1403         (name (make-temp-name
1404                (concat (file-name-as-directory message-autosave-directory)
1405                        "msg."))))
1406     (setq buffer-file-name name)
1407     (mh-send-letter)
1408     (condition-case ()
1409         (delete-file name)
1410       (error nil))))
1411
1412 (defun message-send-news (&optional arg)
1413   (let ((tembuf (generate-new-buffer " *message temp*"))
1414         (case-fold-search nil)
1415         (method (if (message-functionp message-post-method)
1416                     (funcall message-post-method arg)
1417                   message-post-method))
1418         (messbuf (current-buffer))
1419         result)
1420     (save-restriction
1421       (message-narrow-to-headers)
1422       ;; Insert some headers.
1423       (message-generate-headers message-required-news-headers)
1424       ;; Let the user do all of the above.
1425       (run-hooks 'message-header-hook))
1426     (message-cleanup-headers)
1427     (when (message-check-news-syntax)
1428       (unwind-protect
1429           (save-excursion
1430             (set-buffer tembuf)
1431             (buffer-disable-undo (current-buffer))
1432             (erase-buffer) 
1433             (insert-buffer-substring messbuf)
1434             ;; Remove some headers.
1435             (save-restriction
1436               (message-narrow-to-headers)
1437               ;; Remove some headers.
1438               (message-remove-header message-ignored-news-headers t))
1439             (goto-char (point-max))
1440             ;; require one newline at the end.
1441             (or (= (preceding-char) ?\n)
1442                 (insert ?\n))
1443             (let ((case-fold-search t))
1444               ;; Remove the delimeter.
1445               (goto-char (point-min))
1446               (re-search-forward
1447                (concat "^" (regexp-quote mail-header-separator) "\n"))
1448               (replace-match "\n")
1449               (backward-char 1))
1450             (require (car method))
1451             (funcall (intern (format "%s-open-server" (car method)))
1452                      (cadr method) (cddr method))
1453             (setq result
1454                   (funcall (intern (format "%s-request-post" (car method))))))
1455         (kill-buffer tembuf))
1456       (set-buffer messbuf)
1457       (if result
1458           (push 'news message-sent-message-via)
1459         (message "Couldn't send message via news: %s"
1460                  (nnheader-get-report (car method)))
1461         nil))))
1462
1463 ;;;
1464 ;;; Header generation & syntax checking.
1465 ;;;
1466
1467 (defun message-check-news-syntax ()
1468   "Check the syntax of the message."
1469   (and 
1470    ;; We narrow to the headers and check them first.
1471    (save-excursion
1472      (save-restriction
1473        (message-narrow-to-headers)
1474        (and 
1475         ;; Check for commands in Subject.
1476         (or 
1477          (message-check-element 'subject-cmsg)
1478          (save-excursion
1479            (if (string-match "^cmsg " (message-fetch-field "subject"))
1480                (y-or-n-p
1481                 "The control code \"cmsg \" is in the subject. Really post? ")
1482              t)))
1483         ;; Check for multiple identical headers.
1484         (or (message-check-element 'multiple-headers)
1485             (save-excursion
1486               (let (found)
1487                 (while (and (not found) 
1488                             (re-search-forward "^[^ \t:]+: " nil t))
1489                   (save-excursion
1490                     (or (re-search-forward 
1491                          (concat "^" (setq found
1492                                            (buffer-substring 
1493                                             (match-beginning 0) 
1494                                             (- (match-end 0) 2))))
1495                          nil t)
1496                         (setq found nil))))
1497                 (if found
1498                     (y-or-n-p 
1499                      (format "Multiple %s headers. Really post? " found))
1500                   t))))
1501         ;; Check for Version and Sendsys.
1502         (or (message-check-element 'sendsys)
1503             (save-excursion
1504               (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
1505                   (y-or-n-p
1506                    (format "The article contains a %s command. Really post? "
1507                            (buffer-substring (match-beginning 0) 
1508                                              (1- (match-end 0)))))
1509                 t)))
1510         ;; See whether we can shorten Followup-To.
1511         (or (message-check-element 'shorten-followup-to)
1512             (let ((newsgroups (message-fetch-field "newsgroups"))
1513                   (followup-to (message-fetch-field "followup-to"))
1514                   to)
1515               (when (and newsgroups (string-match "," newsgroups)
1516                          (not followup-to)
1517                          (not
1518                           (zerop
1519                            (length
1520                             (setq to (completing-read 
1521                                       "Followups to: (default all groups) " 
1522                                       (mapcar (lambda (g) (list g))
1523                                               (cons "poster" 
1524                                                     (message-tokenize-header 
1525                                                      newsgroups)))))))))
1526                 (goto-char (point-min))
1527                 (insert "Followup-To: " to "\n"))
1528               t))
1529         ;; Check "Shoot me".
1530         (or (message-check-element 'shoot)
1531             (save-excursion
1532               (if (search-forward
1533                    ".i-have-a-misconfigured-system-so-shoot-me" nil t)
1534                   (y-or-n-p
1535                    "You appear to have a misconfigured system.  Really post? ")
1536                 t)))
1537         ;; Check for Approved.
1538         (or (message-check-element 'approved)
1539             (save-excursion
1540               (if (re-search-forward "^Approved:" nil t)
1541                   (y-or-n-p
1542                    "The article contains an Approved header. Really post? ")
1543                 t)))
1544         ;; Check the Message-Id header.
1545         (or (message-check-element 'message-id)
1546             (save-excursion
1547               (let* ((case-fold-search t)
1548                      (message-id (message-fetch-field "message-id")))
1549                 (or (not message-id)
1550                     (and (string-match "@" message-id)
1551                          (string-match "@[^\\.]*\\." message-id))
1552                     (y-or-n-p
1553                      (format 
1554                       "The Message-ID looks strange: \"%s\". Really post? "
1555                       message-id))))))
1556         ;; Check the Subject header.
1557         (or 
1558          (message-check-element 'subject)
1559          (save-excursion
1560            (let* ((case-fold-search t)
1561                   (subject (message-fetch-field "subject")))
1562              (or
1563               (and subject
1564                    (not (string-match "\\`[ \t]*\\'" subject)))
1565               (progn
1566                 (message 
1567                  "The subject field is empty or missing.  Posting is denied.")
1568                 nil)))))
1569         ;; Check the Newsgroups & Followup-To headers.
1570         (or
1571          (message-check-element 'existing-newsgroups)
1572          (let* ((case-fold-search t)
1573                 (newsgroups (message-fetch-field "newsgroups"))
1574                 (followup-to (message-fetch-field "followup-to"))
1575                 (groups (message-tokenize-header
1576                          (if followup-to
1577                              (concat newsgroups "," followup-to)
1578                            newsgroups)))
1579                 (hashtb (and (boundp 'gnus-active-hashtb)
1580                              gnus-active-hashtb))
1581                 errors)
1582            (if (not hashtb)
1583                t
1584              (while groups
1585                (when (and (not (boundp (intern (car groups) hashtb)))
1586                           (not (equal (car groups) "poster")))
1587                  (push (car groups) errors))
1588                (pop groups))
1589              (if (not errors)
1590                  t
1591                (y-or-n-p
1592                 (format
1593                  "Really post to %s unknown group%s: %s "
1594                  (if (= (length errors) 1) "this" "these")
1595                  (if (= (length errors) 1) "" "s")
1596                  (mapconcat 'identity errors ", ")))))))
1597         ;; Check the Newsgroups & Followup-To headers for syntax errors.
1598         (or
1599          (message-check-element 'valid-newsgroups)
1600          (let ((case-fold-search t)
1601                (headers '("Newsgroups" "Followup-To"))
1602                header error)
1603            (while (and headers (not error))
1604              (when (setq header (mail-fetch-field (car headers)))
1605                (if (or
1606                     (not 
1607                      (string-match
1608                       "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-.a-zA-Z0-9]+\\)*\\'"
1609                       header))
1610                     (memq 
1611                      nil (mapcar 
1612                           (lambda (g)
1613                             (not (string-match "\\.\\'\\|\\.\\." g)))
1614                           (message-tokenize-header header ","))))
1615                    (setq error t)))
1616              (unless error
1617                (pop headers)))
1618            (if (not error)
1619                t
1620              (y-or-n-p
1621               (format "The %s header looks odd: \"%s\".  Really post? "
1622                       (car headers) header)))))
1623         ;; Check the From header.
1624         (or 
1625          (save-excursion
1626            (let* ((case-fold-search t)
1627                   (from (message-fetch-field "from")))
1628              (cond
1629               ((not from)
1630                (message "There is no From line.  Posting is denied.")
1631                nil)
1632               ((not (string-match "@[^\\.]*\\." from))
1633                (message
1634                 "Denied posting -- the From looks strange: \"%s\"." from)
1635                nil)
1636               ((string-match "@[^@]*@" from)
1637                (message 
1638                 "Denied posting -- two \"@\"'s in the From header: %s." from)
1639                nil)
1640               ((string-match "(.*).*(.*)" from)
1641                (message
1642                 "Denied posting -- the From header looks strange: \"%s\"." 
1643                 from)
1644                nil)
1645               (t t))))))))
1646    ;; Check for long lines.
1647    (or (message-check-element 'long-lines)
1648        (save-excursion
1649          (goto-char (point-min))
1650          (re-search-forward
1651           (concat "^" (regexp-quote mail-header-separator) "$"))
1652          (while (and
1653                  (progn
1654                    (end-of-line)
1655                    (< (current-column) 80))
1656                  (zerop (forward-line 1))))
1657          (or (bolp)
1658              (eobp)
1659              (y-or-n-p
1660               "You have lines longer than 79 characters.  Really post? "))))
1661    ;; Check whether the article is empty.
1662    (or (message-check-element 'empty)
1663        (save-excursion
1664          (goto-char (point-min))
1665          (re-search-forward
1666           (concat "^" (regexp-quote mail-header-separator) "$"))
1667          (forward-line 1)
1668          (let ((b (point)))
1669            (or (re-search-forward message-signature-separator nil t)
1670                (goto-char (point-max)))
1671            (beginning-of-line)
1672            (or (re-search-backward "[^ \n\t]" b t)
1673                (y-or-n-p "Empty article.  Really post? ")))))
1674    ;; Check for control characters.
1675    (or (message-check-element 'control-chars)
1676        (save-excursion
1677          (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
1678              (y-or-n-p 
1679               "The article contains control characters. Really post? ")
1680            t)))
1681    ;; Check excessive size.
1682    (or (message-check-element 'size)
1683        (if (> (buffer-size) 60000)
1684            (y-or-n-p
1685             (format "The article is %d octets long. Really post? "
1686                     (buffer-size)))
1687          t))
1688    ;; Check whether any new text has been added.
1689    (or (message-check-element 'new-text)
1690        (not message-checksum)
1691        (not (and (eq (message-checksum) (car message-checksum))
1692                  (eq (buffer-size) (cdr message-checksum))))
1693        (y-or-n-p
1694         "It looks like no new text has been added.  Really post? "))
1695    ;; Check the length of the signature.
1696    (or
1697     (message-check-element 'signature)
1698     (progn
1699       (goto-char (point-max))
1700       (if (or (not (re-search-backward "^-- $" nil t))
1701               (search-forward message-forward-end-separator nil t))
1702           t
1703         (if (> (count-lines (point) (point-max)) 5)
1704             (y-or-n-p
1705              (format
1706               "Your .sig is %d lines; it should be max 4.  Really post? "
1707               (count-lines (point) (point-max))))
1708           t))))))
1709
1710 (defun message-check-element (type)
1711   "Returns non-nil if this type is not to be checked."
1712   (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
1713       t
1714     (let ((able (assq type message-syntax-checks)))
1715       (and (consp able)
1716            (eq (cdr able) 'disabled)))))
1717
1718 (defun message-checksum ()
1719   "Return a \"checksum\" for the current buffer."
1720   (let ((sum 0))
1721     (save-excursion
1722       (goto-char (point-min))
1723       (re-search-forward
1724        (concat "^" (regexp-quote mail-header-separator) "$"))
1725       (while (not (eobp))
1726         (when (not (looking-at "[ \t\n]"))
1727           (setq sum (logxor (ash sum 1) (following-char))))
1728         (forward-char 1)))
1729     sum))
1730
1731 (defun message-do-fcc ()
1732   "Process Fcc headers in the current buffer."
1733   (let ((case-fold-search t)
1734         (buf (current-buffer))
1735         list file)
1736     (save-excursion
1737       (set-buffer (get-buffer-create " *message temp*"))
1738       (buffer-disable-undo (current-buffer))
1739       (erase-buffer)
1740       (insert-buffer-substring buf)
1741       (save-restriction
1742         (message-narrow-to-headers)
1743         (while (setq file (message-fetch-field "fcc"))
1744           (push file list)
1745           (message-remove-header "fcc" nil t)))
1746       (goto-char (point-min))
1747       (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
1748       (replace-match "" t t)
1749       ;; Process FCC operations.
1750       (while list
1751         (setq file (pop list))
1752         (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
1753             ;; Pipe the article to the program in question.
1754             (call-process-region (point-min) (point-max) shell-file-name
1755                                  nil nil nil shell-command-switch
1756                                  (match-string 1 file))
1757           ;; Save the article.
1758           (setq file (expand-file-name file))
1759           (unless (file-exists-p (file-name-directory file))
1760             (make-directory (file-name-directory file) t))
1761           (if (and message-fcc-handler-function
1762                    (not (eq message-fcc-handler-function 'rmail-output)))
1763               (funcall message-fcc-handler-function file)
1764             (if (and (file-readable-p file) (mail-file-babyl-p file))
1765                 (rmail-output file 1)
1766               (let ((mail-use-rfc822 t))
1767                 (rmail-output file 1 t t))))))
1768       (kill-buffer (current-buffer)))))
1769
1770 (defun message-cleanup-headers ()
1771   "Do various automatic cleanups of the headers."
1772   ;; Remove empty lines in the header.
1773   (save-restriction
1774     (message-narrow-to-headers)
1775     (while (re-search-forward "^[ \t]*\n" nil t)
1776       (replace-match "" t t)))
1777
1778   ;; Correct Newsgroups and Followup-To headers: change sequence of
1779   ;; spaces to comma and eliminate spaces around commas.  Eliminate
1780   ;; embedded line breaks.
1781   (goto-char (point-min))
1782   (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
1783     (save-restriction
1784       (narrow-to-region
1785        (point)
1786        (if (re-search-forward "^[^ \t]" nil t)
1787            (match-beginning 0)
1788          (forward-line 1)
1789          (point)))
1790       (goto-char (point-min))
1791       (while (re-search-forward "\n[ \t]+" nil t)
1792         (replace-match " " t t))        ;No line breaks (too confusing)
1793       (goto-char (point-min))
1794       (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
1795         (replace-match "," t t))
1796       (goto-char (point-min))
1797       ;; Remove trailing commas.
1798       (when (re-search-forward ",+$" nil t)
1799         (replace-match "" t t)))))
1800
1801 (defun message-make-date ()
1802   "Make a valid data header."
1803   (let ((now (current-time)))
1804     (timezone-make-date-arpa-standard 
1805      (current-time-string now) (current-time-zone now))))
1806
1807 (defun message-make-message-id ()
1808   "Make a unique Message-ID."
1809   (concat "<" (message-unique-id) 
1810           (let ((psubject (save-excursion (message-fetch-field "subject"))))
1811             (if (and message-reply-headers
1812                      (mail-header-references message-reply-headers)
1813                      (mail-header-subject message-reply-headers)
1814                      psubject
1815                      (mail-header-subject message-reply-headers)
1816                      (not (string= 
1817                            (message-strip-subject-re
1818                             (mail-header-subject message-reply-headers))
1819                            (message-strip-subject-re psubject))))
1820                 "_-_" ""))
1821           "@" (message-make-fqdn) ">"))
1822
1823 (defvar message-unique-id-char nil)
1824
1825 ;; If you ever change this function, make sure the new version
1826 ;; cannot generate IDs that the old version could.
1827 ;; You might for example insert a "." somewhere (not next to another dot
1828 ;; or string boundary), or modify the "fsf" string.
1829 (defun message-unique-id ()
1830   ;; Don't use microseconds from (current-time), they may be unsupported.
1831   ;; Instead we use this randomly inited counter.
1832   (setq message-unique-id-char
1833         (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
1834            ;; (current-time) returns 16-bit ints,
1835            ;; and 2^16*25 just fits into 4 digits i base 36.
1836            (* 25 25)))
1837   (let ((tm (current-time)))
1838     (concat
1839      (if (memq system-type '(ms-dos emx vax-vms))
1840          (let ((user (downcase (user-login-name))))
1841            (while (string-match "[^a-z0-9_]" user)
1842              (aset user (match-beginning 0) ?_))
1843            user)
1844        (message-number-base36 (user-uid) -1))
1845      (message-number-base36 (+ (car   tm) 
1846                                (lsh (% message-unique-id-char 25) 16)) 4)
1847      (message-number-base36 (+ (nth 1 tm)
1848                                (lsh (/ message-unique-id-char 25) 16)) 4)
1849      ;; Append the newsreader name, because while the generated
1850      ;; ID is unique to this newsreader, other newsreaders might
1851      ;; otherwise generate the same ID via another algorithm.
1852      ".fsf")))
1853
1854 (defun message-number-base36 (num len)
1855   (if (if (< len 0) (<= num 0) (= len 0))
1856       ""
1857     (concat (message-number-base36 (/ num 36) (1- len))
1858             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
1859                                   (% num 36))))))
1860
1861 (defun message-make-organization ()
1862   "Make an Organization header."
1863   (let* ((organization 
1864           (or (getenv "ORGANIZATION")
1865               (when message-user-organization
1866                 (if (message-functionp message-user-organization)
1867                     (funcall message-user-organization)
1868                   message-user-organization)))))
1869     (save-excursion
1870       (message-set-work-buffer)
1871       (cond ((stringp organization)
1872              (insert organization))
1873             ((and (eq t organization)
1874                   message-user-organization-file
1875                   (file-exists-p message-user-organization-file))
1876              (insert-file-contents message-user-organization-file)))
1877       (goto-char (point-min))
1878       (while (re-search-forward "[\t\n]+" nil t)
1879         (replace-match "" t t))
1880       (unless (zerop (buffer-size))
1881         (buffer-string)))))
1882
1883 (defun message-make-lines ()
1884   "Count the number of lines and return numeric string."
1885   (save-excursion
1886     (save-restriction
1887       (widen)
1888       (goto-char (point-min))
1889       (re-search-forward 
1890        (concat "^" (regexp-quote mail-header-separator) "$"))
1891       (forward-line 1)
1892       (int-to-string (count-lines (point) (point-max))))))
1893
1894 (defun message-make-in-reply-to ()
1895   "Return the In-Reply-To header for this message."
1896   (when message-reply-headers
1897     (let ((from (mail-header-from message-reply-headers))
1898           (date (mail-header-date message-reply-headers)))
1899       (when from
1900         (let ((stop-pos 
1901                (string-match "  *at \\|  *@ \\| *(\\| *<" from)))
1902           (concat (if stop-pos (substring from 0 stop-pos) from)
1903                   "'s message of " 
1904                   (if (or (not date) (string= date ""))
1905                       "(unknown date)" date)))))))
1906
1907 (defun message-make-distribution ()
1908   "Make a Distribution header."
1909   (let ((orig-distribution (message-fetch-reply-field "distribution")))
1910     (cond ((message-functionp message-distribution-function)
1911            (funcall message-distribution-function))
1912           (t orig-distribution))))
1913
1914 (defun message-make-expires ()
1915   "Return an Expires header based on `message-expires'."
1916   (let ((current (current-time))
1917         (future (* 1.0 message-expires 60 60 24)))
1918     ;; Add the future to current.
1919     (setcar current (+ (car current) (round (/ future (expt 2 16)))))
1920     (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
1921     ;; Return the date in the future in UT.
1922     (timezone-make-date-arpa-standard 
1923      (current-time-string current) (current-time-zone current) '(0 "UT"))))
1924
1925 (defun message-make-path ()
1926   "Return uucp path."
1927   (let ((login-name (user-login-name)))
1928     (cond ((null message-user-path)
1929            (concat (system-name) "!" login-name))
1930           ((stringp message-user-path)
1931            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
1932            (concat message-user-path "!" login-name))
1933           (t login-name))))
1934
1935 (defun message-make-from ()
1936   "Make a From header."
1937   (let* ((login (message-make-address))
1938          (fullname 
1939           (or (and (boundp 'user-full-name)
1940                    user-full-name)
1941               (user-full-name))))
1942     (when (string= fullname "&")
1943       (setq fullname (user-login-name)))
1944     (save-excursion
1945       (message-set-work-buffer)
1946       (cond 
1947        ((or (null message-from-style)
1948             (equal fullname ""))
1949         (insert login))
1950        ((or (eq message-from-style 'angles)
1951             (and (not (eq message-from-style 'parens))
1952                  ;; Use angles if no quoting is needed, or if parens would
1953                  ;; need quoting too.
1954                  (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
1955                      (let ((tmp (concat fullname nil)))
1956                        (while (string-match "([^()]*)" tmp)
1957                          (aset tmp (match-beginning 0) ?-)
1958                          (aset tmp (1- (match-end 0)) ?-))
1959                        (string-match "[\\()]" tmp)))))
1960         (insert fullname)
1961         (goto-char (point-min))
1962         ;; Look for a character that cannot appear unquoted
1963         ;; according to RFC 822.
1964         (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
1965           ;; Quote fullname, escaping specials.
1966           (goto-char (point-min))
1967           (insert "\"")
1968           (while (re-search-forward "[\"\\]" nil 1)
1969             (replace-match "\\\\\\&" t))
1970           (insert "\""))
1971         (insert " <" login ">"))
1972        (t                               ; 'parens or default
1973         (insert login " (")
1974         (let ((fullname-start (point)))
1975           (insert fullname)
1976           (goto-char fullname-start)
1977           ;; RFC 822 says \ and nonmatching parentheses
1978           ;; must be escaped in comments.
1979           ;; Escape every instance of ()\ ...
1980           (while (re-search-forward "[()\\]" nil 1)
1981             (replace-match "\\\\\\&" t))
1982           ;; ... then undo escaping of matching parentheses,
1983           ;; including matching nested parentheses.
1984           (goto-char fullname-start)
1985           (while (re-search-forward 
1986                   "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
1987                     nil 1)
1988             (replace-match "\\1(\\3)" t)
1989             (goto-char fullname-start)))
1990         (insert ")")))
1991       (buffer-string))))
1992
1993 (defun message-make-sender ()
1994   "Return the \"real\" user address.
1995 This function tries to ignore all user modifications, and 
1996 give as trustworthy answer as possible."
1997   (concat (user-login-name) "@" (system-name)))
1998
1999 (defun message-make-address ()
2000   "Make the address of the user."
2001   (or (message-user-mail-address)
2002       (concat (user-login-name) "@" (message-make-domain))))
2003
2004 (defun message-user-mail-address ()
2005   "Return the pertinent part of `user-mail-address'."
2006   (when user-mail-address
2007     (nth 1 (mail-extract-address-components user-mail-address))))
2008
2009 (defun message-make-fqdn ()
2010   "Return user's fully qualified domain name."
2011   (let ((system-name (system-name))
2012         (user-mail (message-user-mail-address)))
2013     (cond 
2014      ((string-match "[^.]\\.[^.]" system-name)
2015       ;; `system-name' returned the right result.
2016       system-name)
2017      ;; Try `mail-host-address'.
2018      ((and (boundp 'mail-host-address)
2019            (stringp mail-host-address)
2020            (string-match "\\." mail-host-address))
2021       mail-host-address)
2022      ;; We try `user-mail-address' as a backup.
2023      ((and (string-match "\\." user-mail)
2024            (string-match "@\\(.*\\)\\'" user-mail))
2025       (match-string 1 user-mail))
2026      ;; Default to this bogus thing.
2027      (t
2028       (concat system-name ".i-have-a-misconfigured-system-so-shoot-me")))))
2029
2030 (defun message-make-host-name ()
2031   "Return the name of the host."
2032   (let ((fqdn (message-make-fqdn)))
2033     (string-match "^[^.]+\\." fqdn)
2034     (substring fqdn 0 (1- (match-end 0)))))
2035
2036 (defun message-make-domain ()
2037   "Return the domain name."
2038   (or mail-host-address
2039       (message-make-fqdn)))
2040
2041 (defun message-generate-headers (headers)
2042   "Prepare article HEADERS.
2043 Headers already prepared in the buffer are not modified."
2044   (save-restriction
2045     (message-narrow-to-headers)
2046     (let* ((Date (message-make-date))
2047            (Message-ID (message-make-message-id))
2048            (Organization (message-make-organization))
2049            (From (message-make-from))
2050            (Path (message-make-path))
2051            (Subject nil)
2052            (Newsgroups nil)
2053            (In-Reply-To (message-make-in-reply-to))
2054            (To nil)
2055            (Distribution (message-make-distribution))
2056            (Lines (message-make-lines))
2057            (X-Newsreader message-newsreader)
2058            (X-Mailer (and (not (message-fetch-field "X-Newsreader"))
2059                           message-mailer))
2060            (Expires (message-make-expires))
2061            (case-fold-search t)
2062            header value elem)
2063       ;; First we remove any old generated headers.
2064       (let ((headers message-deletable-headers))
2065         (while headers
2066           (goto-char (point-min))
2067           (and (re-search-forward 
2068                 (concat "^" (symbol-name (car headers)) ": *") nil t)
2069                (get-text-property (1+ (match-beginning 0)) 'message-deletable)
2070                (message-delete-line))
2071           (pop headers)))
2072       ;; Go through all the required headers and see if they are in the
2073       ;; articles already. If they are not, or are empty, they are
2074       ;; inserted automatically - except for Subject, Newsgroups and
2075       ;; Distribution. 
2076       (while headers
2077         (goto-char (point-min))
2078         (setq elem (pop headers))
2079         (if (consp elem)
2080             (if (eq (car elem) 'optional)
2081                 (setq header (cdr elem))
2082               (setq header (car elem)))
2083           (setq header elem))
2084         (when (or (not (re-search-forward 
2085                         (concat "^" (downcase (symbol-name header)) ":") 
2086                         nil t))
2087                   (progn
2088                     ;; The header was found. We insert a space after the
2089                     ;; colon, if there is none.
2090                     (if (/= (following-char) ? ) (insert " ") (forward-char 1))
2091                     ;; Find out whether the header is empty...
2092                     (looking-at "[ \t]*$")))
2093           ;; So we find out what value we should insert.
2094           (setq value
2095                 (cond 
2096                  ((and (consp elem) (eq (car elem) 'optional))
2097                   ;; This is an optional header.  If the cdr of this
2098                   ;; is something that is nil, then we do not insert
2099                   ;; this header.
2100                   (setq header (cdr elem))
2101                   (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
2102                       (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
2103                  ((consp elem)
2104                   ;; The element is a cons.  Either the cdr is a
2105                   ;; string to be inserted verbatim, or it is a
2106                   ;; function, and we insert the value returned from
2107                   ;; this function.
2108                   (or (and (stringp (cdr elem)) (cdr elem))
2109                       (and (fboundp (cdr elem)) (funcall (cdr elem)))))
2110                  ((and (boundp header) (symbol-value header))
2111                   ;; The element is a symbol.  We insert the value
2112                   ;; of this symbol, if any.
2113                   (symbol-value header))
2114                  (t
2115                   ;; We couldn't generate a value for this header,
2116                   ;; so we just ask the user.
2117                   (read-from-minibuffer
2118                    (format "Empty header for %s; enter value: " header)))))
2119           ;; Finally insert the header.
2120           (when (and value 
2121                      (not (equal value "")))
2122             (save-excursion
2123               (if (bolp)
2124                   (progn
2125                     ;; This header didn't exist, so we insert it.
2126                     (goto-char (point-max))
2127                     (insert (symbol-name header) ": " value "\n")
2128                     (forward-line -1))
2129                 ;; The value of this header was empty, so we clear
2130                 ;; totally and insert the new value.
2131                 (delete-region (point) (message-point-at-eol))
2132                 (insert value))
2133               ;; Add the deletable property to the headers that require it.
2134               (and (memq header message-deletable-headers)
2135                    (progn (beginning-of-line) (looking-at "[^:]+: "))
2136                    (add-text-properties 
2137                     (point) (match-end 0)
2138                     '(message-deletable t face italic) (current-buffer)))))))
2139       ;; Insert new Sender if the From is strange. 
2140       (let ((from (message-fetch-field "from"))
2141             (sender (message-fetch-field "sender"))
2142             (secure-sender (message-make-sender)))
2143         (when (and from 
2144                    (not (message-check-element 'sender))
2145                    (not (string=
2146                          (downcase
2147                           (cadr (mail-extract-address-components from)))
2148                          (downcase secure-sender)))
2149                    (or (null sender)
2150                        (not 
2151                         (string=
2152                          (downcase
2153                           (cadr (mail-extract-address-components sender)))
2154                          (downcase secure-sender)))))
2155           (goto-char (point-min))    
2156           ;; Rename any old Sender headers to Original-Sender.
2157           (when (re-search-forward "^Sender:" nil t)
2158             (beginning-of-line)
2159             (insert "Original-")
2160             (beginning-of-line))
2161           (insert "Sender: " secure-sender "\n"))))))
2162
2163 (defun message-insert-courtesy-copy ()
2164   "Insert a courtesy message in mail copies of combined messages."
2165   (save-excursion
2166     (save-restriction
2167       (message-narrow-to-headers)
2168       (let ((newsgroups (message-fetch-field "newsgroups")))
2169         (when newsgroups
2170           (goto-char (point-max))
2171           (insert "Posted-To: " newsgroups "\n"))))
2172     (forward-line 1)
2173     (insert message-courtesy-message)))
2174     
2175 ;;;
2176 ;;; Setting up a message buffer
2177 ;;;
2178
2179 (defun message-fill-address (header value)
2180   (save-restriction
2181     (narrow-to-region (point) (point))
2182     (insert (capitalize (symbol-name header))
2183             ": "
2184             (if (consp value) (car value) value)
2185             "\n")
2186     (narrow-to-region (point-min) (1- (point-max)))
2187     (let (quoted last)
2188       (goto-char (point-min))
2189       (while (not (eobp))
2190         (skip-chars-forward "^,\"" (point-max))
2191         (if (or (= (following-char) ?,)
2192                 (eobp))
2193             (when (not quoted)
2194               (if (and (> (current-column) 78)
2195                        last)
2196                   (progn
2197                     (save-excursion
2198                       (goto-char last)
2199                       (insert "\n\t"))
2200                     (setq last (1+ (point))))
2201                 (setq last (1+ (point)))))
2202           (setq quoted (not quoted)))
2203         (unless (eobp)
2204           (forward-char 1))))
2205     (goto-char (point-max))
2206     (widen)
2207     (forward-line 1)))
2208
2209 (defun message-fill-header (header value)
2210   (let ((begin (point))
2211         (fill-column 78)
2212         (fill-prefix "\t"))
2213     (insert (capitalize (symbol-name header))
2214             ": "
2215             (if (consp value) (car value) value)
2216             "\n")
2217     (save-restriction
2218       (narrow-to-region begin (point))
2219       (fill-region-as-paragraph begin (point))
2220       ;; Tapdance around looong Message-IDs.
2221       (forward-line -1)
2222       (when (looking-at "[ \t]*$")
2223         (message-delete-line))
2224       (goto-char begin)
2225       (re-search-forward ":" nil t)
2226       (when (looking-at "\n[ \t]+")
2227         (replace-match " " t t))
2228       (goto-char (point-max)))))
2229
2230 (defun message-position-point ()
2231   "Move point to where the user probably wants to find it."
2232   (message-narrow-to-headers)
2233   (cond 
2234    ((re-search-forward "^[^:]+:[ \t]*$" nil t)
2235     (search-backward ":" )
2236     (widen)
2237     (forward-char 1)
2238     (if (= (following-char) ? )
2239         (forward-char 1)
2240       (insert " ")))
2241    (t
2242     (goto-char (point-max))
2243     (widen)
2244     (forward-line 1)
2245     (unless (looking-at "$")
2246       (forward-line 2)))
2247    (sit-for 0)))
2248
2249 (defun message-buffer-name (type &optional to group)
2250   "Return a new (unique) buffer name based on TYPE and TO."
2251   (cond
2252    ;; Check whether `message-generate-new-buffers' is a function, 
2253    ;; and if so, call it.
2254    ((message-functionp message-generate-new-buffers)
2255     (funcall message-generate-new-buffers type to group))
2256    ;; Generate a new buffer name The Message Way.
2257    (message-generate-new-buffers
2258     (generate-new-buffer-name
2259      (concat "*" type
2260              (if to
2261                  (concat " to "
2262                          (or (car (mail-extract-address-components to))
2263                              to) "")
2264                "")
2265              (if (and group (not (string= group ""))) (concat " on " group) "")
2266              "*")))
2267    ;; Use standard name.
2268    (t
2269     (format "*%s message*" type))))
2270
2271 (defun message-pop-to-buffer (name)
2272   "Pop to buffer NAME, and warn if it already exists and is modified."
2273   (let ((buffer (get-buffer name)))
2274     (if (and buffer
2275              (buffer-name buffer))
2276         (progn
2277           (set-buffer (pop-to-buffer buffer))
2278           (when (and (buffer-modified-p)
2279                      (not (y-or-n-p
2280                            "Message already being composed; erase? ")))
2281             (error "Message being composed")))
2282       (set-buffer (pop-to-buffer name))))
2283   (erase-buffer)
2284   (message-mode))
2285
2286 (defun message-do-send-housekeeping ()
2287   "Kill old message buffers."
2288   ;; We might have sent this buffer already.  Delete it from the
2289   ;; list of buffers.
2290   (setq message-buffer-list (delq (current-buffer) message-buffer-list))
2291   (when (and message-max-buffers
2292              (>= (length message-buffer-list) message-max-buffers))
2293     ;; Kill the oldest buffer -- unless it has been changed.
2294     (let ((buffer (pop message-buffer-list)))
2295       (when (and (buffer-name buffer)
2296                  (not (buffer-modified-p buffer)))
2297         (kill-buffer buffer))))
2298   ;; Rename the buffer.
2299   (if message-send-rename-function
2300       (funcall message-send-rename-function)
2301     (when (string-match "\\`\\*" (buffer-name))
2302       (rename-buffer 
2303        (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
2304   ;; Push the current buffer onto the list.
2305   (when message-max-buffers
2306     (setq message-buffer-list 
2307           (nconc message-buffer-list (list (current-buffer))))))
2308
2309 (defvar mc-modes-alist)
2310 (defun message-setup (headers &optional replybuffer actions)
2311   (when (and (boundp 'mc-modes-alist)
2312              (not (assq 'message-mode mc-modes-alist)))
2313     (push '(message-mode (encrypt . mc-encrypt-message)
2314                          (sign . mc-sign-message))
2315           mc-modes-alist))
2316   (when actions
2317     (setq message-send-actions actions))
2318   (setq message-reply-buffer replybuffer)
2319   (goto-char (point-min))
2320   ;; Insert all the headers.
2321   (mail-header-format 
2322    (let ((h headers)
2323          (alist message-header-format-alist))
2324      (while h
2325        (unless (assq (caar h) message-header-format-alist)
2326          (push (list (caar h)) alist))
2327        (pop h))
2328      alist)
2329    headers)
2330   (delete-region (point) (progn (forward-line -1) (point)))
2331   (when message-default-headers
2332     (insert message-default-headers))
2333   (put-text-property
2334    (point)
2335    (progn
2336      (insert mail-header-separator "\n")
2337      (1- (point)))
2338    'read-only nil)
2339   (forward-line -1)
2340   (when (message-news-p)
2341     (when message-default-news-headers
2342       (insert message-default-news-headers))
2343     (when message-generate-headers-first
2344       (message-generate-headers
2345        (delq 'Lines
2346              (delq 'Subject
2347                    (copy-sequence message-required-news-headers))))))
2348   (when (message-mail-p)
2349     (when message-default-mail-headers
2350       (insert message-default-mail-headers))
2351     (when message-generate-headers-first
2352       (message-generate-headers
2353        (delq 'Lines
2354              (delq 'Subject
2355                    (copy-sequence message-required-mail-headers))))))
2356   (run-hooks 'message-signature-setup-hook)
2357   (message-insert-signature)
2358   (message-set-auto-save-file-name)
2359   (save-restriction
2360     (message-narrow-to-headers)
2361     (run-hooks 'message-header-setup-hook))
2362   (set-buffer-modified-p nil)
2363   (run-hooks 'message-setup-hook)
2364   (message-position-point)
2365   (undo-boundary))
2366
2367 (defun message-set-auto-save-file-name ()
2368   "Associate the message buffer with a file in the drafts directory."
2369   (when message-autosave-directory
2370     (unless (file-exists-p message-autosave-directory)
2371       (make-directory message-autosave-directory t))
2372     (let ((name (make-temp-name
2373                  (concat (file-name-as-directory message-autosave-directory)
2374                          "msg."))))
2375       (setq buffer-auto-save-file-name
2376             (save-excursion
2377               (prog1
2378                   (progn
2379                     (set-buffer (get-buffer-create " *draft tmp*"))
2380                     (setq buffer-file-name name)
2381                     (make-auto-save-file-name))
2382                 (kill-buffer (current-buffer)))))
2383       (clear-visited-file-modtime))))
2384
2385 \f
2386
2387 ;;;
2388 ;;; Commands for interfacing with message
2389 ;;;
2390
2391 ;;;###autoload
2392 (defun message-mail (&optional to subject)
2393   "Start editing a mail message to be sent."
2394   (interactive)
2395   (message-pop-to-buffer (message-buffer-name "mail" to))
2396   (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
2397
2398 ;;;###autoload
2399 (defun message-news (&optional newsgroups subject)
2400   "Start editing a news article to be sent."
2401   (interactive)
2402   (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
2403   (message-setup `((Newsgroups . ,(or newsgroups "")) 
2404                    (Subject . ,(or subject "")))))
2405
2406 ;;;###autoload
2407 (defun message-reply (&optional to-address wide ignore-reply-to)
2408   "Start editing a reply to the article in the current buffer."
2409   (interactive)
2410   (let ((cur (current-buffer))
2411         from subject date reply-to to cc
2412         references message-id follow-to 
2413         mct never-mct gnus-warning)
2414     (save-restriction
2415       (narrow-to-region
2416        (goto-char (point-min))
2417        (if (search-forward "\n\n" nil t)
2418            (1- (point))
2419          (point-max)))
2420       ;; Allow customizations to have their say.
2421       (if (not wide)
2422           ;; This is a regular reply.
2423           (if (message-functionp message-reply-to-function)
2424               (setq follow-to (funcall message-reply-to-function)))
2425         ;; This is a followup.
2426         (if (message-functionp message-wide-reply-to-function)
2427             (save-excursion
2428               (setq follow-to
2429                     (funcall message-wide-reply-to-function)))))
2430       ;; Find all relevant headers we need.
2431       (setq from (message-fetch-field "from")
2432             date (message-fetch-field "date") 
2433             subject (or (message-fetch-field "subject") "none")
2434             to (message-fetch-field "to")
2435             cc (message-fetch-field "cc")
2436             mct (message-fetch-field "mail-copies-to")
2437             reply-to (unless ignore-reply-to (message-fetch-field "reply-to"))
2438             references (message-fetch-field "references")
2439             message-id (message-fetch-field "message-id"))
2440       ;; Remove any (buggy) Re:'s that are present and make a
2441       ;; proper one.
2442       (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
2443         (setq subject (substring subject (match-end 0))))
2444       (setq subject (concat "Re: " subject))
2445
2446       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
2447                  (string-match "<[^>]+>" gnus-warning))
2448         (setq message-id (match-string 0 gnus-warning)))
2449             
2450       ;; Handle special values of Mail-Copies-To.
2451       (when mct
2452         (cond ((equal (downcase mct) "never")
2453                (setq never-mct t)
2454                (setq mct nil))
2455               ((equal (downcase mct) "always")
2456                (setq mct (or reply-to from)))))
2457
2458       (unless follow-to
2459         (if (or (not wide)
2460                 to-address)
2461             (setq follow-to (list (cons 'To (or to-address reply-to from))))
2462           (let (ccalist)
2463             (save-excursion
2464               (message-set-work-buffer)
2465               (unless never-mct
2466                 (insert (or reply-to from "")))
2467               (insert 
2468                (if (bolp) "" ", ") (or to "")
2469                (if mct (concat (if (bolp) "" ", ") mct) "")
2470                (if cc (concat (if (bolp) "" ", ") cc) ""))
2471               ;; Remove addresses that match `rmail-dont-reply-to-names'. 
2472               (insert (prog1 (rmail-dont-reply-to (buffer-string))
2473                         (erase-buffer)))
2474               (goto-char (point-min))
2475               (setq ccalist
2476                     (mapcar
2477                      (lambda (addr)
2478                        (cons (mail-strip-quoted-names addr) addr))
2479                      (nreverse (mail-parse-comma-list))))
2480               (let ((s ccalist))
2481                 (while s
2482                   (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
2483             (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
2484             (when ccalist
2485               (push (cons 'Cc
2486                           (mapconcat (lambda (addr) (cdr addr)) ccalist ", "))
2487                     follow-to)))))
2488       (widen))
2489
2490     (message-pop-to-buffer (message-buffer-name "reply" from))
2491
2492     (setq message-reply-headers
2493           (vector 0 subject from date message-id references 0 0 ""))
2494
2495     (message-setup
2496      `((Subject . ,subject)
2497        ,@follow-to 
2498        ,@(if (or references message-id)
2499              `((References . ,(concat (or references "") (and references " ")
2500                                       (or message-id ""))))
2501            nil))
2502      cur)))
2503
2504 ;;;###autoload
2505 (defun message-wide-reply (&optional to-address)
2506   (interactive)
2507   (message-reply to-address t))
2508
2509 ;;;###autoload
2510 (defun message-followup ()
2511   (interactive)
2512   (let ((cur (current-buffer))
2513         from subject date reply-to mct
2514         references message-id follow-to 
2515         followup-to distribution newsgroups gnus-warning)
2516     (save-restriction
2517       (narrow-to-region
2518        (goto-char (point-min))
2519        (if (search-forward "\n\n" nil t)
2520            (1- (point))
2521          (point-max)))
2522       (when (message-functionp message-followup-to-function)
2523         (setq follow-to
2524               (funcall message-followup-to-function)))
2525       (setq from (message-fetch-field "from")
2526             date (message-fetch-field "date") 
2527             subject (or (message-fetch-field "subject") "none")
2528             references (message-fetch-field "references")
2529             message-id (message-fetch-field "message-id")
2530             followup-to (message-fetch-field "followup-to")
2531             newsgroups (message-fetch-field "newsgroups")
2532             reply-to (message-fetch-field "reply-to")
2533             distribution (message-fetch-field "distribution")
2534             mct (message-fetch-field "mail-copies-to"))
2535       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
2536                  (string-match "<[^>]+>" gnus-warning))
2537         (setq message-id (match-string 0 gnus-warning)))
2538       ;; Remove bogus distribution.
2539       (and (stringp distribution)
2540            (string-match "world" distribution)
2541            (setq distribution nil))
2542       ;; Remove any (buggy) Re:'s that are present and make a
2543       ;; proper one.
2544       (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
2545         (setq subject (substring subject (match-end 0))))
2546       (setq subject (concat "Re: " subject))
2547       (widen))
2548
2549     (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
2550
2551     (message-setup
2552      `((Subject . ,subject)
2553        ,@(cond 
2554           (follow-to follow-to)
2555           ((and followup-to message-use-followup-to)
2556            (list
2557             (cond 
2558              ((equal (downcase followup-to) "poster")
2559               (if (or (eq message-use-followup-to 'use)
2560                       (message-y-or-n-p "Obey Followup-To: poster? " t "\
2561 You should normally obey the Followup-To: header.
2562
2563 `Followup-To: poster' sends your response via e-mail instead of news.
2564
2565 A typical situation where `Followup-To: poster' is used is when the poster
2566 does not read the newsgroup, so he wouldn't see any replies sent to it."))
2567                   (cons 'To (or reply-to from ""))
2568                 (cons 'Newsgroups newsgroups)))
2569              (t
2570               (if (or (equal followup-to newsgroups)
2571                       (not (eq message-use-followup-to 'ask))
2572                       (message-y-or-n-p
2573                        (concat "Obey Followup-To: " followup-to "? ") t "\
2574 You should normally obey the Followup-To: header.
2575
2576         `Followup-To: " followup-to "'
2577 directs your response to " (if (string-match "," followup-to)
2578                                "the specified newsgroups"
2579                              "that newsgroup only") ".
2580
2581 If a message is posted to several newsgroups, Followup-To is often
2582 used to direct the following discussion to one newsgroup only,
2583 because discussions that are spread over several newsgroup tend to
2584 be fragmented and very difficult to follow.
2585
2586 Also, some source/announcment newsgroups are not indented for discussion;
2587 responses here are directed to other newsgroups."))
2588                   (cons 'Newsgroups followup-to)
2589                 (cons 'Newsgroups newsgroups))))))
2590           (t
2591            `((Newsgroups . ,newsgroups))))
2592        ,@(and distribution (list (cons 'Distribution distribution)))
2593        (References . ,(concat (or references "") (and references " ")
2594                               (or message-id "")))
2595        ,@(when (and mct
2596                     (not (equal (downcase mct) "never")))
2597            (list (cons 'Cc (if (equal (downcase mct) "always")
2598                                (or reply-to from "")
2599                              mct)))))
2600
2601      cur)
2602
2603     (setq message-reply-headers
2604           (vector 0 subject from date message-id references 0 0 ""))))
2605
2606
2607 ;;;###autoload
2608 (defun message-cancel-news ()
2609   "Cancel an article you posted."
2610   (interactive)
2611   (unless (message-news-p)
2612     (error "This is not a news article; canceling is impossible"))
2613   (when (yes-or-no-p "Do you really want to cancel this article? ")
2614     (let (from newsgroups message-id distribution buf)
2615       (save-excursion
2616         ;; Get header info. from original article.
2617         (save-restriction
2618           (message-narrow-to-head)
2619           (setq from (message-fetch-field "from")
2620                 newsgroups (message-fetch-field "newsgroups")
2621                 message-id (message-fetch-field "message-id")
2622                 distribution (message-fetch-field "distribution")))
2623         ;; Make sure that this article was written by the user.
2624         (unless (string-equal
2625                  (downcase (cadr (mail-extract-address-components from)))
2626                  (downcase (message-make-address)))
2627           (error "This article is not yours"))
2628         ;; Make control message.
2629         (setq buf (set-buffer (get-buffer-create " *message cancel*")))
2630         (buffer-disable-undo (current-buffer))
2631         (erase-buffer)
2632         (insert "Newsgroups: " newsgroups "\n"
2633                 "From: " (message-make-from) "\n"
2634                 "Subject: cmsg cancel " message-id "\n"
2635                 "Control: cancel " message-id "\n"
2636                 (if distribution
2637                     (concat "Distribution: " distribution "\n")
2638                   "")
2639                 mail-header-separator "\n"
2640                 "This is a cancel message from " from ".\n")
2641         (message "Canceling your article...")
2642         (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me))
2643           (funcall message-send-news-function))
2644         (message "Canceling your article...done")
2645         (kill-buffer buf)))))
2646
2647 ;;;###autoload
2648 (defun message-supersede ()
2649   "Start composing a message to supersede the current message.
2650 This is done simply by taking the old article and adding a Supersedes
2651 header line with the old Message-ID."
2652   (interactive)
2653   (let ((cur (current-buffer)))
2654     ;; Check whether the user owns the article that is to be superseded. 
2655     (unless (string-equal
2656              (downcase (cadr (mail-extract-address-components
2657                               (message-fetch-field "from"))))
2658              (downcase (message-make-address)))
2659       (error "This article is not yours"))
2660     ;; Get a normal message buffer.
2661     (message-pop-to-buffer (message-buffer-name "supersede"))
2662     (insert-buffer-substring cur)
2663     (message-narrow-to-head)
2664     ;; Remove unwanted headers.
2665     (when message-ignored-supersedes-headers
2666       (message-remove-header message-ignored-supersedes-headers t))
2667     (goto-char (point-min))
2668     (if (not (re-search-forward "^Message-ID: " nil t))
2669         (error "No Message-ID in this article")
2670       (replace-match "Supersedes: " t t))
2671     (goto-char (point-max))
2672     (insert mail-header-separator)
2673     (widen)
2674     (forward-line 1)))
2675
2676 ;;;###autoload
2677 (defun message-recover ()
2678   "Reread contents of current buffer from its last auto-save file."
2679   (interactive)
2680   (let ((file-name (make-auto-save-file-name)))
2681     (cond ((save-window-excursion
2682              (if (not (eq system-type 'vax-vms))
2683                  (with-output-to-temp-buffer "*Directory*"
2684                    (buffer-disable-undo standard-output)
2685                    (let ((default-directory "/"))
2686                      (call-process
2687                       "ls" nil standard-output nil "-l" file-name))))
2688              (yes-or-no-p (format "Recover auto save file %s? " file-name)))
2689            (let ((buffer-read-only nil))
2690              (erase-buffer)
2691              (insert-file-contents file-name nil)))
2692           (t (error "message-recover cancelled")))))
2693
2694 ;;; Forwarding messages.
2695
2696 (defun message-make-forward-subject ()
2697   "Return a Subject header suitable for the message in the current buffer."
2698   (concat "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from"))
2699                   "(nowhere)")
2700           "] " (or (message-fetch-field "Subject") "")))
2701
2702 ;;;###autoload
2703 (defun message-forward (&optional news)
2704   "Forward the current message via mail.  
2705 Optional NEWS will use news to forward instead of mail."
2706   (interactive "P")
2707   (let ((cur (current-buffer))
2708         (subject (message-make-forward-subject)))
2709     (if news (message-news nil subject) (message-mail nil subject))
2710     ;; Put point where we want it before inserting the forwarded
2711     ;; message. 
2712     (if message-signature-before-forwarded-message
2713         (goto-char (point-max))
2714       (message-goto-body))
2715     ;; Make sure we're at the start of the line.
2716     (unless (eolp)
2717       (insert "\n"))
2718     ;; Narrow to the area we are to insert.
2719     (narrow-to-region (point) (point))
2720     ;; Insert the separators and the forwarded buffer.
2721     (insert message-forward-start-separator)
2722     (insert-buffer-substring cur)
2723     (goto-char (point-max))
2724     (insert message-forward-end-separator)
2725     (set-text-properties (point-min) (point-max) nil)
2726     ;; Remove all unwanted headers.
2727     (goto-char (point-min))
2728     (forward-line 1)
2729     (narrow-to-region (point) (if (search-forward "\n\n" nil t)
2730                                   (1- (point))
2731                                 (point)))
2732     (goto-char (point-min))
2733     (message-remove-header message-included-forward-headers t nil t)
2734     (widen)
2735     (message-position-point)))
2736
2737 ;;;###autoload
2738 (defun message-resend (address)
2739   "Resend the current article to ADDRESS."
2740   (interactive "sResend message to: ")
2741   (save-excursion
2742     (let ((cur (current-buffer))
2743           beg)
2744       ;; We first set up a normal mail buffer.
2745       (set-buffer (get-buffer-create " *message resend*"))
2746       (buffer-disable-undo (current-buffer))
2747       (erase-buffer)
2748       (message-setup `((To . ,address)))
2749       ;; Insert our usual headers.
2750       (message-generate-headers '(From Date To))
2751       (message-narrow-to-headers)
2752       ;; Rename them all to "Resent-*".
2753       (while (re-search-forward "^[A-Za-z]" nil t)
2754         (forward-char -1)
2755         (insert "Resent-"))
2756       (widen)
2757       (forward-line)
2758       (delete-region (point) (point-max))
2759       (setq beg (point))
2760       ;; Insert the message to be resent.
2761       (insert-buffer-substring cur)
2762       (goto-char (point-min))
2763       (search-forward "\n\n")
2764       (forward-char -1)
2765       (save-restriction
2766         (narrow-to-region beg (point))
2767         (message-remove-header message-ignored-resent-headers t)
2768         (goto-char (point-max)))
2769       (insert mail-header-separator)
2770       ;; Rename all old ("Also-")Resent headers.
2771       (while (re-search-backward "^\\(Also-\\)?Resent-" beg t)
2772         (beginning-of-line)
2773         (insert "Also-"))
2774       ;; Send it.
2775       (message-send-mail)
2776       (kill-buffer (current-buffer)))))
2777
2778 ;;;###autoload
2779 (defun message-bounce ()
2780   "Re-mail the current message.
2781 This only makes sense if the current message is a bounce message than
2782 contains some mail you have written which has been bounced back to
2783 you."
2784   (interactive)
2785   (let ((cur (current-buffer))
2786         boundary)
2787     (message-pop-to-buffer (message-buffer-name "bounce"))
2788     (insert-buffer-substring cur)
2789     (undo-boundary)
2790     (message-narrow-to-head)
2791     (if (and (message-fetch-field "Mime-Version")
2792              (setq boundary (message-fetch-field "Content-Type")))
2793         (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
2794             (setq boundary (concat (match-string 1 boundary) " *\n"
2795                                    "Content-Type: message/rfc822"))
2796           (setq boundary nil)))
2797     (widen)
2798     (goto-char (point-min))
2799     (search-forward "\n\n" nil t)
2800     (or (and boundary
2801              (re-search-forward boundary nil t)
2802              (forward-line 2))
2803         (and (re-search-forward message-unsent-separator nil t)
2804              (forward-line 1))
2805         (and (search-forward "\n\n" nil t)
2806              (re-search-forward "^Return-Path:.*\n" nil t)))
2807     ;; We remove everything before the bounced mail.
2808     (delete-region 
2809      (point-min)
2810      (if (re-search-forward "[^ \t]*:" nil t)
2811          (match-beginning 0)
2812        (point)))
2813     (save-restriction
2814       (message-narrow-to-head)
2815       (message-remove-header message-ignored-bounced-headers t)
2816       (goto-char (point-max))
2817       (insert mail-header-separator))
2818     (message-position-point)))
2819
2820 ;;;
2821 ;;; Interactive entry points for new message buffers.
2822 ;;;
2823
2824 ;;;###autoload
2825 (defun message-mail-other-window (&optional to subject)
2826   "Like `message-mail' command, but display mail buffer in another window."
2827   (interactive)
2828   (let ((pop-up-windows t)
2829         (special-display-buffer-names nil)
2830         (special-display-regexps nil)
2831         (same-window-buffer-names nil)
2832         (same-window-regexps nil))
2833     (message-pop-to-buffer (message-buffer-name "mail" to)))
2834   (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
2835
2836 ;;;###autoload
2837 (defun message-mail-other-frame (&optional to subject)
2838   "Like `message-mail' command, but display mail buffer in another frame."
2839   (interactive)
2840   (let ((pop-up-frames t)
2841         (special-display-buffer-names nil)
2842         (special-display-regexps nil)
2843         (same-window-buffer-names nil)
2844         (same-window-regexps nil))
2845     (message-pop-to-buffer (message-buffer-name "mail" to)))
2846   (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
2847
2848 ;;;###autoload
2849 (defun message-news-other-window (&optional newsgroups subject)
2850   "Start editing a news article to be sent."
2851   (interactive)
2852   (let ((pop-up-windows t)
2853         (special-display-buffer-names nil)
2854         (special-display-regexps nil)
2855         (same-window-buffer-names nil)
2856         (same-window-regexps nil))
2857     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
2858   (message-setup `((Newsgroups . ,(or newsgroups "")) 
2859                    (Subject . ,(or subject "")))))
2860
2861 ;;;###autoload
2862 (defun message-news-other-frame (&optional newsgroups subject)
2863   "Start editing a news article to be sent."
2864   (interactive)
2865   (let ((pop-up-frames t)
2866         (special-display-buffer-names nil)
2867         (special-display-regexps nil)
2868         (same-window-buffer-names nil)
2869         (same-window-regexps nil))
2870     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
2871   (message-setup `((Newsgroups . ,(or newsgroups "")) 
2872                    (Subject . ,(or subject "")))))
2873
2874 ;;; underline.el
2875
2876 ;; This code should be moved to underline.el (from which it is stolen). 
2877
2878 ;;;###autoload
2879 (defun bold-region (start end)
2880   "Bold all nonblank characters in the region.
2881 Works by overstriking characters.
2882 Called from program, takes two arguments START and END
2883 which specify the range to operate on."
2884   (interactive "r")
2885   (save-excursion
2886    (let ((end1 (make-marker)))
2887      (move-marker end1 (max start end))
2888      (goto-char (min start end))
2889      (while (< (point) end1)
2890        (or (looking-at "[_\^@- ]")
2891            (insert (following-char) "\b"))
2892        (forward-char 1)))))
2893
2894 ;;;###autoload
2895 (defun unbold-region (start end)
2896   "Remove all boldness (overstruck characters) in the region.
2897 Called from program, takes two arguments START and END
2898 which specify the range to operate on."
2899   (interactive "r")
2900   (save-excursion
2901    (let ((end1 (make-marker)))
2902      (move-marker end1 (max start end))
2903      (goto-char (min start end)) 
2904      (while (re-search-forward "\b" end1 t)
2905        (if (eq (following-char) (char-after (- (point) 2)))
2906            (delete-char -2))))))
2907
2908 (fset 'message-exchange-point-and-mark 'exchange-point-and-mark)
2909
2910 ;; Support for toolbar
2911 (when (string-match "XEmacs\\|Lucid" emacs-version)
2912   (require 'messagexmas))
2913
2914 ;;; Group name completion.
2915
2916 (defvar message-newgroups-header-regexp
2917   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\):"
2918   "Regexp that match headers that lists groups.")
2919
2920 (defun message-tab ()
2921   "Expand group names in Newsgroups and Followup-To headers.
2922 Do a `tab-to-tab-stop' if not in those headers."
2923   (interactive)
2924   (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
2925         (mail-abbrev-in-expansion-header-p))
2926       (message-expand-group)
2927     (tab-to-tab-stop)))
2928
2929 (defvar gnus-active-hashtb)
2930 (defun message-expand-group ()
2931   (let* ((b (save-excursion (skip-chars-backward "^, :\t\n") (point)))
2932          (completion-ignore-case t)
2933          (string (buffer-substring b (point)))
2934          (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
2935          (completions (all-completions string hashtb))
2936          (cur (current-buffer))
2937          comp)
2938     (delete-region b (point))
2939     (cond 
2940      ((= (length completions) 1)
2941       (if (string= (car completions) string)
2942           (progn
2943             (insert string)
2944             (message "Only matching group"))
2945         (insert (car completions))))
2946      ((and (setq comp (try-completion string hashtb))
2947            (not (string= comp string)))
2948       (insert comp))
2949      (t
2950       (insert string)
2951       (if (not comp)
2952           (message "No matching groups")
2953         (pop-to-buffer "*Completions*")
2954         (buffer-disable-undo (current-buffer))
2955         (let ((buffer-read-only nil))
2956           (erase-buffer)
2957           (let ((standard-output (current-buffer)))
2958             (display-completion-list (sort completions 'string<)))
2959           (goto-char (point-min))
2960           (pop-to-buffer cur)))))))
2961
2962 ;;; Help stuff.
2963
2964 (defmacro message-y-or-n-p (question show &rest text)
2965   "Ask QUESTION, displaying the rest of the arguments in a temporary buffer."
2966   `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
2967
2968 (defun message-talkative-question (ask question show &rest text)
2969   "Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW.  
2970 The following arguments may contain lists of values."
2971   (if (and show
2972            (setq text (message-flatten-list text)))
2973       (save-window-excursion
2974         (save-excursion
2975           (with-output-to-temp-buffer " *MESSAGE information message*"
2976             (set-buffer " *MESSAGE information message*")
2977             (mapcar 'princ text)
2978             (goto-char (point-min))))
2979         (funcall ask question))
2980     (funcall ask question)))
2981
2982 (defun message-flatten-list (&rest list)
2983   (message-flatten-list-1 list))
2984
2985 (defun message-flatten-list-1 (list)
2986   (cond ((consp list) 
2987          (apply 'append (mapcar 'message-flatten-list-1 list)))
2988         (list
2989          (list list))))
2990
2991 (run-hooks 'message-load-hook)
2992
2993 (provide 'message)
2994
2995 ;;; message.el ends here