git.chise.org Git - elisp/gnus.git-/blob - lisp/message.el

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