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