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

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