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