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 "\n")
3611                     (forward-line -1))
3612                 ;; The value of this header was empty, so we clear
3613                 ;; totally and insert the new value.
3614                 (delete-region (point) (gnus-point-at-eol))
3615                 (insert value))
3616               ;; Add the deletable property to the headers that require it.
3617               (and (memq header message-deletable-headers)
3618                    (progn (beginning-of-line) (looking-at "[^:]+: "))
3619                    (add-text-properties
3620                     (point) (match-end 0)
3621                     '(message-deletable t face italic) (current-buffer)))))))
3622       ;; Insert new Sender if the From is strange.
3623       (let ((from (message-fetch-field "from"))
3624             (sender (message-fetch-field "sender"))
3625             (secure-sender (message-make-sender)))
3626         (when (and from
3627                    (not (message-check-element 'sender))
3628                    (not (string=
3629                          (downcase
3630                           (cadr (std11-extract-address-components from)))
3631                          (downcase secure-sender)))
3632                    (or (null sender)
3633                        (not
3634                         (string=
3635                          (downcase
3636                           (cadr (std11-extract-address-components sender)))
3637                          (downcase secure-sender)))))
3638           (goto-char (point-min))
3639           ;; Rename any old Sender headers to Original-Sender.
3640           (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
3641             (beginning-of-line)
3642             (insert "Original-")
3643             (beginning-of-line))
3644           (when (or (message-news-p)
3645                     (string-match "@.+\\.." secure-sender))
3646             (insert "Sender: " secure-sender "\n")))))))
3647
3648 (defun message-insert-courtesy-copy ()
3649   "Insert a courtesy message in mail copies of combined messages."
3650   (let (newsgroups)
3651     (save-excursion
3652       (save-restriction
3653         (message-narrow-to-headers)
3654         (when (setq newsgroups (message-fetch-field "newsgroups"))
3655           (goto-char (point-max))
3656           (insert "Posted-To: " newsgroups "\n")))
3657       (forward-line 1)
3658       (when message-courtesy-message
3659         (cond
3660          ((string-match "%s" message-courtesy-message)
3661           (insert (format message-courtesy-message newsgroups)))
3662          (t
3663           (insert message-courtesy-message)))))))
3664
3665 ;;;
3666 ;;; Setting up a message buffer
3667 ;;;
3668
3669 (defun message-fill-address (header value)
3670   (save-restriction
3671     (narrow-to-region (point) (point))
3672     (insert (capitalize (symbol-name header))
3673             ": "
3674             (if (consp value) (car value) value)
3675             "\n")
3676     (narrow-to-region (point-min) (1- (point-max)))
3677     (let (quoted last)
3678       (goto-char (point-min))
3679       (while (not (eobp))
3680         (skip-chars-forward "^,\"" (point-max))
3681         (if (or (eq (char-after) ?,)
3682                 (eobp))
3683             (when (not quoted)
3684               (if (and (> (current-column) 78)
3685                        last)
3686                   (save-excursion
3687                     (goto-char last)
3688                     (looking-at "[ \t]*")
3689                     (replace-match "\n " t t)))
3690               (setq last (1+ (point))))
3691           (setq quoted (not quoted)))
3692         (unless (eobp)
3693           (forward-char 1))))
3694     (goto-char (point-max))
3695     (widen)
3696     (forward-line 1)))
3697
3698 (defun message-fill-references (header value)
3699   (insert (capitalize (symbol-name header))
3700           ": "
3701           (std11-fill-msg-id-list-string
3702           (if (consp value) (car value) value))
3703           "\n"))
3704
3705 (defun message-fill-header (header value)
3706   (let ((begin (point))
3707         (fill-column 78)
3708         (fill-prefix " "))
3709     (insert (capitalize (symbol-name header))
3710             ": "
3711             (if (consp value) (car value) value)
3712             "\n")
3713     (save-restriction
3714       (narrow-to-region begin (point))
3715       (fill-region-as-paragraph begin (point))
3716       ;; Tapdance around looong Message-IDs.
3717       (forward-line -1)
3718       (when (looking-at "[ \t]*$")
3719         (message-delete-line))
3720       (goto-char begin)
3721       (re-search-forward ":" nil t)
3722       (when (looking-at "\n[ \t]+")
3723         (replace-match " " t t))
3724       (goto-char (point-max)))))
3725
3726 (defun message-shorten-references (header references)
3727   "Limit REFERENCES to be shorter than 988 characters."
3728   (let ((max 988)
3729         (cut 4)
3730         refs)
3731     (with-temp-buffer
3732       (insert references)
3733       (goto-char (point-min))
3734       (while (re-search-forward "<[^>]+>" nil t)
3735         (push (match-string 0) refs))
3736       (setq refs (nreverse refs))
3737       (while (> (length (mapconcat 'identity refs " ")) max)
3738         (when (< (length refs) (1+ cut))
3739           (decf cut))
3740         (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs)))))
3741     (insert (capitalize (symbol-name header)) ": "
3742             (mapconcat 'identity refs " ") "\n")))
3743
3744 (defun message-position-point ()
3745   "Move point to where the user probably wants to find it."
3746   (message-narrow-to-headers)
3747   (cond
3748    ((re-search-forward "^[^:]+:[ \t]*$" nil t)
3749     (search-backward ":" )
3750     (widen)
3751     (forward-char 1)
3752     (if (eq (char-after) ? )
3753         (forward-char 1)
3754       (insert " ")))
3755    (t
3756     (goto-char (point-max))
3757     (widen)
3758     (forward-line 1)
3759     (unless (looking-at "$")
3760       (forward-line 2)))
3761    (sit-for 0)))
3762
3763 (defun message-buffer-name (type &optional to group)
3764   "Return a new (unique) buffer name based on TYPE and TO."
3765   (cond
3766    ;; Generate a new buffer name The Message Way.
3767    ((eq message-generate-new-buffers 'unique)
3768     (generate-new-buffer-name
3769      (concat "*" type
3770              (if to
3771                  (concat " to "
3772                          (or (car (std11-extract-address-components to))
3773                              to) "")
3774                "")
3775              (if (and group (not (string= group ""))) (concat " on " group) "")
3776              "*")))
3777    ;; Check whether `message-generate-new-buffers' is a function,
3778    ;; and if so, call it.
3779    ((message-functionp message-generate-new-buffers)
3780     (funcall message-generate-new-buffers type to group))
3781    ((eq message-generate-new-buffers 'unsent)
3782     (generate-new-buffer-name
3783      (concat "*unsent " type
3784              (if to
3785                  (concat " to "
3786                          (or (car (mail-extract-address-components to))
3787                              to) "")
3788                "")
3789              (if (and group (not (string= group ""))) (concat " on " group) "")
3790              "*")))
3791    ;; Use standard name.
3792    (t
3793     (format "*%s message*" type))))
3794
3795 (defmacro message-pop-to-buffer-1 (buffer)
3796   `(if pop-up-frames
3797        (let (special-display-buffer-names
3798              special-display-regexps
3799              same-window-buffer-names
3800              same-window-regexps)
3801          (pop-to-buffer ,buffer))
3802      (pop-to-buffer ,buffer)))
3803
3804 (defun message-pop-to-buffer (name)
3805   "Pop to buffer NAME, and warn if it already exists and is modified."
3806   (let ((buffer (get-buffer name))
3807         (pop-up-frames (and (or (static-if (featurep 'xemacs)
3808                                     (device-on-window-system-p)
3809                                   window-system)
3810                                 (>= emacs-major-version 20))
3811                             message-use-multi-frames)))
3812     (if (and buffer
3813              (buffer-name buffer))
3814         (progn
3815           (message-pop-to-buffer-1 buffer)
3816           (when (and (buffer-modified-p)
3817                      (not (y-or-n-p
3818                            "Message already being composed; erase? ")))
3819             (error "Message being composed")))
3820       (message-pop-to-buffer-1 name))
3821     (erase-buffer)
3822     (message-mode)
3823     (when pop-up-frames
3824       (set (make-local-variable 'message-original-frame) (selected-frame)))))
3825
3826 (defun message-do-send-housekeeping ()
3827   "Kill old message buffers."
3828   ;; We might have sent this buffer already.  Delete it from the
3829   ;; list of buffers.
3830   (setq message-buffer-list (delq (current-buffer) message-buffer-list))
3831   (while (and message-max-buffers
3832               message-buffer-list
3833               (>= (length message-buffer-list) message-max-buffers))
3834     ;; Kill the oldest buffer -- unless it has been changed.
3835     (let ((buffer (pop message-buffer-list)))
3836       (when (and (buffer-name buffer)
3837                  (not (buffer-modified-p buffer)))
3838         (kill-buffer buffer))))
3839   ;; Rename the buffer.
3840   (if message-send-rename-function
3841       (funcall message-send-rename-function)
3842     (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name))
3843       (rename-buffer
3844        (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
3845   ;; Push the current buffer onto the list.
3846   (when message-max-buffers
3847     (setq message-buffer-list
3848           (nconc message-buffer-list (list (current-buffer))))))
3849
3850 (defvar mc-modes-alist)
3851 (defun message-setup (headers &optional replybuffer actions)
3852   (when (and (boundp 'mc-modes-alist)
3853              (not (assq 'message-mode mc-modes-alist)))
3854     (push '(message-mode (encrypt . mc-encrypt-message)
3855                          (sign . mc-sign-message))
3856           mc-modes-alist))
3857   (when actions
3858     (setq message-send-actions actions))
3859   (setq message-reply-buffer
3860         (or (message-get-parameter 'reply-buffer)
3861             replybuffer))
3862   (goto-char (point-min))
3863   ;; Insert all the headers.
3864   (mail-header-format
3865    (let ((h headers)
3866          (alist message-header-format-alist))
3867      (while h
3868        (unless (assq (caar h) message-header-format-alist)
3869          (push (list (caar h)) alist))
3870        (pop h))
3871      alist)
3872    headers)
3873   (delete-region (point) (progn (forward-line -1) (point)))
3874   (when message-default-headers
3875     (insert message-default-headers)
3876     (or (bolp) (insert ?\n)))
3877   (put-text-property
3878    (point)
3879    (progn
3880      (insert mail-header-separator "\n")
3881      (1- (point)))
3882    'read-only nil)
3883   (forward-line -1)
3884   (when (message-news-p)
3885     (when message-default-news-headers
3886       (insert message-default-news-headers)
3887       (or (bolp) (insert ?\n)))
3888     (when message-generate-headers-first
3889       (message-generate-headers
3890        (delq 'Lines
3891              (delq 'Subject
3892                    (copy-sequence message-required-news-headers))))))
3893   (when (message-mail-p)
3894     (when message-default-mail-headers
3895       (insert message-default-mail-headers)
3896       (or (bolp) (insert ?\n)))
3897     (when message-generate-headers-first
3898       (message-generate-headers
3899        (delq 'Lines
3900              (delq 'Subject
3901                    (copy-sequence message-required-mail-headers))))))
3902   (run-hooks 'message-signature-setup-hook)
3903   (message-insert-signature)
3904   (save-restriction
3905     (message-narrow-to-headers)
3906     (run-hooks 'message-header-setup-hook))
3907   (set-buffer-modified-p nil)
3908   (setq buffer-undo-list nil)
3909   (run-hooks 'message-setup-hook)
3910   (message-position-point)
3911   (undo-boundary))
3912
3913 (defun message-set-auto-save-file-name ()
3914   "Associate the message buffer with a file in the drafts directory."
3915   (when message-auto-save-directory
3916     (if (gnus-alive-p)
3917         (setq message-draft-article
3918               (nndraft-request-associate-buffer "drafts"))
3919       (setq buffer-file-name (expand-file-name "*message*"
3920                                                message-auto-save-directory))
3921       (setq buffer-auto-save-file-name (make-auto-save-file-name)))
3922     (clear-visited-file-modtime)
3923     (static-if (boundp 'MULE)
3924         (set-file-coding-system message-draft-coding-system)
3925       (setq buffer-file-coding-system message-draft-coding-system))))
3926
3927 (defun message-disassociate-draft ()
3928   "Disassociate the message buffer from the drafts directory."
3929   (when message-draft-article
3930     (nndraft-request-expire-articles
3931      (list message-draft-article) "drafts" nil t)))
3932
3933 (defun message-insert-headers ()
3934   "Generate the headers for the article."
3935   (interactive)
3936   (save-excursion
3937     (save-restriction
3938       (message-narrow-to-headers)
3939       (when (message-news-p)
3940         (message-generate-headers
3941          (delq 'Lines
3942                (delq 'Subject
3943                      (copy-sequence message-required-news-headers)))))
3944       (when (message-mail-p)
3945         (message-generate-headers
3946          (delq 'Lines
3947                (delq 'Subject
3948                      (copy-sequence message-required-mail-headers))))))))
3949
3950 \f
3951
3952 ;;;
3953 ;;; Commands for interfacing with message
3954 ;;;
3955
3956 ;;;###autoload
3957 (defun message-mail (&optional to subject
3958                                other-headers continue switch-function
3959                                yank-action send-actions)
3960   "Start editing a mail message to be sent.
3961 OTHER-HEADERS is an alist of header/value pairs."
3962   (interactive)
3963   (let ((message-this-is-mail t))
3964     (message-pop-to-buffer (message-buffer-name "mail" to))
3965     (message-setup
3966      (nconc
3967       `((To . ,(or to "")) (Subject . ,(or subject "")))
3968       (when other-headers other-headers)))))
3969
3970 ;;;###autoload
3971 (defun message-news (&optional newsgroups subject)
3972   "Start editing a news article to be sent."
3973   (interactive)
3974   (let ((message-this-is-news t))
3975     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
3976     (message-setup `((Newsgroups . ,(or newsgroups ""))
3977                      (Subject . ,(or subject ""))))))
3978
3979 ;;;###autoload
3980 (defun message-reply (&optional to-address wide)
3981   "Start editing a reply to the article in the current buffer."
3982   (interactive)
3983   (let ((cur (current-buffer))
3984         from subject date to cc
3985         references message-id follow-to
3986         (inhibit-point-motion-hooks t)
3987         (message-this-is-mail t)
3988         mct never-mct mft mrt gnus-warning in-reply-to)
3989     (save-restriction
3990       (message-narrow-to-head)
3991       ;; Allow customizations to have their say.
3992       (if (not wide)
3993           ;; This is a regular reply.
3994           (if (message-functionp message-reply-to-function)
3995               (setq follow-to (funcall message-reply-to-function)))
3996         ;; This is a followup.
3997         (if (message-functionp message-wide-reply-to-function)
3998             (save-excursion
3999               (setq follow-to
4000                     (funcall message-wide-reply-to-function)))))
4001       ;; Find all relevant headers we need.
4002       (setq from (message-fetch-field "from")
4003             date (message-fetch-field "date" t)
4004             subject (or (message-fetch-field "subject") "none")
4005             references (message-fetch-field "references")
4006             message-id (message-fetch-field "message-id" t)
4007             to (message-fetch-field "to")
4008             cc (message-fetch-field "cc")
4009             mct (when (and wide message-use-mail-copies-to)
4010                   (message-fetch-field "mail-copies-to"))
4011             mft (when (and wide message-use-mail-followup-to)
4012                   (message-fetch-field "mail-followup-to"))
4013             mrt (when message-use-mail-reply-to
4014                   (or (message-fetch-field "mail-reply-to")
4015                       (message-fetch-field "reply-to")))
4016             gnus-warning (message-fetch-field "gnus-warning"))
4017       (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
4018         (setq message-id (match-string 0 gnus-warning)))
4019       ;; Get the references from "In-Reply-To" field if there were
4020       ;; no references and "In-Reply-To" field looks promising.
4021       (unless references
4022         (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
4023                    (string-match "<[^>]+>" in-reply-to))
4024           (setq references (match-string 0 in-reply-to))))
4025       ;; Remove any (buggy) Re:'s that are present and make a
4026       ;; proper one.
4027       (setq subject (message-make-followup-subject subject))
4028       (widen))
4029
4030     ;; Handle special values of Mail-Copies-To.
4031     (when mct
4032       (cond
4033        ((and (or (equal (downcase mct) "never")
4034                  (equal (downcase mct) "nobody"))
4035              (or (not (eq message-use-mail-copies-to 'ask))
4036                  (message-y-or-n-p
4037                   (concat "Obey Mail-Copies-To: never? ") t "\
4038 You should normally obey the Mail-Copies-To: header.
4039
4040         `Mail-Copies-To: never'
4041 directs you not to send your response to the author.")))
4042         (setq never-mct t)
4043         (setq mct nil))
4044        ((and (or (equal (downcase mct) "always")
4045                  (equal (downcase mct) "poster"))
4046              (or (not (eq message-use-mail-copies-to 'ask))
4047                  (message-y-or-n-p
4048                   (concat "Obey Mail-Copies-To: always? ") t "\
4049 You should normally obey the Mail-Copies-To: header.
4050
4051         `Mail-Copies-To: always'
4052 sends a copy of your response to the author.")))
4053         (setq mct (or mrt from)))
4054        ((and (eq message-use-mail-copies-to 'ask)
4055              (not
4056               (message-y-or-n-p
4057                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
4058 You should normally obey the Mail-Copies-To: header.
4059
4060         `Mail-Copies-To: " mct "'
4061 sends a copy of your response to " (if (string-match "," mct)
4062                                        "the specified addresses"
4063                                      "that address") ".")))
4064         (setq mct nil))
4065        ))
4066
4067     (unless follow-to
4068       (cond
4069        (to-address (setq follow-to (list (cons 'To to-address))))
4070        ((not wide) (setq follow-to (list (cons 'To (or mrt from)))))
4071        ;; Handle Mail-Followup-To.
4072        ((and mft
4073              (or (not (eq message-use-mail-followup-to 'ask))
4074                  (message-y-or-n-p
4075                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
4076 You should normally obey the Mail-Followup-To: header.
4077
4078         `Mail-Followup-To: " mft "'
4079 directs your response to " (if (string-match "," mft)
4080                                "the specified addresses"
4081                              "that address only") ".
4082
4083 A typical situation where Mail-Followup-To is used is when the author thinks
4084 that further discussion should take place only in "
4085                              (if (string-match "," mft)
4086                                  "the specified mailing lists"
4087                                "that mailing list") ".")))
4088         (setq follow-to (list (cons 'To mft)))
4089         (when mct
4090           (push (cons 'Cc mct) follow-to)))
4091        (t
4092         (let (ccalist)
4093           (save-excursion
4094             (message-set-work-buffer)
4095             (unless never-mct
4096               (insert (or mrt from "")))
4097             (insert (if to (concat (if (bolp) "" ", ") to "") ""))
4098             (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
4099             (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
4100             (goto-char (point-min))
4101             (while (re-search-forward "[ \t]+" nil t)
4102               (replace-match " " t t))
4103             ;; Remove addresses that match `rmail-dont-reply-to-names'.
4104             (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
4105               (insert (prog1 (rmail-dont-reply-to (buffer-string))
4106                         (erase-buffer))))
4107             (goto-char (point-min))
4108             ;; Perhaps Mail-Copies-To: never removed the only address?
4109             (when (eobp)
4110               (insert (or mrt from "")))
4111             (setq ccalist
4112                   (mapcar
4113                    (lambda (addr)
4114                      (cons (mail-strip-quoted-names addr) addr))
4115                    (message-tokenize-header (buffer-string))))
4116             (let ((s ccalist))
4117               (while s
4118                 (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
4119           (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
4120           (when ccalist
4121             (let ((ccs (cons 'Cc (mapconcat
4122                                   (lambda (addr) (cdr addr)) ccalist ", "))))
4123               (when (string-match "^ +" (cdr ccs))
4124                 (setcdr ccs (substring (cdr ccs) (match-end 0))))
4125               (push ccs follow-to)))))))
4126
4127     (message-pop-to-buffer (message-buffer-name
4128                             (if wide "wide reply" "reply") from
4129                             (if wide to-address nil)))
4130
4131     (setq message-reply-headers
4132           (make-full-mail-header-from-decoded-header
4133            0 subject from date message-id references 0 0 ""))
4134
4135     (message-setup
4136      `((Subject . ,subject)
4137        ,@follow-to
4138        ,@(if (or references message-id)
4139              `((References . ,(concat (or references "") (and references " ")
4140                                       (or message-id ""))))))
4141      cur)))
4142
4143 ;;;###autoload
4144 (defun message-wide-reply (&optional to-address)
4145   "Make a \"wide\" reply to the message in the current buffer."
4146   (interactive)
4147   (message-reply to-address t))
4148
4149 ;;;###autoload
4150 (defun message-followup (&optional to-newsgroups)
4151   "Follow up to the message in the current buffer.
4152 If TO-NEWSGROUPS, use that as the new Newsgroups line."
4153   (interactive)
4154   (let ((cur (current-buffer))
4155         from subject date mct
4156         references message-id follow-to
4157         (inhibit-point-motion-hooks t)
4158         (message-this-is-news t)
4159         followup-to distribution newsgroups gnus-warning posted-to mft mrt)
4160     (save-restriction
4161       (message-narrow-to-head)
4162       (when (message-functionp message-followup-to-function)
4163         (setq follow-to
4164               (funcall message-followup-to-function)))
4165       (setq from (message-fetch-field "from")
4166             date (message-fetch-field "date" t)
4167             subject (or (message-fetch-field "subject") "none")
4168             references (message-fetch-field "references")
4169             message-id (message-fetch-field "message-id" t)
4170             followup-to (when message-use-followup-to
4171                           (message-fetch-field "followup-to"))
4172             distribution (message-fetch-field "distribution")
4173             newsgroups (message-fetch-field "newsgroups")
4174             posted-to (message-fetch-field "posted-to")
4175             mct (when message-use-mail-copies-to
4176                   (message-fetch-field "mail-copies-to"))
4177             mft (when message-use-mail-followup-to
4178                   (message-fetch-field "mail-followup-to"))
4179             mrt (when message-use-mail-reply-to
4180                   (or (message-fetch-field "mail-reply-to")
4181                       (message-fetch-field "reply-to")))
4182             gnus-warning (message-fetch-field "gnus-warning"))
4183       (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
4184         (setq message-id (match-string 0 gnus-warning)))
4185       ;; Remove bogus distribution.
4186       (when (and (stringp distribution)
4187                  (let ((case-fold-search t))
4188                    (string-match "world" distribution)))
4189         (setq distribution nil))
4190       ;; Remove any (buggy) Re:'s that are present and make a
4191       ;; proper one.
4192       (setq subject (message-make-followup-subject subject))
4193       (widen))
4194
4195     ;; Handle special values of Mail-Copies-To.
4196     (when mct
4197       (cond
4198        ((and (or (equal (downcase mct) "never")
4199                  (equal (downcase mct) "nobody"))
4200              (or (not (eq message-use-mail-copies-to 'ask))
4201                  (message-y-or-n-p
4202                   (concat "Obey Mail-Copies-To: never? ") t "\
4203 You should normally obey the Mail-Copies-To: header.
4204
4205         `Mail-Copies-To: never'
4206 directs you not to send your response to the author.")))
4207         (setq mct nil))
4208        ((and (or (equal (downcase mct) "always")
4209                  (equal (downcase mct) "poster"))
4210              (or (not (eq message-use-mail-copies-to 'ask))
4211                  (message-y-or-n-p
4212                   (concat "Obey Mail-Copies-To: always? ") t "\
4213 You should normally obey the Mail-Copies-To: header.
4214
4215         `Mail-Copies-To: always'
4216 sends a copy of your response to the author.")))
4217         (setq mct (or mrt from)))
4218        ((and (eq message-use-mail-copies-to 'ask)
4219              (not
4220               (message-y-or-n-p
4221                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
4222 You should normally obey the Mail-Copies-To: header.
4223
4224         `Mail-Copies-To: " mct "'
4225 sends a copy of your response to " (if (string-match "," mct)
4226                                        "the specified addresses"
4227                                      "that address") ".")))
4228         (setq mct nil))
4229        ))
4230
4231     (unless follow-to
4232       (cond
4233        (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups))))
4234        ;; Handle Followup-To.
4235        (followup-to
4236         (cond
4237          ((equal (downcase followup-to) "poster")
4238           (if (or (eq message-use-followup-to 'use)
4239                   (message-y-or-n-p "Obey Followup-To: poster? " t "\
4240 You should normally obey the Followup-To: header.
4241
4242         `Followup-To: poster'
4243 sends your response via e-mail instead of news.
4244
4245 A typical situation where `Followup-To: poster' is used is when the author
4246 does not read the newsgroup, so he wouldn't see any replies sent to it."))
4247               (setq message-this-is-news nil
4248                     distribution nil
4249                     follow-to (list (cons 'To (or mrt from ""))))
4250             (setq follow-to (list (cons 'Newsgroups newsgroups)))))
4251          (t
4252           (if (or (equal followup-to newsgroups)
4253                   (not (eq message-use-followup-to 'ask))
4254                   (message-y-or-n-p
4255                    (concat "Obey Followup-To: " followup-to "? ") t "\
4256 You should normally obey the Followup-To: header.
4257
4258         `Followup-To: " followup-to "'
4259 directs your response to " (if (string-match "," followup-to)
4260                                "the specified newsgroups"
4261                              "that newsgroup only") ".
4262
4263 If a message is posted to several newsgroups, Followup-To is often
4264 used to direct the following discussion to one newsgroup only,
4265 because discussions that are spread over several newsgroup tend to
4266 be fragmented and very difficult to follow.
4267
4268 Also, some source/announcement newsgroups are not indented for discussion;
4269 responses here are directed to other newsgroups."))
4270               (setq follow-to (list (cons 'Newsgroups followup-to)))
4271             (setq follow-to (list (cons 'Newsgroups newsgroups)))))))
4272        ;; Handle Mail-Followup-To, followup via e-mail.
4273        ((and mft
4274              (or (not (eq message-use-mail-followup-to 'ask))
4275                  (message-y-or-n-p
4276                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
4277 You should normally obey the Mail-Followup-To: header.
4278
4279         `Mail-Followup-To: " mft "'
4280 directs your response to " (if (string-match "," mft)
4281                                "the specified addresses"
4282                              "that address only") " instead of news.
4283
4284 A typical situation where Mail-Followup-To is used is when the author thinks
4285 that further discussion should take place only in "
4286                              (if (string-match "," mft)
4287                                  "the specified mailing lists"
4288                                "that mailing list") ".")))
4289         (setq message-this-is-news nil
4290               distribution nil
4291               follow-to (list (cons 'To mft))))
4292        (posted-to (setq follow-to (list (cons 'Newsgroups posted-to))))
4293        (t
4294         (setq follow-to (list (cons 'Newsgroups newsgroups))))))
4295
4296     (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
4297
4298     (setq message-reply-headers
4299           (make-full-mail-header-from-decoded-header
4300            0 subject from date message-id references 0 0 ""))
4301
4302     (message-setup
4303      `((Subject . ,subject)
4304        ,@follow-to
4305        ,@(and mct (list (cons 'Cc mct)))
4306        ,@(and distribution (list (cons 'Distribution distribution)))
4307        ,@(if (or references message-id)
4308              `((References . ,(concat (or references "") (and references " ")
4309                                       (or message-id ""))))))
4310      cur)))
4311
4312 ;;;###autoload
4313 (defun message-cancel-news ()
4314   "Cancel an article you posted."
4315   (interactive)
4316   (unless (message-news-p)
4317     (error "This is not a news article; canceling is impossible"))
4318   (when (yes-or-no-p "Do you really want to cancel this article? ")
4319     (let (from newsgroups message-id distribution buf sender)
4320       (save-excursion
4321         ;; Get header info. from original article.
4322         (save-restriction
4323           (message-narrow-to-head)
4324           (setq from (message-fetch-field "from")
4325                 sender (message-fetch-field "sender")
4326                 newsgroups (message-fetch-field "newsgroups")
4327                 message-id (message-fetch-field "message-id" t)
4328                 distribution (message-fetch-field "distribution")))
4329         ;; Make sure that this article was written by the user.
4330         (unless (or (and sender
4331                          (string-equal
4332                           (downcase sender)
4333                           (downcase (message-make-sender))))
4334                     (string-equal
4335                      (downcase (cadr (std11-extract-address-components
4336                                       from)))
4337                      (downcase (cadr (std11-extract-address-components
4338                                       (message-make-from))))))
4339           (error "This article is not yours"))
4340         ;; Make control message.
4341         (setq buf (set-buffer (get-buffer-create " *message cancel*")))
4342         (erase-buffer)
4343         (insert "Newsgroups: " newsgroups "\n"
4344                 "From: " (message-make-from) "\n"
4345                 "Subject: cmsg cancel " message-id "\n"
4346                 "Control: cancel " message-id "\n"
4347                 (if distribution
4348                     (concat "Distribution: " distribution "\n")
4349                   "")
4350                 mail-header-separator "\n"
4351                 message-cancel-message)
4352         (run-hooks 'message-cancel-hook)
4353         (message "Canceling your article...")
4354         (if (let ((message-syntax-checks
4355                    'dont-check-for-anything-just-trust-me)
4356                   (message-encoding-buffer (current-buffer))
4357                   (message-edit-buffer (current-buffer)))
4358               (message-send-news))
4359             (message "Canceling your article...done"))
4360         (kill-buffer buf)))))
4361
4362 (defun message-supersede-setup-for-mime-edit ()
4363   (set (make-local-variable 'message-setup-hook) nil)
4364   (mime-edit-again))
4365
4366 ;;;###autoload
4367 (defun message-supersede ()
4368   "Start composing a message to supersede the current message.
4369 This is done simply by taking the old article and adding a Supersedes
4370 header line with the old Message-ID."
4371   (interactive)
4372   (let ((cur (current-buffer))
4373         (sender (message-fetch-field "sender"))
4374         (from (message-fetch-field "from")))
4375     ;; Check whether the user owns the article that is to be superseded.
4376     (unless (or (and sender
4377                      (string-equal
4378                       (downcase sender)
4379                       (downcase (message-make-sender))))
4380                 (string-equal
4381                  (downcase (cadr (std11-extract-address-components from)))
4382                  (downcase (cadr (std11-extract-address-components
4383                                   (message-make-from))))))
4384       (error "This article is not yours"))
4385     ;; Get a normal message buffer.
4386     (message-pop-to-buffer (message-buffer-name "supersede"))
4387     (insert-buffer-substring cur)
4388     (message-narrow-to-head)
4389     ;; Remove unwanted headers.
4390     (when message-ignored-supersedes-headers
4391       (message-remove-header message-ignored-supersedes-headers t))
4392     (goto-char (point-min))
4393     (if (not (re-search-forward "^Message-ID: " nil t))
4394         (error "No Message-ID in this article")
4395       (replace-match "Supersedes: " t t))
4396     (goto-char (point-max))
4397     (insert mail-header-separator)
4398     (widen)
4399     (when message-supersede-setup-function
4400       (funcall message-supersede-setup-function))
4401     (run-hooks 'message-supersede-setup-hook)
4402     (goto-char (point-min))
4403     (search-forward (concat "\n" mail-header-separator "\n") nil t)))
4404
4405 ;;;###autoload
4406 (defun message-recover ()
4407   "Reread contents of current buffer from its last auto-save file."
4408   (interactive)
4409   (let ((file-name (make-auto-save-file-name)))
4410     (cond ((save-window-excursion
4411              (if (not (eq system-type 'vax-vms))
4412                  (with-output-to-temp-buffer "*Directory*"
4413                    (buffer-disable-undo standard-output)
4414                    (let ((default-directory "/"))
4415                      (call-process
4416                       "ls" nil standard-output nil "-l" file-name))))
4417              (yes-or-no-p (format "Recover auto save file %s? " file-name)))
4418            (let ((buffer-read-only nil))
4419              (erase-buffer)
4420              (insert-file-contents file-name nil)))
4421           (t (error "message-recover cancelled")))))
4422
4423 ;;; Washing Subject:
4424
4425 (defun message-wash-subject (subject)
4426   "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc."
4427   (with-temp-buffer
4428     (insert-string subject)
4429     (goto-char (point-min))
4430     ;; strip Re/Fwd stuff off the beginning
4431     (while (re-search-forward
4432             "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
4433       (replace-match ""))
4434
4435     ;; and gnus-style forwards [foo@bar.com] subject
4436     (goto-char (point-min))
4437     (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
4438       (replace-match ""))
4439
4440     ;; and off the end
4441     (goto-char (point-max))
4442     (while (re-search-backward "([Ff][Ww][Dd])" nil t)
4443       (replace-match ""))
4444
4445     ;; and finally, any whitespace that was left-over
4446     (goto-char (point-min))
4447     (while (re-search-forward "^[ \t]+" nil t)
4448       (replace-match ""))
4449     (goto-char (point-max))
4450     (while (re-search-backward "[ \t]+$" nil t)
4451       (replace-match ""))
4452
4453     (buffer-string)))
4454
4455 ;;; Forwarding messages.
4456
4457 (defun message-forward-subject-author-subject (subject)
4458   "Generate a subject for a forwarded message.
4459 The form is: [Source] Subject, where if the original message was mail,
4460 Source is the sender, and if the original message was news, Source is
4461 the list of newsgroups is was posted to."
4462   (concat "["
4463           (or (message-fetch-field
4464                (if (message-news-p) "newsgroups" "from"))
4465               "(nowhere)")
4466           "] " subject))
4467
4468 (defun message-forward-subject-fwd (subject)
4469   "Generate a subject for a forwarded message.
4470 The form is: Fwd: Subject, where Subject is the original subject of
4471 the message."
4472   (concat "Fwd: " subject))
4473
4474 (defun message-make-forward-subject ()
4475   "Return a Subject header suitable for the message in the current buffer."
4476   (save-excursion
4477     (save-restriction
4478       (current-buffer)
4479       (message-narrow-to-head)
4480       (let ((funcs message-make-forward-subject-function)
4481             (subject (message-fetch-field "Subject")))
4482         (setq subject
4483               (if subject
4484                   (if message-wash-forwarded-subjects
4485                       (message-wash-subject
4486                        (nnheader-decode-subject subject))
4487                     (nnheader-decode-subject subject))
4488                 "(none)"))
4489         ;; Make sure funcs is a list.
4490         (and funcs
4491              (not (listp funcs))
4492              (setq funcs (list funcs)))
4493         ;; Apply funcs in order, passing subject generated by previous
4494         ;; func to the next one.
4495         (while funcs
4496           (when (message-functionp (car funcs))
4497             (setq subject (funcall (car funcs) subject)))
4498           (setq funcs (cdr funcs)))
4499         subject))))
4500
4501 ;;;###autoload
4502 (defun message-forward (&optional news)
4503   "Forward the current message via mail.
4504 Optional NEWS will use news to forward instead of mail."
4505   (interactive "P")
4506   (let ((cur (current-buffer))
4507         (subject (message-make-forward-subject))
4508         art-beg)
4509     (if news
4510         (message-news nil subject)
4511       (message-mail nil subject))
4512     ;; Put point where we want it before inserting the forwarded
4513     ;; message.
4514     (if message-signature-before-forwarded-message
4515         (goto-char (point-max))
4516       (message-goto-body))
4517     ;; Make sure we're at the start of the line.
4518     (unless (eolp)
4519       (insert "\n"))
4520     ;; Narrow to the area we are to insert.
4521     (narrow-to-region (point) (point))
4522     ;; Insert the separators and the forwarded buffer.
4523     (insert message-forward-start-separator)
4524     (setq art-beg (point))
4525     (insert-buffer-substring cur)
4526     (goto-char (point-max))
4527     (insert message-forward-end-separator)
4528     (set-text-properties (point-min) (point-max) nil)
4529     ;; Remove all unwanted headers.
4530     (goto-char art-beg)
4531     (narrow-to-region (point) (if (search-forward "\n\n" nil t)
4532                                   (1- (point))
4533                                 (point)))
4534     (goto-char (point-min))
4535     (message-remove-header message-included-forward-headers t nil t)
4536     (widen)
4537     (message-position-point)))
4538
4539 ;;;###autoload
4540 (defun message-resend (address)
4541   "Resend the current article to ADDRESS."
4542   (interactive "sResend message to: ")
4543   (message "Resending message to %s..." address)
4544   (save-excursion
4545     (let ((cur (current-buffer))
4546           beg)
4547       ;; We first set up a normal mail buffer.
4548       (set-buffer (get-buffer-create " *message resend*"))
4549       (erase-buffer)
4550       ;; avoid to turn-on-mime-edit
4551       (let (message-setup-hook)
4552         (message-setup `((To . ,address)))
4553         )
4554       ;; Insert our usual headers.
4555       (message-generate-headers '(From Date To))
4556       (message-narrow-to-headers)
4557       ;; Rename them all to "Resent-*".
4558       (while (re-search-forward "^[A-Za-z]" nil t)
4559         (forward-char -1)
4560         (insert "Resent-"))
4561       (widen)
4562       (forward-line)
4563       (delete-region (point) (point-max))
4564       (setq beg (point))
4565       ;; Insert the message to be resent.
4566       (insert-buffer-substring cur)
4567       (goto-char (point-min))
4568       (search-forward "\n\n")
4569       (forward-char -1)
4570       (save-restriction
4571         (narrow-to-region beg (point))
4572         (message-remove-header message-ignored-resent-headers t)
4573         (goto-char (point-max)))
4574       (insert mail-header-separator)
4575       ;; Rename all old ("Also-")Resent headers.
4576       (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
4577         (beginning-of-line)
4578         (insert "Also-"))
4579       ;; Quote any "From " lines at the beginning.
4580       (goto-char beg)
4581       (when (looking-at "From ")
4582         (replace-match "X-From-Line: "))
4583       ;; Send it.
4584       (let ((message-encoding-buffer (current-buffer))
4585             (message-edit-buffer (current-buffer)))
4586         (let (message-required-mail-headers)
4587           (message-send-mail)))
4588       (kill-buffer (current-buffer)))
4589     (message "Resending message to %s...done" address)))
4590
4591 (defun message-bounce-setup-for-mime-edit ()
4592   (set (make-local-variable 'message-setup-hook) nil)
4593   (mime-edit-again))
4594
4595 ;;;###autoload
4596 (defun message-bounce ()
4597   "Re-mail the current message.
4598 This only makes sense if the current message is a bounce message than
4599 contains some mail you have written which has been bounced back to
4600 you."
4601   (interactive)
4602   (let ((cur (current-buffer))
4603         boundary)
4604     (message-pop-to-buffer (message-buffer-name "bounce"))
4605     (insert-buffer-substring cur)
4606     (undo-boundary)
4607     (message-narrow-to-head)
4608     (if (and (message-fetch-field "MIME-Version")
4609              (setq boundary (message-fetch-field "Content-Type")))
4610         (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
4611             (setq boundary (concat (match-string 1 boundary) " *\n"
4612                                    "Content-Type: message/rfc822"))
4613           (setq boundary nil)))
4614     (widen)
4615     (goto-char (point-min))
4616     (search-forward "\n\n" nil t)
4617     (or (and boundary
4618              (re-search-forward boundary nil t)
4619              (forward-line 2))
4620         (and (re-search-forward message-unsent-separator nil t)
4621              (forward-line 1))
4622         (re-search-forward "^Return-Path:.*\n" nil t))
4623     ;; We remove everything before the bounced mail.
4624     (delete-region
4625      (point-min)
4626      (if (re-search-forward "^[^ \n\t]+:" nil t)
4627          (match-beginning 0)
4628        (point)))
4629     (save-restriction
4630       (message-narrow-to-head)
4631       (message-remove-header message-ignored-bounced-headers t)
4632       (goto-char (point-max))
4633       (insert mail-header-separator))
4634     (when message-bounce-setup-function
4635       (funcall message-bounce-setup-function))
4636     (run-hooks 'message-bounce-setup-hook)
4637     (message-position-point)))
4638
4639 ;;;
4640 ;;; Interactive entry points for new message buffers.
4641 ;;;
4642
4643 ;;;###autoload
4644 (defun message-mail-other-window (&optional to subject)
4645   "Like `message-mail' command, but display mail buffer in another window."
4646   (interactive)
4647   (let ((pop-up-windows t)
4648         (special-display-buffer-names nil)
4649         (special-display-regexps nil)
4650         (same-window-buffer-names nil)
4651         (same-window-regexps nil))
4652     (message-pop-to-buffer (message-buffer-name "mail" to)))
4653   (let ((message-this-is-mail t))
4654     (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
4655
4656 ;;;###autoload
4657 (defun message-mail-other-frame (&optional to subject)
4658   "Like `message-mail' command, but display mail buffer in another frame."
4659   (interactive)
4660   (let ((pop-up-frames t)
4661         (special-display-buffer-names nil)
4662         (special-display-regexps nil)
4663         (same-window-buffer-names nil)
4664         (same-window-regexps nil))
4665     (message-pop-to-buffer (message-buffer-name "mail" to)))
4666   (let ((message-this-is-mail t))
4667     (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
4668
4669 ;;;###autoload
4670 (defun message-news-other-window (&optional newsgroups subject)
4671   "Start editing a news article to be sent."
4672   (interactive)
4673   (let ((pop-up-windows t)
4674         (special-display-buffer-names nil)
4675         (special-display-regexps nil)
4676         (same-window-buffer-names nil)
4677         (same-window-regexps nil))
4678     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
4679   (let ((message-this-is-news t))
4680     (message-setup `((Newsgroups . ,(or newsgroups ""))
4681                      (Subject . ,(or subject ""))))))
4682
4683 ;;;###autoload
4684 (defun message-news-other-frame (&optional newsgroups subject)
4685   "Start editing a news article to be sent."
4686   (interactive)
4687   (let ((pop-up-frames t)
4688         (special-display-buffer-names nil)
4689         (special-display-regexps nil)
4690         (same-window-buffer-names nil)
4691         (same-window-regexps nil))
4692     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
4693   (let ((message-this-is-news t))
4694     (message-setup `((Newsgroups . ,(or newsgroups ""))
4695                      (Subject . ,(or subject ""))))))
4696
4697 ;;; underline.el
4698
4699 ;; This code should be moved to underline.el (from which it is stolen).
4700
4701 ;;;###autoload
4702 (defun bold-region (start end)
4703   "Bold all nonblank characters in the region.
4704 Works by overstriking characters.
4705 Called from program, takes two arguments START and END
4706 which specify the range to operate on."
4707   (interactive "r")
4708   (save-excursion
4709     (let ((end1 (make-marker)))
4710       (move-marker end1 (max start end))
4711       (goto-char (min start end))
4712       (while (< (point) end1)
4713         (or (looking-at "[_\^@- ]")
4714             (insert (char-after) "\b"))
4715         (forward-char 1)))))
4716
4717 ;;;###autoload
4718 (defun unbold-region (start end)
4719   "Remove all boldness (overstruck characters) in the region.
4720 Called from program, takes two arguments START and END
4721 which specify the range to operate on."
4722   (interactive "r")
4723   (save-excursion
4724     (let ((end1 (make-marker)))
4725       (move-marker end1 (max start end))
4726       (goto-char (min start end))
4727       (while (re-search-forward "\b" end1 t)
4728         (if (eq (char-after) (char-after (- (point) 2)))
4729             (delete-char -2))))))
4730
4731 (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
4732
4733 ;; Support for toolbar
4734 (when (string-match "XEmacs\\|Lucid" emacs-version)
4735   (require 'messagexmas))
4736
4737 ;;; Group name completion.
4738
4739 (defvar message-newgroups-header-regexp
4740   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
4741   "Regexp that match headers that lists groups.")
4742
4743 (defun message-tab ()
4744   "Expand group names in Newsgroups and Followup-To headers.
4745 Do a `tab-to-tab-stop' if not in those headers."
4746   (interactive)
4747   (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
4748         (mail-abbrev-in-expansion-header-p))
4749       (message-expand-group)
4750     (tab-to-tab-stop)))
4751
4752 (defvar gnus-active-hashtb)
4753 (defun message-expand-group ()
4754   "Expand the group name under point."
4755   (let* ((b (save-excursion
4756               (save-restriction
4757                 (narrow-to-region
4758                  (save-excursion
4759                    (beginning-of-line)
4760                    (skip-chars-forward "^:")
4761                    (1+ (point)))
4762                  (point))
4763                 (skip-chars-backward "^, \t\n") (point))))
4764          (completion-ignore-case t)
4765          (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
4766                                             (point))))
4767          (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
4768          (completions (all-completions string hashtb))
4769          comp)
4770     (delete-region b (point))
4771     (cond
4772      ((= (length completions) 1)
4773       (if (string= (car completions) string)
4774           (progn
4775             (insert string)
4776             (message "Only matching group"))
4777         (insert (car completions))))
4778      ((and (setq comp (try-completion string hashtb))
4779            (not (string= comp string)))
4780       (insert comp))
4781      (t
4782       (insert string)
4783       (if (not comp)
4784           (message "No matching groups")
4785         (save-selected-window
4786           (pop-to-buffer "*Completions*")
4787           (buffer-disable-undo)
4788           (let ((buffer-read-only nil))
4789             (erase-buffer)
4790             (let ((standard-output (current-buffer)))
4791               (display-completion-list (sort completions 'string<)))
4792             (goto-char (point-min))
4793             (delete-region (point) (progn (forward-line 3) (point))))))))))
4794
4795 ;;; Help stuff.
4796
4797 (defun message-talkative-question (ask question show &rest text)
4798   "Call FUNCTION with argument QUESTION; optionally display TEXT... args.
4799 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer.
4800 The following arguments may contain lists of values."
4801   (if (and show
4802            (setq text (message-flatten-list text)))
4803       (save-window-excursion
4804         (save-excursion
4805           (with-output-to-temp-buffer " *MESSAGE information message*"
4806             (set-buffer " *MESSAGE information message*")
4807             (mapcar 'princ text)
4808             (goto-char (point-min))))
4809         (funcall ask question))
4810     (funcall ask question)))
4811
4812 (defun message-flatten-list (list)
4813   "Return a new, flat list that contains all elements of LIST.
4814
4815 \(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
4816 => (1 2 3 4 5 6 7)"
4817   (cond ((consp list)
4818          (apply 'append (mapcar 'message-flatten-list list)))
4819         (list
4820          (list list))))
4821
4822 (defun message-generate-new-buffer-clone-locals (name &optional varstr)
4823   "Create and return a buffer with a name based on NAME using generate-new-buffer.
4824 Then clone the local variables and values from the old buffer to the
4825 new one, cloning only the locals having a substring matching the
4826 regexp varstr."
4827   (let ((oldbuf (current-buffer)))
4828     (save-excursion
4829       (set-buffer (generate-new-buffer name))
4830       (message-clone-locals oldbuf)
4831       (current-buffer))))
4832
4833 (defun message-clone-locals (buffer)
4834   "Clone the local variables from BUFFER to the current buffer."
4835   (let ((locals (save-excursion
4836                   (set-buffer buffer)
4837                   (buffer-local-variables)))
4838         (regexp
4839          "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
4840     (mapcar
4841      (lambda (local)
4842        (when (and (consp local)
4843                   (car local)
4844                   (string-match regexp (symbol-name (car local))))
4845          (ignore-errors
4846            (set (make-local-variable (car local))
4847                 (cdr local)))))
4848      locals)))
4849
4850
4851 ;;; @ for MIME Edit mode
4852 ;;;
4853
4854 (defun message-maybe-encode ()
4855   (when message-mime-mode
4856     ;; Inherit the buffer local variable `mime-edit-pgp-processing'.
4857     (let ((pgp-processing (with-current-buffer message-edit-buffer
4858                             mime-edit-pgp-processing)))
4859       (setq mime-edit-pgp-processing pgp-processing))
4860     (run-hooks 'mime-edit-translate-hook)
4861     (if (catch 'mime-edit-error
4862           (save-excursion
4863             (mime-edit-pgp-enclose-buffer)
4864             (mime-edit-translate-body)
4865             ))
4866         (error "Translation error!")
4867       )
4868     (end-of-invisible)
4869     (run-hooks 'mime-edit-exit-hook)
4870     ))
4871
4872 (defun message-mime-insert-article (&optional full-headers)
4873   (interactive "P")
4874   (let ((message-cite-function 'mime-edit-inserted-message-filter)
4875         (message-reply-buffer
4876          (message-get-parameter-with-eval 'original-buffer))
4877         (start (point)))
4878     (message-yank-original nil)
4879     (save-excursion
4880       (narrow-to-region (goto-char start)
4881                         (if (search-forward "\n\n" nil t)
4882                             (1- (point))
4883                           (point-max)))
4884       (goto-char (point-min))
4885       (let ((message-included-forward-headers
4886              (if full-headers "" message-included-forward-headers)))
4887         (message-remove-header message-included-forward-headers t nil t))
4888       (widen))))
4889
4890 (set-alist 'mime-edit-message-inserter-alist
4891            'message-mode (function message-mime-insert-article))
4892
4893 ;;; Miscellaneous functions
4894
4895 ;; stolen (and renamed) from nnheader.el
4896 (defun message-replace-chars-in-string (string from to)
4897   "Replace characters in STRING from FROM to TO."
4898   (let ((string (substring string 0))   ;Copy string.
4899         (len (length string))
4900         (idx 0))
4901     ;; Replace all occurrences of FROM with TO.
4902     (while (< idx len)
4903       (when (= (aref string idx) from)
4904         (aset string idx to))
4905       (setq idx (1+ idx)))
4906     string))
4907
4908 ;;;
4909 ;;; MIME functions
4910 ;;;
4911
4912 (defvar message-inhibit-body-encoding t)
4913
4914 (defun message-encode-message-body ()
4915   (unless message-inhibit-body-encoding
4916     (let ((mail-parse-charset (or mail-parse-charset
4917                                   message-default-charset
4918                                   message-posting-charset))
4919           (case-fold-search t)
4920           lines content-type-p)
4921       (message-goto-body)
4922       (save-restriction
4923         (narrow-to-region (point) (point-max))
4924         (let ((new (mml-generate-mime)))
4925           (when new
4926             (delete-region (point-min) (point-max))
4927             (insert new)
4928             (goto-char (point-min))
4929             (if (eq (aref new 0) ?\n)
4930                 (delete-char 1)
4931               (search-forward "\n\n")
4932               (setq lines (buffer-substring (point-min) (1- (point))))
4933               (delete-region (point-min)  (point))))))
4934       (save-restriction
4935         (message-narrow-to-headers-or-head)
4936         (message-remove-header "Mime-Version")
4937         (goto-char (point-max))
4938         (insert "MIME-Version: 1.0\n")
4939         (when lines
4940           (insert lines))
4941         (setq content-type-p
4942               (re-search-backward "^Content-Type:" nil t)))
4943       (save-restriction
4944         (message-narrow-to-headers-or-head)
4945         (message-remove-first-header "Content-Type")
4946         (message-remove-first-header "Content-Transfer-Encoding"))
4947       ;; We always make sure that the message has a Content-Type header.
4948       ;; This is because some broken MTAs and MUAs get awfully confused
4949       ;; when confronted with a message with a MIME-Version header and
4950       ;; without a Content-Type header.  For instance, Solaris'
4951       ;; /usr/bin/mail.
4952       (unless content-type-p
4953         (goto-char (point-min))
4954         (re-search-forward "^MIME-Version:")
4955         (forward-line 1)
4956         (insert "Content-Type: text/plain; charset=us-ascii\n")))))
4957
4958 (defvar message-save-buffer " *encoding")
4959 (defun message-save-drafts ()
4960   (interactive)
4961   (if (not (get-buffer message-save-buffer))
4962       (get-buffer-create message-save-buffer))
4963   (let ((filename buffer-file-name)
4964         (buffer (current-buffer)))
4965     (set-buffer message-save-buffer)
4966     (erase-buffer)
4967     (insert-buffer buffer)
4968     (mime-edit-translate-buffer)
4969     (write-region (point-min) (point-max) filename)
4970     (set-buffer buffer)
4971     (set-buffer-modified-p nil)))
4972
4973 (provide 'message)
4974
4975 (run-hooks 'message-load-hook)
4976
4977 ;;; message.el ends here