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

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