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