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