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           (message-reply-headers (or message-reply-headers
2411                                      (make-mail-header))))
2412       (mail-header-set-from message-reply-headers
2413                             (save-restriction
2414                               (narrow-to-region
2415                                (point)
2416                                (if (search-forward "\n\n" nil t)
2417                                    (1- (point))
2418                                  (point-max)))
2419                               (or (message-fetch-field "from")
2420                                   "unknown sender")))
2421       (goto-char start)
2422       (while functions
2423         (funcall (pop functions)))
2424       (when message-citation-line-function
2425         (unless (bolp)
2426           (insert "\n"))
2427         (funcall message-citation-line-function)))))
2428
2429 (defun message-insert-citation-line ()
2430   "Function that inserts a simple citation line."
2431   (when message-reply-headers
2432     (insert (mail-header-from message-reply-headers) " writes:\n\n")))
2433
2434 (defun message-position-on-field (header &rest afters)
2435   (let ((case-fold-search t))
2436     (save-restriction
2437       (narrow-to-region
2438        (goto-char (point-min))
2439        (progn
2440          (re-search-forward
2441           (concat "^" (regexp-quote mail-header-separator) "$"))
2442          (match-beginning 0)))
2443       (goto-char (point-min))
2444       (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
2445           (progn
2446             (re-search-forward "^[^ \t]" nil 'move)
2447             (beginning-of-line)
2448             (skip-chars-backward "\n")
2449             t)
2450         (while (and afters
2451                     (not (re-search-forward
2452                           (concat "^" (regexp-quote (car afters)) ":")
2453                           nil t)))
2454           (pop afters))
2455         (when afters
2456           (re-search-forward "^[^ \t]" nil 'move)
2457           (beginning-of-line))
2458         (insert header ": \n")
2459         (forward-char -1)
2460         nil))))
2461
2462 (defun message-remove-signature ()
2463   "Remove the signature from the text between point and mark.
2464 The text will also be indented the normal way."
2465   (save-excursion
2466     (let ((start (point))
2467           mark)
2468       (if (not (re-search-forward message-signature-separator (mark t) t))
2469           ;; No signature here, so we just indent the cited text.
2470           (message-indent-citation)
2471         ;; Find the last non-empty line.
2472         (forward-line -1)
2473         (while (looking-at "[ \t]*$")
2474           (forward-line -1))
2475         (forward-line 1)
2476         (setq mark (set-marker (make-marker) (point)))
2477         (goto-char start)
2478         (message-indent-citation)
2479         ;; Enable undoing the deletion.
2480         (undo-boundary)
2481         (delete-region mark (mark t))
2482         (set-marker mark nil)))))
2483
2484 \f
2485
2486 ;;;
2487 ;;; Sending messages
2488 ;;;
2489
2490 ;; Avoid byte-compile warning.
2491 (defvar message-encoding-buffer nil)
2492 (defvar message-edit-buffer nil)
2493 (defvar message-mime-mode nil)
2494
2495 (defun message-send-and-exit (&optional arg)
2496   "Send message like `message-send', then, if no errors, exit from mail buffer."
2497   (interactive "P")
2498   (let ((buf (current-buffer))
2499         (actions message-exit-actions)
2500         (frame (selected-frame))
2501         (org-frame message-original-frame))
2502     (when (and (message-send arg)
2503                (buffer-name buf))
2504       (if message-kill-buffer-on-exit
2505           (kill-buffer buf)
2506         (bury-buffer buf)
2507         (when (eq buf (current-buffer))
2508           (message-bury buf)))
2509       (message-do-actions actions)
2510       (message-delete-frame frame org-frame)
2511       t)))
2512
2513 (defun message-dont-send ()
2514   "Don't send the message you have been editing."
2515   (interactive)
2516   (message-save-drafts)
2517   (let ((actions message-postpone-actions)
2518         (frame (selected-frame))
2519         (org-frame message-original-frame))
2520     (message-bury (current-buffer))
2521     (message-do-actions actions)
2522     (message-delete-frame frame org-frame)))
2523
2524 (defun message-kill-buffer ()
2525   "Kill the current buffer."
2526   (interactive)
2527   (when (or (not (buffer-modified-p))
2528             (eq t message-kill-buffer-query-function)
2529             (funcall message-kill-buffer-query-function
2530                      "The buffer modified; kill anyway? "))
2531     (let ((actions message-kill-actions)
2532           (frame (selected-frame))
2533           (org-frame message-original-frame))
2534       (setq buffer-file-name nil)
2535       (kill-buffer (current-buffer))
2536       (message-do-actions actions)
2537       (message-delete-frame frame org-frame)))
2538   (message ""))
2539
2540 (defun message-mimic-kill-buffer ()
2541   "Kill the current buffer with query."
2542   (interactive)
2543   (unless (eq 'message-mode major-mode)
2544     (error "%s must be invoked from a message buffer." this-command))
2545   (let ((command this-command)
2546         (bufname (read-buffer (format "Kill buffer: (default %s) "
2547                                       (buffer-name)))))
2548     (if (or (not bufname)
2549             (string-equal bufname "")
2550             (string-equal bufname (buffer-name)))
2551         (message-kill-buffer)
2552       (message "%s must be invoked only for the current buffer." command))))
2553
2554 (defun message-delete-frame (frame org-frame)
2555   "Delete frame for editing message."
2556   (when (and (or (static-if (featurep 'xemacs)
2557                      (device-on-window-system-p)
2558                    window-system)
2559                  (>= emacs-major-version 20))
2560              (or (and (eq message-delete-frame-on-exit t)
2561                       (select-frame frame)
2562                       (or (eq frame org-frame)
2563                           (prog1
2564                               (y-or-n-p "Delete this frame?")
2565                             (message ""))))
2566                  (and (eq message-delete-frame-on-exit 'ask)
2567                       (select-frame frame)
2568                       (prog1
2569                           (y-or-n-p "Delete this frame?")
2570                         (message "")))))
2571     (delete-frame frame)))
2572
2573 (defun message-bury (buffer)
2574   "Bury this mail buffer."
2575   (let ((newbuf (other-buffer buffer)))
2576     (bury-buffer buffer)
2577     (if (and (fboundp 'frame-parameters)
2578              (cdr (assq 'dedicated (frame-parameters)))
2579              (not (null (delq (selected-frame) (visible-frame-list)))))
2580         (delete-frame (selected-frame))
2581       (switch-to-buffer newbuf))))
2582
2583 (defun message-send (&optional arg)
2584   "Send the message in the current buffer.
2585 If `message-interactive' is non-nil, wait for success indication or
2586 error messages, and inform user.
2587 Otherwise any failure is reported in a message back to the user from
2588 the mailer.
2589 The usage of ARG is defined by the instance that called Message.
2590 It should typically alter the sending method in some way or other."
2591   (interactive "P")
2592   ;; Disabled test.
2593   (when (or (buffer-modified-p)
2594             (message-check-element 'unchanged)
2595             (y-or-n-p "No changes in the buffer; really send? "))
2596     ;; Make it possible to undo the coming changes.
2597     (undo-boundary)
2598     (let ((inhibit-read-only t))
2599       (put-text-property (point-min) (point-max) 'read-only nil))
2600     (run-hooks 'message-send-hook)
2601     (message "Sending...")
2602     (let ((message-encoding-buffer
2603            (message-generate-new-buffer-clone-locals " message encoding"))
2604           (message-edit-buffer (current-buffer))
2605           (message-mime-mode mime-edit-mode-flag)
2606           (alist message-send-method-alist)
2607           (success t)
2608           elem sent)
2609       (save-excursion
2610         (set-buffer message-encoding-buffer)
2611         (erase-buffer)
2612         (insert-buffer message-edit-buffer)
2613         (funcall message-encode-function)
2614         (message-fix-before-sending)
2615         (while (and success
2616                     (setq elem (pop alist)))
2617           (when (or (not (funcall (cadr elem)))
2618                     (and (or (not (memq (car elem)
2619                                         message-sent-message-via))
2620                              (y-or-n-p
2621                               (format
2622                                "Already sent message via %s; resend? "
2623                                (car elem))))
2624                          (setq success (funcall (caddr elem) arg))))
2625             (setq sent t))))
2626       (unless (or sent (not success))
2627         (error "No methods specified to send by"))
2628       (prog1
2629           (when (and success sent)
2630             (message-do-fcc)
2631             (save-excursion
2632               (run-hooks 'message-sent-hook))
2633             (message "Sending...done")
2634             ;; Mark the buffer as unmodified and delete autosave.
2635             (set-buffer-modified-p nil)
2636             (delete-auto-save-file-if-necessary t)
2637             (message-disassociate-draft)
2638             ;; Delete other mail buffers and stuff.
2639             (message-do-send-housekeeping)
2640             (message-do-actions message-send-actions)
2641             ;; Return success.
2642             t)
2643         (kill-buffer message-encoding-buffer)))))
2644
2645 (defun message-send-via-mail (arg)
2646   "Send the current message via mail."
2647   (message-send-mail arg))
2648
2649 (defun message-send-via-news (arg)
2650   "Send the current message via news."
2651   (message-send-news arg))
2652
2653 (defmacro message-check (type &rest forms)
2654   "Eval FORMS if TYPE is to be checked."
2655   `(or (message-check-element ,type)
2656        (save-excursion
2657          ,@forms)))
2658
2659 (put 'message-check 'lisp-indent-function 1)
2660 (put 'message-check 'edebug-form-spec '(form body))
2661
2662 (defun message-fix-before-sending ()
2663   "Do various things to make the message nice before sending it."
2664   ;; Make sure there's a newline at the end of the message.
2665   (goto-char (point-max))
2666   (unless (bolp)
2667     (insert "\n"))
2668   ;; Delete all invisible text.
2669   (message-check 'invisible-text
2670     (when (text-property-any (point-min) (point-max) 'invisible t)
2671       (put-text-property (point-min) (point-max) 'invisible nil)
2672       (unless (yes-or-no-p
2673                "Invisible text found and made visible; continue posting? ")
2674         (error "Invisible text found and made visible")))))
2675
2676 (defun message-add-action (action &rest types)
2677   "Add ACTION to be performed when doing an exit of type TYPES."
2678   (let (var)
2679     (while types
2680       (set (setq var (intern (format "message-%s-actions" (pop types))))
2681            (nconc (symbol-value var) (list action))))))
2682
2683 (defun message-do-actions (actions)
2684   "Perform all actions in ACTIONS."
2685   ;; Now perform actions on successful sending.
2686   (while actions
2687     (ignore-errors
2688       (cond
2689        ;; A simple function.
2690        ((message-functionp (car actions))
2691         (funcall (car actions)))
2692        ;; Something to be evaled.
2693        (t
2694         (eval (car actions)))))
2695     (pop actions)))
2696
2697 (defsubst message-maybe-split-and-send-mail ()
2698   "Split a message if necessary, and send it via mail.
2699 Returns nil if sending succeeded, returns any string if sending failed.
2700 This sub function is for exclusive use of `message-send-mail'."
2701   (let ((mime-edit-split-ignored-field-regexp
2702          mime-edit-split-ignored-field-regexp)
2703         (case-fold-search t)
2704         failure)
2705     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
2706       (setq mime-edit-split-ignored-field-regexp
2707             (concat (substring mime-edit-split-ignored-field-regexp
2708                                0 (match-beginning 0))
2709                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
2710                     "_so_don't_rape_it!"
2711                     (substring mime-edit-split-ignored-field-regexp
2712                                (match-end 0)))))
2713     (setq failure
2714           (or
2715            (catch 'message-sending-mail-failure
2716              (mime-edit-maybe-split-and-send
2717               (function
2718                (lambda ()
2719                  (interactive)
2720                  (save-restriction
2721                    (std11-narrow-to-header mail-header-separator)
2722                    (goto-char (point-min))
2723                    (when (re-search-forward "^Message-ID:" nil t)
2724                      (delete-region (match-end 0) (std11-field-end))
2725                      (insert " " (message-make-message-id))))
2726                  (condition-case err
2727                      (funcall message-send-mail-function)
2728                    (error
2729                     (throw 'message-sending-mail-failure err))))))
2730              nil)
2731            (condition-case err
2732                (progn
2733                  (funcall message-send-mail-function)
2734                  nil)
2735              (error err))))
2736     (when failure
2737       (if (eq 'error (car failure))
2738           (cadr failure)
2739         (prin1-to-string failure)))))
2740
2741 (defun message-send-mail (&optional arg)
2742   (require 'mail-utils)
2743   (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
2744          (case-fold-search nil)
2745          (news (message-news-p))
2746          (message-this-is-mail t)
2747          failure)
2748     (save-restriction
2749       (message-narrow-to-headers)
2750       ;; Insert some headers.
2751       (let ((message-deletable-headers
2752              (if news nil message-deletable-headers)))
2753         (message-generate-headers message-required-mail-headers))
2754       ;; Let the user do all of the above.
2755       (run-hooks 'message-header-hook))
2756     (if (not (message-check-mail-syntax))
2757         (progn
2758           (message "")
2759           nil)
2760       (unwind-protect
2761           (save-excursion
2762             (set-buffer tembuf)
2763             (erase-buffer)
2764             (insert-buffer message-encoding-buffer)
2765             ;; Remove some headers.
2766             (save-restriction
2767               (message-narrow-to-headers)
2768 ;; We Semi-gnus people have no use for it.
2769 ;;            ;; We (re)generate the Lines header.
2770 ;;            (when (memq 'Lines message-required-mail-headers)
2771 ;;              (message-generate-headers '(Lines)))
2772               ;; Remove some headers.
2773               (message-remove-header message-ignored-mail-headers t))
2774             (goto-char (point-max))
2775             ;; require one newline at the end.
2776             (or (= (preceding-char) ?\n)
2777                 (insert ?\n))
2778             (when (and news
2779                        (or (message-fetch-field "cc")
2780                            (message-fetch-field "to")))
2781               (message-insert-courtesy-copy))
2782             (setq failure (message-maybe-split-and-send-mail)))
2783         (kill-buffer tembuf))
2784       (set-buffer message-edit-buffer)
2785       (if failure
2786           (progn
2787             (message "Couldn't send message via mail: %s" failure)
2788             nil)
2789         (push 'mail message-sent-message-via)))))
2790
2791 (defun message-send-mail-with-sendmail ()
2792   "Send off the prepared buffer with sendmail."
2793   (let ((errbuf (if message-interactive
2794                     (message-generate-new-buffer-clone-locals " sendmail errors")
2795                   0))
2796         resend-to-addresses delimline)
2797     (let ((case-fold-search t))
2798       (save-restriction
2799         (message-narrow-to-headers)
2800         (setq resend-to-addresses (message-fetch-field "resent-to")))
2801       ;; Change header-delimiter to be what sendmail expects.
2802       (goto-char (point-min))
2803       (re-search-forward
2804        (concat "^" (regexp-quote mail-header-separator) "\n"))
2805       (replace-match "\n")
2806       (backward-char 1)
2807       (setq delimline (point-marker))
2808       (run-hooks 'message-send-mail-hook)
2809       ;; Insert an extra newline if we need it to work around
2810       ;; Sun's bug that swallows newlines.
2811       (goto-char (1+ delimline))
2812       (when (eval message-mailer-swallows-blank-line)
2813         (newline))
2814       (when message-interactive
2815         (save-excursion
2816           (set-buffer errbuf)
2817           (erase-buffer))))
2818     (let ((default-directory "/"))
2819       (as-binary-process
2820        (apply 'call-process-region
2821               (append (list (point-min) (point-max)
2822                             (if (boundp 'sendmail-program)
2823                                 sendmail-program
2824                               "/usr/lib/sendmail")
2825                             nil errbuf nil "-oi")
2826                       ;; Always specify who from,
2827                       ;; since some systems have broken sendmails.
2828                       ;; But some systems are more broken with -f, so
2829                       ;; we'll let users override this.
2830                       (if (null message-sendmail-f-is-evil)
2831                           (list "-f" (message-make-address)))
2832                       ;; These mean "report errors by mail"
2833                       ;; and "deliver in background".
2834                       (if (null message-interactive) '("-oem" "-odb"))
2835                       ;; Get the addresses from the message
2836                       ;; unless this is a resend.
2837                       ;; We must not do that for a resend
2838                       ;; because we would find the original addresses.
2839                       ;; For a resend, include the specific addresses.
2840                       (if resend-to-addresses
2841                           (list resend-to-addresses)
2842                         '("-t"))))))
2843     (when message-interactive
2844       (save-excursion
2845         (set-buffer errbuf)
2846         (goto-char (point-min))
2847         (while (re-search-forward "\n\n* *" nil t)
2848           (replace-match "; "))
2849         (if (not (zerop (buffer-size)))
2850             (error "Sending...failed to %s"
2851                    (buffer-substring (point-min) (point-max)))))
2852       (when (bufferp errbuf)
2853         (kill-buffer errbuf)))))
2854
2855 (defun message-send-mail-with-qmail ()
2856   "Pass the prepared message buffer to qmail-inject.
2857 Refer to the documentation for the variable `message-send-mail-function'
2858 to find out how to use this."
2859   ;; replace the header delimiter with a blank line
2860   (goto-char (point-min))
2861   (re-search-forward
2862    (concat "^" (regexp-quote mail-header-separator) "\n"))
2863   (replace-match "\n")
2864   (backward-char 1)
2865   (run-hooks 'message-send-mail-hook)
2866   ;; send the message
2867   (case
2868       (as-binary-process
2869        (apply
2870         'call-process-region 1 (point-max) message-qmail-inject-program
2871         nil nil nil
2872         ;; qmail-inject's default behaviour is to look for addresses on the
2873         ;; command line; if there're none, it scans the headers.
2874         ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
2875         ;;
2876         ;; in general, ALL of qmail-inject's defaults are perfect for simply
2877         ;; reading a formatted (i. e., at least a To: or Resent-To header)
2878         ;; message from stdin.
2879         ;;
2880         ;; qmail also has the advantage of not having been raped by
2881         ;; various vendors, so we don't have to allow for that, either --
2882         ;; compare this with message-send-mail-with-sendmail and weep
2883         ;; for sendmail's lost innocence.
2884         ;;
2885         ;; all this is way cool coz it lets us keep the arguments entirely
2886         ;; free for -inject-arguments -- a big win for the user and for us
2887         ;; since we don't have to play that double-guessing game and the user
2888         ;; gets full control (no gestapo'ish -f's, for instance).  --sj
2889         message-qmail-inject-args))
2890     ;; qmail-inject doesn't say anything on it's stdout/stderr,
2891     ;; we have to look at the retval instead
2892     (0 nil)
2893     (1   (error "qmail-inject reported permanent failure"))
2894     (111 (error "qmail-inject reported transient failure"))
2895     ;; should never happen
2896     (t   (error "qmail-inject reported unknown failure"))))
2897
2898 (defun message-send-mail-with-mh ()
2899   "Send the prepared message buffer with mh."
2900   (let ((mh-previous-window-config nil)
2901         (name (mh-new-draft-name)))
2902     (setq buffer-file-name name)
2903     ;; MH wants to generate these headers itself.
2904     (when message-mh-deletable-headers
2905       (let ((headers message-mh-deletable-headers))
2906         (while headers
2907           (goto-char (point-min))
2908           (and (re-search-forward
2909                 (concat "^" (symbol-name (car headers)) ": *") nil t)
2910                (message-delete-line))
2911           (pop headers))))
2912     (run-hooks 'message-send-mail-hook)
2913     ;; Pass it on to mh.
2914     (mh-send-letter)))
2915
2916 (defun message-send-mail-with-smtp ()
2917   "Send off the prepared buffer with SMTP."
2918   (require 'smtp) ; XXX
2919   (let ((case-fold-search t)
2920         recipients)
2921     (save-restriction
2922       (message-narrow-to-headers)
2923       (setq recipients
2924             ;; XXX: Should be replaced by better one.
2925             (smtp-deduce-address-list (current-buffer)
2926                                       (point-min) (point-max)))
2927       ;; Remove BCC lines.
2928       (message-remove-header "bcc"))
2929     ;; replace the header delimiter with a blank line.
2930     (goto-char (point-min))
2931     (re-search-forward
2932      (concat "^" (regexp-quote mail-header-separator) "\n"))
2933     (replace-match "\n")
2934     (backward-char 1)
2935     (run-hooks 'message-send-mail-hook)
2936     (if recipients
2937         (let ((result (smtp-via-smtp user-mail-address
2938                                      recipients
2939                                      (current-buffer))))
2940           (unless (eq result t)
2941             (error "Sending failed; " result)))
2942       (error "Sending failed; no recipients"))))
2943
2944 (defsubst message-maybe-split-and-send-news (method)
2945   "Split a message if necessary, and send it via news.
2946 Returns nil if sending succeeded, returns t if sending failed.
2947 This sub function is for exclusive use of `message-send-news'."
2948   (let ((mime-edit-split-ignored-field-regexp
2949          mime-edit-split-ignored-field-regexp)
2950         (case-fold-search t))
2951     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
2952       (setq mime-edit-split-ignored-field-regexp
2953             (concat (substring mime-edit-split-ignored-field-regexp
2954                                0 (match-beginning 0))
2955                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
2956                     "_so_don't_rape_it!"
2957                     (substring mime-edit-split-ignored-field-regexp
2958                                (match-end 0)))))
2959     (or
2960      (catch 'message-sending-news-failure
2961        (mime-edit-maybe-split-and-send
2962         (function
2963          (lambda ()
2964            (interactive)
2965            (save-restriction
2966              (std11-narrow-to-header mail-header-separator)
2967              (goto-char (point-min))
2968              (when (re-search-forward "^Message-ID:" nil t)
2969                (delete-region (match-end 0) (std11-field-end))
2970                (insert " " (message-make-message-id))))
2971            (unless (funcall message-send-news-function method)
2972              (throw 'message-sending-news-failure t)))))
2973        nil)
2974      (not (funcall message-send-news-function method)))))
2975
2976 (defun message-send-news (&optional arg)
2977   (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
2978          (case-fold-search nil)
2979          (method (if (message-functionp message-post-method)
2980                      (funcall message-post-method arg)
2981                    message-post-method))
2982          (message-syntax-checks
2983           (if arg
2984               (cons '(existing-newsgroups . disabled)
2985                     message-syntax-checks)
2986             message-syntax-checks))
2987          (message-this-is-news t)
2988          result)
2989     (save-restriction
2990       (message-narrow-to-headers)
2991       ;; Insert some headers.
2992       (message-generate-headers message-required-news-headers)
2993       ;; Let the user do all of the above.
2994       (run-hooks 'message-header-hook))
2995     (message-cleanup-headers)
2996     (if (not (message-check-news-syntax))
2997         nil
2998       (unwind-protect
2999           (save-excursion
3000             (set-buffer tembuf)
3001             (buffer-disable-undo)
3002             (erase-buffer)
3003             (insert-buffer message-encoding-buffer)
3004             ;; Remove some headers.
3005             (save-restriction
3006               (message-narrow-to-headers)
3007 ;; We Semi-gnus people have no use for it.
3008 ;;            ;; We (re)generate the Lines header.
3009 ;;            (when (memq 'Lines message-required-mail-headers)
3010 ;;              (message-generate-headers '(Lines)))
3011               ;; Remove some headers.
3012               (message-remove-header message-ignored-news-headers t))
3013             (goto-char (point-max))
3014             ;; require one newline at the end.
3015             (or (= (preceding-char) ?\n)
3016                 (insert ?\n))
3017             (setq result (message-maybe-split-and-send-news method)))
3018         (kill-buffer tembuf))
3019       (set-buffer message-edit-buffer)
3020       (if result
3021           (progn
3022             (message "Couldn't send message via news: %s"
3023                      (nnheader-get-report (car method)))
3024             nil)
3025         (push 'news message-sent-message-via)))))
3026
3027 ;; 1997-09-29 by MORIOKA Tomohiko
3028 (defun message-send-news-with-gnus (method)
3029   (let ((case-fold-search t))
3030     ;; Remove the delimiter.
3031     (goto-char (point-min))
3032     (re-search-forward
3033      (concat "^" (regexp-quote mail-header-separator) "\n"))
3034     (replace-match "\n")
3035     (backward-char 1)
3036     (run-hooks 'message-send-news-hook)
3037     (gnus-open-server method)
3038     (gnus-request-post method)
3039     ))
3040
3041 ;;;
3042 ;;; Header generation & syntax checking.
3043 ;;;
3044
3045 (defun message-check-element (type)
3046   "Returns non-nil if this type is not to be checked."
3047   (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
3048       t
3049     (let ((able (assq type message-syntax-checks)))
3050       (and (consp able)
3051            (eq (cdr able) 'disabled)))))
3052
3053 (defun message-check-news-syntax ()
3054   "Check the syntax of the message."
3055   (save-excursion
3056     (save-restriction
3057       (widen)
3058       (and
3059        ;; We narrow to the headers and check them first.
3060        (save-excursion
3061          (save-restriction
3062            (message-narrow-to-headers)
3063            (message-check-news-header-syntax)))
3064        ;; Check the body.
3065        (save-excursion
3066          (set-buffer message-edit-buffer)
3067          (message-check-news-body-syntax))))))
3068
3069 (defun message-check-news-header-syntax ()
3070   (and
3071    ;; Check Newsgroups header.
3072    (message-check 'newsgroyps
3073      (let ((group (message-fetch-field "newsgroups")))
3074        (or
3075         (and group
3076              (not (string-match "\\`[ \t]*\\'" group)))
3077         (ignore
3078          (message
3079           "The newsgroups field is empty or missing.  Posting is denied.")))))
3080    ;; Check the Subject header.
3081    (message-check 'subject
3082      (let* ((case-fold-search t)
3083             (subject (message-fetch-field "subject")))
3084        (or
3085         (and subject
3086              (not (string-match "\\`[ \t]*\\'" subject)))
3087         (ignore
3088          (message
3089           "The subject field is empty or missing.  Posting is denied.")))))
3090    ;; Check for commands in Subject.
3091    (message-check 'subject-cmsg
3092      (if (string-match "^cmsg " (message-fetch-field "subject"))
3093          (y-or-n-p
3094           "The control code \"cmsg\" is in the subject.  Really post? ")
3095        t))
3096    ;; Check for multiple identical headers.
3097    (message-check 'multiple-headers
3098      (let (found)
3099        (while (and (not found)
3100                    (re-search-forward "^[^ \t:]+: " nil t))
3101          (save-excursion
3102            (or (re-search-forward
3103                 (concat "^"
3104                         (regexp-quote
3105                          (setq found
3106                                (buffer-substring
3107                                 (match-beginning 0) (- (match-end 0) 2))))
3108                         ":")
3109                 nil t)
3110                (setq found nil))))
3111        (if found
3112            (y-or-n-p (format "Multiple %s headers.  Really post? " found))
3113          t)))
3114    ;; Check for Version and Sendsys.
3115    (message-check 'sendsys
3116      (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
3117          (y-or-n-p
3118           (format "The article contains a %s command.  Really post? "
3119                   (buffer-substring (match-beginning 0)
3120                                     (1- (match-end 0)))))
3121        t))
3122    ;; See whether we can shorten Followup-To.
3123    (message-check 'shorten-followup-to
3124      (let ((newsgroups (message-fetch-field "newsgroups"))
3125            (followup-to (message-fetch-field "followup-to"))
3126            to)
3127        (when (and newsgroups
3128                   (string-match "," newsgroups)
3129                   (not followup-to)
3130                   (not
3131                    (zerop
3132                     (length
3133                      (setq to (completing-read
3134                                "Followups to: (default all groups) "
3135                                (mapcar (lambda (g) (list g))
3136                                        (cons "poster"
3137                                              (message-tokenize-header
3138                                               newsgroups)))))))))
3139          (goto-char (point-min))
3140          (insert "Followup-To: " to "\n"))
3141        t))
3142    ;; Check "Shoot me".
3143    (message-check 'shoot
3144      (if (re-search-forward
3145           "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
3146          (y-or-n-p "You appear to have a misconfigured system.  Really post? ")
3147        t))
3148    ;; Check for Approved.
3149    (message-check 'approved
3150      (if (re-search-forward "^Approved:" nil t)
3151          (y-or-n-p "The article contains an Approved header.  Really post? ")
3152        t))
3153    ;; Check the Message-ID header.
3154    (message-check 'message-id
3155      (let* ((case-fold-search t)
3156             (message-id (message-fetch-field "message-id" t)))
3157        (or (not message-id)
3158            ;; Is there an @ in the ID?
3159            (and (string-match "@" message-id)
3160                 ;; Is there a dot in the ID?
3161                 (string-match "@[^.]*\\." message-id)
3162                 ;; Does the ID end with a dot?
3163                 (not (string-match "\\.>" message-id)))
3164            (y-or-n-p
3165             (format "The Message-ID looks strange: \"%s\".  Really post? "
3166                     message-id)))))
3167    ;; Check the Newsgroups & Followup-To headers.
3168    (message-check 'existing-newsgroups
3169      (let* ((case-fold-search t)
3170             (newsgroups (message-fetch-field "newsgroups"))
3171             (followup-to (message-fetch-field "followup-to"))
3172             (groups (message-tokenize-header
3173                      (if followup-to
3174                          (concat newsgroups "," followup-to)
3175                        newsgroups)))
3176             (hashtb (and (boundp 'gnus-active-hashtb)
3177                          gnus-active-hashtb))
3178             errors)
3179        (if (or (not hashtb)
3180                (not (boundp 'gnus-read-active-file))
3181                (not gnus-read-active-file)
3182                (eq gnus-read-active-file 'some))
3183            t
3184          (while groups
3185            (when (and (not (boundp (intern (car groups) hashtb)))
3186                       (not (equal (car groups) "poster")))
3187              (push (car groups) errors))
3188            (pop groups))
3189          (if (not errors)
3190              t
3191            (y-or-n-p
3192             (format
3193              "Really post to %s unknown group%s: %s "
3194              (if (= (length errors) 1) "this" "these")
3195              (if (= (length errors) 1) "" "s")
3196              (mapconcat 'identity errors ", ")))))))
3197    ;; Check the Newsgroups & Followup-To headers for syntax errors.
3198    (message-check 'valid-newsgroups
3199      (let ((case-fold-search t)
3200            (headers '("Newsgroups" "Followup-To"))
3201            header error)
3202        (while (and headers (not error))
3203          (when (setq header (mail-fetch-field (car headers)))
3204            (if (or
3205                 (not
3206                  (string-match
3207                   "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
3208                   header))
3209                 (memq
3210                  nil (mapcar
3211                       (lambda (g)
3212                         (not (string-match "\\.\\'\\|\\.\\." g)))
3213                       (message-tokenize-header header ","))))
3214                (setq error t)))
3215          (unless error
3216            (pop headers)))
3217        (if (not error)
3218            t
3219          (y-or-n-p
3220           (format "The %s header looks odd: \"%s\".  Really post? "
3221                   (car headers) header)))))
3222    (message-check 'repeated-newsgroups
3223      (let ((case-fold-search t)
3224            (headers '("Newsgroups" "Followup-To"))
3225            header error groups group)
3226        (while (and headers
3227                    (not error))
3228          (when (setq header (mail-fetch-field (pop headers)))
3229            (setq groups (message-tokenize-header header ","))
3230            (while (setq group (pop groups))
3231              (when (member group groups)
3232                (setq error group
3233                      groups nil)))))
3234        (if (not error)
3235            t
3236          (y-or-n-p
3237           (format "Group %s is repeated in headers.  Really post? " error)))))
3238    ;; Check the From header.
3239    (message-check 'from
3240      (let* ((case-fold-search t)
3241             (from (message-fetch-field "from"))
3242             ad)
3243        (cond
3244         ((not from)
3245          (message "There is no From line.  Posting is denied.")
3246          nil)
3247         ((or (not (string-match
3248                    "@[^\\.]*\\."
3249                    (setq ad (nth 1 (mail-extract-address-components
3250                                     from))))) ;larsi@ifi
3251              (string-match "\\.\\." ad) ;larsi@ifi..uio
3252              (string-match "@\\." ad)   ;larsi@.ifi.uio
3253              (string-match "\\.$" ad)   ;larsi@ifi.uio.
3254              (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
3255              (string-match "(.*).*(.*)" from)) ;(lars) (lars)
3256          (message
3257           "Denied posting -- the From looks strange: \"%s\"." from)
3258          nil)
3259         (t t))))))
3260
3261 (defun message-check-news-body-syntax ()
3262   (and
3263    ;; Check for long lines.
3264    (message-check 'long-lines
3265      (goto-char (point-min))
3266      (re-search-forward
3267       (concat "^" (regexp-quote mail-header-separator) "$"))
3268      (while (and
3269              (progn
3270                (end-of-line)
3271                (< (current-column) 80))
3272              (zerop (forward-line 1))))
3273      (or (bolp)
3274          (eobp)
3275          (y-or-n-p
3276           "You have lines longer than 79 characters.  Really post? ")))
3277    ;; Check whether the article is empty.
3278    (message-check 'empty
3279      (goto-char (point-min))
3280      (re-search-forward
3281       (concat "^" (regexp-quote mail-header-separator) "$"))
3282      (forward-line 1)
3283      (let ((b (point)))
3284        (goto-char (point-max))
3285        (re-search-backward message-signature-separator nil t)
3286        (beginning-of-line)
3287        (or (re-search-backward "[^ \n\t]" b t)
3288            (y-or-n-p "Empty article.  Really post? "))))
3289    ;; Check for control characters.
3290    (message-check 'control-chars
3291      (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
3292          (y-or-n-p
3293           "The article contains control characters.  Really post? ")
3294        t))
3295    ;; Check 8bit characters.
3296    (message-check '8bit
3297      (message-check-8bit))
3298    ;; Check excessive size.
3299    (message-check 'size
3300      (if (> (buffer-size) 60000)
3301          (y-or-n-p
3302           (format "The article is %d octets long.  Really post? "
3303                   (buffer-size)))
3304        t))
3305    ;; Check whether any new text has been added.
3306    (message-check 'new-text
3307      (or
3308       (not message-checksum)
3309       (not (eq (message-checksum) message-checksum))
3310       (y-or-n-p
3311        "It looks like no new text has been added.  Really post? ")))
3312    ;; Check the length of the signature.
3313    (message-check 'signature
3314      (goto-char (point-max))
3315      (if (> (count-lines (point) (point-max)) 5)
3316          (y-or-n-p
3317           (format
3318            "Your .sig is %d lines; it should be max 4.  Really post? "
3319            (1- (count-lines (point) (point-max)))))
3320        t))))
3321
3322 (defun message-check-mail-syntax ()
3323   "Check the syntax of the message."
3324   (save-excursion
3325     (save-restriction
3326       (widen)
3327       (and
3328        ;; We narrow to the headers and check them first.
3329        (save-excursion
3330          (save-restriction
3331            (message-narrow-to-headers)
3332            (message-check-mail-header-syntax)))
3333        ;; Check the body.
3334        (save-excursion
3335          (set-buffer message-edit-buffer)
3336          (message-check-mail-body-syntax))))))
3337
3338 (defun message-check-mail-header-syntax ()
3339   t)
3340
3341 (defun message-check-mail-body-syntax ()
3342   (and
3343    ;; Check 8bit characters.
3344    (message-check '8bit
3345      (message-check-8bit)
3346      )))
3347
3348 (defun message-check-8bit ()
3349   "Check the article contains 8bit characters."
3350   (save-excursion
3351     (set-buffer message-encoding-buffer)
3352     (message-narrow-to-headers)
3353     (let* ((case-fold-search t)
3354            (field-value (message-fetch-field "content-transfer-encoding")))
3355       (if (and field-value
3356                (member (downcase field-value) message-8bit-encoding-list))
3357           t
3358         (widen)
3359         (set-buffer (get-buffer-create " message syntax"))
3360         (erase-buffer)
3361         (goto-char (point-min))
3362         (set-buffer-multibyte nil)
3363         (insert-buffer message-encoding-buffer)
3364         (goto-char (point-min))
3365         (if (re-search-forward "[^\x00-\x7f]" nil t)
3366             (y-or-n-p
3367              "The article contains 8bit characters.  Really post? ")
3368           t)))))
3369
3370 (defun message-checksum ()
3371   "Return a \"checksum\" for the current buffer."
3372   (let ((sum 0))
3373     (save-excursion
3374       (goto-char (point-min))
3375       (re-search-forward
3376        (concat "^" (regexp-quote mail-header-separator) "$"))
3377       (while (not (eobp))
3378         (when (not (looking-at "[ \t\n]"))
3379           (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
3380                             (char-after))))
3381         (forward-char 1)))
3382     sum))
3383
3384 (defun message-do-fcc ()
3385   "Process Fcc headers in the current buffer."
3386   (let ((case-fold-search t)
3387         (coding-system-for-write 'raw-text)
3388         (output-coding-system 'raw-text)
3389         list file)
3390     (save-excursion
3391       (set-buffer (get-buffer-create " *message temp*"))
3392       (erase-buffer)
3393       (insert-buffer-substring message-encoding-buffer)
3394       (save-restriction
3395         (message-narrow-to-headers)
3396         (while (setq file (message-fetch-field "fcc"))
3397           (push file list)
3398           (message-remove-header "fcc" nil t)))
3399       (goto-char (point-min))
3400       (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
3401       (replace-match "" t t)
3402       ;; Process FCC operations.
3403       (while list
3404         (setq file (pop list))
3405         (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
3406             ;; Pipe the article to the program in question.
3407             (call-process-region (point-min) (point-max) shell-file-name
3408                                  nil nil nil shell-command-switch
3409                                  (match-string 1 file))
3410           ;; Save the article.
3411           (setq file (expand-file-name file))
3412           (unless (file-exists-p (file-name-directory file))
3413             (make-directory (file-name-directory file) t))
3414           (if (and message-fcc-handler-function
3415                    (not (eq message-fcc-handler-function 'rmail-output)))
3416               (funcall message-fcc-handler-function file)
3417             (if (and (file-readable-p file) (mail-file-babyl-p file))
3418                 (rmail-output file 1 nil t)
3419               (let ((mail-use-rfc822 t))
3420                 (rmail-output file 1 t t))))))
3421       (kill-buffer (current-buffer)))))
3422
3423 (defun message-output (filename)
3424   "Append this article to Unix/babyl mail file.."
3425   (if (and (file-readable-p filename)
3426            (mail-file-babyl-p filename))
3427       (rmail-output-to-rmail-file filename t)
3428     (gnus-output-to-mail filename t)))
3429
3430 (defun message-cleanup-headers ()
3431   "Do various automatic cleanups of the headers."
3432   ;; Remove empty lines in the header.
3433   (save-restriction
3434     (message-narrow-to-headers)
3435     ;; Remove blank lines.
3436     (while (re-search-forward "^[ \t]*\n" nil t)
3437       (replace-match "" t t))
3438
3439     ;; Correct Newsgroups and Followup-To headers:  Change sequence of
3440     ;; spaces to comma and eliminate spaces around commas.  Eliminate
3441     ;; embedded line breaks.
3442     (goto-char (point-min))
3443     (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
3444       (save-restriction
3445         (narrow-to-region
3446          (point)
3447          (if (re-search-forward "^[^ \t]" nil t)
3448              (match-beginning 0)
3449            (forward-line 1)
3450            (point)))
3451         (goto-char (point-min))
3452         (while (re-search-forward "\n[ \t]+" nil t)
3453           (replace-match " " t t))      ;No line breaks (too confusing)
3454         (goto-char (point-min))
3455         (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
3456           (replace-match "," t t))
3457         (goto-char (point-min))
3458         ;; Remove trailing commas.
3459         (when (re-search-forward ",+$" nil t)
3460           (replace-match "" t t))))))
3461
3462 (defun message-make-date (&optional now)
3463   "Make a valid data header.
3464 If NOW, use that time instead."
3465   (let* ((now (or now (current-time)))
3466          (zone (nth 8 (decode-time now)))
3467          (sign "+"))
3468     (when (< zone 0)
3469       (setq sign "-")
3470       (setq zone (- zone)))
3471     (concat
3472      (format-time-string "%d" now)
3473      ;; The month name of the %b spec is locale-specific.  Pfff.
3474      (format " %s "
3475              (capitalize (car (rassoc (nth 4 (decode-time now))
3476                                       parse-time-months))))
3477      (format-time-string "%Y %H:%M:%S " now)
3478      ;; We do all of this because XEmacs doesn't have the %z spec.
3479      (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
3480
3481 (defun message-make-followup-subject (subject)
3482   "Make a followup Subject."
3483   (cond
3484    ((and (eq message-use-subject-re 'guess)
3485          (string-match message-subject-encoded-re-regexp subject))
3486     subject)
3487    (message-use-subject-re
3488     (concat "Re: " (message-strip-subject-re subject)))
3489    (t subject)))
3490
3491 (defun message-make-message-id ()
3492   "Make a unique Message-ID."
3493   (concat "<" (message-unique-id)
3494           (let ((psubject (save-excursion (message-fetch-field "subject")))
3495                 (psupersedes
3496                  (save-excursion (message-fetch-field "supersedes"))))
3497             (if (or
3498                  (and message-reply-headers
3499                       (mail-header-references message-reply-headers)
3500                       (mail-header-subject message-reply-headers)
3501                       psubject
3502                       (mail-header-subject message-reply-headers)
3503                       (not (string=
3504                             (message-strip-subject-re
3505                              (mail-header-subject message-reply-headers))
3506                             (message-strip-subject-re psubject))))
3507                  (and psupersedes
3508                       (string-match "_-_@" psupersedes)))
3509                 "_-_" ""))
3510           "@" (message-make-fqdn) ">"))
3511
3512 (defvar message-unique-id-char nil)
3513
3514 ;; If you ever change this function, make sure the new version
3515 ;; cannot generate IDs that the old version could.
3516 ;; You might for example insert a "." somewhere (not next to another dot
3517 ;; or string boundary), or modify the "fsf" string.
3518 (defun message-unique-id ()
3519   ;; Don't use microseconds from (current-time), they may be unsupported.
3520   ;; Instead we use this randomly inited counter.
3521   (setq message-unique-id-char
3522         (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
3523            ;; (current-time) returns 16-bit ints,
3524            ;; and 2^16*25 just fits into 4 digits i base 36.
3525            (* 25 25)))
3526   (let ((tm (current-time)))
3527     (concat
3528      (if (memq system-type '(ms-dos emx vax-vms))
3529          (let ((user (downcase (user-login-name))))
3530            (while (string-match "[^a-z0-9_]" user)
3531              (aset user (match-beginning 0) ?_))
3532            user)
3533        (message-number-base36 (user-uid) -1))
3534      (message-number-base36 (+ (car   tm)
3535                                (lsh (% message-unique-id-char 25) 16)) 4)
3536      (message-number-base36 (+ (nth 1 tm)
3537                                (lsh (/ message-unique-id-char 25) 16)) 4)
3538      ;; Append the newsreader name, because while the generated
3539      ;; ID is unique to this newsreader, other newsreaders might
3540      ;; otherwise generate the same ID via another algorithm.
3541      ".fsf")))
3542
3543 (defun message-number-base36 (num len)
3544   (if (if (< len 0)
3545           (<= num 0)
3546         (= len 0))
3547       ""
3548     (concat (message-number-base36 (/ num 36) (1- len))
3549             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
3550                                   (% num 36))))))
3551
3552 (defun message-make-organization ()
3553   "Make an Organization header."
3554   (let* ((organization
3555           (when message-user-organization
3556             (if (message-functionp message-user-organization)
3557                 (funcall message-user-organization)
3558               message-user-organization))))
3559     (save-excursion
3560       (message-set-work-buffer)
3561       (cond ((stringp organization)
3562              (insert organization))
3563             ((and (eq t organization)
3564                   message-user-organization-file
3565                   (file-exists-p message-user-organization-file))
3566              (insert-file-contents message-user-organization-file)))
3567       (goto-char (point-min))
3568       (while (re-search-forward "[\t\n]+" nil t)
3569         (replace-match "" t t))
3570       (unless (zerop (buffer-size))
3571         (buffer-string)))))
3572
3573 (defun message-make-lines ()
3574   "Count the number of lines and return numeric string."
3575   (save-excursion
3576     (save-restriction
3577       (widen)
3578       (goto-char (point-min))
3579       (re-search-forward
3580        (concat "^" (regexp-quote mail-header-separator) "$"))
3581       (forward-line 1)
3582       (int-to-string (count-lines (point) (point-max))))))
3583
3584 (defun message-make-in-reply-to ()
3585   "Return the In-Reply-To header for this message."
3586   (when message-reply-headers
3587     (let ((mid (mail-header-message-id message-reply-headers))
3588           (from (mail-header-from message-reply-headers))
3589           (date (mail-header-date message-reply-headers)))
3590       (when mid
3591         (concat mid
3592                 (when from
3593                   (let ((pair (std11-extract-address-components from)))
3594                     (concat "\n ("
3595                             (or (car pair) (cadr pair))
3596                             "'s message of \""
3597                             (if (or (not date) (string= date ""))
3598                                 "(unknown date)" date)
3599                             "\")"))))))))
3600
3601 (defun message-make-distribution ()
3602   "Make a Distribution header."
3603   (let ((orig-distribution (message-fetch-reply-field "distribution")))
3604     (cond ((message-functionp message-distribution-function)
3605            (funcall message-distribution-function))
3606           (t orig-distribution))))
3607
3608 (defun message-make-expires ()
3609   "Return an Expires header based on `message-expires'."
3610   (let ((current (current-time))
3611         (future (* 1.0 message-expires 60 60 24)))
3612     ;; Add the future to current.
3613     (setcar current (+ (car current) (round (/ future (expt 2 16)))))
3614     (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
3615     (message-make-date current)))
3616
3617 (defun message-make-path ()
3618   "Return uucp path."
3619   (let ((login-name (user-login-name)))
3620     (cond ((null message-user-path)
3621            (concat (system-name) "!" login-name))
3622           ((stringp message-user-path)
3623            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
3624            (concat message-user-path "!" login-name))
3625           (t login-name))))
3626
3627 (defun message-make-from ()
3628   "Make a From header."
3629   (let* ((style message-from-style)
3630          (login (message-make-address))
3631          (fullname
3632           (or (and (boundp 'user-full-name)
3633                    user-full-name)
3634               (user-full-name))))
3635     (when (string= fullname "&")
3636       (setq fullname (user-login-name)))
3637     (save-excursion
3638       (message-set-work-buffer)
3639       (cond
3640        ((or (null style)
3641             (equal fullname ""))
3642         (insert login))
3643        ((or (eq style 'angles)
3644             (and (not (eq style 'parens))
3645                  ;; Use angles if no quoting is needed, or if parens would
3646                  ;; need quoting too.
3647                  (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
3648                      (let ((tmp (concat fullname nil)))
3649                        (while (string-match "([^()]*)" tmp)
3650                          (aset tmp (match-beginning 0) ?-)
3651                          (aset tmp (1- (match-end 0)) ?-))
3652                        (string-match "[\\()]" tmp)))))
3653         (insert fullname)
3654         (goto-char (point-min))
3655         ;; Look for a character that cannot appear unquoted
3656         ;; according to RFC 822.
3657         (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
3658           ;; Quote fullname, escaping specials.
3659           (goto-char (point-min))
3660           (insert "\"")
3661           (while (re-search-forward "[\"\\]" nil 1)
3662             (replace-match "\\\\\\&" t))
3663           (insert "\""))
3664         (insert " <" login ">"))
3665        (t                               ; 'parens or default
3666         (insert login " (")
3667         (let ((fullname-start (point)))
3668           (insert fullname)
3669           (goto-char fullname-start)
3670           ;; RFC 822 says \ and nonmatching parentheses
3671           ;; must be escaped in comments.
3672           ;; Escape every instance of ()\ ...
3673           (while (re-search-forward "[()\\]" nil 1)
3674             (replace-match "\\\\\\&" t))
3675           ;; ... then undo escaping of matching parentheses,
3676           ;; including matching nested parentheses.
3677           (goto-char fullname-start)
3678           (while (re-search-forward
3679                   "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
3680                   nil 1)
3681             (replace-match "\\1(\\3)" t)
3682             (goto-char fullname-start)))
3683         (insert ")")))
3684       (buffer-string))))
3685
3686 (defun message-make-sender ()
3687   "Return the \"real\" user address.
3688 This function tries to ignore all user modifications, and
3689 give as trustworthy answer as possible."
3690   (concat (user-login-name) "@" (system-name)))
3691
3692 (defun message-make-address ()
3693   "Make the address of the user."
3694   (or (message-user-mail-address)
3695       (concat (user-login-name) "@" (message-make-domain))))
3696
3697 (defun message-user-mail-address ()
3698   "Return the pertinent part of `user-mail-address'."
3699   (when user-mail-address
3700     (if (string-match " " user-mail-address)
3701         (nth 1 (std11-extract-address-components user-mail-address))
3702       user-mail-address)))
3703
3704 (defun message-make-fqdn ()
3705   "Return user's fully qualified domain name."
3706   (let ((system-name (system-name))
3707         (user-mail (message-user-mail-address)))
3708     (cond
3709      ((string-match "[^.]\\.[^.]" system-name)
3710       ;; `system-name' returned the right result.
3711       system-name)
3712      ;; Try `mail-host-address'.
3713      ((and (boundp 'mail-host-address)
3714            (stringp mail-host-address)
3715            (string-match "\\." mail-host-address))
3716       mail-host-address)
3717      ;; We try `user-mail-address' as a backup.
3718      ((and user-mail
3719            (string-match "\\." user-mail)
3720            (string-match "@\\(.*\\)\\'" user-mail))
3721       (match-string 1 user-mail))
3722      ;; Default to this bogus thing.
3723      (t
3724       (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me")))))
3725
3726 (defun message-make-host-name ()
3727   "Return the name of the host."
3728   (let ((fqdn (message-make-fqdn)))
3729     (string-match "^[^.]+\\." fqdn)
3730     (substring fqdn 0 (1- (match-end 0)))))
3731
3732 (defun message-make-domain ()
3733   "Return the domain name."
3734   (or mail-host-address
3735       (message-make-fqdn)))
3736
3737 ;; Dummy to avoid byte-compile warning.
3738 (defvar mule-version)
3739 (defvar emacs-beta-version)
3740 (defvar xemacs-codename)
3741 (defvar gnus-inviolable-extended-version)
3742
3743 (defun message-make-user-agent ()
3744   "Return user-agent info if the value `message-user-agent' is non-nil. If the
3745 \"User-Agent\" field has already exist, it's value will be added in the return
3746 string."
3747   (when message-user-agent
3748     (save-excursion
3749       (goto-char (point-min))
3750       (let ((case-fold-search t)
3751             user-agent start p end)
3752         (if (re-search-forward "^User-Agent:[\t ]*" nil t)
3753             (progn
3754               (setq start (match-beginning 0)
3755                     p (match-end 0)
3756                     end (std11-field-end)
3757                     user-agent (buffer-substring-no-properties p end))
3758               (delete-region start (1+ end))
3759               (concat message-user-agent " " user-agent))
3760           message-user-agent)))))
3761
3762 (defun message-generate-headers (headers)
3763   "Prepare article HEADERS.
3764 Headers already prepared in the buffer are not modified."
3765   (save-restriction
3766     (message-narrow-to-headers)
3767     (let* ((Date (message-make-date))
3768            (Message-ID (message-make-message-id))
3769            (Organization (message-make-organization))
3770            (From (message-make-from))
3771            (Path (message-make-path))
3772            (Subject nil)
3773            (Newsgroups nil)
3774            (In-Reply-To (message-make-in-reply-to))
3775            (To nil)
3776            (Distribution (message-make-distribution))
3777            (Lines (message-make-lines))
3778            (User-Agent (message-make-user-agent))
3779            (Expires (message-make-expires))
3780            (case-fold-search t)
3781            header value elem)
3782       ;; First we remove any old generated headers.
3783       (let ((headers message-deletable-headers))
3784         (unless (buffer-modified-p)
3785           (setq headers (delq 'Message-ID (copy-sequence headers))))
3786         (while headers
3787           (goto-char (point-min))
3788           (and (re-search-forward
3789                 (concat "^" (symbol-name (car headers)) ": *") nil t)
3790                (get-text-property (1+ (match-beginning 0)) 'message-deletable)
3791                (message-delete-line))
3792           (pop headers)))
3793       ;; Go through all the required headers and see if they are in the
3794       ;; articles already.  If they are not, or are empty, they are
3795       ;; inserted automatically - except for Subject, Newsgroups and
3796       ;; Distribution.
3797       (while headers
3798         (goto-char (point-min))
3799         (setq elem (pop headers))
3800         (if (consp elem)
3801             (if (eq (car elem) 'optional)
3802                 (setq header (cdr elem))
3803               (setq header (car elem)))
3804           (setq header elem))
3805         (when (or (not (re-search-forward
3806                         (concat "^"
3807                                 (regexp-quote
3808                                  (downcase
3809                                   (if (stringp header)
3810                                       header
3811                                     (symbol-name header))))
3812                                 ":")
3813                         nil t))
3814                   (progn
3815                     ;; The header was found.  We insert a space after the
3816                     ;; colon, if there is none.
3817                     (if (/= (char-after) ? ) (insert " ") (forward-char 1))
3818                     ;; Find out whether the header is empty...
3819                     (looking-at "[ \t]*\n[^ \t]")))
3820           ;; So we find out what value we should insert.
3821           (setq value
3822                 (cond
3823                  ((and (consp elem) (eq (car elem) 'optional))
3824                   ;; This is an optional header.  If the cdr of this
3825                   ;; is something that is nil, then we do not insert
3826                   ;; this header.
3827                   (setq header (cdr elem))
3828                   (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
3829                       (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
3830                  ((consp elem)
3831                   ;; The element is a cons.  Either the cdr is a
3832                   ;; string to be inserted verbatim, or it is a
3833                   ;; function, and we insert the value returned from
3834                   ;; this function.
3835                   (or (and (stringp (cdr elem)) (cdr elem))
3836                       (and (fboundp (cdr elem)) (funcall (cdr elem)))))
3837                  ((and (boundp header) (symbol-value header))
3838                   ;; The element is a symbol.  We insert the value
3839                   ;; of this symbol, if any.
3840                   (symbol-value header))
3841                  (t
3842                   ;; We couldn't generate a value for this header,
3843                   ;; so we just ask the user.
3844                   (read-from-minibuffer
3845                    (format "Empty header for %s; enter value: " header)))))
3846           ;; Finally insert the header.
3847           (when (and value
3848                      (not (equal value "")))
3849             (save-excursion
3850               (if (bolp)
3851                   (progn
3852                     ;; This header didn't exist, so we insert it.
3853                     (goto-char (point-max))
3854                     (insert (if (stringp header) header (symbol-name header))
3855                             ": " value)
3856                     (unless (bolp)
3857                       (insert "\n"))
3858                     (forward-line -1))
3859                 ;; The value of this header was empty, so we clear
3860                 ;; totally and insert the new value.
3861                 (delete-region (point) (gnus-point-at-eol))
3862                 (insert value)
3863                 (when (bolp)
3864                   (delete-char -1)))
3865               ;; Add the deletable property to the headers that require it.
3866               (and (memq header message-deletable-headers)
3867                    (progn (beginning-of-line) (looking-at "[^:]+: "))
3868                    (add-text-properties
3869                     (point) (match-end 0)
3870                     '(message-deletable t face italic) (current-buffer)))))))
3871       ;; Insert new Sender if the From is strange.
3872       (let ((from (message-fetch-field "from"))
3873             (sender (message-fetch-field "sender"))
3874             (secure-sender (message-make-sender)))
3875         (when (and from
3876                    (not (message-check-element 'sender))
3877                    (not (string=
3878                          (downcase
3879                           (cadr (std11-extract-address-components from)))
3880                          (downcase secure-sender)))
3881                    (or (null sender)
3882                        (not
3883                         (string=
3884                          (downcase
3885                           (cadr (std11-extract-address-components sender)))
3886                          (downcase secure-sender)))))
3887           (goto-char (point-min))
3888           ;; Rename any old Sender headers to Original-Sender.
3889           (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
3890             (beginning-of-line)
3891             (insert "Original-")
3892             (beginning-of-line))
3893           (when (or (message-news-p)
3894                     (string-match "@.+\\.." secure-sender))
3895             (insert "Sender: " secure-sender "\n")))))))
3896
3897 (defun message-insert-courtesy-copy ()
3898   "Insert a courtesy message in mail copies of combined messages."
3899   (let (newsgroups)
3900     (save-excursion
3901       (save-restriction
3902         (message-narrow-to-headers)
3903         (when (setq newsgroups (message-fetch-field "newsgroups"))
3904           (goto-char (point-max))
3905           (insert "Posted-To: " newsgroups "\n")))
3906       (forward-line 1)
3907       (when message-courtesy-message
3908         (cond
3909          ((string-match "%s" message-courtesy-message)
3910           (insert (format message-courtesy-message newsgroups)))
3911          (t
3912           (insert message-courtesy-message)))))))
3913
3914 ;;;
3915 ;;; Setting up a message buffer
3916 ;;;
3917
3918 (defun message-fill-address (header value)
3919   (save-restriction
3920     (narrow-to-region (point) (point))
3921     (insert (capitalize (symbol-name header))
3922             ": "
3923             (if (consp value) (car value) value)
3924             "\n")
3925     (narrow-to-region (point-min) (1- (point-max)))
3926     (let (quoted last)
3927       (goto-char (point-min))
3928       (while (not (eobp))
3929         (skip-chars-forward "^,\"" (point-max))
3930         (if (or (eq (char-after) ?,)
3931                 (eobp))
3932             (when (not quoted)
3933               (if (and (> (current-column) 78)
3934                        last)
3935                   (save-excursion
3936                     (goto-char last)
3937                     (looking-at "[ \t]*")
3938                     (replace-match "\n " t t)))
3939               (setq last (1+ (point))))
3940           (setq quoted (not quoted)))
3941         (unless (eobp)
3942           (forward-char 1))))
3943     (goto-char (point-max))
3944     (widen)
3945     (forward-line 1)))
3946
3947 (defun message-fill-references (header value)
3948   (insert (capitalize (symbol-name header))
3949           ": "
3950           (std11-fill-msg-id-list-string
3951           (if (consp value) (car value) value))
3952           "\n"))
3953
3954 (defun message-fill-header (header value)
3955   (let ((begin (point))
3956         (fill-column 78)
3957         (fill-prefix " "))
3958     (insert (capitalize (symbol-name header))
3959             ": "
3960             (if (consp value) (car value) value)
3961             "\n")
3962     (save-restriction
3963       (narrow-to-region begin (point))
3964       (fill-region-as-paragraph begin (point))
3965       ;; Tapdance around looong Message-IDs.
3966       (forward-line -1)
3967       (when (looking-at "[ \t]*$")
3968         (message-delete-line))
3969       (goto-char begin)
3970       (re-search-forward ":" nil t)
3971       (when (looking-at "\n[ \t]+")
3972         (replace-match " " t t))
3973       (goto-char (point-max)))))
3974
3975 (defun message-shorten-1 (list cut surplus)
3976   ;; Cut SURPLUS elements out of LIST, beginning with CUTth one.
3977   (setcdr (nthcdr (- cut 2) list)
3978           (nthcdr (+ (- cut 2) surplus 1) list)))
3979
3980 (defun message-shorten-references (header references)
3981   "Trim REFERENCES to be less than 31 Message-ID long, and fold them.
3982 If folding is disallowed, also check that the REFERENCES are less
3983 than 988 characters long, and if they are not, trim them until they are."
3984   (let ((maxcount 31)
3985         (count 0)
3986         (cut 6)
3987         refs)
3988     (with-temp-buffer
3989       (insert references)
3990       (goto-char (point-min))
3991       ;; Cons a list of valid references.
3992       (while (re-search-forward "<[^>]+>" nil t)
3993         (push (match-string 0) refs))
3994       (setq refs (nreverse refs)
3995             count (length refs)))
3996
3997     ;; If the list has more than MAXCOUNT elements, trim it by
3998     ;; removing the CUTth element and the required number of
3999     ;; elements that follow.
4000     (when (> count maxcount)
4001       (let ((surplus (- count maxcount)))
4002         (message-shorten-1 refs cut surplus)
4003         (decf count surplus)))
4004
4005     ;; If folding is disallowed, make sure the total length (including
4006     ;; the spaces between) will be less than MAXSIZE characters.
4007     (when message-cater-to-broken-inn
4008       (let ((maxsize 988)
4009             (totalsize (+ (apply #'+ (mapcar #'length refs))
4010                           (1- count)))
4011             (surplus 0)
4012             (ptr (nthcdr (1- cut) refs)))
4013         ;; Decide how many elements to cut off...
4014         (while (> totalsize maxsize)
4015           (decf totalsize (1+ (length (car ptr))))
4016           (incf surplus)
4017           (setq ptr (cdr ptr)))
4018         ;; ...and do it.
4019         (when (> surplus 0)
4020           (message-shorten-1 refs cut surplus))))
4021
4022     ;; Finally, collect the references back into a string and insert
4023     ;; it into the buffer.
4024     (let ((refstring (mapconcat #'identity refs " ")))
4025       (if message-cater-to-broken-inn
4026           (insert (capitalize (symbol-name header)) ": "
4027                   refstring "\n")
4028         (message-fill-header header refstring)))))
4029
4030 (defun message-position-point ()
4031   "Move point to where the user probably wants to find it."
4032   (message-narrow-to-headers)
4033   (cond
4034    ((re-search-forward "^[^:]+:[ \t]*$" nil t)
4035     (search-backward ":" )
4036     (widen)
4037     (forward-char 1)
4038     (if (eq (char-after) ? )
4039         (forward-char 1)
4040       (insert " ")))
4041    (t
4042     (goto-char (point-max))
4043     (widen)
4044     (forward-line 1)
4045     (unless (looking-at "$")
4046       (forward-line 2)))
4047    (sit-for 0)))
4048
4049 (defun message-buffer-name (type &optional to group)
4050   "Return a new (unique) buffer name based on TYPE and TO."
4051   (cond
4052    ;; Generate a new buffer name The Message Way.
4053    ((eq message-generate-new-buffers 'unique)
4054     (generate-new-buffer-name
4055      (concat "*" type
4056              (if to
4057                  (concat " to "
4058                          (or (car (std11-extract-address-components to))
4059                              to) "")
4060                "")
4061              (if (and group (not (string= group ""))) (concat " on " group) "")
4062              "*")))
4063    ;; Check whether `message-generate-new-buffers' is a function,
4064    ;; and if so, call it.
4065    ((message-functionp message-generate-new-buffers)
4066     (funcall message-generate-new-buffers type to group))
4067    ((eq message-generate-new-buffers 'unsent)
4068     (generate-new-buffer-name
4069      (concat "*unsent " type
4070              (if to
4071                  (concat " to "
4072                          (or (car (mail-extract-address-components to))
4073                              to) "")
4074                "")
4075              (if (and group (not (string= group ""))) (concat " on " group) "")
4076              "*")))
4077    ;; Use standard name.
4078    (t
4079     (format "*%s message*" type))))
4080
4081 (defmacro message-pop-to-buffer-1 (buffer)
4082   `(if pop-up-frames
4083        (let (special-display-buffer-names
4084              special-display-regexps
4085              same-window-buffer-names
4086              same-window-regexps)
4087          (pop-to-buffer ,buffer))
4088      (pop-to-buffer ,buffer)))
4089
4090 (defun message-pop-to-buffer (name)
4091   "Pop to buffer NAME, and warn if it already exists and is modified."
4092   (let ((buffer (get-buffer name))
4093         (pop-up-frames (and (or (static-if (featurep 'xemacs)
4094                                     (device-on-window-system-p)
4095                                   window-system)
4096                                 (>= emacs-major-version 20))
4097                             message-use-multi-frames)))
4098     (if (and buffer
4099              (buffer-name buffer))
4100         (progn
4101           (message-pop-to-buffer-1 buffer)
4102           (when (and (buffer-modified-p)
4103                      (not (y-or-n-p
4104                            "Message already being composed; erase? ")))
4105             (error "Message being composed")))
4106       (message-pop-to-buffer-1 name))
4107     (erase-buffer)
4108     (message-mode)
4109     (when pop-up-frames
4110       (set (make-local-variable 'message-original-frame) (selected-frame)))))
4111
4112 (defun message-do-send-housekeeping ()
4113   "Kill old message buffers."
4114   ;; We might have sent this buffer already.  Delete it from the
4115   ;; list of buffers.
4116   (setq message-buffer-list (delq (current-buffer) message-buffer-list))
4117   (while (and message-max-buffers
4118               message-buffer-list
4119               (>= (length message-buffer-list) message-max-buffers))
4120     ;; Kill the oldest buffer -- unless it has been changed.
4121     (let ((buffer (pop message-buffer-list)))
4122       (when (and (buffer-name buffer)
4123                  (not (buffer-modified-p buffer)))
4124         (kill-buffer buffer))))
4125   ;; Rename the buffer.
4126   (if message-send-rename-function
4127       (funcall message-send-rename-function)
4128     (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name))
4129       (rename-buffer
4130        (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
4131   ;; Push the current buffer onto the list.
4132   (when message-max-buffers
4133     (setq message-buffer-list
4134           (nconc message-buffer-list (list (current-buffer))))))
4135
4136 (defvar mc-modes-alist)
4137 (defun message-setup (headers &optional replybuffer actions)
4138   (when (and (boundp 'mc-modes-alist)
4139              (not (assq 'message-mode mc-modes-alist)))
4140     (push '(message-mode (encrypt . mc-encrypt-message)
4141                          (sign . mc-sign-message))
4142           mc-modes-alist))
4143   (when actions
4144     (setq message-send-actions actions))
4145   (setq message-reply-buffer
4146         (or (message-get-parameter 'reply-buffer)
4147             replybuffer))
4148   (goto-char (point-min))
4149   ;; Insert all the headers.
4150   (mail-header-format
4151    (let ((h headers)
4152          (alist message-header-format-alist))
4153      (while h
4154        (unless (assq (caar h) message-header-format-alist)
4155          (push (list (caar h)) alist))
4156        (pop h))
4157      alist)
4158    headers)
4159   (delete-region (point) (progn (forward-line -1) (point)))
4160   (when message-default-headers
4161     (insert message-default-headers)
4162     (or (bolp) (insert ?\n)))
4163   (put-text-property
4164    (point)
4165    (progn
4166      (insert mail-header-separator "\n")
4167      (1- (point)))
4168    'read-only nil)
4169   (forward-line -1)
4170   (when (message-news-p)
4171     (when message-default-news-headers
4172       (insert message-default-news-headers)
4173       (or (bolp) (insert ?\n)))
4174     (when message-generate-headers-first
4175       (message-generate-headers
4176        (delq 'Lines
4177              (delq 'Subject
4178                    (copy-sequence message-required-news-headers))))))
4179   (when (message-mail-p)
4180     (when message-default-mail-headers
4181       (insert message-default-mail-headers)
4182       (or (bolp) (insert ?\n)))
4183     (when message-generate-headers-first
4184       (message-generate-headers
4185        (delq 'Lines
4186              (delq 'Subject
4187                    (copy-sequence message-required-mail-headers))))))
4188   (run-hooks 'message-signature-setup-hook)
4189   (message-insert-signature)
4190   (save-restriction
4191     (message-narrow-to-headers)
4192     (run-hooks 'message-header-setup-hook))
4193   (set-buffer-modified-p nil)
4194   (setq buffer-undo-list nil)
4195   (run-hooks 'message-setup-hook)
4196   (message-position-point)
4197   (undo-boundary))
4198
4199 (defun message-set-auto-save-file-name ()
4200   "Associate the message buffer with a file in the drafts directory."
4201   (when message-auto-save-directory
4202     (if (gnus-alive-p)
4203         (setq message-draft-article
4204               (nndraft-request-associate-buffer "drafts"))
4205       (setq buffer-file-name (expand-file-name "*message*"
4206                                                message-auto-save-directory))
4207       (setq buffer-auto-save-file-name (make-auto-save-file-name)))
4208     (clear-visited-file-modtime)
4209     (static-if (boundp 'MULE)
4210         (set-file-coding-system message-draft-coding-system)
4211       (setq buffer-file-coding-system message-draft-coding-system))))
4212
4213 (defun message-disassociate-draft ()
4214   "Disassociate the message buffer from the drafts directory."
4215   (when message-draft-article
4216     (nndraft-request-expire-articles
4217      (list message-draft-article) "drafts" nil t)))
4218
4219 (defun message-insert-headers ()
4220   "Generate the headers for the article."
4221   (interactive)
4222   (save-excursion
4223     (save-restriction
4224       (message-narrow-to-headers)
4225       (when (message-news-p)
4226         (message-generate-headers
4227          (delq 'Lines
4228                (delq 'Subject
4229                      (copy-sequence message-required-news-headers)))))
4230       (when (message-mail-p)
4231         (message-generate-headers
4232          (delq 'Lines
4233                (delq 'Subject
4234                      (copy-sequence message-required-mail-headers))))))))
4235
4236 \f
4237
4238 ;;;
4239 ;;; Commands for interfacing with message
4240 ;;;
4241
4242 ;;;###autoload
4243 (defun message-mail (&optional to subject
4244                                other-headers continue switch-function
4245                                yank-action send-actions)
4246   "Start editing a mail message to be sent.
4247 OTHER-HEADERS is an alist of header/value pairs."
4248   (interactive)
4249   (let ((message-this-is-mail t))
4250     (message-pop-to-buffer (message-buffer-name "mail" to))
4251     (message-setup
4252      (nconc
4253       `((To . ,(or to "")) (Subject . ,(or subject "")))
4254       (when other-headers other-headers)))))
4255
4256 ;;;###autoload
4257 (defun message-news (&optional newsgroups subject)
4258   "Start editing a news article to be sent."
4259   (interactive)
4260   (let ((message-this-is-news t))
4261     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
4262     (message-setup `((Newsgroups . ,(or newsgroups ""))
4263                      (Subject . ,(or subject ""))))))
4264
4265 ;;;###autoload
4266 (defun message-reply (&optional to-address wide)
4267   "Start editing a reply to the article in the current buffer."
4268   (interactive)
4269   (let ((cur (current-buffer))
4270         from subject date to cc
4271         references message-id follow-to
4272         (inhibit-point-motion-hooks t)
4273         (message-this-is-mail t)
4274         mct never-mct mft mrt gnus-warning in-reply-to)
4275     (save-restriction
4276       (message-narrow-to-head)
4277       ;; Allow customizations to have their say.
4278       (if (not wide)
4279           ;; This is a regular reply.
4280           (if (message-functionp message-reply-to-function)
4281               (setq follow-to (funcall message-reply-to-function)))
4282         ;; This is a followup.
4283         (if (message-functionp message-wide-reply-to-function)
4284             (save-excursion
4285               (setq follow-to
4286                     (funcall message-wide-reply-to-function)))))
4287       ;; Find all relevant headers we need.
4288       (setq from (message-fetch-field "from")
4289             date (message-fetch-field "date" t)
4290             subject (or (message-fetch-field "subject") "none")
4291             references (message-fetch-field "references")
4292             message-id (message-fetch-field "message-id" t)
4293             to (message-fetch-field "to")
4294             cc (message-fetch-field "cc")
4295             mct (when (and wide message-use-mail-copies-to)
4296                   (message-fetch-field "mail-copies-to"))
4297             mft (when (and wide message-use-mail-followup-to)
4298                   (message-fetch-field "mail-followup-to"))
4299             mrt (when message-use-mail-reply-to
4300                   (or (message-fetch-field "mail-reply-to")
4301                       (message-fetch-field "reply-to")))
4302             gnus-warning (message-fetch-field "gnus-warning"))
4303       (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
4304         (setq message-id (match-string 0 gnus-warning)))
4305       ;; Get the references from "In-Reply-To" field if there were
4306       ;; no references and "In-Reply-To" field looks promising.
4307       (unless references
4308         (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
4309                    (string-match "<[^>]+>" in-reply-to))
4310           (setq references (match-string 0 in-reply-to))))
4311       ;; Remove any (buggy) Re:'s that are present and make a
4312       ;; proper one.
4313       (setq subject (message-make-followup-subject subject))
4314       (widen))
4315
4316     ;; Handle special values of Mail-Copies-To.
4317     (when mct
4318       (cond
4319        ((and (or (equal (downcase mct) "never")
4320                  (equal (downcase mct) "nobody"))
4321              (or (not (eq message-use-mail-copies-to 'ask))
4322                  (message-y-or-n-p
4323                   (concat "Obey Mail-Copies-To: never? ") t "\
4324 You should normally obey the Mail-Copies-To: header.
4325
4326         `Mail-Copies-To: never'
4327 directs you not to send your response to the author.")))
4328         (setq never-mct t)
4329         (setq mct nil))
4330        ((and (or (equal (downcase mct) "always")
4331                  (equal (downcase mct) "poster"))
4332              (or (not (eq message-use-mail-copies-to 'ask))
4333                  (message-y-or-n-p
4334                   (concat "Obey Mail-Copies-To: always? ") t "\
4335 You should normally obey the Mail-Copies-To: header.
4336
4337         `Mail-Copies-To: always'
4338 sends a copy of your response to the author.")))
4339         (setq mct (or mrt from)))
4340        ((and (eq message-use-mail-copies-to 'ask)
4341              (not
4342               (message-y-or-n-p
4343                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
4344 You should normally obey the Mail-Copies-To: header.
4345
4346         `Mail-Copies-To: " mct "'
4347 sends a copy of your response to " (if (string-match "," mct)
4348                                        "the specified addresses"
4349                                      "that address") ".")))
4350         (setq mct nil))
4351        ))
4352
4353     (unless follow-to
4354       (cond
4355        (to-address (setq follow-to (list (cons 'To to-address))))
4356        ((not wide) (setq follow-to (list (cons 'To (or mrt from)))))
4357        ;; Handle Mail-Followup-To.
4358        ((and mft
4359              (or (not (eq message-use-mail-followup-to 'ask))
4360                  (message-y-or-n-p
4361                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
4362 You should normally obey the Mail-Followup-To: header.
4363
4364         `Mail-Followup-To: " mft "'
4365 directs your response to " (if (string-match "," mft)
4366                                "the specified addresses"
4367                              "that address only") ".
4368
4369 A typical situation where Mail-Followup-To is used is when the author thinks
4370 that further discussion should take place only in "
4371                              (if (string-match "," mft)
4372                                  "the specified mailing lists"
4373                                "that mailing list") ".")))
4374         (setq follow-to (list (cons 'To mft)))
4375         (when mct
4376           (push (cons 'Cc mct) follow-to)))
4377        (t
4378         (let (ccalist)
4379           (save-excursion
4380             (message-set-work-buffer)
4381             (unless never-mct
4382               (insert (or mrt from "")))
4383             (insert (if to (concat (if (bolp) "" ", ") to "") ""))
4384             (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
4385             (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
4386             (goto-char (point-min))
4387             (while (re-search-forward "[ \t]+" nil t)
4388               (replace-match " " t t))
4389             ;; Remove addresses that match `rmail-dont-reply-to-names'.
4390             (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
4391               (insert (prog1 (rmail-dont-reply-to (buffer-string))
4392                         (erase-buffer))))
4393             (goto-char (point-min))
4394             ;; Perhaps Mail-Copies-To: never removed the only address?
4395             (when (eobp)
4396               (insert (or mrt from "")))
4397             (setq ccalist
4398                   (mapcar
4399                    (lambda (addr)
4400                      (cons (mail-strip-quoted-names addr) addr))
4401                    (message-tokenize-header (buffer-string))))
4402             (let ((s ccalist))
4403               (while s
4404                 (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
4405           (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
4406           (when ccalist
4407             (let ((ccs (cons 'Cc (mapconcat
4408                                   (lambda (addr) (cdr addr)) ccalist ", "))))
4409               (when (string-match "^ +" (cdr ccs))
4410                 (setcdr ccs (substring (cdr ccs) (match-end 0))))
4411               (push ccs follow-to)))))))
4412
4413     (message-pop-to-buffer (message-buffer-name
4414                             (if wide "wide reply" "reply") from
4415                             (if wide to-address nil)))
4416
4417     (setq message-reply-headers
4418           (make-full-mail-header-from-decoded-header
4419            0 subject from date message-id references 0 0 ""))
4420
4421     (message-setup
4422      `((Subject . ,subject)
4423        ,@follow-to
4424        ,@(if (or references message-id)
4425              `((References . ,(concat (or references "") (and references " ")
4426                                       (or message-id ""))))))
4427      cur)))
4428
4429 ;;;###autoload
4430 (defun message-wide-reply (&optional to-address)
4431   "Make a \"wide\" reply to the message in the current buffer."
4432   (interactive)
4433   (message-reply to-address t))
4434
4435 ;;;###autoload
4436 (defun message-followup (&optional to-newsgroups)
4437   "Follow up to the message in the current buffer.
4438 If TO-NEWSGROUPS, use that as the new Newsgroups line."
4439   (interactive)
4440   (let ((cur (current-buffer))
4441         from subject date mct
4442         references message-id follow-to
4443         (inhibit-point-motion-hooks t)
4444         (message-this-is-news t)
4445         followup-to distribution newsgroups gnus-warning posted-to mft mrt)
4446     (save-restriction
4447       (message-narrow-to-head)
4448       (when (message-functionp message-followup-to-function)
4449         (setq follow-to
4450               (funcall message-followup-to-function)))
4451       (setq from (message-fetch-field "from")
4452             date (message-fetch-field "date" t)
4453             subject (or (message-fetch-field "subject") "none")
4454             references (message-fetch-field "references")
4455             message-id (message-fetch-field "message-id" t)
4456             followup-to (when message-use-followup-to
4457                           (message-fetch-field "followup-to"))
4458             distribution (message-fetch-field "distribution")
4459             newsgroups (message-fetch-field "newsgroups")
4460             posted-to (message-fetch-field "posted-to")
4461             mct (when message-use-mail-copies-to
4462                   (message-fetch-field "mail-copies-to"))
4463             mft (when message-use-mail-followup-to
4464                   (message-fetch-field "mail-followup-to"))
4465             mrt (when message-use-mail-reply-to
4466                   (or (message-fetch-field "mail-reply-to")
4467                       (message-fetch-field "reply-to")))
4468             gnus-warning (message-fetch-field "gnus-warning"))
4469       (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
4470         (setq message-id (match-string 0 gnus-warning)))
4471       ;; Remove bogus distribution.
4472       (when (and (stringp distribution)
4473                  (let ((case-fold-search t))
4474                    (string-match "world" distribution)))
4475         (setq distribution nil))
4476       ;; Remove any (buggy) Re:'s that are present and make a
4477       ;; proper one.
4478       (setq subject (message-make-followup-subject subject))
4479       (widen))
4480
4481     ;; Handle special values of Mail-Copies-To.
4482     (when mct
4483       (cond
4484        ((and (or (equal (downcase mct) "never")
4485                  (equal (downcase mct) "nobody"))
4486              (or (not (eq message-use-mail-copies-to 'ask))
4487                  (message-y-or-n-p
4488                   (concat "Obey Mail-Copies-To: never? ") t "\
4489 You should normally obey the Mail-Copies-To: header.
4490
4491         `Mail-Copies-To: never'
4492 directs you not to send your response to the author.")))
4493         (setq mct nil))
4494        ((and (or (equal (downcase mct) "always")
4495                  (equal (downcase mct) "poster"))
4496              (or (not (eq message-use-mail-copies-to 'ask))
4497                  (message-y-or-n-p
4498                   (concat "Obey Mail-Copies-To: always? ") t "\
4499 You should normally obey the Mail-Copies-To: header.
4500
4501         `Mail-Copies-To: always'
4502 sends a copy of your response to the author.")))
4503         (setq mct (or mrt from)))
4504        ((and (eq message-use-mail-copies-to 'ask)
4505              (not
4506               (message-y-or-n-p
4507                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
4508 You should normally obey the Mail-Copies-To: header.
4509
4510         `Mail-Copies-To: " mct "'
4511 sends a copy of your response to " (if (string-match "," mct)
4512                                        "the specified addresses"
4513                                      "that address") ".")))
4514         (setq mct nil))
4515        ))
4516
4517     (unless follow-to
4518       (cond
4519        (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups))))
4520        ;; Handle Followup-To.
4521        (followup-to
4522         (cond
4523          ((equal (downcase followup-to) "poster")
4524           (if (or (eq message-use-followup-to 'use)
4525                   (message-y-or-n-p "Obey Followup-To: poster? " t "\
4526 You should normally obey the Followup-To: header.
4527
4528         `Followup-To: poster'
4529 sends your response via e-mail instead of news.
4530
4531 A typical situation where `Followup-To: poster' is used is when the author
4532 does not read the newsgroup, so he wouldn't see any replies sent to it."))
4533               (setq message-this-is-news nil
4534                     distribution nil
4535                     follow-to (list (cons 'To (or mrt from ""))))
4536             (setq follow-to (list (cons 'Newsgroups newsgroups)))))
4537          (t
4538           (if (or (equal followup-to newsgroups)
4539                   (not (eq message-use-followup-to 'ask))
4540                   (message-y-or-n-p
4541                    (concat "Obey Followup-To: " followup-to "? ") t "\
4542 You should normally obey the Followup-To: header.
4543
4544         `Followup-To: " followup-to "'
4545 directs your response to " (if (string-match "," followup-to)
4546                                "the specified newsgroups"
4547                              "that newsgroup only") ".
4548
4549 If a message is posted to several newsgroups, Followup-To is often
4550 used to direct the following discussion to one newsgroup only,
4551 because discussions that are spread over several newsgroup tend to
4552 be fragmented and very difficult to follow.
4553
4554 Also, some source/announcement newsgroups are not indented for discussion;
4555 responses here are directed to other newsgroups."))
4556               (setq follow-to (list (cons 'Newsgroups followup-to)))
4557             (setq follow-to (list (cons 'Newsgroups newsgroups)))))))
4558        ;; Handle Mail-Followup-To, followup via e-mail.
4559        ((and mft
4560              (or (not (eq message-use-mail-followup-to 'ask))
4561                  (message-y-or-n-p
4562                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
4563 You should normally obey the Mail-Followup-To: header.
4564
4565         `Mail-Followup-To: " mft "'
4566 directs your response to " (if (string-match "," mft)
4567                                "the specified addresses"
4568                              "that address only") " instead of news.
4569
4570 A typical situation where Mail-Followup-To is used is when the author thinks
4571 that further discussion should take place only in "
4572                              (if (string-match "," mft)
4573                                  "the specified mailing lists"
4574                                "that mailing list") ".")))
4575         (setq message-this-is-news nil
4576               distribution nil
4577               follow-to (list (cons 'To mft))))
4578        (posted-to (setq follow-to (list (cons 'Newsgroups posted-to))))
4579        (t
4580         (setq follow-to (list (cons 'Newsgroups newsgroups))))))
4581
4582     (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
4583
4584     (setq message-reply-headers
4585           (make-full-mail-header-from-decoded-header
4586            0 subject from date message-id references 0 0 ""))
4587
4588     (message-setup
4589      `((Subject . ,subject)
4590        ,@follow-to
4591        ,@(and mct (list (cons 'Cc mct)))
4592        ,@(and distribution (list (cons 'Distribution distribution)))
4593        ,@(if (or references message-id)
4594              `((References . ,(concat (or references "") (and references " ")
4595                                       (or message-id ""))))))
4596      cur)))
4597
4598 ;;;###autoload
4599 (defun message-cancel-news ()
4600   "Cancel an article you posted."
4601   (interactive)
4602   (unless (message-news-p)
4603     (error "This is not a news article; canceling is impossible"))
4604   (when (yes-or-no-p "Do you really want to cancel this article? ")
4605     (let (from newsgroups message-id distribution buf sender)
4606       (save-excursion
4607         ;; Get header info from original article.
4608         (save-restriction
4609           (message-narrow-to-head)
4610           (setq from (message-fetch-field "from")
4611                 sender (message-fetch-field "sender")
4612                 newsgroups (message-fetch-field "newsgroups")
4613                 message-id (message-fetch-field "message-id" t)
4614                 distribution (message-fetch-field "distribution")))
4615         ;; Make sure that this article was written by the user.
4616         (unless (or (and sender
4617                          (string-equal
4618                           (downcase sender)
4619                           (downcase (message-make-sender))))
4620                     (string-equal
4621                      (downcase (cadr (std11-extract-address-components
4622                                       from)))
4623                      (downcase (cadr (std11-extract-address-components
4624                                       (message-make-from))))))
4625           (error "This article is not yours"))
4626         ;; Make control message.
4627         (setq buf (set-buffer (get-buffer-create " *message cancel*")))
4628         (erase-buffer)
4629         (insert "Newsgroups: " newsgroups "\n"
4630                 "From: " (message-make-from) "\n"
4631                 "Subject: cmsg cancel " message-id "\n"
4632                 "Control: cancel " message-id "\n"
4633                 (if distribution
4634                     (concat "Distribution: " distribution "\n")
4635                   "")
4636                 mail-header-separator "\n"
4637                 message-cancel-message)
4638         (run-hooks 'message-cancel-hook)
4639         (message "Canceling your article...")
4640         (if (let ((message-syntax-checks
4641                    'dont-check-for-anything-just-trust-me)
4642                   (message-encoding-buffer (current-buffer))
4643                   (message-edit-buffer (current-buffer)))
4644               (message-send-news))
4645             (message "Canceling your article...done"))
4646         (kill-buffer buf)))))
4647
4648 (defun message-supersede-setup-for-mime-edit ()
4649   (set (make-local-variable 'message-setup-hook) nil)
4650   (mime-edit-again))
4651
4652 ;;;###autoload
4653 (defun message-supersede ()
4654   "Start composing a message to supersede the current message.
4655 This is done simply by taking the old article and adding a Supersedes
4656 header line with the old Message-ID."
4657   (interactive)
4658   (let ((cur (current-buffer))
4659         (sender (message-fetch-field "sender"))
4660         (from (message-fetch-field "from")))
4661     ;; Check whether the user owns the article that is to be superseded.
4662     (unless (or (and sender
4663                      (string-equal
4664                       (downcase sender)
4665                       (downcase (message-make-sender))))
4666                 (string-equal
4667                  (downcase (cadr (std11-extract-address-components from)))
4668                  (downcase (cadr (std11-extract-address-components
4669                                   (message-make-from))))))
4670       (error "This article is not yours"))
4671     ;; Get a normal message buffer.
4672     (message-pop-to-buffer (message-buffer-name "supersede"))
4673     (insert-buffer-substring cur)
4674     (message-narrow-to-head)
4675     ;; Remove unwanted headers.
4676     (when message-ignored-supersedes-headers
4677       (message-remove-header message-ignored-supersedes-headers t))
4678     (goto-char (point-min))
4679     (if (not (re-search-forward "^Message-ID: " nil t))
4680         (error "No Message-ID in this article")
4681       (replace-match "Supersedes: " t t))
4682     (goto-char (point-max))
4683     (insert mail-header-separator)
4684     (widen)
4685     (when message-supersede-setup-function
4686       (funcall message-supersede-setup-function))
4687     (run-hooks 'message-supersede-setup-hook)
4688     (goto-char (point-min))
4689     (search-forward (concat "\n" mail-header-separator "\n") nil t)))
4690
4691 ;;;###autoload
4692 (defun message-recover ()
4693   "Reread contents of current buffer from its last auto-save file."
4694   (interactive)
4695   (let ((file-name (make-auto-save-file-name)))
4696     (cond ((save-window-excursion
4697              (if (not (eq system-type 'vax-vms))
4698                  (with-output-to-temp-buffer "*Directory*"
4699                    (buffer-disable-undo standard-output)
4700                    (let ((default-directory "/"))
4701                      (call-process
4702                       "ls" nil standard-output nil "-l" file-name))))
4703              (yes-or-no-p (format "Recover auto save file %s? " file-name)))
4704            (let ((buffer-read-only nil))
4705              (erase-buffer)
4706              (insert-file-contents file-name nil)))
4707           (t (error "message-recover cancelled")))))
4708
4709 ;;; Washing Subject:
4710
4711 (defun message-wash-subject (subject)
4712   "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc."
4713   (with-temp-buffer
4714     (insert-string subject)
4715     (goto-char (point-min))
4716     ;; strip Re/Fwd stuff off the beginning
4717     (while (re-search-forward
4718             "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
4719       (replace-match ""))
4720
4721     ;; and gnus-style forwards [foo@bar.com] subject
4722     (goto-char (point-min))
4723     (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
4724       (replace-match ""))
4725
4726     ;; and off the end
4727     (goto-char (point-max))
4728     (while (re-search-backward "([Ff][Ww][Dd])" nil t)
4729       (replace-match ""))
4730
4731     ;; and finally, any whitespace that was left-over
4732     (goto-char (point-min))
4733     (while (re-search-forward "^[ \t]+" nil t)
4734       (replace-match ""))
4735     (goto-char (point-max))
4736     (while (re-search-backward "[ \t]+$" nil t)
4737       (replace-match ""))
4738
4739     (buffer-string)))
4740
4741 ;;; Forwarding messages.
4742
4743 (defun message-forward-subject-author-subject (subject)
4744   "Generate a subject for a forwarded message.
4745 The form is: [Source] Subject, where if the original message was mail,
4746 Source is the sender, and if the original message was news, Source is
4747 the list of newsgroups is was posted to."
4748   (concat "["
4749           (or (message-fetch-field
4750                (if (message-news-p) "newsgroups" "from"))
4751               "(nowhere)")
4752           "] " subject))
4753
4754 (defun message-forward-subject-fwd (subject)
4755   "Generate a subject for a forwarded message.
4756 The form is: Fwd: Subject, where Subject is the original subject of
4757 the message."
4758   (concat "Fwd: " subject))
4759
4760 (defun message-make-forward-subject ()
4761   "Return a Subject header suitable for the message in the current buffer."
4762   (save-excursion
4763     (save-restriction
4764       (current-buffer)
4765       (message-narrow-to-head)
4766       (let ((funcs message-make-forward-subject-function)
4767             (subject (message-fetch-field "Subject")))
4768         (setq subject
4769               (if subject
4770                   (if message-wash-forwarded-subjects
4771                       (message-wash-subject
4772                        (nnheader-decode-subject subject))
4773                     (nnheader-decode-subject subject))
4774                 "(none)"))
4775         ;; Make sure funcs is a list.
4776         (and funcs
4777              (not (listp funcs))
4778              (setq funcs (list funcs)))
4779         ;; Apply funcs in order, passing subject generated by previous
4780         ;; func to the next one.
4781         (while funcs
4782           (when (message-functionp (car funcs))
4783             (setq subject (funcall (car funcs) subject)))
4784           (setq funcs (cdr funcs)))
4785         subject))))
4786
4787 ;;;###autoload
4788 (defun message-forward (&optional news)
4789   "Forward the current message via mail.
4790 Optional NEWS will use news to forward instead of mail."
4791   (interactive "P")
4792   (let ((cur (current-buffer))
4793         (subject (message-make-forward-subject))
4794         art-beg)
4795     (if news
4796         (message-news nil subject)
4797       (message-mail nil subject))
4798     ;; Put point where we want it before inserting the forwarded
4799     ;; message.
4800     (if message-signature-before-forwarded-message
4801         (goto-char (point-max))
4802       (message-goto-body))
4803     ;; Make sure we're at the start of the line.
4804     (unless (eolp)
4805       (insert "\n"))
4806     ;; Narrow to the area we are to insert.
4807     (narrow-to-region (point) (point))
4808     ;; Insert the separators and the forwarded buffer.
4809     (insert message-forward-start-separator)
4810     (setq art-beg (point))
4811     (insert-buffer-substring cur)
4812     (goto-char (point-max))
4813     (insert message-forward-end-separator)
4814     (set-text-properties (point-min) (point-max) nil)
4815     ;; Remove all unwanted headers.
4816     (goto-char art-beg)
4817     (narrow-to-region (point) (if (search-forward "\n\n" nil t)
4818                                   (1- (point))
4819                                 (point)))
4820     (goto-char (point-min))
4821     (message-remove-header message-included-forward-headers t nil t)
4822     (widen)
4823     (message-position-point)))
4824
4825 ;;;###autoload
4826 (defun message-resend (address)
4827   "Resend the current article to ADDRESS."
4828   (interactive
4829    (list (message-read-from-minibuffer "Resend message to: ")))
4830   (message "Resending message to %s..." address)
4831   (save-excursion
4832     (let ((cur (current-buffer))
4833           beg)
4834       ;; We first set up a normal mail buffer.
4835       (set-buffer (get-buffer-create " *message resend*"))
4836       (erase-buffer)
4837       ;; avoid to turn-on-mime-edit
4838       (let (message-setup-hook)
4839         (message-setup `((To . ,address)))
4840         )
4841       ;; Insert our usual headers.
4842       (message-generate-headers '(From Date To))
4843       (message-narrow-to-headers)
4844       ;; Rename them all to "Resent-*".
4845       (while (re-search-forward "^[A-Za-z]" nil t)
4846         (forward-char -1)
4847         (insert "Resent-"))
4848       (widen)
4849       (forward-line)
4850       (delete-region (point) (point-max))
4851       (setq beg (point))
4852       ;; Insert the message to be resent.
4853       (insert-buffer-substring cur)
4854       (goto-char (point-min))
4855       (search-forward "\n\n")
4856       (forward-char -1)
4857       (save-restriction
4858         (narrow-to-region beg (point))
4859         (message-remove-header message-ignored-resent-headers t)
4860         (goto-char (point-max)))
4861       (insert mail-header-separator)
4862       ;; Rename all old ("Also-")Resent headers.
4863       (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
4864         (beginning-of-line)
4865         (insert "Also-"))
4866       ;; Quote any "From " lines at the beginning.
4867       (goto-char beg)
4868       (when (looking-at "From ")
4869         (replace-match "X-From-Line: "))
4870       ;; Send it.
4871       (let ((message-encoding-buffer (current-buffer))
4872             (message-edit-buffer (current-buffer)))
4873         (let (message-required-mail-headers)
4874           (message-send-mail)))
4875       (kill-buffer (current-buffer)))
4876     (message "Resending message to %s...done" address)))
4877
4878 (defun message-bounce-setup-for-mime-edit ()
4879   (set (make-local-variable 'message-setup-hook) nil)
4880   (mime-edit-again))
4881
4882 ;;;###autoload
4883 (defun message-bounce ()
4884   "Re-mail the current message.
4885 This only makes sense if the current message is a bounce message than
4886 contains some mail you have written which has been bounced back to
4887 you."
4888   (interactive)
4889   (let ((cur (current-buffer))
4890         boundary)
4891     (message-pop-to-buffer (message-buffer-name "bounce"))
4892     (insert-buffer-substring cur)
4893     (undo-boundary)
4894     (message-narrow-to-head)
4895     (if (and (message-fetch-field "MIME-Version")
4896              (setq boundary (message-fetch-field "Content-Type")))
4897         (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
4898             (setq boundary (concat (match-string 1 boundary) " *\n"
4899                                    "Content-Type: message/rfc822"))
4900           (setq boundary nil)))
4901     (widen)
4902     (goto-char (point-min))
4903     (search-forward "\n\n" nil t)
4904     (or (and boundary
4905              (re-search-forward boundary nil t)
4906              (forward-line 2))
4907         (and (re-search-forward message-unsent-separator nil t)
4908              (forward-line 1))
4909         (re-search-forward "^Return-Path:.*\n" nil t))
4910     ;; We remove everything before the bounced mail.
4911     (delete-region
4912      (point-min)
4913      (if (re-search-forward "^[^ \n\t]+:" nil t)
4914          (match-beginning 0)
4915        (point)))
4916     (save-restriction
4917       (message-narrow-to-head)
4918       (message-remove-header message-ignored-bounced-headers t)
4919       (goto-char (point-max))
4920       (insert mail-header-separator))
4921     (when message-bounce-setup-function
4922       (funcall message-bounce-setup-function))
4923     (run-hooks 'message-bounce-setup-hook)
4924     (message-position-point)))
4925
4926 ;;;
4927 ;;; Interactive entry points for new message buffers.
4928 ;;;
4929
4930 ;;;###autoload
4931 (defun message-mail-other-window (&optional to subject)
4932   "Like `message-mail' command, but display mail buffer in another window."
4933   (interactive)
4934   (let ((pop-up-windows t)
4935         (special-display-buffer-names nil)
4936         (special-display-regexps nil)
4937         (same-window-buffer-names nil)
4938         (same-window-regexps nil))
4939     (message-pop-to-buffer (message-buffer-name "mail" to)))
4940   (let ((message-this-is-mail t))
4941     (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
4942
4943 ;;;###autoload
4944 (defun message-mail-other-frame (&optional to subject)
4945   "Like `message-mail' command, but display mail buffer in another frame."
4946   (interactive)
4947   (let ((pop-up-frames t)
4948         (special-display-buffer-names nil)
4949         (special-display-regexps nil)
4950         (same-window-buffer-names nil)
4951         (same-window-regexps nil))
4952     (message-pop-to-buffer (message-buffer-name "mail" to)))
4953   (let ((message-this-is-mail t))
4954     (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
4955
4956 ;;;###autoload
4957 (defun message-news-other-window (&optional newsgroups subject)
4958   "Start editing a news article to be sent."
4959   (interactive)
4960   (let ((pop-up-windows t)
4961         (special-display-buffer-names nil)
4962         (special-display-regexps nil)
4963         (same-window-buffer-names nil)
4964         (same-window-regexps nil))
4965     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
4966   (let ((message-this-is-news t))
4967     (message-setup `((Newsgroups . ,(or newsgroups ""))
4968                      (Subject . ,(or subject ""))))))
4969
4970 ;;;###autoload
4971 (defun message-news-other-frame (&optional newsgroups subject)
4972   "Start editing a news article to be sent."
4973   (interactive)
4974   (let ((pop-up-frames t)
4975         (special-display-buffer-names nil)
4976         (special-display-regexps nil)
4977         (same-window-buffer-names nil)
4978         (same-window-regexps nil))
4979     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
4980   (let ((message-this-is-news t))
4981     (message-setup `((Newsgroups . ,(or newsgroups ""))
4982                      (Subject . ,(or subject ""))))))
4983
4984 ;;; underline.el
4985
4986 ;; This code should be moved to underline.el (from which it is stolen).
4987
4988 ;;;###autoload
4989 (defun bold-region (start end)
4990   "Bold all nonblank characters in the region.
4991 Works by overstriking characters.
4992 Called from program, takes two arguments START and END
4993 which specify the range to operate on."
4994   (interactive "r")
4995   (save-excursion
4996     (let ((end1 (make-marker)))
4997       (move-marker end1 (max start end))
4998       (goto-char (min start end))
4999       (while (< (point) end1)
5000         (or (looking-at "[_\^@- ]")
5001             (insert (char-after) "\b"))
5002         (forward-char 1)))))
5003
5004 ;;;###autoload
5005 (defun unbold-region (start end)
5006   "Remove all boldness (overstruck characters) in the region.
5007 Called from program, takes two arguments START and END
5008 which specify the range to operate on."
5009   (interactive "r")
5010   (save-excursion
5011     (let ((end1 (make-marker)))
5012       (move-marker end1 (max start end))
5013       (goto-char (min start end))
5014       (while (re-search-forward "\b" end1 t)
5015         (if (eq (char-after) (char-after (- (point) 2)))
5016             (delete-char -2))))))
5017
5018 (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
5019
5020 ;; Support for toolbar
5021 (when (string-match "XEmacs\\|Lucid" emacs-version)
5022   (require 'messagexmas))
5023
5024 ;;; Group name completion.
5025
5026 (defvar message-newgroups-header-regexp
5027   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
5028   "Regexp that match headers that lists groups.")
5029
5030 (defun message-tab ()
5031   "Expand group names in Newsgroups and Followup-To headers.
5032 Do a `tab-to-tab-stop' if not in those headers."
5033   (interactive)
5034   (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
5035         (mail-abbrev-in-expansion-header-p))
5036       (message-expand-group)
5037     (tab-to-tab-stop)))
5038
5039 (defvar gnus-active-hashtb)
5040 (defun message-expand-group ()
5041   "Expand the group name under point."
5042   (let* ((b (save-excursion
5043               (save-restriction
5044                 (narrow-to-region
5045                  (save-excursion
5046                    (beginning-of-line)
5047                    (skip-chars-forward "^:")
5048                    (1+ (point)))
5049                  (point))
5050                 (skip-chars-backward "^, \t\n") (point))))
5051          (completion-ignore-case t)
5052          (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
5053                                             (point))))
5054          (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
5055          (completions (all-completions string hashtb))
5056          comp)
5057     (delete-region b (point))
5058     (cond
5059      ((= (length completions) 1)
5060       (if (string= (car completions) string)
5061           (progn
5062             (insert string)
5063             (message "Only matching group"))
5064         (insert (car completions))))
5065      ((and (setq comp (try-completion string hashtb))
5066            (not (string= comp string)))
5067       (insert comp))
5068      (t
5069       (insert string)
5070       (if (not comp)
5071           (message "No matching groups")
5072         (save-selected-window
5073           (pop-to-buffer "*Completions*")
5074           (buffer-disable-undo)
5075           (let ((buffer-read-only nil))
5076             (erase-buffer)
5077             (let ((standard-output (current-buffer)))
5078               (display-completion-list (sort completions 'string<)))
5079             (goto-char (point-min))
5080             (delete-region (point) (progn (forward-line 3) (point))))))))))
5081
5082 ;;; Help stuff.
5083
5084 (defun message-talkative-question (ask question show &rest text)
5085   "Call FUNCTION with argument QUESTION; optionally display TEXT... args.
5086 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer.
5087 The following arguments may contain lists of values."
5088   (if (and show
5089            (setq text (message-flatten-list text)))
5090       (save-window-excursion
5091         (save-excursion
5092           (with-output-to-temp-buffer " *MESSAGE information message*"
5093             (set-buffer " *MESSAGE information message*")
5094             (mapcar 'princ text)
5095             (goto-char (point-min))))
5096         (funcall ask question))
5097     (funcall ask question)))
5098
5099 (defun message-flatten-list (list)
5100   "Return a new, flat list that contains all elements of LIST.
5101
5102 \(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
5103 => (1 2 3 4 5 6 7)"
5104   (cond ((consp list)
5105          (apply 'append (mapcar 'message-flatten-list list)))
5106         (list
5107          (list list))))
5108
5109 (defun message-generate-new-buffer-clone-locals (name &optional varstr)
5110   "Create and return a buffer with a name based on NAME using generate-new-buffer.
5111 Then clone the local variables and values from the old buffer to the
5112 new one, cloning only the locals having a substring matching the
5113 regexp varstr."
5114   (let ((oldbuf (current-buffer)))
5115     (save-excursion
5116       (set-buffer (generate-new-buffer name))
5117       (message-clone-locals oldbuf varstr)
5118       (current-buffer))))
5119
5120 (defun message-clone-locals (buffer &optional varstr)
5121   "Clone the local variables from BUFFER to the current buffer."
5122   (let ((locals (save-excursion
5123                   (set-buffer buffer)
5124                   (buffer-local-variables)))
5125         (regexp
5126          "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
5127     (mapcar
5128      (lambda (local)
5129        (when (and (consp local)
5130                   (car local)
5131                   (string-match regexp (symbol-name (car local)))
5132                   (or (null varstr)
5133                       (string-match varstr (symbol-name (car local)))))
5134          (ignore-errors
5135            (set (make-local-variable (car local))
5136                 (cdr local)))))
5137      locals)))
5138
5139
5140 ;;; @ for MIME Edit mode
5141 ;;;
5142
5143 (defun message-maybe-encode ()
5144   (when message-mime-mode
5145     ;; Inherit the buffer local variable `mime-edit-pgp-processing'.
5146     (let ((pgp-processing (with-current-buffer message-edit-buffer
5147                             mime-edit-pgp-processing)))
5148       (setq mime-edit-pgp-processing pgp-processing))
5149     (run-hooks 'mime-edit-translate-hook)
5150     (if (catch 'mime-edit-error
5151           (save-excursion
5152             (mime-edit-pgp-enclose-buffer)
5153             (mime-edit-translate-body)
5154             ))
5155         (error "Translation error!")
5156       )
5157     (end-of-invisible)
5158     (run-hooks 'mime-edit-exit-hook)
5159     ))
5160
5161 (defun message-mime-insert-article (&optional full-headers)
5162   (interactive "P")
5163   (let ((message-cite-function 'mime-edit-inserted-message-filter)
5164         (message-reply-buffer
5165          (message-get-parameter-with-eval 'original-buffer))
5166         (start (point)))
5167     (message-yank-original nil)
5168     (save-excursion
5169       (narrow-to-region (goto-char start)
5170                         (if (search-forward "\n\n" nil t)
5171                             (1- (point))
5172                           (point-max)))
5173       (goto-char (point-min))
5174       (let ((message-included-forward-headers
5175              (if full-headers "" message-included-forward-headers)))
5176         (message-remove-header message-included-forward-headers t nil t))
5177       (widen))))
5178
5179 (set-alist 'mime-edit-message-inserter-alist
5180            'message-mode (function message-mime-insert-article))
5181
5182 ;;; Miscellaneous functions
5183
5184 ;; stolen (and renamed) from nnheader.el
5185 (defun message-replace-chars-in-string (string from to)
5186   "Replace characters in STRING from FROM to TO."
5187   (let ((string (substring string 0))   ;Copy string.
5188         (len (length string))
5189         (idx 0))
5190     ;; Replace all occurrences of FROM with TO.
5191     (while (< idx len)
5192       (when (= (aref string idx) from)
5193         (aset string idx to))
5194       (setq idx (1+ idx)))
5195     string))
5196
5197 ;;;
5198 ;;; MIME functions
5199 ;;;
5200
5201 (defvar message-inhibit-body-encoding t)
5202
5203 (defun message-encode-message-body ()
5204   (unless message-inhibit-body-encoding
5205     (let ((mail-parse-charset (or mail-parse-charset
5206                                   message-default-charset))
5207           (case-fold-search t)
5208           lines content-type-p)
5209       (message-goto-body)
5210       (save-restriction
5211         (narrow-to-region (point) (point-max))
5212         (let ((new (mml-generate-mime)))
5213           (when new
5214             (delete-region (point-min) (point-max))
5215             (insert new)
5216             (goto-char (point-min))
5217             (if (eq (aref new 0) ?\n)
5218                 (delete-char 1)
5219               (search-forward "\n\n")
5220               (setq lines (buffer-substring (point-min) (1- (point))))
5221               (delete-region (point-min) (point))))))
5222       (save-restriction
5223         (message-narrow-to-headers-or-head)
5224         (message-remove-header "Mime-Version")
5225         (goto-char (point-max))
5226         (insert "MIME-Version: 1.0\n")
5227         (when lines
5228           (insert lines))
5229         (setq content-type-p
5230               (re-search-backward "^Content-Type:" nil t)))
5231       (save-restriction
5232         (message-narrow-to-headers-or-head)
5233         (message-remove-first-header "Content-Type")
5234         (message-remove-first-header "Content-Transfer-Encoding"))
5235       ;; We always make sure that the message has a Content-Type header.
5236       ;; This is because some broken MTAs and MUAs get awfully confused
5237       ;; when confronted with a message with a MIME-Version header and
5238       ;; without a Content-Type header.  For instance, Solaris'
5239       ;; /usr/bin/mail.
5240       (unless content-type-p
5241         (goto-char (point-min))
5242         (re-search-forward "^MIME-Version:")
5243         (forward-line 1)
5244         (insert "Content-Type: text/plain; charset=us-ascii\n")))))
5245
5246 (defun message-read-from-minibuffer (prompt)
5247   "Read from the minibuffer while providing abbrev expansion."
5248   (if (fboundp 'mail-abbrevs-setup)
5249       (let ((mail-abbrev-mode-regexp "")
5250             (minibuffer-setup-hook 'mail-abbrevs-setup))
5251         (read-from-minibuffer prompt)))
5252   (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook))
5253     (read-string prompt)))
5254
5255 (defvar message-save-buffer " *encoding")
5256 (defun message-save-drafts ()
5257   (interactive)
5258   (if (not (get-buffer message-save-buffer))
5259       (get-buffer-create message-save-buffer))
5260   (let ((filename buffer-file-name)
5261         (buffer (current-buffer))
5262         (reply-headers message-reply-headers))
5263     (set-buffer message-save-buffer)
5264     (erase-buffer)
5265     (insert-buffer buffer)
5266     (setq message-reply-headers reply-headers)
5267     (message-generate-headers  '((optional . In-Reply-To)))
5268     (mime-edit-translate-buffer)
5269     (write-region (point-min) (point-max) filename)
5270     (set-buffer buffer)
5271     (set-buffer-modified-p nil)))
5272
5273 (provide 'message)
5274
5275 (run-hooks 'message-load-hook)
5276
5277 ;; Local Variables:
5278 ;; coding: iso-8859-1
5279 ;; End:
5280
5281 ;;; message.el ends here