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

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