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