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

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