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