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

   1 ;;; message.el --- composing mail and news messages
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;;      Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
   8 ;;      Keiichi Suzuki   <kei-suzu@mail.wbs.ne.jp>
   9 ;;      Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
  10 ;;      Katsumi Yamaoka  <yamaoka@jpl.org>
  11 ;;      Kiyokazu SUTO    <suto@merry.xmath.ous.ac.jp>
  12 ;; Keywords: mail, news, MIME
  13
  14 ;; This file is part of GNU Emacs.
  15
  16 ;; GNU Emacs is free software; you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation; either version 2, or (at your option)
  19 ;; any later version.
  20
  21 ;; GNU Emacs is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29 ;; Boston, MA 02111-1307, USA.
  30
  31 ;;; Commentary:
  32
  33 ;; This mode provides mail-sending facilities from within Emacs.  It
  34 ;; consists mainly of large chunks of code from the sendmail.el,
  35 ;; gnus-msg.el and rnewspost.el files.
  36
  37 ;;; Code:
  38
  39 (eval-when-compile
  40   (require 'cl)
  41   (require 'smtp)
  42   (defvar gnus-message-group-art)
  43   (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
  44 (eval-and-compile
  45   (if (boundp 'MULE)
  46       (progn
  47         (require 'base64)
  48         (require 'canlock-om))
  49     (require 'canlock)))
  50 (require 'mailheader)
  51 (require 'nnheader)
  52 ;; This is apparently necessary even though things are autoloaded.
  53 ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better
  54 ;; require mailabbrev here.
  55 (if (featurep 'xemacs)
  56     (require 'mail-abbrevs)
  57   (require 'mailabbrev))
  58 (require 'mime-edit)
  59 (eval-when-compile (require 'static))
  60
  61 ;; Avoid byte-compile warnings.
  62 (eval-when-compile
  63   (require 'mail-parse)
  64   (require 'mml))
  65
  66 (require 'rfc822)
  67 (eval-and-compile
  68   (autoload 'sha1 "sha1-el")
  69   (autoload 'gnus-find-method-for-group "gnus")
  70   (autoload 'nnvirtual-find-group-art "nnvirtual")
  71   (autoload 'customize-save-variable "cus-edit")) ;; for Mule 2.
  72
  73 (defgroup message '((user-mail-address custom-variable)
  74                     (user-full-name custom-variable))
  75   "Mail and news message composing."
  76   :link '(custom-manual "(message)Top")
  77   :group 'mail
  78   :group 'news)
  79
  80 (put 'user-mail-address 'custom-type 'string)
  81 (put 'user-full-name 'custom-type 'string)
  82
  83 (defgroup message-various nil
  84   "Various Message Variables"
  85   :link '(custom-manual "(message)Various Message Variables")
  86   :group 'message)
  87
  88 (defgroup message-buffers nil
  89   "Message Buffers"
  90   :link '(custom-manual "(message)Message Buffers")
  91   :group 'message)
  92
  93 (defgroup message-sending nil
  94   "Message Sending"
  95   :link '(custom-manual "(message)Sending Variables")
  96   :group 'message)
  97
  98 (defgroup message-interface nil
  99   "Message Interface"
 100   :link '(custom-manual "(message)Interface")
 101   :group 'message)
 102
 103 (defgroup message-forwarding nil
 104   "Message Forwarding"
 105   :link '(custom-manual "(message)Forwarding")
 106   :group 'message-interface)
 107
 108 (defgroup message-insertion nil
 109   "Message Insertion"
 110   :link '(custom-manual "(message)Insertion")
 111   :group 'message)
 112
 113 (defgroup message-headers nil
 114   "Message Headers"
 115   :link '(custom-manual "(message)Message Headers")
 116   :group 'message)
 117
 118 (defgroup message-news nil
 119   "Composing News Messages"
 120   :group 'message)
 121
 122 (defgroup message-mail nil
 123   "Composing Mail Messages"
 124   :group 'message)
 125
 126 (defgroup message-faces nil
 127   "Faces used for message composing."
 128   :group 'message
 129   :group 'faces)
 130
 131 (defgroup message-frames nil
 132   "Message frames"
 133   :group 'message)
 134
 135 (defcustom message-directory "~/Mail/"
 136   "*Directory from which all other mail file variables are derived."
 137   :group 'message-various
 138   :type 'directory)
 139
 140 (defcustom message-max-buffers 10
 141   "*How many buffers to keep before starting to kill them off."
 142   :group 'message-buffers
 143   :type 'integer)
 144
 145 (defcustom message-send-rename-function nil
 146   "Function called to rename the buffer after sending it."
 147   :group 'message-buffers
 148   :type '(choice function (const nil)))
 149
 150 (defcustom message-fcc-handler-function 'message-output
 151   "*A function called to save outgoing articles.
 152 This function will be called with the name of the file to store the
 153 article in.  The default function is `message-output' which saves in Unix
 154 mailbox format."
 155   :type '(radio (function-item message-output)
 156                 (function :tag "Other"))
 157   :group 'message-sending)
 158
 159 (defcustom message-encode-function 'message-maybe-encode
 160   "*A function called to encode messages."
 161   :group 'message-sending
 162   :type 'function)
 163
 164 (defcustom message-8bit-encoding-list '(8bit binary)
 165   "*8bit encoding type in Content-Transfer-Encoding field."
 166   :group 'message-sending
 167   :type '(repeat (symbol :tag "Type")))
 168
 169 (defcustom message-fcc-externalize-attachments nil
 170   "If non-nil, attachments are included as external parts in Fcc copies."
 171   :type 'boolean
 172   :group 'message-sending)
 173
 174 (defcustom message-courtesy-message
 175   "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"
 176   "*This is inserted at the start of a mailed copy of a posted message.
 177 If the string contains the format spec \"%s\", the Newsgroups
 178 the article has been posted to will be inserted there.
 179 If this variable is nil, no such courtesy message will be added."
 180   :group 'message-sending
 181   :type '(radio (string :format "%t: %v\n" :size 0) (const nil)))
 182
 183 (defcustom message-ignored-bounced-headers
 184   "^\\(Received\\|Return-Path\\|Delivered-To\\):"
 185   "*Regexp that matches headers to be removed in resent bounced mail."
 186   :group 'message-interface
 187   :type 'regexp)
 188
 189 (defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit
 190   "Function to setup a re-sending bounced message."
 191   :group 'message-sending
 192   :type 'function)
 193
 194 ;;; Start of variables adopted from `message-utils.el'.
 195
 196 (defcustom message-subject-trailing-was-query 'ask
 197   ;; should it default to nil or ask?
 198   "*What to do with trailing \"(was: <old subject>)\" in subject lines.
 199 If nil, leave the subject unchanged.  If it is the symbol `ask', query
 200 the user what do do.  In this case, the subject is matched against
 201 `message-subject-trailing-was-ask-regexp'.  If
 202 `message-subject-trailing-was-query' is t, always strip the trailing
 203 old subject.  In this case, `message-subject-trailing-was-regexp' is
 204 used."
 205   :type '(choice (const :tag "never" nil)
 206                  (const :tag "always strip" t)
 207                  (const ask))
 208   :group 'message-various)
 209
 210 (defcustom message-subject-trailing-was-ask-regexp
 211   "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)"
 212   "*Regexp matching \"(was: <old subject>)\" in the subject line.
 213
 214 The function `message-strip-subject-trailing-was' uses this regexp if
 215 `message-subject-trailing-was-query' is set to the symbol `ask'.  If
 216 the variable is t instead of `ask', use
 217 `message-subject-trailing-was-regexp' instead.
 218
 219 It is okay to create some false positives here, as the user is asked."
 220   :group 'message-various
 221   :type 'regexp)
 222
 223 (defcustom message-subject-trailing-was-regexp
 224   "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)"
 225   "*Regexp matching \"(was: <old subject>)\" in the subject line.
 226
 227 If `message-subject-trailing-was-query' is set to t, the subject is
 228 matched against `message-subject-trailing-was-regexp' in
 229 `message-strip-subject-trailing-was'.  You should use a regexp creating very
 230 few false positives here."
 231   :group 'message-various
 232   :type 'regexp)
 233
 234 ;; Fixme: Why are all these things autoloaded?
 235
 236 ;;; marking inserted text
 237
 238 ;;;###autoload
 239 (defcustom message-mark-insert-begin
 240   "--8<---------------cut here---------------start------------->8---\n"
 241   "How to mark the beginning of some inserted text."
 242   :type 'string
 243   :group 'message-various)
 244
 245 ;;;###autoload
 246 (defcustom message-mark-insert-end
 247   "--8<---------------cut here---------------end--------------->8---\n"
 248   "How to mark the end of some inserted text."
 249   :type 'string
 250   :group 'message-various)
 251
 252 ;;;###autoload
 253 (defcustom message-archive-header
 254   "X-No-Archive: Yes\n"
 255   "Header to insert when you don't want your article to be archived.
 256 Archives \(such as groups.google.com\) respect this header."
 257   :type 'string
 258   :group 'message-various)
 259
 260 ;;;###autoload
 261 (defcustom message-archive-note
 262   "X-No-Archive: Yes - save http://groups.google.com/"
 263   "Note to insert why you wouldn't want this posting archived.
 264 If nil, don't insert any text in the body."
 265   :type '(radio (string :format "%t: %v\n" :size 0)
 266                 (const nil))
 267   :group 'message-various)
 268
 269 ;;; Crossposts and Followups
 270 ;; inspired by JoH-followup-to by Jochem Huhman <joh  at gmx.de>
 271 ;; new suggestions by R. Weikusat <rw at another.de>
 272
 273 (defvar message-cross-post-old-target nil
 274   "Old target for cross-posts or follow-ups.")
 275 (make-variable-buffer-local 'message-cross-post-old-target)
 276
 277 ;;;###autoload
 278 (defcustom message-cross-post-default t
 279   "When non-nil `message-cross-post-followup-to' will perform a crosspost.
 280 If nil, `message-cross-post-followup-to' will only do a followup.  Note that
 281 you can explicitly override this setting by calling
 282 `message-cross-post-followup-to' with a prefix."
 283   :type 'boolean
 284   :group 'message-various)
 285
 286 ;;;###autoload
 287 (defcustom message-cross-post-note
 288   "Crosspost & Followup-To: "
 289   "Note to insert before signature to notify of xpost and follow-up."
 290   :type 'string
 291   :group 'message-various)
 292
 293 ;;;###autoload
 294 (defcustom message-followup-to-note
 295   "Followup-To: "
 296   "Note to insert before signature to notify of follow-up only."
 297   :type 'string
 298   :group 'message-various)
 299
 300 ;;;###autoload
 301 (defcustom message-cross-post-note-function
 302   'message-cross-post-insert-note
 303   "Function to use to insert note about Crosspost or Followup-To.
 304 The function will be called with four arguments.  The function should not only
 305 insert a note, but also ensure old notes are deleted.  See the documentation
 306 for `message-cross-post-insert-note'."
 307   :type 'function
 308   :group 'message-various)
 309
 310 ;;; End of variables adopted from `message-utils.el'.
 311
 312 ;;;###autoload
 313 (defcustom message-from-style 'default
 314   "*Specifies how \"From\" headers look.
 315
 316 If nil, they contain just the return address like:
 317         king@grassland.com
 318 If `parens', they look like:
 319         king@grassland.com (Elvis Parsley)
 320 If `angles', they look like:
 321         Elvis Parsley <king@grassland.com>
 322
 323 Otherwise, most addresses look like `angles', but they look like
 324 `parens' if `angles' would need quoting and `parens' would not."
 325   :type '(choice (const :tag "simple" nil)
 326                  (const parens)
 327                  (const angles)
 328                  (const default))
 329   :group 'message-headers)
 330
 331 (defcustom message-insert-canlock t
 332   "Whether to insert a Cancel-Lock header in news postings."
 333   :version "21.3"
 334   :group 'message-headers
 335   :type 'boolean)
 336
 337 (defcustom message-syntax-checks
 338   (if message-insert-canlock '((sender . disabled)) nil)
 339   ;; Guess this one shouldn't be easy to customize...
 340   "*Controls what syntax checks should not be performed on outgoing posts.
 341 To disable checking of long signatures, for instance, add
 342  `(signature . disabled)' to this list.
 343
 344 Don't touch this variable unless you really know what you're doing.
 345
 346 Checks include `subject-cmsg', `multiple-headers', `sendsys',
 347 `message-id', `from', `long-lines', `control-chars', `size',
 348 `new-text', `quoting-style', `redirected-followup', `signature',
 349 `approved', `sender', `empty', `empty-headers', `message-id', `from',
 350 `subject', `shorten-followup-to', `existing-newsgroups',
 351 `buffer-file-name', `unchanged', `newsgroups', `reply-to',
 352 `continuation-headers', `long-header-lines', `invisible-text' and
 353 `illegible-text'."
 354   :group 'message-news
 355   :type '(repeat sexp))                 ; Fixme: improve this
 356
 357 (defcustom message-required-headers '((optional . References)
 358                                       From)
 359   "*Headers to be generated or prompted for when sending a message.
 360 Also see `message-required-news-headers' and
 361 `message-required-mail-headers'."
 362   :group 'message-news
 363   :group 'message-headers
 364   :type '(repeat sexp))
 365
 366 (defcustom message-draft-headers '(References From)
 367   "*Headers to be generated when saving a draft message."
 368   :group 'message-news
 369   :group 'message-headers
 370   :type '(repeat sexp))
 371
 372 (defcustom message-required-news-headers
 373   '(From Newsgroups Subject Date Message-ID
 374          (optional . Organization)
 375          (optional . User-Agent))
 376   "*Headers to be generated or prompted for when posting an article.
 377 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
 378 Message-ID.  Organization, Lines, In-Reply-To, Expires, and
 379 User-Agent are optional.  If don't you want message to insert some
 380 header, remove it from this list."
 381   :group 'message-news
 382   :group 'message-headers
 383   :type '(repeat sexp))
 384
 385 (defcustom message-required-mail-headers
 386   '(From Subject Date (optional . In-Reply-To) Message-ID
 387          (optional . User-Agent))
 388   "*Headers to be generated or prompted for when mailing a message.
 389 It is recommended that From, Date, To, Subject and Message-ID be
 390 included.  Organization and User-Agent are optional."
 391   :group 'message-mail
 392   :group 'message-headers
 393   :type '(repeat sexp))
 394
 395 (defcustom message-deletable-headers '(Message-ID Date Lines)
 396   "Headers to be deleted if they already exist and were generated by message previously."
 397   :group 'message-headers
 398   :type 'sexp)
 399
 400 (defcustom message-ignored-news-headers
 401   "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
 402   "*Regexp of headers to be removed unconditionally before posting."
 403   :group 'message-news
 404   :group 'message-headers
 405   :type 'regexp)
 406
 407 (defcustom message-ignored-mail-headers
 408   "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
 409   "*Regexp of headers to be removed unconditionally before mailing."
 410   :group 'message-mail
 411   :group 'message-headers
 412   :type 'regexp)
 413
 414 (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:"
 415   "*Header lines matching this regexp will be deleted before posting.
 416 It's best to delete old Path and Date headers before posting to avoid
 417 any confusion."
 418   :group 'message-interface
 419   :type 'regexp)
 420
 421 (defcustom message-supersede-setup-function
 422   'message-supersede-setup-for-mime-edit
 423   "Function to setup a supersede message."
 424   :group 'message-sending
 425   :type 'function)
 426
 427 (defcustom message-subject-re-regexp
 428   "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
 429   "*Regexp matching \"Re: \" in the subject line."
 430   :group 'message-various
 431   :type 'regexp)
 432
 433 ;;; Some sender agents encode the whole subject including leading "Re: ".
 434 ;;; And if followup agent does not decode it for some reason (e.g. unknown
 435 ;;; charset) and just add a new "Re: " in front of the encoded-word, the
 436 ;;; result will contain multiple "Re: "'s.
 437 (defcustom message-subject-encoded-re-regexp
 438   (concat
 439    "^[ \t]*"
 440    (regexp-quote "=?")
 441    "[-!#$%&'*+0-9A-Z^_`a-z{|}~]+" ; charset
 442    (regexp-quote "?")
 443    "\\("
 444    "[Bb]" (regexp-quote "?") ; B encoding
 445    "\\(\\(CQk\\|CSA\\|IAk\\|ICA\\)[Jg]\\)*" ; \([ \t][ \t][ \t]\)*
 446    "\\("
 447    "[Uc][km]U6" ; [Rr][Ee]:
 448    "\\|"
 449    "\\(C[VX]\\|I[FH]\\)J[Fl]O[g-v]" ; [ \t][Rr][Ee]:
 450    "\\|"
 451    "\\(CQl\\|CSB\\|IAl\\|ICB\\)[Sy][RZ]T[o-r]" ; [ \t][ \t][Rr][Ee]:
 452    "\\)"
 453    "\\|"
 454    "[Qb]" (regexp-quote "?") ; Q encoding
 455    "\\(_\\|=09\\|=20\\)*"
 456    "\\([Rr]\\|=[57]2\\)\\([Ee]\\|=[46]5\\)\\(:\\|=3[Aa]\\)"
 457    "\\)"
 458    )
 459   "*Regexp matching \"Re: \" in the subject line.
 460 Unlike `message-subject-re-regexp', this regexp matches \"Re: \" within
 461 an encoded-word."
 462   :group 'message-various
 463   :type 'regexp)
 464
 465 (defcustom message-use-subject-re t
 466   "*If t, remove any (buggy) \"Re: \"'s from the subject of the precursor
 467 and add a new \"Re: \".  If it is nil, use the subject \"as-is\".  If it
 468 is the symbol `guess', try to detect \"Re: \" within an encoded-word."
 469   :group 'message-various
 470   :type '(choice (const :tag "off" nil)
 471                  (const :tag "on" t)
 472                  (const guess)))
 473
 474 ;;;###autoload
 475 (defcustom message-signature-separator "^-- *$"
 476   "Regexp matching the signature separator."
 477   :type 'regexp
 478   :group 'message-various)
 479
 480 (defcustom message-signature-separator-for-insertion "-- \n"
 481   "*Signature separator. This value will be inserted as signature separator
 482 when composing message. Default value is \"-- \\n\". Notice: Changing this
 483 value may go against RFC-1036 and draft-ietf-usefor-article-05.txt. "
 484   :type 'string
 485   :group 'message-insertion)
 486
 487 (defcustom message-elide-ellipsis "\n[...]\n\n"
 488   "*The string which is inserted for elided text."
 489   :type 'string
 490   :group 'message-various)
 491
 492 (defcustom message-interactive t
 493   "Non-nil means when sending a message wait for and display errors.
 494 nil means let mailer mail back a message to report errors."
 495   :group 'message-sending
 496   :group 'message-mail
 497   :type 'boolean)
 498
 499 (defcustom message-generate-new-buffers 'unique
 500   "*Non-nil means create a new message buffer whenever `message-setup' is called.
 501 If this is a function, call that function with three parameters:  The type,
 502 the to address and the group name.  (Any of these may be nil.)  The function
 503 should return the new buffer name."
 504   :group 'message-buffers
 505   :type '(choice (const :tag "off" nil)
 506                  (const :tag "unique" unique)
 507                  (const :tag "unsent" unsent)
 508                  (function fun)))
 509
 510 (defcustom message-kill-buffer-on-exit nil
 511   "*Non-nil means that the message buffer will be killed after sending a message."
 512   :group 'message-buffers
 513   :type 'boolean)
 514
 515 (defcustom message-kill-buffer-query-function 'yes-or-no-p
 516   "*Function used to prompt user whether to kill the message buffer.  If
 517 it is t, the buffer will be killed unconditionally."
 518   :type '(radio (function-item yes-or-no-p)
 519                 (function-item y-or-n-p)
 520                 (function-item nnheader-Y-or-n-p)
 521                 (function :tag "Other" t))
 522   :group 'message-buffers)
 523
 524 (defcustom message-kill-buffer-and-remove-file t
 525   "*Non-nil means that the associated file will be removed before
 526 removing the message buffer.  However, it is treated as nil when the
 527 command `message-mimic-kill-buffer' is used."
 528   :group 'message-buffers
 529   :type 'boolean)
 530
 531 (eval-when-compile
 532   (defvar gnus-local-organization))
 533 (defcustom message-user-organization
 534   (or (and (boundp 'gnus-local-organization)
 535            (stringp gnus-local-organization)
 536            gnus-local-organization)
 537       (getenv "ORGANIZATION")
 538       t)
 539   "*String to be used as an Organization header.
 540 If t, use `message-user-organization-file'."
 541   :group 'message-headers
 542   :type '(choice string
 543                  (const :tag "consult file" t)))
 544
 545 ;;;###autoload
 546 (defcustom message-user-organization-file "/usr/lib/news/organization"
 547   "*Local news organization file."
 548   :type 'file
 549   :group 'message-headers)
 550
 551 (defcustom message-forward-start-separator
 552   (concat (mime-make-tag "message" "rfc822") "\n")
 553   "*Delimiter inserted before forwarded messages."
 554   :group 'message-forwarding
 555   :type 'string)
 556
 557 (defcustom message-forward-end-separator
 558   (concat (mime-make-tag "text" "plain") "\n")
 559   "*Delimiter inserted after forwarded messages."
 560   :group 'message-forwarding
 561   :type 'string)
 562
 563 (defcustom message-included-forward-headers
 564   "^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:"
 565   "*Regexp matching headers to be included in forwarded messages."
 566   :group 'message-forwarding
 567   :type 'regexp)
 568
 569 (defcustom message-make-forward-subject-function
 570   'message-forward-subject-name-subject
 571   "*List of functions called to generate subject headers for forwarded messages.
 572 The subject generated by the previous function is passed into each
 573 successive function.
 574
 575 The provided functions are:
 576
 577 * `message-forward-subject-author-subject' (Source of article (author or
 578       newsgroup)), in brackets followed by the subject
 579 * `message-forward-subject-name-subject' (Source of article (name of author
 580       or newsgroup)), in brackets followed by the subject
 581 * `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended
 582       to it."
 583   :group 'message-forwarding
 584   :type '(radio (function-item message-forward-subject-author-subject)
 585                 (function-item message-forward-subject-fwd)
 586                 (function-item message-forward-subject-name-subject)
 587                 (repeat :tag "List of functions" function)))
 588
 589 (defcustom message-forward-as-mime t
 590   "*Non-nil means forward messages as an inline/rfc822 MIME section.
 591 Otherwise, directly inline the old message in the forwarded message."
 592   :version "21.1"
 593   :group 'message-forwarding
 594   :type 'boolean)
 595
 596 (defcustom message-forward-show-mml t
 597   "*Non-nil means show forwarded messages as mml.
 598 Otherwise, forwarded messages are unchanged."
 599   :version "21.1"
 600   :group 'message-forwarding
 601   :type 'boolean)
 602
 603 (defcustom message-forward-before-signature t
 604   "*Non-nil means put forwarded message before signature, else after."
 605   :group 'message-forwarding
 606   :type 'boolean)
 607
 608 (defcustom message-wash-forwarded-subjects nil
 609   "*Non-nil means try to remove as much cruft as possible from the subject.
 610 Done before generating the new subject of a forward."
 611   :group 'message-forwarding
 612   :type 'boolean)
 613
 614 (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From "
 615   "*All headers that match this regexp will be deleted when resending a message."
 616   :group 'message-interface
 617   :type 'regexp)
 618
 619 (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
 620   "*All headers that match this regexp will be deleted when forwarding a message."
 621   :version "21.1"
 622   :group 'message-forwarding
 623   :type '(choice (const :tag "None" nil)
 624                  regexp))
 625
 626 (defcustom message-ignored-cited-headers "."
 627   "*Delete these headers from the messages you yank."
 628   :group 'message-insertion
 629   :type 'regexp)
 630
 631 (defcustom message-cite-prefix-regexp
 632   (if (string-match "[[:digit:]]" "1") ;; support POSIX?
 633       "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
 634     ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
 635     (let ((old-table (syntax-table))
 636           non-word-constituents)
 637       (set-syntax-table text-mode-syntax-table)
 638       (setq non-word-constituents
 639             (concat
 640              (if (string-match "\\w" "-")  "" "-")
 641              (if (string-match "\\w" "_")  "" "_")
 642              (if (string-match "\\w" ".")  "" ".")))
 643       (set-syntax-table old-table)
 644       (if (equal non-word-constituents "")
 645           "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+"
 646         (concat "\\([ \t]*\\(\\w\\|["
 647                 non-word-constituents
 648                 "]\\)+>+\\|[ \t]*[]>|}+]\\)+"))))
 649   "*Regexp matching the longest possible citation prefix on a line."
 650   :group 'message-insertion
 651   :type 'regexp)
 652
 653 (defcustom message-cancel-message "I am canceling my own article.\n"
 654   "Message to be inserted in the cancel message."
 655   :group 'message-interface
 656   :type 'string)
 657
 658 ;; Useful to set in site-init.el
 659 ;;;###autoload
 660 (defcustom message-send-mail-function 'message-send-mail-with-sendmail
 661   "Function to call to send the current buffer as mail.
 662 The headers should be delimited by a line whose contents match the
 663 variable `mail-header-separator'.
 664
 665 Valid values include `message-send-mail-with-sendmail' (the default),
 666 `message-send-mail-with-mh', `message-send-mail-with-qmail',
 667 `message-send-mail-with-smtp', `message-smtpmail-send-it',
 668 `smtpmail-send-it' and `feedmail-send-it'.
 669
 670 See also `send-mail-function'."
 671   :type '(radio (function-item message-send-mail-with-sendmail)
 672                 (function-item message-send-mail-with-mh)
 673                 (function-item message-send-mail-with-qmail)
 674                 (function-item message-send-mail-with-smtp)
 675                 (function-item message-smtpmail-send-it)
 676                 (function-item smtpmail-send-it)
 677                 (function-item feedmail-send-it)
 678                 (function :tag "Other"))
 679   :group 'message-sending
 680   :group 'message-mail)
 681
 682 ;; 1997-09-29 by MORIOKA Tomohiko
 683 (defcustom message-send-news-function 'message-send-news-with-gnus
 684   "Function to call to send the current buffer as news.
 685 The headers should be delimited by a line whose contents match the
 686 variable `mail-header-separator'."
 687   :group 'message-sending
 688   :group 'message-news
 689   :type 'function)
 690
 691 (defcustom message-reply-to-function nil
 692   "If non-nil, function that should return a list of headers.
 693 This function should pick out addresses from the To, Cc, and From headers
 694 and respond with new To and Cc headers."
 695   :group 'message-interface
 696   :type '(choice function (const nil)))
 697
 698 (defcustom message-wide-reply-to-function nil
 699   "If non-nil, function that should return a list of headers.
 700 This function should pick out addresses from the To, Cc, and From headers
 701 and respond with new To and Cc headers."
 702   :group 'message-interface
 703   :type '(choice function (const nil)))
 704
 705 (defcustom message-followup-to-function nil
 706   "If non-nil, function that should return a list of headers.
 707 This function should pick out addresses from the To, Cc, and From headers
 708 and respond with new To and Cc headers."
 709   :group 'message-interface
 710   :type '(choice function (const nil)))
 711
 712 (defcustom message-use-followup-to 'ask
 713   "*Specifies what to do with Followup-To header.
 714 If nil, always ignore the header.  If it is t, use its value, but
 715 query before using the \"poster\" value.  If it is the symbol `ask',
 716 always query the user whether to use the value.  If it is the symbol
 717 `use', always use the value."
 718   :group 'message-interface
 719   :type '(choice (const :tag "ignore" nil)
 720                  (const :tag "use & query" t)
 721                  (const :tag "maybe" t)
 722                  (const :tag "always" use)
 723                  (const :tag "ask" ask)))
 724
 725 (defcustom message-use-mail-copies-to 'ask
 726   "*Specifies what to do with Mail-Copies-To header.
 727 If nil, always ignore the header.  If it is t, use its value, but
 728 query before using the value other than \"always\" or \"never\".
 729 If it is the symbol `ask', always query the user whether to use
 730 the value.  If it is the symbol `use', always use the value."
 731   :group 'message-interface
 732   :type '(choice (const :tag "ignore" nil)
 733                  (const :tag "maybe" t)
 734                  (const :tag "always" use)
 735                  (const :tag "ask" ask)))
 736
 737 ;;; XXX: 'ask and 'use are not implemented yet.
 738 (defcustom message-use-mail-reply-to 'ask
 739   "*Specifies what to do with Mail-Reply-To/Reply-To header.
 740 If nil, always ignore the header.  If it is t or the symbol `use', use
 741 its value.  If it is the symbol `ask', always query the user whether to
 742 use the value.  Note that if \"Reply-To\" is marked as \"broken\", its value
 743 is never used."
 744   :group 'message-interface
 745   :type '(choice (const :tag "ignore" nil)
 746                  (const :tag "maybe" t)
 747                  (const :tag "always" use)
 748                  (const :tag "ask" ask)))
 749
 750 (defcustom message-use-mail-followup-to 'use
 751   "*Specifies what to do with Mail-Followup-To header.
 752 If nil, always ignore the header.  If it is the symbol `ask', always
 753 query the user whether to use the value.  If it is t or the symbol
 754 `use', always use the value."
 755   :group 'message-interface
 756   :type '(choice (const :tag "ignore" nil)
 757                  (const :tag "maybe" t)
 758                  (const :tag "always" use)
 759                  (const :tag "ask" ask)))
 760
 761 (defcustom message-subscribed-address-functions nil
 762   "*Specifies functions for determining list subscription.
 763 If nil, do not attempt to determine list subscription with functions.
 764 If non-nil, this variable contains a list of functions which return
 765 regular expressions to match lists.  These functions can be used in
 766 conjunction with `message-subscribed-regexps' and
 767 `message-subscribed-addresses'."
 768   :group 'message-interface
 769   :type '(repeat sexp))
 770
 771 (defcustom message-subscribed-address-file nil
 772   "*A file containing addresses the user is subscribed to.
 773 If nil, do not look at any files to determine list subscriptions.  If
 774 non-nil, each line of this file should be a mailing list address."
 775   :group 'message-interface
 776   :type '(radio (file :format "%t: %v\n" :size 0)
 777                 (const nil)))
 778
 779 (defcustom message-subscribed-addresses nil
 780   "*Specifies a list of addresses the user is subscribed to.
 781 If nil, do not use any predefined list subscriptions.  This list of
 782 addresses can be used in conjunction with
 783 `message-subscribed-address-functions' and `message-subscribed-regexps'."
 784   :group 'message-interface
 785   :type '(repeat string))
 786
 787 (defcustom message-subscribed-regexps nil
 788   "*Specifies a list of addresses the user is subscribed to.
 789 If nil, do not use any predefined list subscriptions.  This list of
 790 regular expressions can be used in conjunction with
 791 `message-subscribed-address-functions' and `message-subscribed-addresses'."
 792   :group 'message-interface
 793   :type '(repeat regexp))
 794
 795 (defcustom message-allow-no-recipients 'ask
 796   "Specifies what to do when there are no recipients other than Gcc/Fcc.
 797 If it is the symbol `always', the posting is allowed.  If it is the
 798 symbol `never', the posting is not allowed.  If it is the symbol
 799 `ask', you are prompted."
 800   :group 'message-interface
 801   :type '(choice (const always)
 802                  (const never)
 803                  (const ask)))
 804
 805 (defcustom message-sendmail-f-is-evil nil
 806   "*Non-nil means don't add \"-f username\" to the sendmail command line.
 807 Doing so would be even more evil than leaving it out."
 808   :group 'message-sending
 809   :type 'boolean)
 810
 811 (defcustom message-sendmail-envelope-from nil
 812   "*Envelope-from when sending mail with sendmail.
 813 If this is nil, use `user-mail-address'.  If it is the symbol
 814 `header', use the From: header of the message."
 815   :type '(choice (string :tag "From name")
 816                  (const :tag "Use From: header from message" header)
 817                  (const :tag "Use `user-mail-address'" nil))
 818   :group 'message-sending)
 819
 820 ;; qmail-related stuff
 821 (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
 822   "Location of the qmail-inject program."
 823   :group 'message-sending
 824   :type 'file)
 825
 826 (defcustom message-qmail-inject-args nil
 827   "Arguments passed to qmail-inject programs.
 828 This should be a list of strings, one string for each argument.  It
 829 may also be a function.
 830
 831 For e.g., if you wish to set the envelope sender address so that bounces
 832 go to the right place or to deal with listserv's usage of that address, you
 833 might set this variable to '(\"-f\" \"you@some.where\")."
 834   :group 'message-sending
 835   :type '(choice (function)
 836                  (repeat string)))
 837
 838 (defvar message-cater-to-broken-inn t
 839   "Non-nil means Gnus should not fold the `References' header.
 840 Folding `References' makes ancient versions of INN create incorrect
 841 NOV lines.")
 842
 843 (eval-when-compile
 844   (defvar gnus-post-method)
 845   (defvar gnus-select-method))
 846 (defcustom message-post-method
 847   (cond ((and (boundp 'gnus-post-method)
 848               (listp gnus-post-method)
 849               gnus-post-method)
 850          gnus-post-method)
 851         ((boundp 'gnus-select-method)
 852          gnus-select-method)
 853         (t '(nnspool "")))
 854   "*Method used to post news.
 855 Note that when posting from inside Gnus, for instance, this
 856 variable isn't used."
 857   :group 'message-news
 858   :group 'message-sending
 859   ;; This should be the `gnus-select-method' widget, but that might
 860   ;; create a dependence to `gnus.el'.
 861   :type 'sexp)
 862
 863 ;; FIXME: This should be a temporary workaround until someone implements a
 864 ;; proper solution.  If a crash happens while replying, the auto-save file
 865 ;; will *not* have a `References:' header if `message-generate-headers-first'
 866 ;; is nil.  See: http://article.gmane.org/gmane.emacs.gnus.general/51138
 867 (defcustom message-generate-headers-first '(references)
 868   "*If non-nil, generate all required headers before composing.
 869 The variables `message-required-news-headers' and
 870 `message-required-mail-headers' specify which headers to generate.
 871 This can also be a list of headers that should be generated before
 872 composing.
 873
 874 Note that the variable `message-deletable-headers' specifies headers which
 875 are to be deleted and then re-generated before sending, so this variable
 876 will not have a visible effect for those headers."
 877   :group 'message-headers
 878   :type '(choice (const :tag "None" nil)
 879                  (const :tag "References" '(references))
 880                  (const :tag "All" t)
 881                  (repeat (sexp :tag "Header"))))
 882
 883 (defcustom message-setup-hook '(turn-on-mime-edit)
 884   "Normal hook, run each time a new outgoing message is initialized.
 885 The function `message-setup' runs this hook."
 886   :group 'message-various
 887   :type 'hook)
 888
 889 (defcustom message-cancel-hook nil
 890   "Hook run when cancelling articles."
 891   :group 'message-various
 892   :type 'hook)
 893
 894 (defcustom message-signature-setup-hook nil
 895   "Normal hook, run each time a new outgoing message is initialized.
 896 It is run after the headers have been inserted and before
 897 the signature is inserted."
 898   :group 'message-various
 899   :type 'hook)
 900
 901 (defcustom message-bounce-setup-hook nil
 902   "Normal hook, run each time a re-sending bounced message is initialized.
 903 The function `message-bounce' runs this hook."
 904   :group 'message-various
 905   :type 'hook)
 906
 907 (defcustom message-supersede-setup-hook nil
 908   "Normal hook, run each time a supersede message is initialized.
 909 The function `message-supersede' runs this hook."
 910   :group 'message-various
 911   :type 'hook)
 912
 913 (defcustom message-mode-hook nil
 914   "Hook run in message mode buffers."
 915   :group 'message-various
 916   :type 'hook)
 917
 918 (defcustom message-header-hook '((lambda () (mime-encode-header-in-buffer t)))
 919   "Hook run in a message mode buffer narrowed to the headers."
 920   :group 'message-various
 921   :type 'hook)
 922
 923 (defcustom message-header-setup-hook nil
 924   "Hook called narrowed to the headers when setting up a message buffer."
 925   :group 'message-various
 926   :type 'hook)
 927
 928 (defcustom message-minibuffer-local-map
 929   (let ((map (make-sparse-keymap 'message-minibuffer-local-map)))
 930     (set-keymap-parent map minibuffer-local-map)
 931     map)
 932   "Keymap for `message-read-from-minibuffer'.")
 933
 934 ;;;###autoload
 935 (defcustom message-citation-line-function 'message-insert-citation-line
 936   "*Function called to insert the \"Whomever writes:\" line.
 937
 938 Note that Gnus provides a feature where the reader can click on
 939 `writes:' to hide the cited text.  If you change this line too much,
 940 people who read your message will have to change their Gnus
 941 configuration.  See the variable `gnus-cite-attribution-suffix'."
 942   :type 'function
 943   :group 'message-insertion)
 944
 945 ;;;###autoload
 946 (defcustom message-yank-prefix "> "
 947   "*Prefix inserted on the lines of yanked messages.
 948 Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
 949 See also `message-yank-cited-prefix'."
 950   :type 'string
 951   :group 'message-insertion)
 952
 953 (defcustom message-yank-add-new-references t
 954   "Non-nil means new IDs will be added to \"References\" field when an
 955 article is yanked by the command `message-yank-original' interactively.
 956 If it is a symbol `message-id-only', only an ID from \"Message-ID\" field
 957 is used, otherwise IDs extracted from \"References\", \"In-Reply-To\" and
 958 \"Message-ID\" fields are used."
 959   :type '(radio (const :tag "Do not add anything" nil)
 960                 (const :tag "From Message-Id, References and In-Reply-To fields" t)
 961                 (const :tag "From only Message-Id field." message-id-only))
 962   :group 'message-insertion)
 963
 964 (defcustom message-list-references-add-position nil
 965   "Integer value means position for adding to \"References\" field when
 966 an article is yanked by the command `message-yank-original' interactively."
 967   :type '(radio (const :tag "Add to last" nil)
 968                 (integer :tag "Position from last ID"))
 969   :group 'message-insertion)
 970
 971 (defcustom message-yank-cited-prefix ">"
 972   "*Prefix inserted on cited or empty lines of yanked messages.
 973 Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
 974 See also `message-yank-prefix'."
 975   :type 'string
 976   :group 'message-insertion)
 977
 978 (defcustom message-indentation-spaces 3
 979   "*Number of spaces to insert at the beginning of each cited line.
 980 Used by `message-yank-original' via `message-yank-cite'."
 981   :group 'message-insertion
 982   :type 'integer)
 983
 984 ;;;###autoload
 985 (defcustom message-cite-function 'message-cite-original
 986   "*Function for citing an original message.
 987 Predefined functions include `message-cite-original' and
 988 `message-cite-original-without-signature'.
 989 Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil."
 990   :type '(radio (function-item message-cite-original)
 991                 (function-item message-cite-original-without-signature)
 992                 (function-item mu-cite-original)
 993                 (function-item sc-cite-original)
 994                 (function :tag "Other"))
 995   :group 'message-insertion)
 996
 997 ;;;###autoload
 998 (defcustom message-suspend-font-lock-when-citing nil
 999   "Non-nil means suspend font-lock'ing while citing an original message.
1000 Some lazy demand-driven fontification tools (or Emacs itself) have a
1001 bug that they often miss a buffer to be fontified.  It will mostly
1002 occur when Emacs prompts user for any inputs in the minibuffer.
1003 Setting this option to non-nil may help you to avoid unpleasant errors
1004 even if it is an add-hoc expedient."
1005   :type 'boolean
1006   :group 'message-insertion)
1007
1008 ;;;###autoload
1009 (defcustom message-indent-citation-function 'message-indent-citation
1010   "*Function for modifying a citation just inserted in the mail buffer.
1011 This can also be a list of functions.  Each function can find the
1012 citation between (point) and (mark t).  And each function should leave
1013 point and mark around the citation text as modified."
1014   :type 'function
1015   :group 'message-insertion)
1016
1017 ;;;###autoload
1018 (defcustom message-signature t
1019   "*String to be inserted at the end of the message buffer.
1020 If t, the `message-signature-file' file will be inserted instead.
1021 If a function, the result from the function will be used instead.
1022 If a form, the result from the form will be used instead."
1023   :type 'sexp
1024   :group 'message-insertion)
1025
1026 ;;;###autoload
1027 (defcustom message-signature-file "~/.signature"
1028   "*Name of file containing the text inserted at end of message buffer.
1029 Ignored if the named file doesn't exist.
1030 If nil, don't insert a signature."
1031   :type '(choice file (const :tags "None" nil))
1032   :group 'message-insertion)
1033
1034 ;;;###autoload
1035 (defcustom message-signature-insert-empty-line t
1036   "*If non-nil, insert an empty line before the signature separator."
1037   :type 'boolean
1038   :group 'message-insertion)
1039
1040 (defcustom message-distribution-function nil
1041   "*Function called to return a Distribution header."
1042   :group 'message-news
1043   :group 'message-headers
1044   :type '(choice function (const nil)))
1045
1046 (defcustom message-expires 14
1047   "Number of days before your article expires."
1048   :group 'message-news
1049   :group 'message-headers
1050   :link '(custom-manual "(message)News Headers")
1051   :type 'integer)
1052
1053 (defcustom message-user-path nil
1054   "If nil, use the NNTP server name in the Path header.
1055 If stringp, use this; if non-nil, use no host name (user name only)."
1056   :group 'message-news
1057   :group 'message-headers
1058   :link '(custom-manual "(message)News Headers")
1059   :type '(choice (const :tag "nntp" nil)
1060                  (string :tag "name")
1061                  (sexp :tag "none" :format "%t" t)))
1062
1063 (defvar message-reply-buffer nil)
1064 (defvar message-reply-headers nil
1065   "The headers of the current replied article.
1066 It is a vector of the following headers:
1067 \[number subject from date id references chars lines xref extra].")
1068 (defvar message-sent-message-via nil)
1069 (defvar message-checksum nil)
1070 (defvar message-send-actions nil
1071   "A list of actions to be performed upon successful sending of a message.")
1072 (defvar message-exit-actions nil
1073   "A list of actions to be performed upon exiting after sending a message.")
1074 (defvar message-kill-actions nil
1075   "A list of actions to be performed before killing a message buffer.")
1076 (defvar message-postpone-actions nil
1077   "A list of actions to be performed after postponing a message.")
1078 (defvar message-original-frame nil)
1079 (defvar message-parameter-alist nil)
1080 (defvar message-startup-parameter-alist nil)
1081
1082 (define-widget 'message-header-lines 'text
1083   "All header lines must be LFD terminated."
1084   :format "%{%t%}:%n%v"
1085   :valid-regexp "^\\'"
1086   :error "All header lines must be newline terminated")
1087
1088 (defcustom message-default-headers ""
1089   "*A string containing header lines to be inserted in outgoing messages.
1090 It is inserted before you edit the message, so you can edit or delete
1091 these lines."
1092   :group 'message-headers
1093   :type 'message-header-lines)
1094
1095 (defcustom message-default-mail-headers ""
1096   "*A string of header lines to be inserted in outgoing mails."
1097   :group 'message-headers
1098   :group 'message-mail
1099   :type 'message-header-lines)
1100
1101 (defcustom message-default-news-headers ""
1102   "*A string of header lines to be inserted in outgoing news articles."
1103   :group 'message-headers
1104   :group 'message-news
1105   :type 'message-header-lines)
1106
1107 ;; Note: could use /usr/ucb/mail instead of sendmail;
1108 ;; options -t, and -v if not interactive.
1109 (defcustom message-mailer-swallows-blank-line
1110   (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
1111                          system-configuration)
1112            (file-readable-p "/etc/sendmail.cf")
1113            (let ((buffer (get-buffer-create " *temp*")))
1114              (unwind-protect
1115                  (save-excursion
1116                    (set-buffer buffer)
1117                    (insert-file-contents "/etc/sendmail.cf")
1118                    (goto-char (point-min))
1119                    (let ((case-fold-search nil))
1120                      (re-search-forward "^OR\\>" nil t)))
1121                (kill-buffer buffer))))
1122       ;; According to RFC822, "The field-name must be composed of printable
1123       ;; ASCII characters (i. e., characters that have decimal values between
1124       ;; 33 and 126, except colon)", i. e., any chars except ctl chars,
1125       ;; space, or colon.
1126       '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
1127   "*Set this non-nil if the system's mailer runs the header and body together.
1128 \(This problem exists on Sunos 4 when sendmail is run in remote mode.)
1129 The value should be an expression to test whether the problem will
1130 actually occur."
1131   :group 'message-sending
1132   :type 'sexp)
1133
1134 ;;; XXX: This symbol is overloaded!  See below.
1135 (defvar message-user-agent nil
1136   "String of the form of PRODUCT/VERSION.  Used for User-Agent header field.")
1137
1138 (static-when (boundp 'MULE)
1139   (require 'reporter));; `define-mail-user-agent' is here.
1140
1141 ;;;###autoload
1142 (define-mail-user-agent 'message-user-agent
1143   'message-mail 'message-send-and-exit
1144   'message-kill-buffer 'message-send-hook)
1145
1146 (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
1147   "If non-nil, delete the deletable headers before feeding to mh.")
1148
1149 (defvar message-send-method-alist
1150   '((news message-news-p message-send-via-news)
1151     (mail message-mail-p message-send-via-mail))
1152   "Alist of ways to send outgoing messages.
1153 Each element has the form
1154
1155   \(TYPE PREDICATE FUNCTION)
1156
1157 where TYPE is a symbol that names the method; PREDICATE is a function
1158 called without any parameters to determine whether the message is
1159 a message of type TYPE; and FUNCTION is a function to be called if
1160 PREDICATE returns non-nil.  FUNCTION is called with one parameter --
1161 the prefix.")
1162
1163 (defcustom message-mail-alias-type 'abbrev
1164   "*What alias expansion type to use in Message buffers.
1165 The default is `abbrev', which uses mailabbrev.  nil switches
1166 mail aliases off."
1167   :group 'message
1168   :link '(custom-manual "(message)Mail Aliases")
1169   :type '(choice (const :tag "Use Mailabbrev" abbrev)
1170                  (const :tag "No expansion" nil)))
1171
1172 (defcustom message-auto-save-directory
1173   (file-name-as-directory (nnheader-concat message-directory "drafts"))
1174   "*Directory where Message auto-saves buffers if Gnus isn't running.
1175 If nil, Message won't auto-save."
1176   :group 'message-buffers
1177   :type '(choice directory (const :tag "Don't auto-save" nil)))
1178
1179 (defcustom message-default-charset
1180   (and (featurep 'xemacs) (not (featurep 'mule)) 'iso-8859-1)
1181   "Default charset used in non-MULE XEmacsen."
1182   :version "21.1"
1183   :group 'message
1184   :type 'symbol)
1185
1186 (defcustom message-dont-reply-to-names
1187   (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
1188   "*A regexp specifying addresses to prune when doing wide replies.
1189 A value of nil means exclude your own user name only."
1190   :version "21.1"
1191   :group 'message
1192   :type '(choice (const :tag "Yourself" nil)
1193                  regexp))
1194
1195 (defvar message-shoot-gnksa-feet nil
1196   "*A list of GNKSA feet you are allowed to shoot.
1197 Gnus gives you all the opportunity you could possibly want for
1198 shooting yourself in the foot.  Also, Gnus allows you to shoot the
1199 feet of Good Net-Keeping Seal of Approval.  The following are foot
1200 candidates:
1201 `empty-article'     Allow you to post an empty article;
1202 `quoted-text-only'  Allow you to post quoted text only;
1203 `multiple-copies'   Allow you to post multiple copies;
1204 `cancel-messages'   Allow you to cancel or supersede messages from
1205                     your other email addresses.")
1206
1207 (defsubst message-gnksa-enable-p (feature)
1208   (or (not (listp message-shoot-gnksa-feet))
1209       (memq feature message-shoot-gnksa-feet)))
1210
1211 (defcustom message-hidden-headers nil
1212   "Regexp of headers to be hidden when composing new messages.
1213 This can also be a list of regexps to match headers.  Or a list
1214 starting with `not' and followed by regexps.."
1215   :group 'message
1216   :type '(repeat regexp))
1217
1218 ;;; Internal variables.
1219 ;;; Well, not really internal.
1220
1221 (defvar message-mode-syntax-table
1222   (let ((table (copy-syntax-table text-mode-syntax-table)))
1223     (modify-syntax-entry ?% ". " table)
1224     (modify-syntax-entry ?> ". " table)
1225     (modify-syntax-entry ?< ". " table)
1226     table)
1227   "Syntax table used while in Message mode.")
1228
1229 (defface message-header-to-face
1230   '((((class color)
1231       (background dark))
1232      (:foreground "green2" :bold t))
1233     (((class color)
1234       (background light))
1235      (:foreground "MidnightBlue" :bold t))
1236     (t
1237      (:bold t :italic t)))
1238   "Face used for displaying From headers."
1239   :group 'message-faces)
1240
1241 (defface message-header-cc-face
1242   '((((class color)
1243       (background dark))
1244      (:foreground "green4" :bold t))
1245     (((class color)
1246       (background light))
1247      (:foreground "MidnightBlue"))
1248     (t
1249      (:bold t)))
1250   "Face used for displaying Cc headers."
1251   :group 'message-faces)
1252
1253 (defface message-header-subject-face
1254   '((((class color)
1255       (background dark))
1256      (:foreground "green3"))
1257     (((class color)
1258       (background light))
1259      (:foreground "navy blue" :bold t))
1260     (t
1261      (:bold t)))
1262   "Face used for displaying subject headers."
1263   :group 'message-faces)
1264
1265 (defface message-header-newsgroups-face
1266   '((((class color)
1267       (background dark))
1268      (:foreground "yellow" :bold t :italic t))
1269     (((class color)
1270       (background light))
1271      (:foreground "blue4" :bold t :italic t))
1272     (t
1273      (:bold t :italic t)))
1274   "Face used for displaying newsgroups headers."
1275   :group 'message-faces)
1276
1277 (defface message-header-other-face
1278   '((((class color)
1279       (background dark))
1280      (:foreground "#b00000"))
1281     (((class color)
1282       (background light))
1283      (:foreground "steel blue"))
1284     (t
1285      (:bold t :italic t)))
1286   "Face used for displaying newsgroups headers."
1287   :group 'message-faces)
1288
1289 (defface message-header-name-face
1290   '((((class color)
1291       (background dark))
1292      (:foreground "DarkGreen"))
1293     (((class color)
1294       (background light))
1295      (:foreground "cornflower blue"))
1296     (t
1297      (:bold t)))
1298   "Face used for displaying header names."
1299   :group 'message-faces)
1300
1301 (defface message-header-xheader-face
1302   '((((class color)
1303       (background dark))
1304      (:foreground "blue"))
1305     (((class color)
1306       (background light))
1307      (:foreground "blue"))
1308     (t
1309      (:bold t)))
1310   "Face used for displaying X-Header headers."
1311   :group 'message-faces)
1312
1313 (defface message-separator-face
1314   '((((class color)
1315       (background dark))
1316      (:foreground "blue3"))
1317     (((class color)
1318       (background light))
1319      (:foreground "brown"))
1320     (t
1321      (:bold t)))
1322   "Face used for displaying the separator."
1323   :group 'message-faces)
1324
1325 (defface message-cited-text-face
1326   '((((class color)
1327       (background dark))
1328      (:foreground "red"))
1329     (((class color)
1330       (background light))
1331      (:foreground "red"))
1332     (t
1333      (:bold t)))
1334   "Face used for displaying cited text names."
1335   :group 'message-faces)
1336
1337 (defface message-mml-face
1338   '((((class color)
1339       (background dark))
1340      (:foreground "ForestGreen"))
1341     (((class color)
1342       (background light))
1343      (:foreground "ForestGreen"))
1344     (t
1345      (:bold t)))
1346   "Face used for displaying MML."
1347   :group 'message-faces)
1348
1349 (defun message-font-lock-make-header-matcher (regexp)
1350   (let ((form
1351          `(lambda (limit)
1352             (let ((start (point)))
1353               (save-restriction
1354                 (widen)
1355                 (goto-char (point-min))
1356                 (if (re-search-forward
1357                      (concat "^" (regexp-quote mail-header-separator) "$")
1358                      nil t)
1359                     (setq limit (min limit (match-beginning 0))))
1360                 (goto-char start))
1361               (and (< start limit)
1362                    (re-search-forward ,regexp limit t))))))
1363     (if (featurep 'bytecomp)
1364         (byte-compile form)
1365       form)))
1366
1367 (defvar message-font-lock-keywords
1368   (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
1369     `((,(message-font-lock-make-header-matcher
1370          (concat "^\\([Tt]o:\\)" content))
1371        (1 'message-header-name-face)
1372        (2 'message-header-to-face nil t))
1373       (,(message-font-lock-make-header-matcher
1374          (concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
1375                  "[Mm]ail-[Cc]opies-[Tt]o:\\|"
1376                  "[Mm]ail-[Rr]eply-[Tt]o:\\|"
1377                  "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content))
1378        (1 'message-header-name-face)
1379        (2 'message-header-cc-face nil t))
1380       (,(message-font-lock-make-header-matcher
1381          (concat "^\\([Ss]ubject:\\)" content))
1382        (1 'message-header-name-face)
1383        (2 'message-header-subject-face nil t))
1384       (,(message-font-lock-make-header-matcher
1385          (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
1386        (1 'message-header-name-face)
1387        (2 'message-header-newsgroups-face nil t))
1388       (,(message-font-lock-make-header-matcher
1389          (concat "^\\([A-Z][^: \n\t]+:\\)" content))
1390        (1 'message-header-name-face)
1391        (2 'message-header-other-face nil t))
1392       (,(message-font-lock-make-header-matcher
1393          (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
1394        (1 'message-header-name-face)
1395        (2 'message-header-name-face))
1396       ,@(if (and mail-header-separator
1397                  (not (equal mail-header-separator "")))
1398             `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1399                1 'message-separator-face))
1400           nil)
1401       ((lambda (limit)
1402          (re-search-forward (concat "^\\("
1403                                     message-cite-prefix-regexp
1404                                     "\\).*")
1405                             limit t))
1406        (0 'message-cited-text-face))
1407       (,mime-edit-tag-regexp
1408        (0 'message-mml-face))))
1409   "Additional expressions to highlight in Message mode.")
1410
1411 ;; XEmacs does it like this.  For Emacs, we have to set the
1412 ;; `font-lock-defaults' buffer-local variable.
1413 (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
1414
1415 (defvar message-face-alist
1416   '((bold . bold-region)
1417     (underline . underline-region)
1418     (default . (lambda (b e)
1419                  (unbold-region b e)
1420                  (ununderline-region b e))))
1421   "Alist of mail and news faces for facemenu.
1422 The cdr of each entry is a function for applying the face to a region.")
1423
1424 (defcustom message-send-hook nil
1425   "Hook run before sending messages.
1426 This hook is run quite early when sending."
1427   :group 'message-various
1428   :options '(ispell-message)
1429   :type 'hook)
1430
1431 (defcustom message-send-mail-hook nil
1432   "Hook run before sending mail messages.
1433 This hook is run very late -- just before the message is sent as
1434 mail."
1435   :group 'message-various
1436   :type 'hook)
1437
1438 (defcustom message-send-news-hook nil
1439   "Hook run before sending news messages.
1440 This hook is run very late -- just before the message is sent as
1441 news."
1442   :group 'message-various
1443   :type 'hook)
1444
1445 (defcustom message-sent-hook nil
1446   "Hook run after sending messages."
1447   :group 'message-various
1448   :type 'hook)
1449
1450 (defcustom message-use-multi-frames nil
1451   "Make new frame when sending messages."
1452   :group 'message-frames
1453   :type 'boolean)
1454
1455 (defcustom message-delete-frame-on-exit nil
1456   "Delete frame after sending messages."
1457   :group 'message-frames
1458   :type '(choice (const :tag "off" nil)
1459                  (const :tag "always" t)
1460                  (const :tag "ask" ask)))
1461
1462 (defvar message-draft-coding-system
1463   nnheader-auto-save-coding-system
1464   "*Coding system to compose mail.
1465 If you'd like to make it possible to share draft files between XEmacs
1466 and Emacs, you may use `iso-2022-7bit' for this value at your own risk.
1467 Note that the coding-system `iso-2022-7bit' isn't suitable to all data.")
1468
1469 (defcustom message-send-mail-partially-limit 1000000
1470   "The limitation of messages sent as message/partial.
1471 The lower bound of message size in characters, beyond which the message
1472 should be sent in several parts.  If it is nil, the size is unlimited."
1473   :version "21.1"
1474   :group 'message-buffers
1475   :type '(choice (const :tag "unlimited" nil)
1476                  (integer 1000000)))
1477
1478 (defcustom message-alternative-emails nil
1479   "A regexp to match the alternative email addresses.
1480 The first matched address (not primary one) is used in the From field."
1481   :group 'message-headers
1482   :type '(choice (const :tag "Always use primary" nil)
1483                  regexp))
1484
1485 (defcustom message-hierarchical-addresses nil
1486   "A list of hierarchical mail address definitions.
1487
1488 Inside each entry, the first address is the \"top\" address, and
1489 subsequent addresses are subaddresses; this is used to indicate that
1490 mail sent to the first address will automatically be delivered to the
1491 subaddresses.  So if the first address appears in the recipient list
1492 for a message, the subaddresses will be removed (if present) before
1493 the mail is sent.  All addresses in this structure should be
1494 downcased."
1495   :group 'message-headers
1496   :type '(repeat (repeat string)))
1497
1498 (defcustom message-mail-user-agent nil
1499   "Like `mail-user-agent'.
1500 Except if it is nil, use Gnus native MUA; if it is t, use
1501 `mail-user-agent'."
1502   :type '(radio (const :tag "Gnus native"
1503                        :format "%t\n"
1504                        nil)
1505                 (const :tag "`mail-user-agent'"
1506                        :format "%t\n"
1507                        t)
1508                 (function-item :tag "Default Emacs mail"
1509                                :format "%t\n"
1510                                sendmail-user-agent)
1511                 (function-item :tag "Emacs interface to MH"
1512                                :format "%t\n"
1513                                mh-e-user-agent)
1514                 (function :tag "Other"))
1515   :version "21.1"
1516   :group 'message)
1517
1518 (defcustom message-wide-reply-confirm-recipients nil
1519   "Whether to confirm a wide reply to multiple email recipients.
1520 If this variable is nil, don't ask whether to reply to all recipients.
1521 If this variable is non-nil, pose the question \"Reply to all
1522 recipients?\" before a wide reply to multiple recipients.  If the user
1523 answers yes, reply to all recipients as usual.  If the user answers
1524 no, only reply back to the author."
1525   :version "21.3"
1526   :group 'message-headers
1527   :type 'boolean)
1528
1529 (defcustom message-user-fqdn nil
1530   "*Domain part of Messsage-Ids."
1531   :group 'message-headers
1532   :link '(custom-manual "(message)News Headers")
1533   :type '(radio (const :format "%v  " nil)
1534                 (string :format "FQDN: %v\n" :size 0)))
1535
1536 (defcustom message-use-idna (and (condition-case nil (require 'idna)
1537                                    (file-error))
1538                                  (mm-coding-system-p 'utf-8)
1539                                  (executable-find idna-program)
1540                                  'ask)
1541   "Whether to encode non-ASCII in domain names into ASCII according to IDNA."
1542   :group 'message-headers
1543   :type '(choice (const :tag "Ask" ask)
1544                  (const :tag "Never" nil)
1545                  (const :tag "Always" t)))
1546
1547 ;;; Internal variables.
1548
1549 (defvar message-sending-message "Sending...")
1550 (defvar message-buffer-list nil)
1551 (defvar message-this-is-news nil)
1552 (defvar message-this-is-mail nil)
1553 (defvar message-draft-article nil)
1554 (defvar message-mime-part nil)
1555 (defvar message-posting-charset nil)
1556
1557 ;; Byte-compiler warning
1558 (eval-when-compile
1559   (defvar gnus-active-hashtb)
1560   (defvar gnus-read-active-file))
1561
1562 ;;; Regexp matching the delimiter of messages in UNIX mail format
1563 ;;; (UNIX From lines), minus the initial ^.  It should be a copy
1564 ;;; of rmail.el's rmail-unix-mail-delimiter.
1565 (defvar message-unix-mail-delimiter
1566   (let ((time-zone-regexp
1567          (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
1568                  "\\|[-+]?[0-9][0-9][0-9][0-9]"
1569                  "\\|"
1570                  "\\) *")))
1571     (concat
1572      "From "
1573
1574      ;; Many things can happen to an RFC 822 mailbox before it is put into
1575      ;; a `From' line.  The leading phrase can be stripped, e.g.
1576      ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'.  The <> can be stripped, e.g.
1577      ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'.  Everything starting with a CRLF
1578      ;; can be removed, e.g.
1579      ;;         From: joe@y.z (Joe      K
1580      ;;                 User)
1581      ;; can yield `From joe@y.z (Joe    K Fri Mar 22 08:11:15 1996', and
1582      ;;         From: Joe User
1583      ;;                 <joe@y.z>
1584      ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.
1585      ;; The mailbox can be removed or be replaced by white space, e.g.
1586      ;;         From: "Joe User"{space}{tab}
1587      ;;                 <joe@y.z>
1588      ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996',
1589      ;; where {space} and {tab} represent the Ascii space and tab characters.
1590      ;; We want to match the results of any of these manglings.
1591      ;; The following regexp rejects names whose first characters are
1592      ;; obviously bogus, but after that anything goes.
1593      "\\([^\0-\b\n-\r\^?].*\\)?"
1594
1595      ;; The time the message was sent.
1596      "\\([^\0-\r \^?]+\\) +"            ; day of the week
1597      "\\([^\0-\r \^?]+\\) +"            ; month
1598      "\\([0-3]?[0-9]\\) +"              ; day of month
1599      "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
1600
1601      ;; Perhaps a time zone, specified by an abbreviation, or by a
1602      ;; numeric offset.
1603      time-zone-regexp
1604
1605      ;; The year.
1606      " \\([0-9][0-9]+\\) *"
1607
1608      ;; On some systems the time zone can appear after the year, too.
1609      time-zone-regexp
1610
1611      ;; Old uucp cruft.
1612      "\\(remote from .*\\)?"
1613
1614      "\n"))
1615   "Regexp matching the delimiter of messages in UNIX mail format.")
1616
1617 (defvar message-unsent-separator
1618   (concat "^ *---+ +Unsent message follows +---+ *$\\|"
1619           "^ *---+ +Returned message +---+ *$\\|"
1620           "^Start of returned message$\\|"
1621           "^ *---+ +Original message +---+ *$\\|"
1622           "^ *--+ +begin message +--+ *$\\|"
1623           "^ *---+ +Original message follows +---+ *$\\|"
1624           "^ *---+ +Undelivered message follows +---+ *$\\|"
1625           "^|? *---+ +Message text follows: +---+ *|?$")
1626   "A regexp that matches the separator before the text of a failed message.")
1627
1628 (defvar message-header-format-alist
1629   `((Newsgroups)
1630     (To . message-fill-address)
1631     (Cc . message-fill-address)
1632     (Subject)
1633     (In-Reply-To)
1634     (Fcc)
1635     (Bcc)
1636     (Date)
1637     (Organization)
1638     (Distribution)
1639     (Lines)
1640     (Expires)
1641     (Message-ID)
1642     (References . message-shorten-references)
1643     (User-Agent))
1644   "Alist used for formatting headers.")
1645
1646 (defvar message-options nil
1647   "Some saved answers when sending message.")
1648
1649 (defvar message-send-mail-real-function nil
1650   "Internal send mail function.")
1651
1652 (defvar message-bogus-system-names "^localhost\\."
1653   "The regexp of bogus system names.")
1654
1655 (defcustom message-valid-fqdn-regexp
1656   (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
1657           ;; valid TLDs:
1658           "\\([a-z][a-z]" ;; two letter country TDLs
1659           "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
1660           "\\|aero\\|coop\\|info\\|name\\|museum"
1661           "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
1662           "\\)")
1663   "Regular expression that matches a valid FQDN."
1664   ;; see also: gnus-button-valid-fqdn-regexp
1665   :group 'message-headers
1666   :type 'regexp)
1667
1668 (eval-and-compile
1669   (autoload 'message-setup-toolbar "messagexmas")
1670   (autoload 'mh-new-draft-name "mh-comp")
1671   (autoload 'mh-send-letter "mh-comp")
1672   (autoload 'gnus-point-at-eol "gnus-util")
1673   (autoload 'gnus-point-at-bol "gnus-util")
1674   (autoload 'gnus-output-to-rmail "gnus-util")
1675   (autoload 'gnus-output-to-mail "gnus-util")
1676   (autoload 'nndraft-request-associate-buffer "nndraft")
1677   (autoload 'nndraft-request-expire-articles "nndraft")
1678   (autoload 'gnus-open-server "gnus-int")
1679   (autoload 'gnus-request-post "gnus-int")
1680   (autoload 'gnus-copy-article-buffer "gnus-msg")
1681   (autoload 'gnus-alive-p "gnus-util")
1682   (autoload 'gnus-server-string "gnus")
1683   (autoload 'gnus-group-name-charset "gnus-group")
1684   (autoload 'gnus-group-name-decode "gnus-group")
1685   (autoload 'gnus-groups-from-server "gnus")
1686   (autoload 'rmail-output "rmailout")
1687   (autoload 'gnus-delay-article "gnus-delay")
1688   (autoload 'gnus-make-local-hook "gnus-util")
1689   (autoload 'mu-cite-original "mu-cite"))
1690
1691 \f
1692
1693 ;;;
1694 ;;; Utility functions.
1695 ;;;
1696 (defun message-eval-parameter (parameter)
1697   (condition-case ()
1698       (if (symbolp parameter)
1699           (if (functionp parameter)
1700               (funcall parameter)
1701             (eval parameter))
1702         parameter)
1703     (error nil)))
1704
1705 (defsubst message-get-parameter (key &optional alist)
1706   (unless alist
1707     (setq alist message-parameter-alist))
1708   (cdr (assq key alist)))
1709
1710 (defmacro message-get-parameter-with-eval (key &optional alist)
1711   `(message-eval-parameter (message-get-parameter ,key ,alist)))
1712
1713 (defmacro message-y-or-n-p (question show &rest text)
1714   "Ask QUESTION, displaying remaining args in a temporary buffer if SHOW."
1715   `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
1716
1717 (defmacro message-delete-line (&optional n)
1718   "Delete the current line (and the next N lines)."
1719   `(delete-region (progn (beginning-of-line) (point))
1720                   (progn (forward-line ,(or n 1)) (point))))
1721
1722 (defun message-mark-active-p ()
1723   "Non-nil means the mark and region are currently active in this buffer."
1724   mark-active)
1725
1726 (defun message-unquote-tokens (elems)
1727   "Remove double quotes (\") from strings in list ELEMS."
1728   (mapcar (lambda (item)
1729             (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)
1730               (setq item (concat (match-string 1 item)
1731                                  (match-string 2 item))))
1732             item)
1733           elems))
1734
1735 (defun message-tokenize-header (header &optional separator)
1736   "Split HEADER into a list of header elements.
1737 SEPARATOR is a string of characters to be used as separators.  \",\"
1738 is used by default."
1739   (if (not header)
1740       nil
1741     (let ((regexp (format "[%s]+" (or separator ",")))
1742           (beg 1)
1743           (first t)
1744           quoted elems paren)
1745       (with-temp-buffer
1746         (set-buffer-multibyte t)
1747         (insert header)
1748         (goto-char (point-min))
1749         (while (not (eobp))
1750           (if first
1751               (setq first nil)
1752             (forward-char 1))
1753           (cond ((and (> (point) beg)
1754                       (or (eobp)
1755                           (and (looking-at regexp)
1756                                (not quoted)
1757                                (not paren))))
1758                  (push (buffer-substring beg (point)) elems)
1759                  (setq beg (match-end 0)))
1760                 ((eq (char-after) ?\")
1761                  (setq quoted (not quoted)))
1762                 ((and (eq (char-after) ?\()
1763                       (not quoted))
1764                  (setq paren t))
1765                 ((and (eq (char-after) ?\))
1766                       (not quoted))
1767                  (setq paren nil))))
1768         (nreverse elems)))))
1769
1770 (defun message-mail-file-mbox-p (file)
1771   "Say whether FILE looks like a Unix mbox file."
1772   (when (and (file-exists-p file)
1773              (file-readable-p file)
1774              (file-regular-p file))
1775     (with-temp-buffer
1776       (nnheader-insert-file-contents file)
1777       (goto-char (point-min))
1778       (looking-at message-unix-mail-delimiter))))
1779
1780 (defun message-fetch-field (header &optional not-all)
1781   "The same as `mail-fetch-field', only remove all newlines.
1782 The buffer is expected to be narrowed to just the header of the message;
1783 see `message-narrow-to-headers-or-head'."
1784   (let* ((inhibit-point-motion-hooks t)
1785          (case-fold-search t)
1786          (value (mail-fetch-field header nil (not not-all))))
1787     (when value
1788       (while (string-match "\n[\t ]+" value)
1789         (setq value (replace-match " " t t value)))
1790       (set-text-properties 0 (length value) nil value)
1791       value)))
1792
1793 (defun message-narrow-to-field ()
1794   "Narrow the buffer to the header on the current line."
1795   (beginning-of-line)
1796   (narrow-to-region
1797    (point)
1798    (progn
1799      (forward-line 1)
1800      (if (re-search-forward "^[^ \n\t]" nil t)
1801          (progn
1802            (beginning-of-line)
1803            (point))
1804        (point-max))))
1805   (goto-char (point-min)))
1806
1807 (defun message-add-header (&rest headers)
1808   "Add the HEADERS to the message header, skipping those already present."
1809   (while headers
1810     (let (hclean)
1811       (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers))
1812         (error "Invalid header `%s'" (car headers)))
1813       (setq hclean (match-string 1 (car headers)))
1814       (save-restriction
1815         (message-narrow-to-headers)
1816         (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
1817           (goto-char (point-max))
1818           (if (string-match "\n$" (car headers))
1819               (insert (car headers))
1820             (insert (car headers) ?\n)))))
1821     (setq headers (cdr headers))))
1822
1823 (defmacro message-with-reply-buffer (&rest forms)
1824   "Evaluate FORMS in the reply buffer, if it exists."
1825   `(let ((buffer (message-eval-parameter message-reply-buffer)))
1826      (when (and buffer
1827                 (buffer-name buffer))
1828        (save-excursion
1829          (set-buffer buffer)
1830          ,@forms))))
1831
1832 (put 'message-with-reply-buffer 'lisp-indent-function 0)
1833 (put 'message-with-reply-buffer 'edebug-form-spec '(body))
1834
1835 (defun message-fetch-reply-field (header)
1836   "Fetch field HEADER from the message we're replying to."
1837   (message-with-reply-buffer
1838     (save-restriction
1839       (mail-narrow-to-head)
1840       (message-fetch-field header))))
1841
1842 (defun message-strip-list-identifiers (subject)
1843   "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT."
1844   (require 'gnus-sum)                   ; for gnus-list-identifiers
1845   (let ((regexp (if (stringp gnus-list-identifiers)
1846                     gnus-list-identifiers
1847                   (mapconcat 'identity gnus-list-identifiers " *\\|"))))
1848     (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
1849                               " *\\)\\)+\\(Re: +\\)?\\)") subject)
1850         (concat (substring subject 0 (match-beginning 1))
1851                 (or (match-string 3 subject)
1852                     (match-string 5 subject))
1853                 (substring subject
1854                            (match-end 1)))
1855       subject)))
1856
1857 (defun message-strip-subject-re (subject)
1858   "Remove \"Re:\" from subject lines in string SUBJECT."
1859   (if (string-match message-subject-re-regexp subject)
1860       (substring subject (match-end 0))
1861     subject))
1862
1863 ;;; Start of functions adopted from `message-utils.el'.
1864
1865 (defun message-strip-subject-trailing-was (subject)
1866   "Remove trailing \"(Was: <old subject>)\" from SUBJECT lines.
1867 Leading \"Re: \" is not stripped by this function.  Use the function
1868 `message-strip-subject-re' for this."
1869   (let* ((query message-subject-trailing-was-query)
1870          (new) (found))
1871     (setq found
1872           (string-match
1873            (if (eq query 'ask)
1874                message-subject-trailing-was-ask-regexp
1875              message-subject-trailing-was-regexp)
1876            subject))
1877     (if found
1878         (setq new (substring subject 0 (match-beginning 0))))
1879     (if (or (not found) (eq query nil))
1880         subject
1881       (if (eq query 'ask)
1882           (if (message-y-or-n-p
1883                "Strip `(was: <old subject>)' in subject? " t
1884                (concat
1885                 "Strip `(was: <old subject>)' in subject "
1886                 "and use the new one instead?\n\n"
1887                 "Current subject is:   \""
1888                 subject "\"\n\n"
1889                 "New subject would be: \""
1890                 new "\"\n\n"
1891                 "See the variable `message-subject-trailing-was-query' "
1892                 "to get rid of this query."
1893                 ))
1894               new subject)
1895         new))))
1896
1897 ;;; Suggested by Jonas Steverud  @  www.dtek.chalmers.se/~d4jonas/
1898
1899 ;;;###autoload
1900 (defun message-change-subject (new-subject)
1901   "Ask for NEW-SUBJECT header, append (was: <Old Subject>)."
1902   (interactive
1903    (list
1904     (read-from-minibuffer "New subject: ")))
1905   (cond ((and (not (or (null new-subject) ; new subject not empty
1906                        (zerop (string-width new-subject))
1907                        (string-match "^[ \t]*$" new-subject))))
1908          (save-excursion
1909            (let ((old-subject
1910                   (save-restriction
1911                     (message-narrow-to-headers)
1912                     (message-fetch-field "Subject"))))
1913              (cond ((not old-subject)
1914                     (error "No current subject"))
1915                    ((not (string-match
1916                           (concat "^[ \t]*"
1917                                   (regexp-quote new-subject)
1918                                   " \t]*$")
1919                           old-subject))  ; yes, it really is a new subject
1920                     ;; delete eventual Re: prefix
1921                     (setq old-subject
1922                           (message-strip-subject-re old-subject))
1923                     (message-goto-subject)
1924                     (message-delete-line)
1925                     (insert (concat "Subject: "
1926                                     new-subject
1927                                     " (was: "
1928                                     old-subject ")\n")))))))))
1929
1930 ;;;###autoload
1931 (defun message-mark-inserted-region (beg end)
1932   "Mark some region in the current article with enclosing tags.
1933 See `message-mark-insert-begin' and `message-mark-insert-end'."
1934   (interactive "r")
1935   (save-excursion
1936     ; add to the end of the region first, otherwise end would be invalid
1937     (goto-char end)
1938     (insert message-mark-insert-end)
1939     (goto-char beg)
1940     (insert message-mark-insert-begin)))
1941
1942 ;;;###autoload
1943 (defun message-mark-insert-file (file)
1944   "Insert FILE at point, marking it with enclosing tags.
1945 See `message-mark-insert-begin' and `message-mark-insert-end'."
1946   (interactive "fFile to insert: ")
1947     ;; reverse insertion to get correct result.
1948   (let ((p (point)))
1949     (insert message-mark-insert-end)
1950     (goto-char p)
1951     (insert-file-contents file)
1952     (goto-char p)
1953     (insert message-mark-insert-begin)))
1954
1955 ;;;###autoload
1956 (defun message-add-archive-header ()
1957   "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
1958 The note can be customized using `message-archive-note'.  When called with a
1959 prefix argument, ask for a text to insert.  If you don't want the note in the
1960 body, set  `message-archive-note' to nil."
1961   (interactive)
1962   (if current-prefix-arg
1963       (setq message-archive-note
1964             (read-from-minibuffer "Reason for No-Archive: "
1965                                   (cons message-archive-note 0))))
1966     (save-excursion
1967       (if (message-goto-signature)
1968           (re-search-backward message-signature-separator))
1969       (when message-archive-note
1970         (insert message-archive-note)
1971         (newline))
1972       (message-add-header message-archive-header)
1973       (message-sort-headers)))
1974
1975 ;;;###autoload
1976 (defun message-cross-post-followup-to-header (target-group)
1977   "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
1978 With prefix-argument just set Follow-Up, don't cross-post."
1979   (interactive
1980    (list ; Completion based on Gnus
1981     (completing-read "Followup To: "
1982                      (if (boundp 'gnus-newsrc-alist)
1983                          gnus-newsrc-alist)
1984                      nil nil '("poster" . 0)
1985                      (if (boundp 'gnus-group-history)
1986                          'gnus-group-history))))
1987   (message-remove-header "Follow[Uu]p-[Tt]o" t)
1988   (message-goto-newsgroups)
1989   (beginning-of-line)
1990   ;; if we already did a crosspost before, kill old target
1991   (if (and message-cross-post-old-target
1992            (re-search-forward
1993             (regexp-quote (concat "," message-cross-post-old-target))
1994             nil t))
1995       (replace-match ""))
1996   ;; unless (followup is to poster or user explicitly asked not
1997   ;; to cross-post, or target-group is already in Newsgroups)
1998   ;; add target-group to Newsgroups line.
1999   (cond ((and (or
2000                ;; def: cross-post, req:no
2001                (and message-cross-post-default (not current-prefix-arg))
2002                ;; def: no-cross-post, req:yes
2003                (and (not message-cross-post-default) current-prefix-arg))
2004               (not (string-match "poster" target-group))
2005               (not (string-match (regexp-quote target-group)
2006                                  (message-fetch-field "Newsgroups"))))
2007          (end-of-line)
2008          (insert (concat "," target-group))))
2009   (end-of-line) ; ensure Followup: comes after Newsgroups:
2010   ;; unless new followup would be identical to Newsgroups line
2011   ;; make a new Followup-To line
2012   (if (not (string-match (concat "^[ \t]*"
2013                                  target-group
2014                                  "[ \t]*$")
2015                          (message-fetch-field "Newsgroups")))
2016       (insert (concat "\nFollowup-To: " target-group)))
2017   (setq message-cross-post-old-target target-group))
2018
2019 ;;;###autoload
2020 (defun message-cross-post-insert-note (target-group cross-post in-old
2021                                                     old-groups)
2022   "Insert a in message body note about a set Followup or Crosspost.
2023 If there have been previous notes, delete them.  TARGET-GROUP specifies the
2024 group to Followup-To.  When CROSS-POST is t, insert note about
2025 crossposting.  IN-OLD specifies whether TARGET-GROUP is a member of
2026 OLD-GROUPS.  OLD-GROUPS lists the old-groups the posting would have
2027 been made to before the user asked for a Crosspost."
2028   ;; start scanning body for previous uses
2029   (message-goto-signature)
2030   (let ((head (re-search-backward
2031                (concat "^" mail-header-separator)
2032                nil t))) ; just search in body
2033     (message-goto-signature)
2034     (while (re-search-backward
2035             (concat "^" (regexp-quote message-cross-post-note) ".*")
2036             head t)
2037       (message-delete-line))
2038     (message-goto-signature)
2039     (while (re-search-backward
2040             (concat "^" (regexp-quote message-followup-to-note) ".*")
2041             head t)
2042       (message-delete-line))
2043     ;; insert new note
2044     (if (message-goto-signature)
2045         (re-search-backward message-signature-separator))
2046     (if (or in-old
2047             (not cross-post)
2048             (string-match "^[ \t]*poster[ \t]*$" target-group))
2049         (insert (concat message-followup-to-note target-group "\n"))
2050       (insert (concat message-cross-post-note target-group "\n")))))
2051
2052 ;;;###autoload
2053 (defun message-cross-post-followup-to (target-group)
2054   "Crossposts message and set Followup-To to TARGET-GROUP.
2055 With prefix-argument just set Follow-Up, don't cross-post."
2056   (interactive
2057    (list ; Completion based on Gnus
2058     (completing-read "Followup To: "
2059                      (if (boundp 'gnus-newsrc-alist)
2060                          gnus-newsrc-alist)
2061                      nil nil '("poster" . 0)
2062                      (if (boundp 'gnus-group-history)
2063                          'gnus-group-history))))
2064   (cond ((not (or (null target-group) ; new subject not empty
2065                   (zerop (string-width target-group))
2066                   (string-match "^[ \t]*$" target-group)))
2067          (save-excursion
2068            (let* ((old-groups (message-fetch-field "Newsgroups"))
2069                   (in-old (string-match
2070                            (regexp-quote target-group)
2071                            (or old-groups ""))))
2072              ;; check whether target exactly matches old Newsgroups
2073              (cond ((not old-groups)
2074                     (error "No current newsgroup"))
2075                    ((or (not in-old)
2076                         (not (string-match
2077                               (concat "^[ \t]*"
2078                                       (regexp-quote target-group)
2079                                       "[ \t]*$")
2080                               old-groups)))
2081                     ;; yes, Newsgroups line must change
2082                     (message-cross-post-followup-to-header target-group)
2083                     ;; insert note whether we do cross-post or followup-to
2084                     (funcall message-cross-post-note-function
2085                              target-group
2086                              (if (or (and message-cross-post-default
2087                                           (not current-prefix-arg))
2088                                      (and (not message-cross-post-default)
2089                                           current-prefix-arg)) t)
2090                              in-old old-groups))))))))
2091
2092 ;;; Reduce To: to Cc: or Bcc: header
2093
2094 ;;;###autoload
2095 (defun message-reduce-to-to-cc ()
2096  "Replace contents of To: header with contents of Cc: or Bcc: header."
2097  (interactive)
2098  (let ((cc-content
2099         (save-restriction (message-narrow-to-headers)
2100                           (message-fetch-field "cc")))
2101        (bcc nil))
2102    (if (and (not cc-content)
2103             (setq cc-content
2104                   (save-restriction
2105                     (message-narrow-to-headers)
2106                     (message-fetch-field "bcc"))))
2107        (setq bcc t))
2108    (cond (cc-content
2109           (save-excursion
2110             (message-goto-to)
2111             (message-delete-line)
2112             (insert (concat "To: " cc-content "\n"))
2113             (save-restriction
2114               (message-narrow-to-headers)
2115               (message-remove-header (if bcc
2116                                          "bcc"
2117                                        "cc"))))))))
2118
2119 ;;; End of functions adopted from `message-utils.el'.
2120
2121 (defun message-remove-header (header &optional is-regexp first reverse)
2122   "Remove HEADER in the narrowed buffer.
2123 If IS-REGEXP, HEADER is a regular expression.
2124 If FIRST, only remove the first instance of the header.
2125 Return the number of headers removed."
2126   (goto-char (point-min))
2127   (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":")))
2128         (number 0)
2129         (case-fold-search t)
2130         last)
2131     (while (and (not (eobp))
2132                 (not last))
2133       (if (if reverse
2134               (not (looking-at regexp))
2135             (looking-at regexp))
2136           (progn
2137             (incf number)
2138             (when first
2139               (setq last t))
2140             (delete-region
2141              (point)
2142              ;; There might be a continuation header, so we have to search
2143              ;; until we find a new non-continuation line.
2144              (progn
2145                (forward-line 1)
2146                (if (re-search-forward "^[^ \t]" nil t)
2147                    (goto-char (match-beginning 0))
2148                  (point-max)))))
2149         (forward-line 1)
2150         (if (re-search-forward "^[^ \t]" nil t)
2151             (goto-char (match-beginning 0))
2152           (goto-char (point-max)))))
2153     number))
2154
2155 (defun message-remove-first-header (header)
2156   "Remove the first instance of HEADER if there is more than one."
2157   (let ((count 0)
2158         (regexp (concat "^" (regexp-quote header) ":")))
2159     (save-excursion
2160       (goto-char (point-min))
2161       (while (re-search-forward regexp nil t)
2162         (incf count)))
2163     (while (> count 1)
2164       (message-remove-header header nil t)
2165       (decf count))))
2166
2167 (defun message-narrow-to-headers ()
2168   "Narrow the buffer to the head of the message."
2169   (widen)
2170   (narrow-to-region
2171    (goto-char (point-min))
2172    (if (re-search-forward
2173         (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
2174        (match-beginning 0)
2175      (point-max)))
2176   (goto-char (point-min)))
2177
2178 (defun message-narrow-to-head-1 ()
2179   "Like `message-narrow-to-head'.  Don't widen."
2180   (narrow-to-region
2181    (goto-char (point-min))
2182    (if (search-forward "\n\n" nil 1)
2183        (1- (point))
2184      (point-max)))
2185   (goto-char (point-min)))
2186
2187 (defun message-narrow-to-head ()
2188   "Narrow the buffer to the head of the message.
2189 Point is left at the beginning of the narrowed-to region."
2190   (widen)
2191   (message-narrow-to-head-1))
2192
2193 (defun message-narrow-to-headers-or-head ()
2194   "Narrow the buffer to the head of the message."
2195   (widen)
2196   (narrow-to-region
2197    (goto-char (point-min))
2198    (cond
2199     ((re-search-forward
2200       (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
2201      (match-beginning 0))
2202     ((search-forward "\n\n" nil t)
2203      (1- (point)))
2204     (t
2205      (point-max))))
2206   (goto-char (point-min)))
2207
2208 (defun message-news-p ()
2209   "Say whether the current buffer contains a news message."
2210   (and (not message-this-is-mail)
2211        (or message-this-is-news
2212            (save-excursion
2213              (save-restriction
2214                (message-narrow-to-headers)
2215                (and (message-fetch-field "newsgroups")
2216                     (not (message-fetch-field "posted-to"))))))))
2217
2218 (defun message-mail-p ()
2219   "Say whether the current buffer contains a mail message."
2220   (and (not message-this-is-news)
2221        (or message-this-is-mail
2222            (save-excursion
2223              (save-restriction
2224                (message-narrow-to-headers)
2225                (or (message-fetch-field "to")
2226                    (message-fetch-field "cc")
2227                    (message-fetch-field "bcc")))))))
2228
2229 (defun message-subscribed-p ()
2230   "Say whether we need to insert a MFT header."
2231   (or message-subscribed-regexps
2232       message-subscribed-addresses
2233       message-subscribed-address-file
2234       message-subscribed-address-functions))
2235
2236 (defun message-next-header ()
2237   "Go to the beginning of the next header."
2238   (beginning-of-line)
2239   (or (eobp) (forward-char 1))
2240   (not (if (re-search-forward "^[^ \t]" nil t)
2241            (beginning-of-line)
2242          (goto-char (point-max)))))
2243
2244 (defun message-sort-headers-1 ()
2245   "Sort the buffer as headers using `message-rank' text props."
2246   (goto-char (point-min))
2247   (require 'sort)
2248   (sort-subr
2249    nil 'message-next-header
2250    (lambda ()
2251      (message-next-header)
2252      (unless (bobp)
2253        (forward-char -1)))
2254    (lambda ()
2255      (or (get-text-property (point) 'message-rank)
2256          10000))))
2257
2258 (defun message-sort-headers ()
2259   "Sort the headers of the current message according to `message-header-format-alist'."
2260   (interactive)
2261   (save-excursion
2262     (save-restriction
2263       (let ((max (1+ (length message-header-format-alist)))
2264             rank)
2265         (message-narrow-to-headers)
2266         (while (re-search-forward "^[^ \n]+:" nil t)
2267           (put-text-property
2268            (match-beginning 0) (1+ (match-beginning 0))
2269            'message-rank
2270            (if (setq rank (length (memq (assq (intern (buffer-substring
2271                                                        (match-beginning 0)
2272                                                        (1- (match-end 0))))
2273                                               message-header-format-alist)
2274                                         message-header-format-alist)))
2275                (- max rank)
2276              (1+ max)))))
2277       (message-sort-headers-1))))
2278
2279 \f
2280
2281 ;;;
2282 ;;; Message mode
2283 ;;;
2284
2285 ;;; Set up keymap.
2286
2287 (defvar message-mode-map nil)
2288
2289 (unless message-mode-map
2290   (setq message-mode-map (make-keymap))
2291   (set-keymap-parent message-mode-map text-mode-map)
2292   (define-key message-mode-map "\C-c?" 'describe-mode)
2293
2294   (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
2295   (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from)
2296   (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
2297   (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
2298   (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
2299   (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
2300   ;; (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
2301   (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-mail-reply-to)
2302   (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
2303   (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
2304   (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
2305   (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
2306   (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
2307   (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
2308   (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
2309   (define-key message-mode-map "\C-c\C-f\C-i"
2310     'message-insert-or-toggle-importance)
2311   (define-key message-mode-map "\C-c\C-f\C-a"
2312     'message-generate-unsubscribed-mail-followup-to)
2313
2314   ;; modify headers (and insert notes in body)
2315   (define-key message-mode-map "\C-c\C-fs"    'message-change-subject)
2316   ;;
2317   (define-key message-mode-map "\C-c\C-fx"    'message-cross-post-followup-to)
2318   ;; prefix+message-cross-post-followup-to = same w/o cross-post
2319   (define-key message-mode-map "\C-c\C-ft"    'message-reduce-to-to-cc)
2320   (define-key message-mode-map "\C-c\C-fa"    'message-add-archive-header)
2321   ;; mark inserted text
2322   (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region)
2323   (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file)
2324
2325   (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
2326   (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
2327   (define-key message-mode-map "\C-c\C-fc" 'message-goto-mail-copies-to)
2328
2329   (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
2330   (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
2331   (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
2332   (define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
2333
2334   (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance)
2335   (define-key message-mode-map "\C-c\M-n"
2336     'message-insert-disposition-notification-to)
2337
2338   (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
2339   (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)
2340   (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
2341   (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
2342   (define-key message-mode-map "\C-c\M-h" 'message-insert-headers)
2343   (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
2344   (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
2345   (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
2346
2347   (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
2348   (define-key message-mode-map "\C-c\C-s" 'message-send)
2349   (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
2350   (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
2351   (define-key message-mode-map "\C-c\n" 'gnus-delay-article)
2352
2353   (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
2354   (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
2355   (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
2356   (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
2357   ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
2358   (define-key message-mode-map [remap split-line]  'message-split-line)
2359
2360   (define-key message-mode-map "\C-a" 'message-beginning-of-line)
2361   (define-key message-mode-map "\t" 'message-tab)
2362   (define-key message-mode-map "\M-;" 'comment-region)
2363
2364   (define-key message-mode-map "\C-xk" 'message-mimic-kill-buffer))
2365
2366 (easy-menu-define
2367  message-mode-menu message-mode-map "Message Menu."
2368  `("Message"
2369    ["Yank Original" message-yank-original t]
2370    ["Fill Yanked Message" message-fill-yanked-message t]
2371    ["Insert Signature" message-insert-signature t]
2372    ["Caesar (rot13) Message" message-caesar-buffer-body t]
2373    ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)]
2374    ["Elide Region" message-elide-region
2375     :active (message-mark-active-p)
2376     ,@(if (featurep 'xemacs) nil
2377         '(:help "Replace text in region with an ellipsis"))]
2378    ["Delete Outside Region" message-delete-not-region
2379     :active (message-mark-active-p)
2380     ,@(if (featurep 'xemacs) nil
2381         '(:help "Delete all quoted text outside region"))]
2382    ["Kill To Signature" message-kill-to-signature t]
2383    ["Newline and Reformat" message-newline-and-reformat t]
2384    ["Rename buffer" message-rename-buffer t]
2385    ["Spellcheck" ispell-message
2386     ,@(if (featurep 'xemacs) '(t)
2387         '(:help "Spellcheck this message"))]
2388    ["Attach file as MIME" mime-edit-insert-file
2389     ,@(if (featurep 'xemacs) '(t)
2390         '(:help "Attach a file at point"))]
2391    "----"
2392    ["Insert Region Marked" message-mark-inserted-region
2393     :active (message-mark-active-p)
2394     ,@(if (featurep 'xemacs) nil
2395         '(:help "Mark region with enclosing tags"))]
2396    ["Insert File Marked..." message-mark-insert-file
2397     ,@(if (featurep 'xemacs) '(t)
2398         '(:help "Insert file at point marked with enclosing tags"))]
2399    "----"
2400    ["Send Message" message-send-and-exit
2401     ,@(if (featurep 'xemacs) '(t)
2402         '(:help "Send this message"))]
2403    ["Postpone Message" message-dont-send
2404     ,@(if (featurep 'xemacs) '(t)
2405         '(:help "File this draft message and exit"))]
2406    ["Send at Specific Time..." gnus-delay-article
2407     ,@(if (featurep 'xemacs) '(t)
2408         '(:help "Ask, then arrange to send message at that time"))]
2409    ["Kill Message" message-kill-buffer
2410     ,@(if (featurep 'xemacs) '(t)
2411         '(:help "Delete this message without sending"))]))
2412
2413 (easy-menu-define
2414  message-mode-field-menu message-mode-map ""
2415  `("Field"
2416    ["Fetch To" message-insert-to t]
2417    ["Fetch Newsgroups" message-insert-newsgroups t]
2418    "----"
2419    ["To" message-goto-to t]
2420    ["From" message-goto-from t]
2421    ["Subject" message-goto-subject t]
2422    ["Change subject..." message-change-subject t]
2423    ["Cc" message-goto-cc t]
2424    ["Bcc" message-goto-bcc t]
2425    ["Fcc" message-goto-fcc t]
2426    ["Reply-To" message-goto-reply-to t]
2427    ["Flag As Important" message-insert-importance-high
2428     ,@(if (featurep 'xemacs) '(t)
2429         '(:help "Mark this message as important"))]
2430    ["Flag As Unimportant" message-insert-importance-low
2431     ,@(if (featurep 'xemacs) '(t)
2432         '(:help "Mark this message as unimportant"))]
2433    ["Request Receipt"
2434     message-insert-disposition-notification-to
2435     ,@(if (featurep 'xemacs) '(t)
2436         '(:help "Request a receipt notification"))]
2437    "----"
2438    ;; (typical) news stuff
2439    ["Summary" message-goto-summary t]
2440    ["Keywords" message-goto-keywords t]
2441    ["Newsgroups" message-goto-newsgroups t]
2442    ["Followup-To" message-goto-followup-to t]
2443    ;; ["Followup-To (with note in body)" message-cross-post-followup-to t]
2444    ["Crosspost / Followup-To..." message-cross-post-followup-to t]
2445    ["Distribution" message-goto-distribution t]
2446    ["X-No-Archive:" message-add-archive-header t ]
2447    "----"
2448    ;; (typical) mailing-lists stuff
2449    ["Send to list only" message-to-list-only t]
2450    ["Mail-Followup-To" message-goto-mail-followup-to t]
2451    ["Mail-Reply-To" message-goto-mail-reply-to t]
2452    ["Mail-Copies-To" message-goto-mail-copies-to t]
2453    ["Reduce To: to Cc:" message-reduce-to-to-cc t]
2454    "----"
2455    ["Sort Headers" message-sort-headers t]
2456    ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t]
2457    ["Goto Body" message-goto-body t]
2458    ["Goto Signature" message-goto-signature t]))
2459
2460 (defvar message-tool-bar-map nil)
2461
2462 (eval-when-compile
2463   (defvar facemenu-add-face-function)
2464   (defvar facemenu-remove-face-function))
2465
2466 ;;; Forbidden properties
2467 ;;
2468 ;; We use `after-change-functions' to keep special text properties
2469 ;; that interfer with the normal function of message mode out of the
2470 ;; buffer.
2471
2472 (defcustom message-strip-special-text-properties t
2473   "Strip special properties from the message buffer.
2474
2475 Emacs has a number of special text properties which can break message
2476 composing in various ways.  If this option is set, message will strip
2477 these properties from the message composition buffer.  However, some
2478 packages requires these properties to be present in order to work.
2479 If you use one of these packages, turn this option off, and hope the
2480 message composition doesn't break too bad."
2481   :group 'message-various
2482   :type 'boolean)
2483
2484 (defconst message-forbidden-properties
2485   ;; No reason this should be clutter up customize.  We make it a
2486   ;; property list (rather than a list of property symbols), to be
2487   ;; directly useful for `remove-text-properties'.
2488   '(field nil read-only nil invisible nil intangible nil
2489           mouse-face nil modification-hooks nil insert-in-front-hooks nil
2490           insert-behind-hooks nil point-entered nil point-left nil)
2491   ;; Other special properties:
2492   ;; category, face, display: probably doesn't do any harm.
2493   ;; fontified: is used by font-lock.
2494   ;; syntax-table, local-map: I dunno.
2495   ;; We need to add XEmacs names to the list.
2496   "Property list of with properties.forbidden in message buffers.
2497 The values of the properties are ignored, only the property names are used.")
2498
2499 (defun message-tamago-not-in-use-p (pos)
2500   "Return t when tamago version 4 is not in use at the cursor position.
2501 Tamago version 4 is a popular input method for writing Japanese text.
2502 It uses the properties `intangible', `invisible', `modification-hooks'
2503 and `read-only' when translating ascii or kana text to kanji text.
2504 These properties are essential to work, so we should never strip them."
2505   (not (and (boundp 'egg-modefull-mode)
2506             (symbol-value 'egg-modefull-mode)
2507             (or (memq (get-text-property pos 'intangible)
2508                       '(its-part-1 its-part-2))
2509                 (get-text-property pos 'egg-end)
2510                 (get-text-property pos 'egg-lang)
2511                 (get-text-property pos 'egg-start)))))
2512
2513 (defun message-strip-forbidden-properties (begin end &optional old-length)
2514   "Strip forbidden properties between BEGIN and END, ignoring the third arg.
2515 This function is intended to be called from `after-change-functions'.
2516 See also `message-forbidden-properties'."
2517   (when (and message-strip-special-text-properties
2518              (message-tamago-not-in-use-p begin)
2519              ;; Check whether the invisible MIME part is not inserted.
2520              (not (text-property-any begin end 'mime-edit-invisible t)))
2521     (while (not (= begin end))
2522       (when (not (get-text-property begin 'message-hidden))
2523         (remove-text-properties begin (1+ begin)
2524                                 message-forbidden-properties))
2525       (incf begin))))
2526
2527 ;;;###autoload
2528 (define-derived-mode message-mode text-mode "Message"
2529   "Major mode for editing mail and news to be sent.
2530 Like Text Mode but with these additional commands:\\<message-mode-map>
2531 C-c C-s  `message-send' (send the message)  C-c C-c  `message-send-and-exit'
2532 C-c C-d  Postpone sending the message       C-c C-k  Kill the message
2533 C-c C-f  move to a header field (and create it if there isn't):
2534          C-c C-f C-t  move to To        C-c C-f C-s  move to Subject
2535          C-c C-f C-c  move to Cc        C-c C-f C-b  move to Bcc
2536          C-c C-f C-w  move to Fcc       C-c C-f C-r  move to Reply-To
2537          C-c C-f C-u  move to Summary   C-c C-f C-n  move to Newsgroups
2538          C-c C-f C-k  move to Keywords  C-c C-f C-d  move to Distribution
2539          C-c C-f C-o  move to From (\"Originator\")
2540          C-c C-f C-f  move to Followup-To
2541          C-c C-f C-m  move to Mail-Followup-To
2542          C-c C-f c    move to Mail-Copies-To
2543          C-c C-f C-i  cycle through Importance values
2544          C-c C-f s    change subject and append \"(was: <Old Subject>)\"
2545          C-c C-f x    crossposting with FollowUp-To header and note in body
2546          C-c C-f t    replace To: header with contents of Cc: or Bcc:
2547          C-c C-f a    Insert X-No-Archive: header and a note in the body
2548 C-c C-t  `message-insert-to' (add a To header to a news followup)
2549 C-c C-l  `message-to-list-only' (removes all but list address in to/cc)
2550 C-c C-n  `message-insert-newsgroups' (add a Newsgroup header to a news reply)
2551 C-c C-b  `message-goto-body' (move to beginning of message text).
2552 C-c C-i  `message-goto-signature' (move to the beginning of the signature).
2553 C-c C-w  `message-insert-signature' (insert `message-signature-file' file).
2554 C-c C-y  `message-yank-original' (insert current message, if any).
2555 C-c C-q  `message-fill-yanked-message' (fill what was yanked).
2556 C-c C-e  `message-elide-region' (elide the text between point and mark).
2557 C-c C-v  `message-delete-not-region' (remove the text outside the region).
2558 C-c C-z  `message-kill-to-signature' (kill the text up to the signature).
2559 C-c C-r  `message-caesar-buffer-body' (rot13 the message body).
2560 C-c C-u  `message-insert-or-toggle-importance'  (insert or cycle importance).
2561 C-c M-n  `message-insert-disposition-notification-to'  (request receipt).
2562 C-c M-m  `message-mark-inserted-region' (mark region with enclosing tags).
2563 C-c M-f  `message-mark-insert-file' (insert file marked with enclosing tags).
2564 M-RET    `message-newline-and-reformat' (break the line and reformat)."
2565   (setq local-abbrev-table text-mode-abbrev-table)
2566   (set (make-local-variable 'message-reply-buffer) nil)
2567   (make-local-variable 'message-send-actions)
2568   (make-local-variable 'message-exit-actions)
2569   (make-local-variable 'message-kill-actions)
2570   (make-local-variable 'message-postpone-actions)
2571   (make-local-variable 'message-draft-article)
2572   (setq buffer-offer-save t)
2573   (set (make-local-variable 'facemenu-add-face-function)
2574        (lambda (face end)
2575          (let ((face-fun (cdr (assq face message-face-alist))))
2576            (if face-fun
2577                (funcall face-fun (point) end)
2578              (error "Face %s not configured for %s mode" face mode-name)))
2579          ""))
2580   (set (make-local-variable 'facemenu-remove-face-function) t)
2581   (set (make-local-variable 'message-reply-headers) nil)
2582   (make-local-variable 'message-user-agent)
2583   (make-local-variable 'message-post-method)
2584   (set (make-local-variable 'message-sent-message-via) nil)
2585   (set (make-local-variable 'message-checksum) nil)
2586   (make-local-variable 'message-parameter-alist)
2587   (setq message-parameter-alist
2588         (copy-sequence message-startup-parameter-alist))
2589   (message-setup-fill-variables)
2590   (set
2591    (make-local-variable 'paragraph-separate)
2592    (format "\\(%s\\)\\|\\(%s\\)"
2593            paragraph-separate
2594            "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
2595   ;; Allow using comment commands to add/remove quoting.
2596   (set (make-local-variable 'comment-start) message-yank-prefix)
2597   (if (featurep 'xemacs)
2598       (message-setup-toolbar)
2599     (set (make-local-variable 'font-lock-defaults)
2600          '(message-font-lock-keywords t))
2601     (if (boundp 'tool-bar-map)
2602         (set (make-local-variable 'tool-bar-map) (message-tool-bar-map))))
2603   (easy-menu-add message-mode-menu message-mode-map)
2604   (easy-menu-add message-mode-field-menu message-mode-map)
2605   (gnus-make-local-hook 'after-change-functions)
2606   ;; Mmmm... Forbidden properties...
2607   (add-hook 'after-change-functions 'message-strip-forbidden-properties
2608             nil 'local)
2609   ;; Allow mail alias things.
2610   (when (eq message-mail-alias-type 'abbrev)
2611     (if (fboundp 'mail-abbrevs-setup)
2612         (mail-abbrevs-setup)
2613       (if (fboundp 'mail-aliases-setup) ; warning avoidance
2614           (mail-aliases-setup))))
2615   (unless buffer-file-name
2616     (message-set-auto-save-file-name))
2617   (set (make-local-variable 'indent-tabs-mode) nil)) ;No tabs for indentation.
2618
2619 (defun message-setup-fill-variables ()
2620   "Setup message fill variables."
2621   (set (make-local-variable 'fill-paragraph-function)
2622        'message-fill-paragraph)
2623   (make-local-variable 'paragraph-separate)
2624   (make-local-variable 'paragraph-start)
2625   (make-local-variable 'adaptive-fill-regexp)
2626   (unless (boundp 'adaptive-fill-first-line-regexp)
2627     (setq adaptive-fill-first-line-regexp nil))
2628   (make-local-variable 'adaptive-fill-first-line-regexp)
2629   (let ((quote-prefix-regexp
2630          ;; User should change message-cite-prefix-regexp if
2631          ;; message-yank-prefix is set to an abnormal value.
2632          (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
2633     (setq paragraph-start
2634           (concat
2635            (regexp-quote mail-header-separator) "$\\|"
2636            "[ \t]*$\\|"                 ; blank lines
2637            "-- $\\|"                    ; signature delimiter
2638            "---+$\\|"                   ; delimiters for forwarded messages
2639            page-delimiter "$\\|"        ; spoiler warnings
2640            ".*wrote:$\\|"               ; attribution lines
2641            quote-prefix-regexp "$"))    ; empty lines in quoted text
2642     (setq paragraph-separate paragraph-start)
2643     (setq adaptive-fill-regexp
2644           (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
2645     (setq adaptive-fill-first-line-regexp
2646           (concat quote-prefix-regexp "\\|"
2647                   adaptive-fill-first-line-regexp)))
2648   (make-local-variable 'auto-fill-inhibit-regexp)
2649   ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
2650   (setq auto-fill-inhibit-regexp nil)
2651   (make-local-variable 'normal-auto-fill-function)
2652   (setq normal-auto-fill-function 'message-do-auto-fill)
2653   ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'.
2654   ;; In that case, ensure that it uses the right function.  The real
2655   ;; solution would be not to use `define-derived-mode', and run
2656   ;; `text-mode-hook' ourself at the end of the mode.
2657   ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19.
2658   (when auto-fill-function
2659     (setq auto-fill-function normal-auto-fill-function)))
2660
2661 \f
2662
2663 ;;;
2664 ;;; Message mode commands
2665 ;;;
2666
2667 ;;; Movement commands
2668
2669 (defun message-goto-to ()
2670   "Move point to the To header."
2671   (interactive)
2672   (message-position-on-field "To"))
2673
2674 (defun message-goto-from ()
2675   "Move point to the From header."
2676   (interactive)
2677   (message-position-on-field "From"))
2678
2679 (defun message-goto-subject ()
2680   "Move point to the Subject header."
2681   (interactive)
2682   (message-position-on-field "Subject"))
2683
2684 (defun message-goto-cc ()
2685   "Move point to the Cc header."
2686   (interactive)
2687   (message-position-on-field "Cc" "To"))
2688
2689 (defun message-goto-bcc ()
2690   "Move point to the Bcc  header."
2691   (interactive)
2692   (message-position-on-field "Bcc" "Cc" "To"))
2693
2694 (defun message-goto-fcc ()
2695   "Move point to the Fcc header."
2696   (interactive)
2697   (message-position-on-field "Fcc" "To" "Newsgroups"))
2698
2699 (defun message-goto-reply-to ()
2700   "Move point to the Reply-To header."
2701   (interactive)
2702   (message-position-on-field "Reply-To" "Subject"))
2703
2704 (defun message-goto-mail-reply-to ()
2705   "Move point to the Mail-Reply-To header."
2706   (interactive)
2707   (message-position-on-field "Mail-Reply-To" "Subject"))
2708
2709 (defun message-goto-mail-copies-to ()
2710   "Move point to the Mail-Copies-To header.  If the header is newly created,
2711 a string \"never\" is inserted in default."
2712   (interactive)
2713   (unless (message-position-on-field "Mail-Copies-To" "Subject")
2714     (insert "never")
2715     (backward-char 5)))
2716
2717 (defun message-goto-newsgroups ()
2718   "Move point to the Newsgroups header."
2719   (interactive)
2720   (message-position-on-field "Newsgroups"))
2721
2722 (defun message-goto-distribution ()
2723   "Move point to the Distribution header."
2724   (interactive)
2725   (message-position-on-field "Distribution"))
2726
2727 (defun message-goto-followup-to ()
2728   "Move point to the Followup-To header."
2729   (interactive)
2730   (message-position-on-field "Followup-To" "Newsgroups"))
2731
2732 (defun message-goto-mail-followup-to ()
2733   "Move point to the Mail-Followup-To header.  If the header is newly created
2734 and To field contains only one address, the address is inserted in default."
2735   (interactive)
2736   (unless (message-position-on-field "Mail-Followup-To" "Subject")
2737     (let ((start (point))
2738           addresses)
2739       (save-restriction
2740         (message-narrow-to-headers)
2741         (setq addresses (split-string (mail-strip-quoted-names
2742                                        (or (std11-fetch-field "to") ""))
2743                                       "[ \f\t\n\r\v,]+"))
2744         (when (eq 1 (length addresses))
2745           (goto-char start)
2746           (insert (car addresses))
2747           (goto-char start))))))
2748
2749 (defun message-goto-keywords ()
2750   "Move point to the Keywords header."
2751   (interactive)
2752   (message-position-on-field "Keywords" "Subject"))
2753
2754 (defun message-goto-summary ()
2755   "Move point to the Summary header."
2756   (interactive)
2757   (message-position-on-field "Summary" "Subject"))
2758
2759 (defun message-goto-body (&optional interactivep)
2760   "Move point to the beginning of the message body."
2761   (interactive (list t))
2762   (when (and interactivep
2763              (looking-at "[ \t]*\n"))
2764     (expand-abbrev))
2765   (goto-char (point-min))
2766   (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
2767       (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
2768
2769 (defun message-goto-eoh ()
2770   "Move point to the end of the headers."
2771   (interactive)
2772   (message-goto-body)
2773   (forward-line -1))
2774
2775 (defun message-goto-signature ()
2776   "Move point to the beginning of the message signature.
2777 If there is no signature in the article, go to the end and
2778 return nil."
2779   (interactive)
2780   (goto-char (point-min))
2781   (if (re-search-forward message-signature-separator nil t)
2782       (forward-line 1)
2783     (goto-char (point-max))
2784     nil))
2785
2786 (defun message-generate-unsubscribed-mail-followup-to (&optional include-cc)
2787   "Insert a reasonable MFT header in a post to an unsubscribed list.
2788 When making original posts to a mailing list you are not subscribed to,
2789 you have to type in a MFT header by hand.  The contents, usually, are
2790 the addresses of the list and your own address.  This function inserts
2791 such a header automatically.  It fetches the contents of the To: header
2792 in the current mail buffer, and appends the current `user-mail-address'.
2793
2794 If the optional argument INCLUDE-CC is non-nil, the addresses in the
2795 Cc: header are also put into the MFT."
2796
2797   (interactive "P")
2798   (let* (cc tos)
2799     (save-restriction
2800       (message-narrow-to-headers)
2801       (message-remove-header "Mail-Followup-To")
2802       (setq cc (and include-cc (message-fetch-field "Cc")))
2803       (setq tos (if cc
2804                     (concat (message-fetch-field "To") "," cc)
2805                   (message-fetch-field "To"))))
2806     (message-goto-mail-followup-to)
2807     (insert (concat tos ", " user-mail-address))))
2808
2809 \f
2810
2811 (defun message-insert-to (&optional force)
2812   "Insert a To header that points to the author of the article being replied to.
2813 If the original author requested not to be sent mail, the function signals
2814 an error.
2815 With the prefix argument FORCE, insert the header anyway."
2816   (interactive "P")
2817   (let ((co (message-fetch-reply-field "mail-copies-to")))
2818     (when (and (null force)
2819                co
2820                (or (equal (downcase co) "never")
2821                    (equal (downcase co) "nobody")))
2822       (error "The user has requested not to have copies sent via mail")))
2823   (message-carefully-insert-headers
2824    (list (cons 'To
2825                (or (message-fetch-reply-field "mail-reply-to")
2826                    (message-fetch-reply-field "reply-to")
2827                    (message-fetch-reply-field "from")
2828                    "")))))
2829
2830 (defun message-insert-wide-reply ()
2831   "Insert To and Cc headers as if you were doing a wide reply."
2832   (interactive)
2833   (let ((headers (message-with-reply-buffer
2834                    (message-get-reply-headers t))))
2835     (message-carefully-insert-headers headers)))
2836
2837 (defun message-carefully-insert-headers (headers)
2838   (dolist (header headers)
2839     (let ((header-name (symbol-name (car header))))
2840       (when (and (message-position-on-field header-name)
2841                  (mail-fetch-field header-name)
2842                  (not (string-match "\\` *\\'"
2843                                     (mail-fetch-field header-name))))
2844         (insert ", "))
2845       (insert (cdr header)))))
2846
2847 (defun message-widen-reply ()
2848   "Widen the reply to include maximum recipients."
2849   (interactive)
2850   (let ((follow-to
2851          (and message-reply-buffer
2852               (buffer-name message-reply-buffer)
2853               (save-excursion
2854                 (set-buffer message-reply-buffer)
2855                 (message-get-reply-headers t)))))
2856     (save-excursion
2857       (save-restriction
2858         (message-narrow-to-headers)
2859         (dolist (elem follow-to)
2860           (message-remove-header (symbol-name (car elem)))
2861           (goto-char (point-min))
2862           (insert (symbol-name (car elem)) ": "
2863                   (cdr elem) "\n"))))))
2864
2865 (defun message-insert-newsgroups ()
2866   "Insert the Newsgroups header from the article being replied to."
2867   (interactive)
2868   (when (and (message-position-on-field "Newsgroups")
2869              (mail-fetch-field "newsgroups")
2870              (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
2871     (insert ","))
2872   (insert (or (message-fetch-reply-field "newsgroups") "")))
2873
2874 \f
2875
2876 ;;; Various commands
2877
2878 (defun message-delete-not-region (beg end)
2879   "Delete everything in the body of the current message outside of the region."
2880   (interactive "r")
2881   (let (citeprefix)
2882     (save-excursion
2883       (goto-char beg)
2884       ;; snarf citation prefix, if appropriate
2885       (unless (eq (point) (progn (beginning-of-line) (point)))
2886         (when (looking-at message-cite-prefix-regexp)
2887           (setq citeprefix (match-string 0))))
2888       (goto-char end)
2889       (delete-region (point) (if (not (message-goto-signature))
2890                                  (point)
2891                                (forward-line -2)
2892                                (point)))
2893       (insert "\n")
2894       (goto-char beg)
2895       (delete-region beg (progn (message-goto-body)
2896                                 (forward-line 2)
2897                                 (point)))
2898       (when citeprefix
2899         (insert citeprefix))))
2900   (when (message-goto-signature)
2901     (forward-line -2)))
2902
2903 (defun message-kill-to-signature ()
2904   "Deletes all text up to the signature."
2905   (interactive)
2906   (let ((point (point)))
2907     (message-goto-signature)
2908     (unless (eobp)
2909       (end-of-line -1))
2910     (kill-region point (point))
2911     (unless (bolp)
2912       (insert "\n"))))
2913
2914 (defun message-newline-and-reformat (&optional arg not-break)
2915   "Insert four newlines, and then reformat if inside quoted text.
2916 Prefix arg means justify as well."
2917   (interactive (list (if current-prefix-arg 'full)))
2918   (let (quoted point beg end leading-space bolp)
2919     (setq point (point))
2920     (beginning-of-line)
2921     (setq beg (point))
2922     (setq bolp (= beg point))
2923     ;; Find first line of the paragraph.
2924     (if not-break
2925         (while (and (not (eobp))
2926                     (not (looking-at message-cite-prefix-regexp))
2927                     (looking-at paragraph-start))
2928           (forward-line 1)))
2929     ;; Find the prefix
2930     (when (looking-at message-cite-prefix-regexp)
2931       (setq quoted (match-string 0))
2932       (goto-char (match-end 0))
2933       (looking-at "[ \t]*")
2934       (setq leading-space (match-string 0)))
2935     (if (and quoted
2936              (not not-break)
2937              (not bolp)
2938              (< (- point beg) (length quoted)))
2939         ;; break inside the cite prefix.
2940         (setq quoted nil
2941               end nil))
2942     (if quoted
2943         (progn
2944           (forward-line 1)
2945           (while (and (not (eobp))
2946                       (not (looking-at paragraph-separate))
2947                       (looking-at message-cite-prefix-regexp)
2948                       (equal quoted (match-string 0)))
2949             (goto-char (match-end 0))
2950             (looking-at "[ \t]*")
2951             (if (> (length leading-space) (length (match-string 0)))
2952                 (setq leading-space (match-string 0)))
2953             (forward-line 1))
2954           (setq end (point))
2955           (goto-char beg)
2956           (while (and (if (bobp) nil (forward-line -1) t)
2957                       (not (looking-at paragraph-start))
2958                       (looking-at message-cite-prefix-regexp)
2959                       (equal quoted (match-string 0)))
2960             (setq beg (point))
2961             (goto-char (match-end 0))
2962             (looking-at "[ \t]*")
2963             (if (> (length leading-space) (length (match-string 0)))
2964                 (setq leading-space (match-string 0)))))
2965       (while (and (not (eobp))
2966                   (not (looking-at paragraph-separate))
2967                   (not (looking-at message-cite-prefix-regexp)))
2968         (forward-line 1))
2969       (setq end (point))
2970       (goto-char beg)
2971       (while (and (if (bobp) nil (forward-line -1) t)
2972                   (not (looking-at paragraph-start))
2973                   (not (looking-at message-cite-prefix-regexp)))
2974         (setq beg (point))))
2975     (goto-char point)
2976     (save-restriction
2977       (narrow-to-region beg end)
2978       (if not-break
2979           (setq point nil)
2980         (if bolp
2981             (newline)
2982           (newline)
2983           (newline))
2984         (setq point (point))
2985         ;; (newline 2) doesn't mark both newline's as hard, so call
2986         ;; newline twice. -jas
2987         (newline)
2988         (newline)
2989         (delete-region (point) (re-search-forward "[ \t]*"))
2990         (when (and quoted (not bolp))
2991           (insert quoted leading-space)))
2992       (undo-boundary)
2993       (if quoted
2994           (let* ((adaptive-fill-regexp
2995                   (regexp-quote (concat quoted leading-space)))
2996                  (adaptive-fill-first-line-regexp
2997                   adaptive-fill-regexp ))
2998             (fill-paragraph arg))
2999         (fill-paragraph arg))
3000       (if point (goto-char point)))))
3001
3002 (defun message-fill-paragraph (&optional arg)
3003   "Like `fill-paragraph'."
3004   (interactive (list (if current-prefix-arg 'full)))
3005   (if (if (boundp 'filladapt-mode) filladapt-mode)
3006       nil
3007     (message-newline-and-reformat arg t)
3008     t))
3009
3010 ;; Is it better to use `mail-header-end'?
3011 (defun message-point-in-header-p ()
3012   "Return t if point is in the header."
3013   (save-excursion
3014     (let ((p (point)))
3015       (goto-char (point-min))
3016       (not (re-search-forward
3017             (concat "^" (regexp-quote mail-header-separator) "\n")
3018             p t)))))
3019
3020 (defun message-do-auto-fill ()
3021   "Like `do-auto-fill', but don't fill in message header."
3022   (unless (message-point-in-header-p)
3023     (do-auto-fill)))
3024
3025 (defun message-insert-signature (&optional force)
3026   "Insert a signature.  See documentation for variable `message-signature'."
3027   (interactive (list 0))
3028   (let* ((signature
3029           (cond
3030            ((and (null message-signature)
3031                  (eq force 0))
3032             (save-excursion
3033               (goto-char (point-max))
3034               (not (re-search-backward message-signature-separator nil t))))
3035            ((and (null message-signature)
3036                  force)
3037             t)
3038            ((functionp message-signature)
3039             (funcall message-signature))
3040            ((listp message-signature)
3041             (eval message-signature))
3042            (t message-signature)))
3043          (signature
3044           (cond ((stringp signature)
3045                  signature)
3046                 ((and (eq t signature)
3047                       message-signature-file
3048                       (file-exists-p message-signature-file))
3049                  signature))))
3050     (when signature
3051       (goto-char (point-max))
3052       ;; Insert the signature.
3053       (unless (bolp)
3054         (insert "\n"))
3055       (when message-signature-insert-empty-line
3056         (insert "\n"))
3057       (insert "\n" message-signature-separator-for-insertion)
3058       (unless (bolp)
3059         (insert "\n"))
3060       (if (eq signature t)
3061           (insert-file-contents message-signature-file)
3062         (insert signature))
3063       (goto-char (point-max))
3064       (or (bolp) (insert "\n")))))
3065
3066 (defun message-insert-importance-high ()
3067   "Insert header to mark message as important."
3068   (interactive)
3069   (save-excursion
3070     (save-restriction
3071       (message-narrow-to-headers)
3072       (message-remove-header "Importance"))
3073     (message-goto-eoh)
3074     (insert "Importance: high\n")))
3075
3076 (defun message-insert-importance-low ()
3077   "Insert header to mark message as unimportant."
3078   (interactive)
3079   (save-excursion
3080     (save-restriction
3081       (message-narrow-to-headers)
3082       (message-remove-header "Importance"))
3083     (message-goto-eoh)
3084     (insert "Importance: low\n")))
3085
3086 (defun message-insert-or-toggle-importance ()
3087   "Insert a \"Importance: high\" header, or cycle through the header values.
3088 The three allowed values according to RFC 1327 are `high', `normal'
3089 and `low'."
3090   (interactive)
3091   (save-excursion
3092     (let ((valid '("high" "normal" "low"))
3093           (new "high")
3094           cur)
3095       (save-restriction
3096         (message-narrow-to-headers)
3097         (when (setq cur (message-fetch-field "Importance"))
3098           (message-remove-header "Importance")
3099           (setq new (cond ((string= cur "high")
3100                            "low")
3101                           ((string= cur "low")
3102                            "normal")
3103                           (t
3104                            "high")))))
3105       (message-goto-eoh)
3106       (insert (format "Importance: %s\n" new)))))
3107
3108 (defun message-insert-disposition-notification-to ()
3109   "Request a disposition notification (return receipt) to this message.
3110 Note that this should not be used in newsgroups."
3111   (interactive)
3112   (save-excursion
3113     (save-restriction
3114       (message-narrow-to-headers)
3115       (message-remove-header "Disposition-Notification-To"))
3116     (message-goto-eoh)
3117     (insert (format "Disposition-Notification-To: %s\n"
3118                     (or (save-excursion
3119                           (save-restriction
3120                             (message-narrow-to-headers)
3121                             (message-fetch-field "From")))
3122                         (message-make-from))))))
3123
3124 (defun message-elide-region (b e)
3125   "Elide the text in the region.
3126 An ellipsis (from `message-elide-ellipsis') will be inserted where the
3127 text was killed."
3128   (interactive "r")
3129   (kill-region b e)
3130   (insert message-elide-ellipsis))
3131
3132 (defvar message-caesar-translation-table nil)
3133
3134 (defun message-caesar-region (b e &optional n)
3135   "Caesar rotate region B to E by N, default 13, for decrypting netnews."
3136   (interactive
3137    (list
3138     (min (point) (or (mark t) (point)))
3139     (max (point) (or (mark t) (point)))
3140     (when current-prefix-arg
3141       (prefix-numeric-value current-prefix-arg))))
3142
3143   (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
3144   (unless (or (zerop n)                 ; no action needed for a rot of 0
3145               (= b e))                  ; no region to rotate
3146     ;; We build the table, if necessary.
3147     (when (or (not message-caesar-translation-table)
3148               (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
3149       (setq message-caesar-translation-table
3150             (message-make-caesar-translation-table n)))
3151     (translate-region b e message-caesar-translation-table)))
3152
3153 (defun message-make-caesar-translation-table (n)
3154   "Create a rot table with offset N."
3155   (let ((i -1)
3156         (table (make-string 256 0)))
3157     (while (< (incf i) 256)
3158       (aset table i i))
3159     (concat
3160      (substring table 0 ?A)
3161      (substring table (+ ?A n) (+ ?A n (- 26 n)))
3162      (substring table ?A (+ ?A n))
3163      (substring table (+ ?A 26) ?a)
3164      (substring table (+ ?a n) (+ ?a n (- 26 n)))
3165      (substring table ?a (+ ?a n))
3166      (substring table (+ ?a 26) 255))))
3167
3168 (defun message-caesar-buffer-body (&optional rotnum)
3169   "Caesar rotate all letters in the current buffer by 13 places.
3170 Used to encode/decode possibly offensive messages (commonly in rec.humor).
3171 With prefix arg, specifies the number of places to rotate each letter forward.
3172 Mail and USENET news headers are not rotated."
3173   (interactive (if current-prefix-arg
3174                    (list (prefix-numeric-value current-prefix-arg))
3175                  (list nil)))
3176   (save-excursion
3177     (save-restriction
3178       (when (message-goto-body)
3179         (narrow-to-region (point) (point-max)))
3180       (message-caesar-region (point-min) (point-max) rotnum))))
3181
3182 (defun message-pipe-buffer-body (program)
3183   "Pipe the message body in the current buffer through PROGRAM."
3184   (save-excursion
3185     (save-restriction
3186       (when (message-goto-body)
3187         (narrow-to-region (point) (point-max)))
3188       (shell-command-on-region
3189        (point-min) (point-max) program nil t))))
3190
3191 (defun message-rename-buffer (&optional enter-string)
3192   "Rename the *message* buffer to \"*message* RECIPIENT\".
3193 If the function is run with a prefix, it will ask for a new buffer
3194 name, rather than giving an automatic name."
3195   (interactive "Pbuffer name: ")
3196   (save-excursion
3197     (save-restriction
3198       (goto-char (point-min))
3199       (narrow-to-region (point)
3200                         (search-forward mail-header-separator nil 'end))
3201       (let* ((mail-to (or
3202                        (if (message-news-p) (message-fetch-field "Newsgroups")
3203                          (message-fetch-field "To"))
3204                        ""))
3205              (mail-trimmed-to
3206               (if (string-match "," mail-to)
3207                   (concat (substring mail-to 0 (match-beginning 0)) ", ...")
3208                 mail-to))
3209              (name-default (concat "*message* " mail-trimmed-to))
3210              (name (if enter-string
3211                        (read-string "New buffer name: " name-default)
3212                      name-default)))
3213         (rename-buffer name t)))))
3214
3215 (defun message-fill-yanked-message (&optional justifyp)
3216   "Fill the paragraphs of a message yanked into this one.
3217 Numeric argument means justify as well."
3218   (interactive "P")
3219   (save-excursion
3220     (goto-char (point-min))
3221     (search-forward (concat "\n" mail-header-separator "\n") nil t)
3222     (let ((fill-prefix message-yank-prefix))
3223       (fill-individual-paragraphs (point) (point-max) justifyp))))
3224
3225 (defun message-indent-citation ()
3226   "Modify text just inserted from a message to be cited.
3227 The inserted text should be the region.
3228 When this function returns, the region is again around the modified text.
3229
3230 Normally, indent each nonblank line `message-indentation-spaces' spaces.
3231 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
3232   (let ((start (point)))
3233     ;; Remove unwanted headers.
3234     (when message-ignored-cited-headers
3235       (let (all-removed)
3236         (save-restriction
3237           (narrow-to-region
3238            (goto-char start)
3239            (if (search-forward "\n\n" nil t)
3240                (1- (point))
3241              (point)))
3242           (message-remove-header message-ignored-cited-headers t)
3243           (when (= (point-min) (point-max))
3244             (setq all-removed t))
3245           (goto-char (point-max)))
3246         (if all-removed
3247             (goto-char start)
3248           (forward-line 1))))
3249     ;; Delete blank lines at the start of the buffer.
3250     (while (and (point-min)
3251                 (eolp)
3252                 (not (eobp)))
3253       (message-delete-line))
3254     ;; Delete blank lines at the end of the buffer.
3255     (goto-char (point-max))
3256     (unless (bolp)
3257       (insert "\n"))
3258     (while (and (zerop (forward-line -1))
3259                 (looking-at "$"))
3260       (message-delete-line))
3261     ;; Do the indentation.
3262     (if (null message-yank-prefix)
3263         (indent-rigidly start (mark t) message-indentation-spaces)
3264       (save-excursion
3265         (goto-char start)
3266         (while (< (point) (mark t))
3267           (if (or (looking-at ">") (looking-at "^$"))
3268               (insert message-yank-cited-prefix)
3269             (insert message-yank-prefix))
3270           (forward-line 1))))
3271     (goto-char start)))
3272
3273 (defun message-list-references (refs-list &rest refs-strs)
3274   "Add `Message-ID's which appear in REFS-STRS but not in REFS-LIST,
3275 to REFS-LIST."
3276   (let (refs ref id saved-id)
3277     (when (and refs-list
3278                (integerp message-list-references-add-position))
3279       (let ((pos message-list-references-add-position))
3280         (while (and refs-list
3281                     (> pos 0))
3282           (push (pop refs-list) saved-id)
3283           (setq pos (1- pos)))))
3284     (while refs-strs
3285       (when (setq refs (pop refs-strs))
3286         (setq refs (std11-parse-msg-ids (std11-lexical-analyze refs)))
3287         (while refs
3288           (when (eq (car (setq ref (pop refs))) 'msg-id)
3289             (setq id (concat "<" (mapconcat 'cdr (cdr ref) "") ">"))
3290             (or (member id refs-list)
3291                 (member id saved-id)
3292                 (push id refs-list))))))
3293     (while saved-id
3294       (push (pop saved-id) refs-list))
3295     refs-list))
3296
3297 (defun message-yank-original (&optional arg)
3298   "Insert the message being replied to, if any.
3299 Puts point before the text and mark after.
3300 Normally indents each nonblank line ARG spaces (default 3).  However,
3301 if `message-yank-prefix' is non-nil, insert that prefix on each line.
3302
3303 This function uses `message-cite-function' to do the actual citing.
3304
3305 Just \\[universal-argument] as argument means don't indent, insert no
3306 prefix, and don't delete any headers.
3307
3308 In addition, if `message-yank-add-new-references' is non-nil and this
3309 command is called interactively, new IDs from the yanked article will
3310 be added to the \"References\" field."
3311   (interactive "P")
3312   (let ((modified (buffer-modified-p)))
3313     (when (let ((buffer (message-eval-parameter message-reply-buffer)))
3314             (and buffer
3315                  message-cite-function
3316                  (prog1
3317                      t
3318                    (delete-windows-on buffer t)
3319                    ; The mark will be set at the end of the article.
3320                    (insert-buffer buffer))))
3321       ;; Add new IDs to the References field.
3322       (when (and message-yank-add-new-references
3323                  (interactive-p))
3324         (let ((start (point))
3325               (end (mark t))
3326               refs newrefs)
3327           (save-excursion
3328             (save-restriction
3329               (widen)
3330               (setq refs (message-list-references
3331                           nil
3332                           (or (message-make-references)
3333                               (prog2
3334                                   (message-narrow-to-headers)
3335                                   (message-fetch-field "References")
3336                                 (widen)))))
3337               (narrow-to-region start end)
3338               (std11-narrow-to-header)
3339               (unless (equal (setq newrefs
3340                                    (message-list-references
3341                                     (copy-sequence refs)
3342                                     (unless (eq message-yank-add-new-references
3343                                                 'message-id-only)
3344                                       (or (message-fetch-field "References")
3345                                           (message-fetch-field "In-Reply-To")))
3346                                     (message-fetch-field "Message-ID")))
3347                              refs)
3348                 ;; If the References field has been changed, we make it
3349                 ;; visible in the header.
3350                 (when message-reply-headers
3351                   (mail-header-set-message-id message-reply-headers nil)
3352                   (mail-header-set-references message-reply-headers nil))
3353                 (widen)
3354                 (message-narrow-to-headers)
3355                 (if (let ((case-fold-search t))
3356                       (re-search-forward "^References:\\([\t ]+.+\n\\)+"
3357                                          nil t))
3358                     (replace-match "")
3359                   (goto-char (point-max)))
3360                 (mail-header-format
3361                  (list (or (assq 'References message-header-format-alist)
3362                            '(References . message-fill-references)))
3363                  (list (cons 'References (mapconcat 'identity
3364                                                     (nreverse newrefs) " "))))
3365                 (backward-delete-char 1))))))
3366       (unless arg
3367         (if (and message-suspend-font-lock-when-citing
3368                  (boundp 'font-lock-mode)
3369                  (symbol-value 'font-lock-mode))
3370             (unwind-protect
3371                 (progn
3372                   (sit-for 0)
3373                   (font-lock-mode 0)
3374                   (funcall message-cite-function))
3375               (font-lock-mode 1))
3376           (funcall message-cite-function)))
3377       (message-exchange-point-and-mark)
3378       (unless (bolp)
3379         (insert ?\n))
3380       (unless modified
3381         (setq message-checksum (message-checksum))))))
3382
3383 (defun message-yank-buffer (buffer)
3384   "Insert BUFFER into the current buffer and quote it."
3385   (interactive "bYank buffer: ")
3386   (let ((message-reply-buffer buffer))
3387     (save-window-excursion
3388       (message-yank-original))))
3389
3390 (defun message-buffers ()
3391   "Return a list of active message buffers."
3392   (let (buffers)
3393     (save-excursion
3394       (dolist (buffer (buffer-list t))
3395         (set-buffer buffer)
3396         (when (and (eq major-mode 'message-mode)
3397                    (null message-sent-message-via))
3398           (push (buffer-name buffer) buffers))))
3399     (nreverse buffers)))
3400
3401 (defun message-cite-original-without-signature ()
3402   "Cite function in the standard Message manner."
3403   (let ((start (point))
3404         (end (mark t))
3405         (functions
3406          (when message-indent-citation-function
3407            (if (listp message-indent-citation-function)
3408                message-indent-citation-function
3409              (list message-indent-citation-function))))
3410         (message-reply-headers (or message-reply-headers
3411                                    (make-mail-header))))
3412     (mail-header-set-from message-reply-headers
3413                           (save-restriction
3414                             (narrow-to-region
3415                              (point)
3416                              (if (search-forward "\n\n" nil t)
3417                                  (1- (point))
3418                                (point-max)))
3419                             (or (message-fetch-field "from")
3420                                 "unknown sender")))
3421     ;; Allow undoing.
3422     (undo-boundary)
3423     (goto-char end)
3424     (when (re-search-backward message-signature-separator start t)
3425       ;; Also peel off any blank lines before the signature.
3426       (forward-line -1)
3427       (while (looking-at "^[ \t]*$")
3428         (forward-line -1))
3429       (forward-line 1)
3430       (delete-region (point) end)
3431       (unless (search-backward "\n\n" start t)
3432         ;; Insert a blank line if it is peeled off.
3433         (insert "\n")))
3434     (goto-char start)
3435     (while functions
3436       (funcall (pop functions)))
3437     (when message-citation-line-function
3438       (unless (bolp)
3439         (insert "\n"))
3440       (funcall message-citation-line-function))))
3441
3442 (eval-when-compile (defvar mail-citation-hook))         ;Compiler directive
3443 (defun message-cite-original ()
3444   "Cite function in the standard Message manner."
3445   (if (and (boundp 'mail-citation-hook)
3446            mail-citation-hook)
3447       (run-hooks 'mail-citation-hook)
3448     (let ((start (point))
3449           (end (mark t))
3450           (functions
3451            (when message-indent-citation-function
3452              (if (listp message-indent-citation-function)
3453                  message-indent-citation-function
3454                (list message-indent-citation-function))))
3455           (message-reply-headers (or message-reply-headers
3456                                      (make-mail-header))))
3457       (mail-header-set-from message-reply-headers
3458                             (save-restriction
3459                               (narrow-to-region
3460                                (point)
3461                                (if (search-forward "\n\n" nil t)
3462                                    (1- (point))
3463                                  (point-max)))
3464                               (or (message-fetch-field "from")
3465                                   "unknown sender")))
3466       (goto-char start)
3467       (while functions
3468         (funcall (pop functions)))
3469       (when message-citation-line-function
3470         (unless (bolp)
3471           (insert "\n"))
3472         (funcall message-citation-line-function)))))
3473
3474 (defun message-insert-citation-line ()
3475   "Insert a simple citation line."
3476   (when message-reply-headers
3477     (insert (mail-header-from message-reply-headers) " writes:\n\n")))
3478
3479 (defun message-position-on-field (header &rest afters)
3480   (let ((case-fold-search t))
3481     (save-restriction
3482       (narrow-to-region
3483        (goto-char (point-min))
3484        (progn
3485          (re-search-forward
3486           (concat "^" (regexp-quote mail-header-separator) "$"))
3487          (match-beginning 0)))
3488       (goto-char (point-min))
3489       (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
3490           (progn
3491             (re-search-forward "^[^ \t]" nil 'move)
3492             (beginning-of-line)
3493             (skip-chars-backward "\n")
3494             t)
3495         (while (and afters
3496                     (not (re-search-forward
3497                           (concat "^" (regexp-quote (car afters)) ":")
3498                           nil t)))
3499           (pop afters))
3500         (when afters
3501           (re-search-forward "^[^ \t]" nil 'move)
3502           (beginning-of-line))
3503         (insert header ": \n")
3504         (forward-char -1)
3505         nil))))
3506
3507 (defun message-remove-signature ()
3508   "Remove the signature from the text between point and mark.
3509 The text will also be indented the normal way."
3510   (save-excursion
3511     (let ((start (point))
3512           mark)
3513       (if (not (re-search-forward message-signature-separator (mark t) t))
3514           ;; No signature here, so we just indent the cited text.
3515           (message-indent-citation)
3516         ;; Find the last non-empty line.
3517         (forward-line -1)
3518         (while (looking-at "[ \t]*$")
3519           (forward-line -1))
3520         (forward-line 1)
3521         (setq mark (set-marker (make-marker) (point)))
3522         (goto-char start)
3523         (message-indent-citation)
3524         ;; Enable undoing the deletion.
3525         (undo-boundary)
3526         (delete-region mark (mark t))
3527         (set-marker mark nil)))))
3528
3529 \f
3530
3531 ;;;
3532 ;;; Sending messages
3533 ;;;
3534
3535 ;; Avoid byte-compile warning.
3536 (defvar message-encoding-buffer nil)
3537 (defvar message-edit-buffer nil)
3538 (defvar message-mime-mode nil)
3539
3540 (defun message-send-and-exit (&optional arg)
3541   "Send message like `message-send', then, if no errors, exit from mail buffer."
3542   (interactive "P")
3543   (let ((buf (current-buffer))
3544         (actions message-exit-actions)
3545         (frame (selected-frame))
3546         (org-frame message-original-frame))
3547     (when (and (message-send arg)
3548                (buffer-name buf))
3549       (if message-kill-buffer-on-exit
3550           (kill-buffer buf)
3551         (bury-buffer buf)
3552         (when (eq buf (current-buffer))
3553           (message-bury buf)))
3554       (message-do-actions actions)
3555       (message-delete-frame frame org-frame)
3556       t)))
3557
3558 (defun message-dont-send ()
3559   "Don't send the message you have been editing.
3560 Instead, just auto-save the buffer and then bury it."
3561   (interactive)
3562   (set-buffer-modified-p t)
3563   (save-buffer)
3564   (let ((actions message-postpone-actions)
3565         (frame (selected-frame))
3566         (org-frame message-original-frame))
3567     (message-bury (current-buffer))
3568     (message-do-actions actions)
3569     (message-delete-frame frame org-frame)))
3570
3571 (defun message-kill-buffer ()
3572   "Kill the current buffer."
3573   (interactive)
3574   (when (or (not (buffer-modified-p))
3575             (eq t message-kill-buffer-query-function)
3576             (funcall message-kill-buffer-query-function
3577                      "The buffer modified; kill anyway? "))
3578     (let ((actions message-kill-actions)
3579           (draft-article message-draft-article)
3580           (auto-save-file-name buffer-auto-save-file-name)
3581           (file-name buffer-file-name)
3582           (modified (buffer-modified-p))
3583           (frame (selected-frame))
3584           (org-frame message-original-frame))
3585       (setq buffer-file-name nil)
3586       (kill-buffer (current-buffer))
3587       (when (and message-kill-buffer-and-remove-file
3588                  (or (and auto-save-file-name
3589                           (file-exists-p auto-save-file-name))
3590                      (and file-name
3591                           (file-exists-p file-name)))
3592                  (yes-or-no-p (format "Remove the backup file%s? "
3593                                       (if modified " too" ""))))
3594         (ignore-errors
3595           (delete-file auto-save-file-name))
3596         (let ((message-draft-article draft-article))
3597           (message-disassociate-draft)))
3598       (message-do-actions actions)
3599       (message-delete-frame frame org-frame)))
3600   (message ""))
3601
3602 (defun message-mimic-kill-buffer ()
3603   "Kill the current buffer with query.  This is an imitation for
3604 `kill-buffer', but it will delete a message frame."
3605   (interactive)
3606   (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
3607                                       (buffer-name))))
3608         message-kill-buffer-and-remove-file)
3609     (when (or (not bufname)
3610               (string-equal bufname "")
3611               (string-equal bufname (buffer-name)))
3612       (message-kill-buffer))))
3613
3614 (defun message-delete-frame (frame org-frame)
3615   "Delete frame for editing message."
3616   (when (and (or (static-if (featurep 'xemacs)
3617                      (device-on-window-system-p)
3618                    window-system)
3619                  (>= emacs-major-version 20))
3620              (or (and (eq message-delete-frame-on-exit t)
3621                       (select-frame frame)
3622                       (or (eq frame org-frame)
3623                           (prog1
3624                               (y-or-n-p "Delete this frame?")
3625                             (message ""))))
3626                  (and (eq message-delete-frame-on-exit 'ask)
3627                       (select-frame frame)
3628                       (prog1
3629                           (y-or-n-p "Delete this frame?")
3630                         (message "")))))
3631     (delete-frame frame)))
3632
3633 (defun message-bury (buffer)
3634   "Bury this mail BUFFER."
3635   (let ((newbuf (other-buffer buffer)))
3636     (bury-buffer buffer)
3637     (if (and (fboundp 'frame-parameters)
3638              (cdr (assq 'dedicated (frame-parameters)))
3639              (not (null (delq (selected-frame) (visible-frame-list)))))
3640         (delete-frame (selected-frame))
3641       (switch-to-buffer newbuf))))
3642
3643 (defun message-send (&optional arg)
3644   "Send the message in the current buffer.
3645 If `message-interactive' is non-nil, wait for success indication or
3646 error messages, and inform user.
3647 Otherwise any failure is reported in a message back to the user from
3648 the mailer.
3649 The usage of ARG is defined by the instance that called Message.
3650 It should typically alter the sending method in some way or other."
3651   (interactive "P")
3652   ;; Disabled test.
3653   (when (or (buffer-modified-p)
3654             (message-check-element 'unchanged)
3655             (y-or-n-p "No changes in the buffer; really send? "))
3656     ;; Make it possible to undo the coming changes.
3657     (undo-boundary)
3658     (let ((inhibit-read-only t))
3659       (put-text-property (point-min) (point-max) 'read-only nil))
3660     (run-hooks 'message-send-hook)
3661     (message-fix-before-sending)
3662     (message message-sending-message)
3663     (let ((message-encoding-buffer
3664            (message-generate-new-buffer-clone-locals " message encoding"))
3665           (message-edit-buffer (current-buffer))
3666           (message-mime-mode mime-edit-mode-flag)
3667           (alist message-send-method-alist)
3668           (success t)
3669           elem sent dont-barf-on-no-method
3670           (message-options message-options))
3671       (unwind-protect
3672           (progn
3673             (message-options-set-recipient)
3674             (save-excursion
3675               (set-buffer message-encoding-buffer)
3676               (erase-buffer)
3677               ;; ;; Avoid copying text props (except hard newlines).
3678               ;; T-gnus change: copy all text props from the editing buffer
3679               ;; into the encoding buffer.
3680               (insert-buffer-substring message-edit-buffer)
3681               (funcall message-encode-function)
3682               (while (and success
3683                           (setq elem (pop alist)))
3684                 (when (funcall (cadr elem))
3685                   (when (and
3686                          (or (not (memq (car elem)
3687                                         message-sent-message-via))
3688                              (not (message-fetch-field "supersedes"))
3689                              (if (or (message-gnksa-enable-p 'multiple-copies)
3690                                      (not (eq (car elem) 'news)))
3691                                  (y-or-n-p
3692                                   (format
3693                                    "Already sent message via %s; resend? "
3694                                    (car elem)))
3695                                (error "Denied posting -- multiple copies")))
3696                          (setq success (funcall (caddr elem) arg)))
3697                     (setq sent t)))))
3698             (unless
3699                 (or
3700                  sent
3701                  (not success)
3702                  (let ((fcc (message-fetch-field "Fcc"))
3703                        (gcc (message-fetch-field "Gcc")))
3704                    (when (or fcc gcc)
3705                      (or
3706                       (eq message-allow-no-recipients 'always)
3707                       (and (not (eq message-allow-no-recipients 'never))
3708                            (setq dont-barf-on-no-method
3709                                  (gnus-y-or-n-p
3710                                   (format "No receiver, perform %s anyway? "
3711                                           (cond ((and fcc gcc) "Fcc and Gcc")
3712                                                 (fcc "Fcc")
3713                                                 (t "Gcc"))))))))))
3714               (error "No methods specified to send by"))
3715             (when (or dont-barf-on-no-method
3716                       (and success sent))
3717               (message-do-fcc)
3718               (save-excursion
3719                 (run-hooks 'message-sent-hook))
3720               (message "Sending...done")
3721               ;; Mark the buffer as unmodified and delete auto-save.
3722               (set-buffer-modified-p nil)
3723               (delete-auto-save-file-if-necessary t)
3724               (message-disassociate-draft)
3725               ;; Delete other mail buffers and stuff.
3726               (message-do-send-housekeeping)
3727               (message-do-actions message-send-actions)
3728               ;; Return success.
3729               t))
3730         (kill-buffer message-encoding-buffer)))))
3731
3732 (defun message-send-via-mail (arg)
3733   "Send the current message via mail."
3734   (message-send-mail arg))
3735
3736 (defun message-send-via-news (arg)
3737   "Send the current message via news."
3738   (message-send-news arg))
3739
3740 (defmacro message-check (type &rest forms)
3741   "Eval FORMS if TYPE is to be checked."
3742   `(or (message-check-element ,type)
3743        (save-excursion
3744          ,@forms)))
3745
3746 (put 'message-check 'lisp-indent-function 1)
3747 (put 'message-check 'edebug-form-spec '(form body))
3748
3749 ;; Advise the function `invisible-region'.
3750 (let (current-load-list)
3751   (eval
3752    `(defadvice invisible-region (around add-mime-edit-invisible (start end)
3753                                         activate)
3754       "Advised by T-gnus Message.
3755 Add the text property `mime-edit-invisible' to an invisible text when
3756 the buffer's major mode is `message-mode'.  The added property will be
3757 used to distinguish whether the invisible text is a MIME part or not."
3758       ,(if (featurep 'xemacs)
3759            '(if (eq ?\n (char-after start))
3760                 (setq start (1+ start)))
3761          '(if (eq ?\n (char-after (1- end)))
3762               (setq end (1- end))))
3763       (setq ad-return-value
3764             (if (eq 'message-mode major-mode)
3765                 (add-text-properties start end
3766                                      '(invisible t mime-edit-invisible t))
3767               (put-text-property start end 'invisible t))))))
3768
3769 (defun message-text-with-property (prop)
3770   "Return a list of all points where the text has PROP."
3771   (let ((points nil)
3772         (point (point-min)))
3773     (save-excursion
3774       (while (< point (point-max))
3775         (when (get-text-property point prop)
3776           (push point points))
3777         (incf point)))
3778     (nreverse points)))
3779
3780 (defun message-fix-before-sending ()
3781   "Do various things to make the message nice before sending it."
3782   ;; Make sure there's a newline at the end of the message.
3783   (widen)
3784   (goto-char (point-max))
3785   (unless (bolp)
3786     (insert "\n"))
3787   ;; Make the hidden headers visible.
3788   (let ((points (message-text-with-property 'message-hidden)))
3789     (when points
3790       (goto-char (car points))
3791       (dolist (point points)
3792         (add-text-properties point (1+ point)
3793                              '(invisible nil intangible nil)))))
3794   ;; Make invisible text visible except for mime parts which may be
3795   ;; inserted by the MIME-Edit.
3796   ;; It doesn't seem as if this is useful, since the invisible property
3797   ;; is clobbered by an after-change hook anyhow.
3798   (message-check 'invisible-text
3799     ;; FIXME T-gnus: It should also detect invisible overlays.
3800     (let (from
3801           (to (point-min))
3802           mime-from mime-to hidden-start)
3803       (while (setq from (text-property-any to (point-max) 'invisible t))
3804         (setq to (or (text-property-not-all from (point-max) 'invisible t)
3805                      (point-max))
3806               mime-to from)
3807         (while (setq mime-from (text-property-any mime-to to
3808                                                   'mime-edit-invisible t))
3809           (when (> mime-from mime-to)
3810             (setq hidden-start (or hidden-start mime-to))
3811             (add-text-properties mime-to mime-from
3812                                  '(invisible nil face highlight
3813                                              font-lock-face highlight)))
3814           (setq mime-to (or (text-property-not-all mime-from to
3815                                                    'mime-edit-invisible t)
3816                             to)))
3817         (when (< mime-to to)
3818           (setq hidden-start (or hidden-start mime-to))
3819           (add-text-properties mime-to to
3820                                '(invisible nil face highlight
3821                                            font-lock-face highlight))))
3822       (when hidden-start
3823         (goto-char hidden-start)
3824         (set-window-start (selected-window) (gnus-point-at-bol))
3825         (unless (yes-or-no-p
3826                  "Invisible text found and made visible; continue sending? ")
3827           (error "Invisible text found and made visible")))))
3828 ;; The following check is needless to T-gnus since T-gnus determines
3829 ;; a MIME charset forcibly (even if it cannot be determined properly,
3830 ;; the value of the `default-mime-charset-for-write' variable is used).
3831 ;;  (message-check 'illegible-text
3832 ;;    (let ((mm-7bit-chars "\x20-\x7f\r\n\t\x7\x8\xb\xc\x1f\x1b")
3833 ;;        found choice)
3834 ;;      (message-goto-body)
3835 ;;      (skip-chars-forward mm-7bit-chars)
3836 ;;      (while (not (eobp))
3837 ;;      (when (let ((char (char-after)))
3838 ;;              (or (< (mm-char-int char) 128)
3839 ;;                  (and (mm-multibyte-p)
3840 ;;                       (> (length (mm-find-mime-charset-region
3841 ;;                                   (point) (point-max)))
3842 ;;                          1))))
3843 ;;        (message-overlay-put (message-make-overlay (point) (1+ (point)))
3844 ;;                             'face 'highlight)
3845 ;;        (setq found t))
3846 ;;      (forward-char)
3847 ;;      (skip-chars-forward mm-7bit-chars))
3848 ;;      (when found
3849 ;;      (setq choice
3850 ;;            (gnus-multiple-choice
3851 ;;             "Non-printable characters found.  Continue sending?"
3852 ;;             '((?d "Remove non-printable characters and send")
3853 ;;               (?r "Replace non-printable characters with dots and send")
3854 ;;               (?i "Ignore non-printable characters and send")
3855 ;;               (?e "Continue editing"))))
3856 ;;      (if (eq choice ?e)
3857 ;;        (error "Non-printable characters"))
3858 ;;      (message-goto-body)
3859 ;;      (skip-chars-forward mm-7bit-chars)
3860 ;;      (while (not (eobp))
3861 ;;        (when (let ((char (char-after)))
3862 ;;                (or (< (mm-char-int char) 128)
3863 ;;                    (and (mm-multibyte-p)
3864 ;;                         ;; Fixme: Wrong for Emacs 22 and for things
3865 ;;                         ;; like undecable utf-8.  Should at least
3866 ;;                         ;; use find-coding-systems-region.
3867 ;;                         (memq (char-charset char)
3868 ;;                               '(eight-bit-control eight-bit-graphic
3869 ;;                                                   control-1)))))
3870 ;;          (if (eq choice ?i)
3871 ;;              (message-kill-all-overlays)
3872 ;;            (delete-char 1)
3873 ;;            (when (eq choice ?r)
3874 ;;              (insert "."))))
3875 ;;        (forward-char)
3876 ;;        (skip-chars-forward mm-7bit-chars)))))
3877   )
3878
3879 (defun message-add-action (action &rest types)
3880   "Add ACTION to be performed when doing an exit of type TYPES."
3881   (while types
3882     (add-to-list (intern (format "message-%s-actions" (pop types)))
3883                  action)))
3884
3885 (defun message-delete-action (action &rest types)
3886   "Delete ACTION from lists of actions performed when doing an exit of type TYPES."
3887   (let (var)
3888     (while types
3889       (set (setq var (intern (format "message-%s-actions" (pop types))))
3890            (delq action (symbol-value var))))))
3891
3892 (defun message-do-actions (actions)
3893   "Perform all actions in ACTIONS."
3894   ;; Now perform actions on successful sending.
3895   (while actions
3896     (ignore-errors
3897       (cond
3898        ;; A simple function.
3899        ((functionp (car actions))
3900         (funcall (car actions)))
3901        ;; Something to be evaled.
3902        (t
3903         (eval (car actions)))))
3904     (pop actions)))
3905
3906 (defsubst message-maybe-split-and-send-mail ()
3907   "Split a message if necessary, and send it via mail.
3908 Returns nil if sending succeeded, returns any string if sending failed.
3909 This sub function is for exclusive use of `message-send-mail'."
3910   (let ((mime-edit-split-ignored-field-regexp
3911          mime-edit-split-ignored-field-regexp)
3912         (case-fold-search t)
3913         failure)
3914     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
3915       (setq mime-edit-split-ignored-field-regexp
3916             (concat (substring mime-edit-split-ignored-field-regexp
3917                                0 (match-beginning 0))
3918                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
3919                     "_so_don't_rape_it!"
3920                     (substring mime-edit-split-ignored-field-regexp
3921                                (match-end 0)))))
3922     (setq failure
3923           (or
3924            (catch 'message-sending-mail-failure
3925              (mime-edit-maybe-split-and-send
3926               (function
3927                (lambda ()
3928                  (interactive)
3929                  (save-restriction
3930                    (std11-narrow-to-header mail-header-separator)
3931                    (goto-char (point-min))
3932                    (when (re-search-forward "^Message-ID:" nil t)
3933                      (delete-region (match-end 0) (std11-field-end))
3934                      (insert " " (message-make-message-id))))
3935                  (condition-case err
3936                      (funcall (or message-send-mail-real-function
3937                                   message-send-mail-function))
3938                    (error
3939                     (throw 'message-sending-mail-failure err))))))
3940              nil)
3941            (condition-case err
3942                (progn
3943                  (funcall (or message-send-mail-real-function
3944                               message-send-mail-function))
3945                  nil)
3946              (error err))))
3947     (when failure
3948       (if (eq 'error (car failure))
3949           (cadr failure)
3950         (prin1-to-string failure)))))
3951
3952 (defun message-send-mail-partially ()
3953   "Send mail as message/partial."
3954   ;; replace the header delimiter with a blank line
3955   (goto-char (point-min))
3956   (re-search-forward
3957    (concat "^" (regexp-quote mail-header-separator) "\n"))
3958   (replace-match "\n")
3959   (run-hooks 'message-send-mail-hook)
3960   (let ((p (goto-char (point-min)))
3961         (tembuf (message-generate-new-buffer-clone-locals " message temp"))
3962         (curbuf (current-buffer))
3963         (id (message-make-message-id)) (n 1)
3964         plist total  header required-mail-headers)
3965     (while (not (eobp))
3966       (if (< (point-max) (+ p message-send-mail-partially-limit))
3967           (goto-char (point-max))
3968         (goto-char (+ p message-send-mail-partially-limit))
3969         (beginning-of-line)
3970         (if (<= (point) p) (forward-line 1))) ;; In case of bad message.
3971       (push p plist)
3972       (setq p (point)))
3973     (setq total (length plist))
3974     (push (point-max) plist)
3975     (setq plist (nreverse plist))
3976     (unwind-protect
3977         (save-excursion
3978           (setq p (pop plist))
3979           (while plist
3980             (set-buffer curbuf)
3981             (copy-to-buffer tembuf p (car plist))
3982             (set-buffer tembuf)
3983             (goto-char (point-min))
3984             (if header
3985                 (progn
3986                   (goto-char (point-min))
3987                   (narrow-to-region (point) (point))
3988                   (insert header))
3989               (message-goto-eoh)
3990               (setq header (buffer-substring (point-min) (point)))
3991               (goto-char (point-min))
3992               (narrow-to-region (point) (point))
3993               (insert header)
3994               (message-remove-header "Mime-Version")
3995               (message-remove-header "Content-Type")
3996               (message-remove-header "Content-Transfer-Encoding")
3997               (message-remove-header "Message-ID")
3998               (message-remove-header "Lines")
3999               (goto-char (point-max))
4000               (insert "Mime-Version: 1.0\n")
4001               (setq header (buffer-string)))
4002             (goto-char (point-max))
4003             (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
4004                             id n total))
4005             (forward-char -1)
4006             (let ((mail-header-separator ""))
4007               (when (memq 'Message-ID message-required-mail-headers)
4008                 (insert "Message-ID: " (message-make-message-id) "\n"))
4009               (when (memq 'Lines message-required-mail-headers)
4010                 (insert "Lines: " (message-make-lines) "\n"))
4011               (message-goto-subject)
4012               (end-of-line)
4013               (insert (format " (%d/%d)" n total))
4014               (widen)
4015               (mm-with-unibyte-current-buffer
4016                 (funcall (or message-send-mail-real-function
4017                              message-send-mail-function))))
4018             (setq n (+ n 1))
4019             (setq p (pop plist))
4020             (erase-buffer)))
4021       (kill-buffer tembuf))))
4022
4023 (defun message-send-mail (&optional arg)
4024   (require 'mail-utils)
4025   (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
4026          (case-fold-search nil)
4027          (news (message-news-p))
4028          (message-this-is-mail t)
4029          (headers message-required-mail-headers)
4030          failure)
4031     (save-restriction
4032       (message-narrow-to-headers)
4033       ;; Generate the Mail-Followup-To header if the header is not there...
4034       (if (and (message-subscribed-p)
4035                (not (mail-fetch-field "mail-followup-to")))
4036           (setq headers
4037                 (cons
4038                  (cons "Mail-Followup-To" (message-make-mail-followup-to))
4039                  message-required-mail-headers))
4040         ;; otherwise, delete the MFT header if the field is empty
4041         (when (equal "" (mail-fetch-field "mail-followup-to"))
4042           (message-remove-header "^Mail-Followup-To:")))
4043       ;; Insert some headers.
4044       (let ((message-deletable-headers
4045              (if news nil message-deletable-headers)))
4046         (message-generate-headers headers))
4047       ;; Let the user do all of the above.
4048       (run-hooks 'message-header-hook))
4049     (if (not (message-check-mail-syntax))
4050         (progn
4051           (message "")
4052           nil)
4053       (unwind-protect
4054           (save-excursion
4055             (set-buffer tembuf)
4056             (erase-buffer)
4057             ;; ;; Avoid copying text props (except hard newlines).
4058             ;; T-gnus change: copy all text props from the editing buffer
4059             ;; into the encoding buffer.
4060             (insert-buffer-substring message-encoding-buffer)
4061             ;; Remove some headers.
4062             (save-restriction
4063               (message-narrow-to-headers)
4064 ;; We Semi-gnus people have no use for it.
4065 ;;            ;; We (re)generate the Lines header.
4066 ;;            (when (memq 'Lines message-required-mail-headers)
4067 ;;              (message-generate-headers '(Lines)))
4068               (message-remove-header message-ignored-mail-headers t))
4069             (goto-char (point-max))
4070             ;; require one newline at the end.
4071             (or (= (preceding-char) ?\n)
4072                 (insert ?\n))
4073             (message-cleanup-headers)
4074             ;; FIXME: we're inserting the courtesy copy after encoding.
4075             ;; This is wrong if the courtesy copy string contains
4076             ;; non-ASCII characters. -- jh
4077             (when
4078                 (save-restriction
4079                   (message-narrow-to-headers)
4080                   (and news
4081                        (or (message-fetch-field "cc")
4082                            (message-fetch-field "bcc")
4083                            (message-fetch-field "to"))
4084                        (let ((content-type (mime-read-Content-Type)))
4085                          (and
4086                           (or
4087                            (not content-type)
4088                            (and
4089                             (eq 'text (cdr (assq 'type content-type)))
4090                             (eq 'plain (cdr (assq 'subtype content-type)))))
4091                           (not
4092                            (string= "base64"
4093                                     (mime-read-Content-Transfer-Encoding)))))))
4094               (message-insert-courtesy-copy))
4095             (setq failure (message-maybe-split-and-send-mail)))
4096         (kill-buffer tembuf))
4097       (set-buffer message-edit-buffer)
4098       (if failure
4099           (progn
4100             (message "Couldn't send message via mail: %s" failure)
4101             nil)
4102         (push 'mail message-sent-message-via)))))
4103
4104 (defun message-send-mail-with-sendmail ()
4105   "Send off the prepared buffer with sendmail."
4106   (let ((errbuf (if message-interactive
4107                     (message-generate-new-buffer-clone-locals
4108                      " sendmail errors")
4109                   0))
4110         resend-to-addresses delimline)
4111     (unwind-protect
4112         (progn
4113           (let ((case-fold-search t))
4114             (save-restriction
4115               (message-narrow-to-headers)
4116               (setq resend-to-addresses (message-fetch-field "resent-to")))
4117             ;; Change header-delimiter to be what sendmail expects.
4118             (goto-char (point-min))
4119             (re-search-forward
4120              (concat "^" (regexp-quote mail-header-separator) "\n"))
4121             (replace-match "\n")
4122             (backward-char 1)
4123             (setq delimline (point-marker))
4124             (run-hooks 'message-send-mail-hook)
4125             ;; Insert an extra newline if we need it to work around
4126             ;; Sun's bug that swallows newlines.
4127             (goto-char (1+ delimline))
4128             (when (eval message-mailer-swallows-blank-line)
4129               (newline))
4130             (when message-interactive
4131               (save-excursion
4132                 (set-buffer errbuf)
4133                 (erase-buffer))))
4134           (let* ((default-directory "/")
4135                  (cpr (as-binary-process
4136                        (apply
4137                         'call-process-region
4138                         (append
4139                          (list (point-min) (point-max)
4140                                (if (boundp 'sendmail-program)
4141                                    sendmail-program
4142                                  "/usr/lib/sendmail")
4143                                nil errbuf nil "-oi")
4144                          ;; Always specify who from,
4145                          ;; since some systems have broken sendmails.
4146                          ;; But some systems are more broken with -f, so
4147                          ;; we'll let users override this.
4148                          (if (null message-sendmail-f-is-evil)
4149                              (list "-f" (message-sendmail-envelope-from)))
4150                          ;; These mean "report errors by mail"
4151                          ;; and "deliver in background".
4152                          (if (null message-interactive) '("-oem" "-odb"))
4153                          ;; Get the addresses from the message
4154                          ;; unless this is a resend.
4155                          ;; We must not do that for a resend
4156                          ;; because we would find the original addresses.
4157                          ;; For a resend, include the specific addresses.
4158                          (if resend-to-addresses
4159                              (list resend-to-addresses)
4160                            '("-t")))))))
4161             (unless (or (null cpr) (and (numberp cpr) (zerop cpr)))
4162               (error "Sending...failed with exit value %d" cpr)))
4163           (when message-interactive
4164             (save-excursion
4165               (set-buffer errbuf)
4166               (goto-char (point-min))
4167               (while (re-search-forward "\n\n* *" nil t)
4168                 (replace-match "; "))
4169               (if (not (zerop (buffer-size)))
4170                   (error "Sending...failed to %s"
4171                          (buffer-string))))))
4172       (when (bufferp errbuf)
4173         (kill-buffer errbuf)))))
4174
4175 (defun message-send-mail-with-qmail ()
4176   "Pass the prepared message buffer to qmail-inject.
4177 Refer to the documentation for the variable `message-send-mail-function'
4178 to find out how to use this."
4179   ;; replace the header delimiter with a blank line
4180   (goto-char (point-min))
4181   (re-search-forward
4182    (concat "^" (regexp-quote mail-header-separator) "\n"))
4183   (replace-match "\n")
4184   (backward-char 1)
4185   (run-hooks 'message-send-mail-hook)
4186   ;; send the message
4187   (case
4188       (as-binary-process
4189        (apply
4190         'call-process-region 1 (point-max) message-qmail-inject-program
4191         nil nil nil
4192         ;; qmail-inject's default behaviour is to look for addresses on the
4193         ;; command line; if there're none, it scans the headers.
4194         ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
4195         ;;
4196         ;; in general, ALL of qmail-inject's defaults are perfect for simply
4197         ;; reading a formatted (i. e., at least a To: or Resent-To header)
4198         ;; message from stdin.
4199         ;;
4200         ;; qmail also has the advantage of not having been raped by
4201         ;; various vendors, so we don't have to allow for that, either --
4202         ;; compare this with message-send-mail-with-sendmail and weep
4203         ;; for sendmail's lost innocence.
4204         ;;
4205         ;; all this is way cool coz it lets us keep the arguments entirely
4206         ;; free for -inject-arguments -- a big win for the user and for us
4207         ;; since we don't have to play that double-guessing game and the user
4208         ;; gets full control (no gestapo'ish -f's, for instance).  --sj
4209         (if (functionp message-qmail-inject-args)
4210             (funcall message-qmail-inject-args)
4211           message-qmail-inject-args)))
4212     ;; qmail-inject doesn't say anything on it's stdout/stderr,
4213     ;; we have to look at the retval instead
4214     (0 nil)
4215     (100 (error "qmail-inject reported permanent failure"))
4216     (111 (error "qmail-inject reported transient failure"))
4217     ;; should never happen
4218     (t   (error "qmail-inject reported unknown failure"))))
4219
4220 (defun message-send-mail-with-mh ()
4221   "Send the prepared message buffer with mh."
4222   (let ((mh-previous-window-config nil)
4223         (name (mh-new-draft-name)))
4224     (setq buffer-file-name name)
4225     ;; MH wants to generate these headers itself.
4226     (when message-mh-deletable-headers
4227       (let ((headers message-mh-deletable-headers))
4228         (while headers
4229           (goto-char (point-min))
4230           (and (re-search-forward
4231                 (concat "^" (symbol-name (car headers)) ": *") nil t)
4232                (message-delete-line))
4233           (pop headers))))
4234     (run-hooks 'message-send-mail-hook)
4235     ;; Pass it on to mh.
4236     (mh-send-letter)))
4237
4238 (defun message-send-mail-with-smtp ()
4239   "Send off the prepared buffer with SMTP."
4240   (require 'smtp) ; XXX
4241   (let ((case-fold-search t)
4242         recipients)
4243     (save-restriction
4244       (message-narrow-to-headers)
4245       (setq recipients
4246             ;; XXX: Should be replaced by better one.
4247             (smtp-deduce-address-list (current-buffer)
4248                                       (point-min) (point-max)))
4249       ;; Remove BCC lines.
4250       (message-remove-header "bcc"))
4251     ;; replace the header delimiter with a blank line.
4252     (goto-char (point-min))
4253     (re-search-forward
4254      (concat "^" (regexp-quote mail-header-separator) "\n"))
4255     (replace-match "\n")
4256     (backward-char 1)
4257     (run-hooks 'message-send-mail-hook)
4258     (if recipients
4259         (smtp-send-buffer user-mail-address recipients (current-buffer))
4260       (error "Sending failed; no recipients"))))
4261
4262 (defsubst message-maybe-split-and-send-news (method)
4263   "Split a message if necessary, and send it via news.
4264 Returns nil if sending succeeded, returns t if sending failed.
4265 This sub function is for exclusive use of `message-send-news'."
4266   (let ((mime-edit-split-ignored-field-regexp
4267          mime-edit-split-ignored-field-regexp)
4268         (case-fold-search t))
4269     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
4270       (setq mime-edit-split-ignored-field-regexp
4271             (concat (substring mime-edit-split-ignored-field-regexp
4272                                0 (match-beginning 0))
4273                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
4274                     "_so_don't_rape_it!"
4275                     (substring mime-edit-split-ignored-field-regexp
4276                                (match-end 0)))))
4277     (or
4278      (catch 'message-sending-news-failure
4279        (mime-edit-maybe-split-and-send
4280         (function
4281          (lambda ()
4282            (interactive)
4283            (save-restriction
4284              (std11-narrow-to-header mail-header-separator)
4285              (goto-char (point-min))
4286              (when (re-search-forward "^Message-ID:" nil t)
4287                (delete-region (match-end 0) (std11-field-end))
4288                (insert " " (message-make-message-id))))
4289            (unless (funcall message-send-news-function method)
4290              (throw 'message-sending-news-failure t)))))
4291        nil)
4292      (not (funcall message-send-news-function method)))))
4293
4294 (defun message-smtpmail-send-it ()
4295   "Send the prepared message buffer with `smtpmail-send-it'.
4296 This only differs from `smtpmail-send-it' that this command evaluates
4297 `message-send-mail-hook' just before sending a message.  It is useful
4298 if your ISP requires the POP-before-SMTP authentication.  See the
4299 documentation for the function `mail-source-touch-pop'."
4300   (run-hooks 'message-send-mail-hook)
4301   (smtpmail-send-it))
4302
4303 (defun message-canlock-generate ()
4304   "Return a string that is non-trivial to guess.
4305 Do not use this for anything important, it is cryptographically weak."
4306   (let (sha1-maximum-internal-length)
4307     (sha1 (concat (message-unique-id)
4308                   (format "%x%x%x" (random) (random t) (random))
4309                   (prin1-to-string (recent-keys))
4310                   (prin1-to-string (garbage-collect))))))
4311
4312 (defun message-canlock-password ()
4313   "The password used by message for cancel locks.
4314 This is the value of `canlock-password', if that option is non-nil.
4315 Otherwise, generate and save a value for `canlock-password' first."
4316   (unless canlock-password
4317     (customize-save-variable 'canlock-password (message-canlock-generate))
4318     (setq canlock-password-for-verify canlock-password))
4319   canlock-password)
4320
4321 (defun message-insert-canlock ()
4322   (when message-insert-canlock
4323     (message-canlock-password)
4324     (canlock-insert-header)))
4325
4326 (defun message-send-news (&optional arg)
4327   (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
4328          (case-fold-search nil)
4329          (method (if (functionp message-post-method)
4330                      (funcall message-post-method arg)
4331                    message-post-method))
4332          (newsgroups-field (save-restriction
4333                              (message-narrow-to-headers-or-head)
4334                              (message-fetch-field "Newsgroups")))
4335          (followup-field (save-restriction
4336                            (message-narrow-to-headers-or-head)
4337                            (message-fetch-field "Followup-To")))
4338          ;; BUG: We really need to get the charset for each name in the
4339          ;; Newsgroups and Followup-To lines to allow crossposting
4340          ;; between group namess with incompatible character sets.
4341          ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
4342          (group-field-charset
4343           (gnus-group-name-charset method newsgroups-field))
4344          (followup-field-charset
4345           (gnus-group-name-charset method (or followup-field "")))
4346          (mime-field-encoding-method-alist
4347           (append (when group-field-charset
4348                     (list (cons "Newsgroups" group-field-charset)))
4349                   (when followup-field-charset
4350                     (list (cons "Followup-To" followup-field-charset)))
4351                   mime-field-encoding-method-alist))
4352          (message-syntax-checks
4353           (if (and arg
4354                    (listp message-syntax-checks))
4355               (cons '(existing-newsgroups . disabled)
4356                     message-syntax-checks)
4357             message-syntax-checks))
4358          (message-this-is-news t)
4359          result)
4360     (save-restriction
4361       (message-narrow-to-headers)
4362       ;; Insert some headers.
4363       (message-generate-headers message-required-news-headers)
4364       (message-insert-canlock)
4365       ;; Let the user do all of the above.
4366       (run-hooks 'message-header-hook))
4367     ;; Note: This check will be disabled by the ".*" default value for
4368     ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07.
4369     (when (and group-field-charset
4370                (listp message-syntax-checks))
4371       (setq message-syntax-checks
4372             (cons '(valid-newsgroups . disabled)
4373                   message-syntax-checks)))
4374     (message-cleanup-headers)
4375     (if (not (let ((message-post-method method))
4376                (message-check-news-syntax)))
4377         nil
4378       (unwind-protect
4379           (save-excursion
4380             (set-buffer tembuf)
4381             (buffer-disable-undo)
4382             (erase-buffer)
4383             (insert-buffer-substring message-encoding-buffer)
4384             ;; Remove some headers.
4385             (save-restriction
4386               (message-narrow-to-headers)
4387 ;; We Semi-gnus people have no use for it.
4388 ;;            ;; We (re)generate the Lines header.
4389 ;;            (when (memq 'Lines message-required-mail-headers)
4390 ;;              (message-generate-headers '(Lines)))
4391               ;; Remove some headers.
4392               (message-remove-header message-ignored-news-headers t))
4393             (goto-char (point-max))
4394             ;; require one newline at the end.
4395             (or (= (preceding-char) ?\n)
4396                 (insert ?\n))
4397             (setq result (message-maybe-split-and-send-news method)))
4398         (kill-buffer tembuf))
4399       (set-buffer message-edit-buffer)
4400       (if result
4401           (progn
4402             (message "Couldn't send message via news: %s"
4403                      (nnheader-get-report (car method)))
4404             nil)
4405         (push 'news message-sent-message-via)))))
4406
4407 ;; 1997-09-29 by MORIOKA Tomohiko
4408 (defun message-send-news-with-gnus (method)
4409   (let ((case-fold-search t))
4410     ;; Remove the delimiter.
4411     (goto-char (point-min))
4412     (re-search-forward
4413      (concat "^" (regexp-quote mail-header-separator) "\n"))
4414     (replace-match "\n")
4415     (backward-char 1)
4416     (run-hooks 'message-send-news-hook)
4417     (gnus-open-server method)
4418     (message "Sending news via %s..." (gnus-server-string method))
4419     (gnus-request-post method)
4420     ))
4421
4422 ;;;
4423 ;;; Header generation & syntax checking.
4424 ;;;
4425
4426 (defun message-check-element (type)
4427   "Return non-nil if this TYPE is not to be checked."
4428   (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
4429       t
4430     (let ((able (assq type message-syntax-checks)))
4431       (and (consp able)
4432            (eq (cdr able) 'disabled)))))
4433
4434 (defun message-check-news-syntax ()
4435   "Check the syntax of the message."
4436   (save-excursion
4437     (save-restriction
4438       (widen)
4439       (and
4440        ;; We narrow to the headers and check them first.
4441        (save-excursion
4442          (save-restriction
4443            (message-narrow-to-headers)
4444            (message-check-news-header-syntax)))
4445        ;; Check the body.
4446        (save-excursion
4447          (set-buffer message-edit-buffer)
4448          (message-check-news-body-syntax))))))
4449
4450 (defun message-check-news-header-syntax ()
4451   (and
4452    ;; Check Newsgroups header.
4453    (message-check 'newsgroups
4454      (let ((group (message-fetch-field "newsgroups")))
4455        (or
4456         (and group
4457              (not (string-match "\\`[ \t]*\\'" group)))
4458         (ignore
4459          (message
4460           "The newsgroups field is empty or missing.  Posting is denied.")))))
4461    ;; Check the Subject header.
4462    (message-check 'subject
4463      (let* ((case-fold-search t)
4464             (subject (message-fetch-field "subject")))
4465        (or
4466         (and subject
4467              (not (string-match "\\`[ \t]*\\'" subject)))
4468         (ignore
4469          (message
4470           "The subject field is empty or missing.  Posting is denied.")))))
4471    ;; Check for commands in Subject.
4472    (message-check 'subject-cmsg
4473      (if (string-match "^cmsg " (message-fetch-field "subject"))
4474          (y-or-n-p
4475           "The control code \"cmsg\" is in the subject.  Really post? ")
4476        t))
4477    ;; Check long header lines.
4478    (message-check 'long-header-lines
4479      (let ((start (point))
4480            (header nil)
4481            (length 0)
4482            found)
4483        (while (and (not found)
4484                    (re-search-forward "^\\([^ \t:]+\\): " nil t))
4485          (if (> (- (point) (match-beginning 0)) 998)
4486              (setq found t
4487                    length (- (point) (match-beginning 0)))
4488            (setq header (match-string-no-properties 1)))
4489          (setq start (match-beginning 0))
4490          (forward-line 1))
4491        (if found
4492            (y-or-n-p (format "Your %s header is too long (%d).  Really post? "
4493                              header length))
4494          t)))
4495    ;; Check for multiple identical headers.
4496    (message-check 'multiple-headers
4497      (let (found)
4498        (while (and (not found)
4499                    (re-search-forward "^[^ \t:]+: " nil t))
4500          (save-excursion
4501            (or (re-search-forward
4502                 (concat "^"
4503                         (regexp-quote
4504                          (setq found
4505                                (buffer-substring
4506                                 (match-beginning 0) (- (match-end 0) 2))))
4507                         ":")
4508                 nil t)
4509                (setq found nil))))
4510        (if found
4511            (y-or-n-p (format "Multiple %s headers.  Really post? " found))
4512          t)))
4513    ;; Check for Version and Sendsys.
4514    (message-check 'sendsys
4515      (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
4516          (y-or-n-p
4517           (format "The article contains a %s command.  Really post? "
4518                   (buffer-substring (match-beginning 0)
4519                                     (1- (match-end 0)))))
4520        t))
4521    ;; See whether we can shorten Followup-To.
4522    (message-check 'shorten-followup-to
4523      (let ((newsgroups (message-fetch-field "newsgroups"))
4524            (followup-to (message-fetch-field "followup-to"))
4525            to)
4526        (when (and newsgroups
4527                   (string-match "," newsgroups)
4528                   (not followup-to)
4529                   (not
4530                    (zerop
4531                     (length
4532                      (setq to (completing-read
4533                                "Followups to (default: no Followup-To header) "
4534                                (mapcar #'list
4535                                        (cons "poster"
4536                                              (message-tokenize-header
4537                                               newsgroups)))))))))
4538          (goto-char (point-min))
4539          (insert "Followup-To: " to "\n"))
4540        t))
4541    ;; Check "Shoot me".
4542    (message-check 'shoot
4543      (if (re-search-forward
4544           "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t)
4545          (y-or-n-p "You appear to have a misconfigured system.  Really post? ")
4546        t))
4547    ;; Check for Approved.
4548    (message-check 'approved
4549      (if (re-search-forward "^Approved:" nil t)
4550          (y-or-n-p "The article contains an Approved header.  Really post? ")
4551        t))
4552    ;; Check the Message-ID header.
4553    (message-check 'message-id
4554      (let* ((case-fold-search t)
4555             (message-id (message-fetch-field "message-id" t)))
4556        (or (not message-id)
4557            ;; Is there an @ in the ID?
4558            (and (string-match "@" message-id)
4559                 ;; Is there a dot in the ID?
4560                 (string-match "@[^.]*\\." message-id)
4561                 ;; Does the ID end with a dot?
4562                 (not (string-match "\\.>" message-id)))
4563            (y-or-n-p
4564             (format "The Message-ID looks strange: \"%s\".  Really post? "
4565                     message-id)))))
4566    ;; Check the Newsgroups & Followup-To headers.
4567    (message-check 'existing-newsgroups
4568      (let* ((case-fold-search t)
4569             (newsgroups (message-fetch-field "newsgroups"))
4570             (followup-to (message-fetch-field "followup-to"))
4571             (groups (message-tokenize-header
4572                      (if followup-to
4573                          (concat newsgroups "," followup-to)
4574                        newsgroups)))
4575             (post-method (if (functionp message-post-method)
4576                              (funcall message-post-method)
4577                            message-post-method))
4578             ;; KLUDGE to handle nnvirtual groups.  Doing this right
4579             ;; would probably involve a new nnoo function.
4580             ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17.
4581             (method (if (and (consp post-method)
4582                              (eq (car post-method) 'nnvirtual)
4583                              gnus-message-group-art)
4584                         (let ((group (car (nnvirtual-find-group-art
4585                                            (car gnus-message-group-art)
4586                                            (cdr gnus-message-group-art)))))
4587                           (gnus-find-method-for-group group))
4588                       post-method))
4589             (known-groups
4590              (mapcar (lambda (n)
4591                        (gnus-group-name-decode
4592                         (gnus-group-real-name n)
4593                         (gnus-group-name-charset method n)))
4594                      (gnus-groups-from-server method)))
4595             errors)
4596        (while groups
4597          (when (and (not (equal (car groups) "poster"))
4598                     (not (member (car groups) known-groups))
4599                     (not (member (car groups) errors)))
4600            (push (car groups) errors))
4601          (pop groups))
4602        (cond
4603         ;; Gnus is not running.
4604         ((or (not (and (boundp 'gnus-active-hashtb)
4605                        gnus-active-hashtb))
4606              (not (boundp 'gnus-read-active-file)))
4607          t)
4608         ;; We don't have all the group names.
4609         ((and (or (not gnus-read-active-file)
4610                   (eq gnus-read-active-file 'some))
4611               errors)
4612          (y-or-n-p
4613           (format
4614            "Really use %s possibly unknown group%s: %s? "
4615            (if (= (length errors) 1) "this" "these")
4616            (if (= (length errors) 1) "" "s")
4617            (mapconcat 'identity errors ", "))))
4618         ;; There were no errors.
4619         ((not errors)
4620          t)
4621         ;; There are unknown groups.
4622         (t
4623          (y-or-n-p
4624           (format
4625            "Really post to %s unknown group%s: %s? "
4626            (if (= (length errors) 1) "this" "these")
4627            (if (= (length errors) 1) "" "s")
4628            (mapconcat 'identity errors ", ")))))))
4629    ;; Check continuation headers.
4630    (message-check 'continuation-headers
4631      (goto-char (point-min))
4632      (let ((do-posting t))
4633        (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t)
4634          (if (y-or-n-p "Fix continuation lines? ")
4635              (progn
4636                (goto-char (match-beginning 0))
4637                (insert " "))
4638            (unless (y-or-n-p "Send anyway? ")
4639              (setq do-posting nil))))
4640        do-posting))
4641    ;; Check the Newsgroups & Followup-To headers for syntax errors.
4642    (message-check 'valid-newsgroups
4643      (let ((case-fold-search t)
4644            (headers '("Newsgroups" "Followup-To"))
4645            header error)
4646        (while (and headers (not error))
4647          (when (setq header (mail-fetch-field (car headers)))
4648            (if (or
4649                 (not
4650                  (string-match
4651                   "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
4652                   header))
4653                 (memq
4654                  nil (mapcar
4655                       (lambda (g)
4656                         (not (string-match "\\.\\'\\|\\.\\." g)))
4657                       (message-tokenize-header header ","))))
4658                (setq error t)))
4659          (unless error
4660            (pop headers)))
4661        (if (not error)
4662            t
4663          (y-or-n-p
4664           (format "The %s header looks odd: \"%s\".  Really post? "
4665                   (car headers) header)))))
4666    (message-check 'repeated-newsgroups
4667      (let ((case-fold-search t)
4668            (headers '("Newsgroups" "Followup-To"))
4669            header error groups group)
4670        (while (and headers
4671                    (not error))
4672          (when (setq header (mail-fetch-field (pop headers)))
4673            (setq groups (message-tokenize-header header ","))
4674            (while (setq group (pop groups))
4675              (when (member group groups)
4676                (setq error group
4677                      groups nil)))))
4678        (if (not error)
4679            t
4680          (y-or-n-p
4681           (format "Group %s is repeated in headers.  Really post? " error)))))
4682    ;; Check the From header.
4683    (message-check 'from
4684      (let* ((case-fold-search t)
4685             (from (message-fetch-field "from"))
4686             ad)
4687        (cond
4688         ((not from)
4689          (message "There is no From line.  Posting is denied.")
4690          nil)
4691         ((or (not (string-match
4692                    "@[^\\.]*\\."
4693                    (setq ad (nth 1 (std11-extract-address-components
4694                                     from))))) ;larsi@ifi
4695              (string-match "\\.\\." ad) ;larsi@ifi..uio
4696              (string-match "@\\." ad)   ;larsi@.ifi.uio
4697              (string-match "\\.$" ad)   ;larsi@ifi.uio.
4698              (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
4699              (string-match "(.*).*(.*)" from)) ;(lars) (lars)
4700          (message
4701           "Denied posting -- the From looks strange: \"%s\"." from)
4702          nil)
4703         ((let ((addresses (rfc822-addresses from)))
4704            (while (and addresses
4705                        (not (eq (string-to-char (car addresses)) ?\()))
4706              (setq addresses (cdr addresses)))
4707            addresses)
4708          (message
4709           "Denied posting -- bad From address: \"%s\"." from)
4710          nil)
4711         (t t))))
4712    ;; Check the Reply-To header.
4713    (message-check 'reply-to
4714      (let* ((case-fold-search t)
4715             (reply-to (message-fetch-field "reply-to"))
4716             ad)
4717        (cond
4718         ((not reply-to)
4719          t)
4720         ((string-match "," reply-to)
4721          (y-or-n-p
4722           (format "Multiple Reply-To addresses: \"%s\". Really post? "
4723                   reply-to)))
4724         ((or (not (string-match
4725                    "@[^\\.]*\\."
4726                    (setq ad (nth 1 (std11-extract-address-components
4727                                     reply-to))))) ;larsi@ifi
4728              (string-match "\\.\\." ad) ;larsi@ifi..uio
4729              (string-match "@\\." ad)   ;larsi@.ifi.uio
4730              (string-match "\\.$" ad)   ;larsi@ifi.uio.
4731              (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
4732              (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars)
4733          (y-or-n-p
4734           (format
4735            "The Reply-To looks strange: \"%s\". Really post? "
4736            reply-to)))
4737         (t t))))))
4738
4739 (defun message-check-news-body-syntax ()
4740   (and
4741    ;; Check for long lines.
4742    (message-check 'long-lines
4743      (goto-char (point-min))
4744      (re-search-forward
4745       (concat "^" (regexp-quote mail-header-separator) "$"))
4746      (forward-line 1)
4747      (while (and
4748              (or (looking-at
4749                   mime-edit-tag-regexp)
4750                  (let ((p (point)))
4751                    (end-of-line)
4752                    (< (- (point) p) 80)))
4753              (zerop (forward-line 1))))
4754      (or (bolp)
4755          (eobp)
4756          (y-or-n-p
4757           "You have lines longer than 79 characters.  Really post? ")))
4758    ;; Check whether the article is empty.
4759    (message-check 'empty
4760      (goto-char (point-min))
4761      (re-search-forward
4762       (concat "^" (regexp-quote mail-header-separator) "$"))
4763      (forward-line 1)
4764      (let ((b (point)))
4765        (goto-char (point-max))
4766        (re-search-backward message-signature-separator nil t)
4767        (beginning-of-line)
4768        (or (re-search-backward "[^ \n\t]" b t)
4769            (if (message-gnksa-enable-p 'empty-article)
4770                (y-or-n-p "Empty article.  Really post? ")
4771              (message "Denied posting -- Empty article.")
4772              nil))))
4773    ;; Check for control characters.
4774    (message-check 'control-chars
4775      (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
4776          (y-or-n-p
4777           "The article contains control characters.  Really post? ")
4778        t))
4779    ;; Check 8bit characters.
4780    (message-check '8bit
4781      (message-check-8bit))
4782    ;; Check excessive size.
4783    (message-check 'size
4784      (if (> (buffer-size) 60000)
4785          (y-or-n-p
4786           (format "The article is %d octets long.  Really post? "
4787                   (buffer-size)))
4788        t))
4789    ;; Check whether any new text has been added.
4790    (message-check 'new-text
4791      (or
4792       (not message-checksum)
4793       (not (eq (message-checksum) message-checksum))
4794       (if (message-gnksa-enable-p 'quoted-text-only)
4795           (y-or-n-p
4796            "It looks like no new text has been added.  Really post? ")
4797         (message "Denied posting -- no new text has been added.")
4798         nil)))
4799    ;; Check the length of the signature.
4800    (message-check 'signature
4801      (goto-char (point-max))
4802      (if (> (count-lines (point) (point-max)) 5)
4803          (y-or-n-p
4804           (format
4805            "Your .sig is %d lines; it should be max 4.  Really post? "
4806            (1- (count-lines (point) (point-max)))))
4807        t))
4808    ;; Ensure that text follows last quoted portion.
4809    (message-check 'quoting-style
4810      (goto-char (point-max))
4811      (let ((no-problem t))
4812        (when (search-backward-regexp "^>[^\n]*\n" nil t)
4813          (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t)))
4814        (if no-problem
4815            t
4816          (if (message-gnksa-enable-p 'quoted-text-only)
4817              (y-or-n-p "Your text should follow quoted text.  Really post? ")
4818            ;; Ensure that
4819            (goto-char (point-min))
4820            (re-search-forward
4821             (concat "^" (regexp-quote mail-header-separator) "$"))
4822            (if (search-forward-regexp "^[ \t]*[^>\n]" nil t)
4823                (y-or-n-p "Your text should follow quoted text.  Really post? ")
4824              (message "Denied posting -- only quoted text.")
4825              nil)))))))
4826
4827 (defun message-check-mail-syntax ()
4828   "Check the syntax of the message."
4829   (save-excursion
4830     (save-restriction
4831       (widen)
4832       (and
4833        ;; We narrow to the headers and check them first.
4834        (save-excursion
4835          (save-restriction
4836            (message-narrow-to-headers)
4837            (message-check-mail-header-syntax)))
4838        ;; Check the body.
4839        (save-excursion
4840          (set-buffer message-edit-buffer)
4841          (message-check-mail-body-syntax))))))
4842
4843 (defun message-check-mail-header-syntax ()
4844   t)
4845
4846 (defun message-check-mail-body-syntax ()
4847   (and
4848    ;; Check 8bit characters.
4849    (message-check '8bit
4850      (message-check-8bit)
4851      )))
4852
4853 (defun message-check-8bit ()
4854   "Check the article contains 8bit characters."
4855   (save-excursion
4856     (set-buffer message-encoding-buffer)
4857     (message-narrow-to-headers)
4858     (let* ((case-fold-search t)
4859            (field-value (message-fetch-field "content-transfer-encoding")))
4860       (if (and field-value
4861                (member (downcase field-value) message-8bit-encoding-list))
4862           t
4863         (widen)
4864         (set-buffer (get-buffer-create " message syntax"))
4865         (erase-buffer)
4866         (goto-char (point-min))
4867         (set-buffer-multibyte nil)
4868         (insert-buffer-substring message-encoding-buffer)
4869         (goto-char (point-min))
4870         (if (re-search-forward "[^\x00-\x7f]" nil t)
4871             (y-or-n-p
4872              "The article contains 8bit characters.  Really post? ")
4873           t)))))
4874
4875 (defun message-checksum ()
4876   "Return a \"checksum\" for the current buffer."
4877   (let ((sum 0))
4878     (save-excursion
4879       (goto-char (point-min))
4880       (re-search-forward
4881        (concat "^" (regexp-quote mail-header-separator) "$"))
4882       (while (not (eobp))
4883         (when (not (looking-at "[ \t\n]"))
4884           (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
4885                             (char-after))))
4886         (forward-char 1)))
4887     sum))
4888
4889 (defun message-do-fcc ()
4890   "Process Fcc headers in the current buffer."
4891   (let ((case-fold-search t)
4892         (coding-system-for-write 'raw-text)
4893         (output-coding-system 'raw-text)
4894         list file
4895         (mml-externalize-attachments message-fcc-externalize-attachments))
4896     (save-excursion
4897       (save-restriction
4898         (message-narrow-to-headers)
4899         (setq file (message-fetch-field "fcc" t)))
4900       (when file
4901         (set-buffer (get-buffer-create " *message temp*"))
4902         (erase-buffer)
4903         (insert-buffer-substring message-encoding-buffer)
4904         (save-restriction
4905           (message-narrow-to-headers)
4906           (while (setq file (message-fetch-field "fcc"))
4907             (push file list)
4908             (message-remove-header "fcc" nil t)))
4909         (goto-char (point-min))
4910         (when (re-search-forward
4911                (concat "^" (regexp-quote mail-header-separator) "$")
4912                nil t)
4913           (replace-match "" t t))
4914         ;; Process FCC operations.
4915         (while list
4916           (setq file (pop list))
4917           (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
4918               ;; Pipe the article to the program in question.
4919               (call-process-region (point-min) (point-max) shell-file-name
4920                                    nil nil nil shell-command-switch
4921                                    (match-string 1 file))
4922             ;; Save the article.
4923             (setq file (expand-file-name file))
4924             (unless (file-exists-p (file-name-directory file))
4925               (make-directory (file-name-directory file) t))
4926             (if (and message-fcc-handler-function
4927                      (not (eq message-fcc-handler-function 'rmail-output)))
4928                 (funcall message-fcc-handler-function file)
4929               (if (and (file-readable-p file) (mail-file-babyl-p file))
4930                   (rmail-output file 1 nil t)
4931                 (let ((mail-use-rfc822 t))
4932                   (rmail-output file 1 t t))))))
4933         (kill-buffer (current-buffer))))))
4934
4935 (defun message-output (filename)
4936   "Append this article to Unix/babyl mail file FILENAME."
4937   (if (and (file-readable-p filename)
4938            (mail-file-babyl-p filename))
4939       (gnus-output-to-rmail filename t)
4940     (gnus-output-to-mail filename t)))
4941
4942 (defun message-cleanup-headers ()
4943   "Do various automatic cleanups of the headers."
4944   ;; Remove empty lines in the header.
4945   (save-restriction
4946     (message-narrow-to-headers)
4947     ;; Remove blank lines.
4948     (while (re-search-forward "^[ \t]*\n" nil t)
4949       (replace-match "" t t))
4950
4951     ;; Correct Newsgroups and Followup-To headers:  Change sequence of
4952     ;; spaces to comma and eliminate spaces around commas.  Eliminate
4953     ;; embedded line breaks.
4954     (goto-char (point-min))
4955     (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
4956       (save-restriction
4957         (narrow-to-region
4958          (point)
4959          (if (re-search-forward "^[^ \t]" nil t)
4960              (match-beginning 0)
4961            (forward-line 1)
4962            (point)))
4963         (goto-char (point-min))
4964         (while (re-search-forward "\n[ \t]+" nil t)
4965           (replace-match " " t t))      ;No line breaks (too confusing)
4966         (goto-char (point-min))
4967         (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
4968           (replace-match "," t t))
4969         (goto-char (point-min))
4970         ;; Remove trailing commas.
4971         (when (re-search-forward ",+$" nil t)
4972           (replace-match "" t t))))))
4973
4974 (defun message-make-date (&optional now)
4975   "Make a valid data header.
4976 If NOW, use that time instead."
4977   (let* ((now (or now (current-time)))
4978          (zone (nth 8 (decode-time now)))
4979          (sign "+"))
4980     (when (< zone 0)
4981       (setq sign "-")
4982       (setq zone (- zone)))
4983     (concat
4984      ;; The day name of the %a spec is locale-specific.  Pfff.
4985      (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now))
4986                                              parse-time-weekdays))))
4987      (format-time-string "%d" now)
4988      ;; The month name of the %b spec is locale-specific.  Pfff.
4989      (format " %s "
4990              (capitalize (car (rassoc (nth 4 (decode-time now))
4991                                       parse-time-months))))
4992      (format-time-string "%Y %H:%M:%S " now)
4993      ;; We do all of this because XEmacs doesn't have the %z spec.
4994      (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
4995
4996 (defun message-make-followup-subject (subject)
4997   "Make a followup Subject."
4998   (cond
4999    ((and (eq message-use-subject-re 'guess)
5000          (string-match message-subject-encoded-re-regexp subject))
5001     subject)
5002    (message-use-subject-re
5003     (concat "Re: " (message-strip-subject-re subject)))
5004    (t subject)))
5005
5006 (defun message-make-message-id ()
5007   "Make a unique Message-ID."
5008   (concat "<" (message-unique-id)
5009           (let ((psubject (save-excursion (message-fetch-field "subject")))
5010                 (psupersedes
5011                  (save-excursion (message-fetch-field "supersedes"))))
5012             (if (or
5013                  (and message-reply-headers
5014                       (mail-header-references message-reply-headers)
5015                       (mail-header-subject message-reply-headers)
5016                       psubject
5017                       (not (string=
5018                             (message-strip-subject-re
5019                              (mail-header-subject message-reply-headers))
5020                             (message-strip-subject-re psubject))))
5021                  (and psupersedes
5022                       (string-match "_-_@" psupersedes)))
5023                 "_-_" ""))
5024           "@" (message-make-fqdn) ">"))
5025
5026 (defvar message-unique-id-char nil)
5027
5028 ;; If you ever change this function, make sure the new version
5029 ;; cannot generate IDs that the old version could.
5030 ;; You might for example insert a "." somewhere (not next to another dot
5031 ;; or string boundary), or modify the "fsf" string.
5032 (defun message-unique-id ()
5033   ;; Don't use microseconds from (current-time), they may be unsupported.
5034   ;; Instead we use this randomly inited counter.
5035   (setq message-unique-id-char
5036         (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
5037            ;; (current-time) returns 16-bit ints,
5038            ;; and 2^16*25 just fits into 4 digits i base 36.
5039            (* 25 25)))
5040   (let ((tm (current-time)))
5041     (concat
5042      (if (memq system-type '(ms-dos emx vax-vms))
5043          (let ((user (downcase (user-login-name))))
5044            (while (string-match "[^a-z0-9_]" user)
5045              (aset user (match-beginning 0) ?_))
5046            user)
5047        (message-number-base36 (user-uid) -1))
5048      (message-number-base36 (+ (car tm)
5049                                (lsh (% message-unique-id-char 25) 16)) 4)
5050      (message-number-base36 (+ (nth 1 tm)
5051                                (lsh (/ message-unique-id-char 25) 16)) 4)
5052      ;; Append a given name, because while the generated ID is unique
5053      ;; to this newsreader, other newsreaders might otherwise generate
5054      ;; the same ID via another algorithm.
5055      ".fsf")))
5056
5057 (defun message-number-base36 (num len)
5058   (if (if (< len 0)
5059           (<= num 0)
5060         (= len 0))
5061       ""
5062     (concat (message-number-base36 (/ num 36) (1- len))
5063             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
5064                                   (% num 36))))))
5065
5066 (defun message-make-organization ()
5067   "Make an Organization header."
5068   (let* ((organization
5069           (when message-user-organization
5070             (if (functionp message-user-organization)
5071                 (funcall message-user-organization)
5072               message-user-organization))))
5073     (with-temp-buffer
5074       (set-buffer-multibyte t)
5075       (cond ((stringp organization)
5076              (insert organization))
5077             ((and (eq t organization)
5078                   message-user-organization-file
5079                   (file-exists-p message-user-organization-file))
5080              (insert-file-contents message-user-organization-file)))
5081       (goto-char (point-min))
5082       (while (re-search-forward "[\t\n]+" nil t)
5083         (replace-match "" t t))
5084       (unless (zerop (buffer-size))
5085         (buffer-string)))))
5086
5087 (defun message-make-lines ()
5088   "Count the number of lines and return numeric string."
5089   (save-excursion
5090     (save-restriction
5091       (widen)
5092       (message-goto-body)
5093       (int-to-string (count-lines (point) (point-max))))))
5094
5095 (defun message-make-references ()
5096   "Return the References header for this message."
5097   (when message-reply-headers
5098     (let ((message-id (mail-header-message-id message-reply-headers))
5099           (references (mail-header-references message-reply-headers))
5100           new-references)
5101       (if (or references message-id)
5102           (concat (or references "") (and references " ")
5103                   (or message-id ""))
5104         nil))))
5105
5106 (defun message-make-in-reply-to ()
5107   "Return the In-Reply-To header for this message."
5108   (when message-reply-headers
5109     (let ((from (mail-header-from message-reply-headers))
5110           (date (mail-header-date message-reply-headers))
5111           (msg-id (mail-header-message-id message-reply-headers)))
5112       (when from
5113         (let ((name (std11-extract-address-components from)))
5114           (concat msg-id (if msg-id " (")
5115                   (or (car name)
5116                       (nth 1 name))
5117                   "'s message of \""
5118                   (if (or (not date) (string= date ""))
5119                       "(unknown date)" date)
5120                   "\"" (if msg-id ")")))))))
5121
5122 (defun message-make-distribution ()
5123   "Make a Distribution header."
5124   (let ((orig-distribution (message-fetch-reply-field "distribution")))
5125     (cond ((functionp message-distribution-function)
5126            (funcall message-distribution-function))
5127           (t orig-distribution))))
5128
5129 (defun message-make-expires ()
5130   "Return an Expires header based on `message-expires'."
5131   (let ((current (current-time))
5132         (future (* 1.0 message-expires 60 60 24)))
5133     ;; Add the future to current.
5134     (setcar current (+ (car current) (round (/ future (expt 2 16)))))
5135     (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
5136     (message-make-date current)))
5137
5138 (defun message-make-path ()
5139   "Return uucp path."
5140   (let ((login-name (user-login-name)))
5141     (cond ((null message-user-path)
5142            (concat (system-name) "!" login-name))
5143           ((stringp message-user-path)
5144            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
5145            (concat message-user-path "!" login-name))
5146           (t login-name))))
5147
5148 (defun message-make-from ()
5149   "Make a From header."
5150   (let* ((style message-from-style)
5151          (login (message-make-address))
5152          (fullname
5153           (or (and (boundp 'user-full-name)
5154                    user-full-name)
5155               (user-full-name))))
5156     (when (string= fullname "&")
5157       (setq fullname (user-login-name)))
5158     (with-temp-buffer
5159       (set-buffer-multibyte t)
5160       (cond
5161        ((or (null style)
5162             (equal fullname ""))
5163         (insert login))
5164        ((or (eq style 'angles)
5165             (and (not (eq style 'parens))
5166                  ;; Use angles if no quoting is needed, or if parens would
5167                  ;; need quoting too.
5168                  (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
5169                      (let ((tmp (concat fullname nil)))
5170                        (while (string-match "([^()]*)" tmp)
5171                          (aset tmp (match-beginning 0) ?-)
5172                          (aset tmp (1- (match-end 0)) ?-))
5173                        (string-match "[\\()]" tmp)))))
5174         (insert fullname)
5175         (goto-char (point-min))
5176         ;; Look for a character that cannot appear unquoted
5177         ;; according to RFC 822.
5178         (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
5179           ;; Quote fullname, escaping specials.
5180           (goto-char (point-min))
5181           (insert "\"")
5182           (while (re-search-forward "[\"\\]" nil 1)
5183             (replace-match "\\\\\\&" t))
5184           (insert "\""))
5185         (insert " <" login ">"))
5186        (t                               ; 'parens or default
5187         (insert login " (")
5188         (let ((fullname-start (point)))
5189           (insert fullname)
5190           (goto-char fullname-start)
5191           ;; RFC 822 says \ and nonmatching parentheses
5192           ;; must be escaped in comments.
5193           ;; Escape every instance of ()\ ...
5194           (while (re-search-forward "[()\\]" nil 1)
5195             (replace-match "\\\\\\&" t))
5196           ;; ... then undo escaping of matching parentheses,
5197           ;; including matching nested parentheses.
5198           (goto-char fullname-start)
5199           (while (re-search-forward
5200                   "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
5201                   nil 1)
5202             (replace-match "\\1(\\3)" t)
5203             (goto-char fullname-start)))
5204         (insert ")")))
5205       (buffer-string))))
5206
5207 (defun message-make-sender ()
5208   "Return the \"real\" user address.
5209 This function tries to ignore all user modifications, and
5210 give as trustworthy answer as possible."
5211   (concat (user-login-name) "@" (system-name)))
5212
5213 (defun message-make-address ()
5214   "Make the address of the user."
5215   (or (message-user-mail-address)
5216       (concat (user-login-name) "@" (message-make-domain))))
5217
5218 (defun message-user-mail-address ()
5219   "Return the pertinent part of `user-mail-address'."
5220   (when (and user-mail-address
5221              (string-match "@.*\\." user-mail-address))
5222     (if (string-match " " user-mail-address)
5223         (nth 1 (std11-extract-address-components user-mail-address))
5224       user-mail-address)))
5225
5226 (defun message-sendmail-envelope-from ()
5227   "Return the envelope from."
5228   (cond ((eq message-sendmail-envelope-from 'header)
5229          (nth 1 (std11-extract-address-components
5230                  (message-fetch-field "from"))))
5231         ((stringp message-sendmail-envelope-from)
5232          message-sendmail-envelope-from)
5233         (t
5234          (message-make-address))))
5235
5236 (defun message-make-fqdn ()
5237   "Return user's fully qualified domain name."
5238   (let* ((system-name (system-name))
5239          (user-mail (message-user-mail-address))
5240          (user-domain
5241           (if (and user-mail
5242                    (string-match "@\\(.*\\)\\'" user-mail))
5243               (match-string 1 user-mail))))
5244     (cond
5245      ((and message-user-fqdn
5246            (stringp message-user-fqdn)
5247            (string-match message-valid-fqdn-regexp message-user-fqdn)
5248            (not (string-match message-bogus-system-names message-user-fqdn)))
5249       message-user-fqdn)
5250      ;; `message-user-fqdn' seems to be valid
5251      ((and (string-match message-valid-fqdn-regexp system-name)
5252            (not (string-match message-bogus-system-names system-name)))
5253       ;; `system-name' returned the right result.
5254       system-name)
5255      ;; Try `mail-host-address'.
5256      ((and (boundp 'mail-host-address)
5257            (stringp mail-host-address)
5258            (string-match message-valid-fqdn-regexp mail-host-address)
5259            (not (string-match message-bogus-system-names mail-host-address)))
5260       mail-host-address)
5261      ;; We try `user-mail-address' as a backup.
5262      ((and user-domain
5263            (stringp user-domain)
5264            (string-match message-valid-fqdn-regexp user-domain)
5265            (not (string-match message-bogus-system-names user-domain)))
5266       user-domain)
5267      ;; Default to this bogus thing.
5268      (t
5269       (concat system-name
5270               ".i-did-not-set--mail-host-address--so-tickle-me")))))
5271
5272 (defun message-make-host-name ()
5273   "Return the name of the host."
5274   (let ((fqdn (message-make-fqdn)))
5275     (string-match "^[^.]+\\." fqdn)
5276     (substring fqdn 0 (1- (match-end 0)))))
5277
5278 (defun message-make-domain ()
5279   "Return the domain name."
5280   (or mail-host-address
5281       (message-make-fqdn)))
5282
5283 (defun message-to-list-only ()
5284   "Send a message to the list only.
5285 Remove all addresses but the list address from To and Cc headers."
5286   (interactive)
5287   (let ((listaddr (message-make-mail-followup-to t)))
5288     (when listaddr
5289       (save-excursion
5290         (message-remove-header "to")
5291         (message-remove-header "cc")
5292         (message-position-on-field "To" "X-Draft-From")
5293         (insert listaddr)))))
5294
5295 (defun message-make-mail-followup-to (&optional only-show-subscribed)
5296   "Return the Mail-Followup-To header.
5297 If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the
5298 subscribed address (and not the additional To and Cc header contents)."
5299   (let* ((case-fold-search t)
5300          (to (message-fetch-field "To"))
5301          (cc (message-fetch-field "cc"))
5302          (msg-recipients (concat to (and to cc ", ") cc))
5303          (recipients
5304           (mapcar 'mail-strip-quoted-names
5305                   (message-tokenize-header msg-recipients)))
5306          (file-regexps
5307           (if message-subscribed-address-file
5308               (let (begin end item re)
5309                 (save-excursion
5310                   (with-temp-buffer
5311                     (insert-file-contents message-subscribed-address-file)
5312                     (while (not (eobp))
5313                       (setq begin (point))
5314                       (forward-line 1)
5315                       (setq end (point))
5316                       (if (bolp) (setq end (1- end)))
5317                       (setq item (regexp-quote (buffer-substring begin end)))
5318                       (if re (setq re (concat re "\\|" item))
5319                         (setq re (concat "\\`\\(" item))))
5320                     (and re (list (concat re "\\)\\'"))))))))
5321          (mft-regexps (apply 'append message-subscribed-regexps
5322                              (mapcar 'regexp-quote
5323                                      message-subscribed-addresses)
5324                              file-regexps
5325                              (mapcar 'funcall
5326                                      message-subscribed-address-functions))))
5327     (save-match-data
5328       (let ((subscribed-lists nil)
5329             (list
5330              (loop for recipient in recipients
5331                when (loop for regexp in mft-regexps
5332                       when (string-match regexp recipient) return t)
5333                return recipient)))
5334         (when list
5335           (if only-show-subscribed
5336               list
5337             msg-recipients))))))
5338
5339 ;; Dummy to avoid byte-compile warning.
5340 (defvar mule-version)
5341 (defvar emacs-beta-version)
5342 (defvar xemacs-codename)
5343 (defvar gnus-inviolable-extended-version)
5344
5345 (defun message-make-user-agent ()
5346   "Return user-agent info if the value `message-user-agent' is non-nil. If the
5347 \"User-Agent\" field has already exist, remove it."
5348   (when message-user-agent
5349     (save-excursion
5350       (goto-char (point-min))
5351       (let ((case-fold-search t))
5352         (when (re-search-forward "^User-Agent:[\t ]*" nil t)
5353           (delete-region (match-beginning 0) (1+ (std11-field-end)))))))
5354   message-user-agent)
5355
5356 (defun message-idna-inside-rhs-p ()
5357   "Return t iff point is inside a RHS (heuristically).
5358 Only works properly if header contains mailbox-list or address-list.
5359 I.e., calling it on a Subject: header is useless."
5360   (save-restriction
5361     (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t)
5362                                           (point-min)))
5363                       (save-excursion (or (re-search-forward "^[^ \t]" nil t)
5364                                           (point-max))))
5365     (if (re-search-backward "[\\\n\r\t ]"
5366                             (save-excursion (search-backward "@" nil t)) t)
5367         ;; whitespace between @ and point
5368         nil
5369       (let ((dquote 1) (paren 1))
5370         (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
5371           (incf dquote))
5372         (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
5373           (incf paren))
5374         (and (= (% dquote 2) 1) (= (% paren 2) 1))))))
5375
5376 (autoload 'idna-to-ascii "idna")
5377
5378 (defun message-idna-to-ascii-rhs-1 (header)
5379   "Interactively potentially IDNA encode domain names in HEADER."
5380   (let (rhs ace start startpos endpos ovl)
5381     (goto-char (point-min))
5382     (while (re-search-forward (concat "^" header) nil t)
5383       (while (re-search-forward "@\\([^ \t\r\n>]+\\)"
5384                                 (or (save-excursion
5385                                       (re-search-forward "^[^ \t]" nil t))
5386                                     (point-max))
5387                                 t)
5388         (setq rhs (match-string-no-properties 1)
5389               startpos (match-beginning 1)
5390               endpos (match-end 1))
5391         (when (save-match-data
5392                 (and (message-idna-inside-rhs-p)
5393                      (setq ace (idna-to-ascii rhs))
5394                      (not (string= rhs ace))
5395                      (if (eq message-use-idna 'ask)
5396                          (unwind-protect
5397                              (progn
5398                                (setq ovl (message-make-overlay startpos
5399                                                                endpos))
5400                                (message-overlay-put ovl 'face 'highlight)
5401                                (y-or-n-p
5402                                 (format "Replace with `%s'? " ace)))
5403                            (message "")
5404                            (message-delete-overlay ovl))
5405                        message-use-idna)))
5406           (replace-match (concat "@" ace)))))))
5407
5408 (defun message-idna-to-ascii-rhs ()
5409   "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
5410 See `message-idna-encode'."
5411   (interactive)
5412   (when message-use-idna
5413     (save-excursion
5414       (save-restriction
5415         (message-narrow-to-head)
5416         (message-idna-to-ascii-rhs-1 "From")
5417         (message-idna-to-ascii-rhs-1 "To")
5418         (message-idna-to-ascii-rhs-1 "Cc")))))
5419
5420 (defun message-generate-headers (headers)
5421   "Prepare article HEADERS.
5422 Headers already prepared in the buffer are not modified."
5423   (setq headers (append headers message-required-headers))
5424   (save-restriction
5425     (message-narrow-to-headers)
5426     (let* ((Date (message-make-date))
5427            (Message-ID (message-make-message-id))
5428            (Organization (message-make-organization))
5429            (From (message-make-from))
5430            (Path (message-make-path))
5431            (Subject nil)
5432            (Newsgroups nil)
5433            (In-Reply-To (message-make-in-reply-to))
5434            (References (message-make-references))
5435            (To nil)
5436            (Distribution (message-make-distribution))
5437            (Lines (message-make-lines))
5438            (User-Agent (message-make-user-agent))
5439            (Expires (message-make-expires))
5440            (case-fold-search t)
5441            (optionalp nil)
5442            header value elem)
5443       ;; First we remove any old generated headers.
5444       (let ((headers message-deletable-headers))
5445         (unless (buffer-modified-p)
5446           (setq headers (delq 'Message-ID (copy-sequence headers))))
5447         (while headers
5448           (goto-char (point-min))
5449           (and (re-search-forward
5450                 (concat "^" (symbol-name (car headers)) ": *") nil t)
5451                (get-text-property (1+ (match-beginning 0)) 'message-deletable)
5452                (message-delete-line))
5453           (pop headers)))
5454       ;; Go through all the required headers and see if they are in the
5455       ;; articles already.  If they are not, or are empty, they are
5456       ;; inserted automatically - except for Subject, Newsgroups and
5457       ;; Distribution.
5458       (while headers
5459         (goto-char (point-min))
5460         (setq elem (pop headers))
5461         (if (consp elem)
5462             (if (eq (car elem) 'optional)
5463                 (setq header (cdr elem)
5464                       optionalp t)
5465               (setq header (car elem)))
5466           (setq header elem))
5467         (when (or (not (re-search-forward
5468                         (concat "^"
5469                                 (regexp-quote
5470                                  (downcase
5471                                   (if (stringp header)
5472                                       header
5473                                     (symbol-name header))))
5474                                 ":")
5475                         nil t))
5476                   (progn
5477                     ;; The header was found.  We insert a space after the
5478                     ;; colon, if there is none.
5479                     (if (/= (char-after) ? ) (insert " ") (forward-char 1))
5480                     ;; Find out whether the header is empty.
5481                     (looking-at "[ \t]*\n[^ \t]")))
5482           ;; So we find out what value we should insert.
5483           (setq value
5484                 (cond
5485                  ((and (consp elem)
5486                        (eq (car elem) 'optional))
5487                   ;; This is an optional header.  If the cdr of this
5488                   ;; is something that is nil, then we do not insert
5489                   ;; this header.
5490                   (setq header (cdr elem))
5491                   (or (and (functionp (cdr elem))
5492                            (funcall (cdr elem)))
5493                       (and (boundp (cdr elem))
5494                            (symbol-value (cdr elem)))))
5495                  ((consp elem)
5496                   ;; The element is a cons.  Either the cdr is a
5497                   ;; string to be inserted verbatim, or it is a
5498                   ;; function, and we insert the value returned from
5499                   ;; this function.
5500                   (or (and (stringp (cdr elem))
5501                            (cdr elem))
5502                       (and (functionp (cdr elem))
5503                            (funcall (cdr elem)))))
5504                  ((and (boundp header)
5505                        (symbol-value header))
5506                   ;; The element is a symbol.  We insert the value
5507                   ;; of this symbol, if any.
5508                   (symbol-value header))
5509                  ((not (message-check-element header))
5510                   ;; We couldn't generate a value for this header,
5511                   ;; so we just ask the user.
5512                   (read-from-minibuffer
5513                    (format "Empty header for %s; enter value: " header)))))
5514           ;; Finally insert the header.
5515           (when (and value
5516                      (not (equal value "")))
5517             (save-excursion
5518               (if (bolp)
5519                   (progn
5520                     ;; This header didn't exist, so we insert it.
5521                     (goto-char (point-max))
5522                     (let ((formatter
5523                            (cdr (assq header message-header-format-alist))))
5524                       (if formatter
5525                           (funcall formatter header value)
5526                         (insert (if (stringp header)
5527                                     header (symbol-name header))
5528                                 ": " value))
5529                       ;; We check whether the value was ended by a
5530                       ;; newline.  If now, we insert one.
5531                       (unless (bolp)
5532                         (insert "\n"))
5533                       (forward-line -1)))
5534                 ;; The value of this header was empty, so we clear
5535                 ;; totally and insert the new value.
5536                 (delete-region (point) (gnus-point-at-eol))
5537                 ;; If the header is optional, and the header was
5538                 ;; empty, we can't insert it anyway.
5539                 (unless optionalp
5540                   (insert value)
5541                   (when (bolp)
5542                     (delete-char -1))))
5543               ;; Add the deletable property to the headers that require it.
5544               (and (memq header message-deletable-headers)
5545                    (progn (beginning-of-line) (looking-at "[^:]+: "))
5546                    (add-text-properties
5547                     (point) (match-end 0)
5548                     '(message-deletable t face italic) (current-buffer)))))))
5549       ;; Insert new Sender if the From is strange.
5550       (let ((from (message-fetch-field "from"))
5551             (sender (message-fetch-field "sender"))
5552             (secure-sender (message-make-sender)))
5553         (when (and from
5554                    (not (message-check-element 'sender))
5555                    (not (string=
5556                          (downcase
5557                           (cadr (std11-extract-address-components from)))
5558                          (downcase secure-sender)))
5559                    (or (null sender)
5560                        (not
5561                         (string=
5562                          (downcase
5563                           (cadr (std11-extract-address-components sender)))
5564                          (downcase secure-sender)))))
5565           (goto-char (point-min))
5566           ;; Rename any old Sender headers to Original-Sender.
5567           (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
5568             (beginning-of-line)
5569             (insert "Original-")
5570             (beginning-of-line))
5571           (when (or (message-news-p)
5572                     (string-match "@.+\\.." secure-sender))
5573             (insert "Sender: " secure-sender "\n"))))
5574       ;; Check for IDNA
5575       (message-idna-to-ascii-rhs))))
5576
5577 (defun message-insert-courtesy-copy ()
5578   "Insert a courtesy message in mail copies of combined messages."
5579   (let (newsgroups)
5580     (save-excursion
5581       (save-restriction
5582         (message-narrow-to-headers)
5583         (when (setq newsgroups (message-fetch-field "newsgroups"))
5584           (goto-char (point-max))
5585           (insert "Posted-To: " newsgroups "\n")))
5586       (forward-line 1)
5587       (when message-courtesy-message
5588         (cond
5589          ((string-match "%s" message-courtesy-message)
5590           (insert (format message-courtesy-message newsgroups)))
5591          (t
5592           (insert message-courtesy-message)))))))
5593
5594 ;;;
5595 ;;; Setting up a message buffer
5596 ;;;
5597
5598 (defun message-fill-address (header value)
5599   (save-restriction
5600     (narrow-to-region (point) (point))
5601     (insert (capitalize (symbol-name header))
5602             ": "
5603             (if (consp value) (car value) value)
5604             "\n")
5605     (narrow-to-region (point-min) (1- (point-max)))
5606     (let (quoted last)
5607       (goto-char (point-min))
5608       (while (not (eobp))
5609         (skip-chars-forward "^,\"" (point-max))
5610         (if (or (eq (char-after) ?,)
5611                 (eobp))
5612             (when (not quoted)
5613               (if (and (> (current-column) 78)
5614                        last)
5615                   (save-excursion
5616                     (goto-char last)
5617                     (looking-at "[ \t]*")
5618                     (replace-match "\n " t t)))
5619               (setq last (1+ (point))))
5620           (setq quoted (not quoted)))
5621         (unless (eobp)
5622           (forward-char 1))))
5623     (goto-char (point-max))
5624     (widen)
5625     (forward-line 1)))
5626
5627 (defun message-fill-references (header value)
5628   (insert (capitalize (symbol-name header))
5629           ": "
5630           (std11-fill-msg-id-list-string
5631            (if (consp value) (car value) value))
5632           "\n"))
5633
5634 (defun message-split-line ()
5635   "Split current line, moving portion beyond point vertically down.
5636 If the current line has `message-yank-prefix', insert it on the new line."
5637   (interactive "*")
5638   (condition-case nil
5639       (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
5640     (error
5641      (split-line))))
5642
5643
5644 (defun message-fill-header (header value)
5645   (let ((begin (point))
5646         (fill-column 78)
5647         (fill-prefix " "))
5648     (insert (capitalize (symbol-name header))
5649             ": "
5650             (if (consp value) (car value) value)
5651             "\n")
5652     (save-restriction
5653       (narrow-to-region begin (point))
5654       (fill-region-as-paragraph begin (point))
5655       ;; Tapdance around looong Message-IDs.
5656       (forward-line -1)
5657       (when (looking-at "[ \t]*$")
5658         (message-delete-line))
5659       (goto-char begin)
5660       (re-search-forward ":" nil t)
5661       (when (looking-at "\n[ \t]+")
5662         (replace-match " " t t))
5663       (goto-char (point-max)))))
5664
5665 (defun message-shorten-1 (list cut surplus)
5666   "Cut SURPLUS elements out of LIST, beginning with CUTth one."
5667   (setcdr (nthcdr (- cut 2) list)
5668           (nthcdr (+ (- cut 2) surplus 1) list)))
5669
5670 (defun message-shorten-references (header references)
5671   "Trim REFERENCES to be 21 Message-ID long or less, and fold them.
5672 If folding is disallowed, also check that the REFERENCES are less
5673 than 988 characters long, and if they are not, trim them until they are."
5674   (let ((maxcount 21)
5675         (count 0)
5676         (cut 2)
5677         refs)
5678     (with-temp-buffer
5679       (insert references)
5680       (goto-char (point-min))
5681       ;; Cons a list of valid references.
5682       (while (re-search-forward "<[^>]+>" nil t)
5683         (push (match-string 0) refs))
5684       (setq refs (nreverse refs)
5685             count (length refs)))
5686
5687     ;; If the list has more than MAXCOUNT elements, trim it by
5688     ;; removing the CUTth element and the required number of
5689     ;; elements that follow.
5690     (when (> count maxcount)
5691       (let ((surplus (- count maxcount)))
5692         (message-shorten-1 refs cut surplus)
5693         (decf count surplus)))
5694
5695     ;; If folding is disallowed, make sure the total length (including
5696     ;; the spaces between) will be less than MAXSIZE characters.
5697     ;;
5698     ;; Only disallow folding for News messages. At this point the headers
5699     ;; have not been generated, thus we use message-this-is-news directly.
5700     (when (and message-this-is-news message-cater-to-broken-inn)
5701       (let ((maxsize 988)
5702             (totalsize (+ (apply #'+ (mapcar #'length refs))
5703                           (1- count)))
5704             (surplus 0)
5705             (ptr (nthcdr (1- cut) refs)))
5706         ;; Decide how many elements to cut off...
5707         (while (> totalsize maxsize)
5708           (decf totalsize (1+ (length (car ptr))))
5709           (incf surplus)
5710           (setq ptr (cdr ptr)))
5711         ;; ...and do it.
5712         (when (> surplus 0)
5713           (message-shorten-1 refs cut surplus))))
5714
5715     ;; Finally, collect the references back into a string and insert
5716     ;; it into the buffer.
5717     (let ((refstring (mapconcat #'identity refs " ")))
5718       (if (and message-this-is-news message-cater-to-broken-inn)
5719           (insert (capitalize (symbol-name header)) ": "
5720                   refstring "\n")
5721         (message-fill-header header refstring)))))
5722
5723 (defun message-position-point ()
5724   "Move point to where the user probably wants to find it."
5725   (message-narrow-to-headers)
5726   (cond
5727    ((re-search-forward "^[^:]+:[ \t]*$" nil t)
5728     (search-backward ":" )
5729     (widen)
5730     (forward-char 1)
5731     (if (eq (char-after) ? )
5732         (forward-char 1)
5733       (insert " ")))
5734    (t
5735     (goto-char (point-max))
5736     (widen)
5737     (forward-line 1)
5738     (unless (looking-at "$")
5739       (forward-line 2)))
5740    (sit-for 0)))
5741
5742 (defcustom message-beginning-of-line t
5743   "Whether \\<message-mode-map>\\[message-beginning-of-line]\
5744  goes to beginning of header values."
5745   :group 'message-buffers
5746   :type 'boolean)
5747
5748 (defun message-beginning-of-line (&optional n)
5749   "Move point to beginning of header value or to beginning of line.
5750 The prefix argument N is passed directly to `beginning-of-line'.
5751
5752 This command is identical to `beginning-of-line' if point is
5753 outside the message header or if the option `message-beginning-of-line'
5754 is nil.
5755
5756 If point is in the message header and on a (non-continued) header
5757 line, move point to the beginning of the header value.  If point
5758 is already there, move point to beginning of line.  Therefore,
5759 repeated calls will toggle point between beginning of field and
5760 beginning of line."
5761   (interactive "p")
5762   (let ((zrs 'zmacs-region-stays))
5763     (when (and (interactive-p) (boundp zrs))
5764       (set zrs t)))
5765   (if (and message-beginning-of-line
5766            (message-point-in-header-p))
5767       (let* ((here (point))
5768              (bol (progn (beginning-of-line n) (point)))
5769              (eol (gnus-point-at-eol))
5770              (eoh (re-search-forward ": *" eol t)))
5771         (if (or (not eoh) (equal here eoh))
5772             (goto-char bol)
5773           (goto-char eoh)))
5774     (beginning-of-line n)))
5775
5776 (defun message-buffer-name (type &optional to group)
5777   "Return a new (unique) buffer name based on TYPE and TO."
5778   (cond
5779    ;; Generate a new buffer name The Message Way.
5780    ((eq message-generate-new-buffers 'unique)
5781     (generate-new-buffer-name
5782      (concat "*" type
5783              (if to
5784                  (concat " to "
5785                          (or (car (std11-extract-address-components to))
5786                              to) "")
5787                "")
5788              (if (and group (not (string= group ""))) (concat " on " group) "")
5789              "*")))
5790    ;; Check whether `message-generate-new-buffers' is a function,
5791    ;; and if so, call it.
5792    ((functionp message-generate-new-buffers)
5793     (funcall message-generate-new-buffers type to group))
5794    ((eq message-generate-new-buffers 'unsent)
5795     (generate-new-buffer-name
5796      (concat "*unsent " type
5797              (if to
5798                  (concat " to "
5799                          (or (car (std11-extract-address-components to))
5800                              to) "")
5801                "")
5802              (if (and group (not (string= group ""))) (concat " on " group) "")
5803              "*")))
5804    ;; Use standard name.
5805    (t
5806     (format "*%s message*" type))))
5807
5808 (defmacro message-pop-to-buffer-1 (buffer)
5809   `(if pop-up-frames
5810        (let (special-display-buffer-names
5811              special-display-regexps
5812              same-window-buffer-names
5813              same-window-regexps)
5814          (pop-to-buffer ,buffer))
5815      (pop-to-buffer ,buffer)))
5816
5817 (defun message-pop-to-buffer (name)
5818   "Pop to buffer NAME, and warn if it already exists and is modified."
5819   (let ((buffer (get-buffer name))
5820         (pop-up-frames (and (or (static-if (featurep 'xemacs)
5821                                     (device-on-window-system-p)
5822                                   window-system)
5823                                 (>= emacs-major-version 20))
5824                             message-use-multi-frames)))
5825     (if (and buffer
5826              (buffer-name buffer))
5827         (progn
5828           (message-pop-to-buffer-1 buffer)
5829           (when (and (buffer-modified-p)
5830                      (not (y-or-n-p
5831                            "Message already being composed; erase? ")))
5832             (error "Message being composed")))
5833       (message-pop-to-buffer-1 name))
5834     (erase-buffer)
5835     (message-mode)
5836     (when pop-up-frames
5837       (set (make-local-variable 'message-original-frame) (selected-frame)))))
5838
5839 (defun message-do-send-housekeeping ()
5840   "Kill old message buffers."
5841   ;; We might have sent this buffer already.  Delete it from the
5842   ;; list of buffers.
5843   (setq message-buffer-list (delq (current-buffer) message-buffer-list))
5844   (while (and message-max-buffers
5845               message-buffer-list
5846               (>= (length message-buffer-list) message-max-buffers))
5847     ;; Kill the oldest buffer -- unless it has been changed.
5848     (let ((buffer (pop message-buffer-list)))
5849       (when (and (buffer-name buffer)
5850                  (not (buffer-modified-p buffer)))
5851         (kill-buffer buffer))))
5852   ;; Rename the buffer.
5853   (if message-send-rename-function
5854       (funcall message-send-rename-function)
5855     ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
5856     (when (string-match
5857            "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
5858            (buffer-name))
5859       (let ((name (match-string 2 (buffer-name)))
5860             to group)
5861         (if (not (or (null name)
5862                      (string-equal name "mail")
5863                      (string-equal name "posting")))
5864             (setq name (concat "*sent " name "*"))
5865           (message-narrow-to-headers)
5866           (setq to (message-fetch-field "to"))
5867           (setq group (message-fetch-field "newsgroups"))
5868           (widen)
5869           (setq name
5870                 (cond
5871                  (to (concat "*sent mail to "
5872                              (or (car (std11-extract-address-components to))
5873                                  to) "*"))
5874                  ((and group (not (string= group "")))
5875                   (concat "*sent posting on " group "*"))
5876                  (t "*sent mail*"))))
5877         (unless (string-equal name (buffer-name))
5878           (rename-buffer name t)))))
5879   ;; Push the current buffer onto the list.
5880   (when message-max-buffers
5881     (setq message-buffer-list
5882           (nconc message-buffer-list (list (current-buffer))))))
5883
5884 (defun message-mail-user-agent ()
5885   (let ((mua (cond
5886               ((not message-mail-user-agent) nil)
5887               ((eq message-mail-user-agent t) mail-user-agent)
5888               (t message-mail-user-agent))))
5889     (if (memq mua '(message-user-agent gnus-user-agent))
5890         nil
5891       mua)))
5892
5893 (defun message-setup (headers &optional replybuffer actions switch-function)
5894   (let ((mua (message-mail-user-agent))
5895         subject to field yank-action)
5896     (if (not (and message-this-is-mail mua))
5897         (message-setup-1 headers replybuffer actions)
5898       (if replybuffer
5899           (setq yank-action (list 'insert-buffer replybuffer)))
5900       (setq headers (copy-sequence headers))
5901       (setq field (assq 'Subject headers))
5902       (when field
5903         (setq subject (cdr field))
5904         (setq headers (delq field headers)))
5905       (setq field (assq 'To headers))
5906       (when field
5907         (setq to (cdr field))
5908         (setq headers (delq field headers)))
5909       (let ((mail-user-agent mua))
5910         (compose-mail to subject
5911                       (mapcar (lambda (item)
5912                                 (cons
5913                                  (format "%s" (car item))
5914                                  (cdr item)))
5915                               headers)
5916                       nil switch-function yank-action actions)))))
5917
5918 (defun message-headers-to-generate (headers included-headers excluded-headers)
5919   "Return a list that includes all headers from HEADERS.
5920 If INCLUDED-HEADERS is a list, just include those headers.  If if is
5921 t, include all headers.  In any case, headers from EXCLUDED-HEADERS
5922 are not included."
5923   (let ((result nil)
5924         header-name)
5925     (dolist (header headers)
5926       (setq header-name (cond
5927                          ((and (consp header)
5928                                (eq (car header) 'optional))
5929                           ;; On the form (optional . Header)
5930                           (cdr header))
5931                          ((consp header)
5932                           ;; On the form (Header . function)
5933                           (car header))
5934                          (t
5935                           ;; Just a Header.
5936                           header)))
5937       (when (and (not (memq header-name excluded-headers))
5938                  (or (eq included-headers t)
5939                      (memq header-name included-headers)))
5940         (push header result)))
5941     (nreverse result)))
5942
5943 (defun message-setup-1 (headers &optional replybuffer actions)
5944   (dolist (action actions)
5945     (condition-case nil
5946         (add-to-list 'message-send-actions
5947                      `(apply ',(car action) ',(cdr action)))))
5948   (setq message-reply-buffer
5949         (or (message-get-parameter 'reply-buffer)
5950             replybuffer))
5951   (goto-char (point-min))
5952   ;; Insert all the headers.
5953   (mail-header-format
5954    (let ((h headers)
5955          (alist message-header-format-alist))
5956      (while h
5957        (unless (assq (caar h) message-header-format-alist)
5958          (push (list (caar h)) alist))
5959        (pop h))
5960      alist)
5961    headers)
5962   (delete-region (point) (progn (forward-line -1) (point)))
5963   (when message-default-headers
5964     (insert message-default-headers)
5965     (or (bolp) (insert ?\n)))
5966   (put-text-property
5967    (point)
5968    (progn
5969      (insert mail-header-separator "\n")
5970      (1- (point)))
5971    'read-only nil)
5972   (forward-line -1)
5973   (when (message-news-p)
5974     (when message-default-news-headers
5975       (insert message-default-news-headers)
5976       (or (bolp) (insert ?\n)))
5977     (when message-generate-headers-first
5978       (message-generate-headers
5979        (message-headers-to-generate
5980         (append message-required-news-headers
5981                 message-required-headers)
5982         message-generate-headers-first
5983         '(Lines Subject)))))
5984   (when (message-mail-p)
5985     (when message-default-mail-headers
5986       (insert message-default-mail-headers)
5987       (or (bolp) (insert ?\n)))
5988     (save-restriction
5989       (message-narrow-to-headers)
5990       (if (and replybuffer
5991                message-alternative-emails)
5992           (message-use-alternative-email-as-from)))
5993     (when message-generate-headers-first
5994       (message-generate-headers
5995        (message-headers-to-generate
5996         (append message-required-mail-headers
5997                 message-required-headers)
5998         message-generate-headers-first
5999         '(Lines Subject)))))
6000   (run-hooks 'message-signature-setup-hook)
6001   (message-insert-signature)
6002   (save-restriction
6003     (message-narrow-to-headers)
6004     (run-hooks 'message-header-setup-hook))
6005   (set-buffer-modified-p nil)
6006   (setq buffer-undo-list nil)
6007   (run-hooks 'message-setup-hook)
6008   (message-position-point)
6009   (undo-boundary))
6010
6011 (defun message-set-auto-save-file-name ()
6012   "Associate the message buffer with a file in the drafts directory."
6013   (when message-auto-save-directory
6014     (unless (file-directory-p
6015              (directory-file-name message-auto-save-directory))
6016       (make-directory message-auto-save-directory t))
6017     (if (gnus-alive-p)
6018         (setq message-draft-article
6019               (nndraft-request-associate-buffer "drafts"))
6020       (setq buffer-file-name (expand-file-name
6021                               (if (memq system-type
6022                                         '(ms-dos ms-windows windows-nt
6023                                                  cygwin cygwin32 win32 w32
6024                                                  mswindows))
6025                                   "message"
6026                                 "*message*")
6027                               message-auto-save-directory))
6028       (setq buffer-auto-save-file-name (make-auto-save-file-name)))
6029     (clear-visited-file-modtime)
6030     (static-if (boundp 'MULE)
6031         (set-file-coding-system message-draft-coding-system)
6032       (setq buffer-file-coding-system message-draft-coding-system))))
6033
6034 (defun message-disassociate-draft ()
6035   "Disassociate the message buffer from the drafts directory."
6036   (when message-draft-article
6037     (nndraft-request-expire-articles
6038      (list message-draft-article) "drafts" nil t)))
6039
6040 (defun message-insert-headers ()
6041   "Generate the headers for the article."
6042   (interactive)
6043   (save-excursion
6044     (save-restriction
6045       (message-narrow-to-headers)
6046       (when (message-news-p)
6047         (message-generate-headers
6048          (delq 'Lines
6049                (delq 'Subject
6050                      (copy-sequence message-required-news-headers)))))
6051       (when (message-mail-p)
6052         (message-generate-headers
6053          (delq 'Lines
6054                (delq 'Subject
6055                      (copy-sequence message-required-mail-headers))))))))
6056
6057 \f
6058
6059 ;;;
6060 ;;; Commands for interfacing with message
6061 ;;;
6062
6063 ;;;###autoload
6064 (defun message-mail (&optional to subject
6065                                other-headers continue switch-function
6066                                yank-action send-actions)
6067   "Start editing a mail message to be sent.
6068 OTHER-HEADERS is an alist of header/value pairs."
6069   (interactive)
6070   (let ((message-this-is-mail t) replybuffer)
6071     (unless (message-mail-user-agent)
6072       (message-pop-to-buffer (message-buffer-name "mail" to)))
6073     ;; FIXME: message-mail should do something if YANK-ACTION is not
6074     ;; insert-buffer.
6075     (and (consp yank-action) (eq (car yank-action) 'insert-buffer)
6076          (setq replybuffer (nth 1 yank-action)))
6077     (message-setup
6078      (nconc
6079       `((To . ,(or to "")) (Subject . ,(or subject "")))
6080       (when other-headers other-headers))
6081      replybuffer send-actions)
6082     ;; FIXME: Should return nil if failure.
6083     t))
6084
6085 ;;;###autoload
6086 (defun message-news (&optional newsgroups subject)
6087   "Start editing a news article to be sent."
6088   (interactive)
6089   (let ((message-this-is-news t))
6090     (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))
6091     (message-setup `((Newsgroups . ,(or newsgroups ""))
6092                      (Subject . ,(or subject ""))))))
6093
6094 (defun message-get-reply-headers (wide &optional to-address address-headers)
6095   (let (follow-to mct never-mct to cc author mft recipients)
6096     ;; Find all relevant headers we need.
6097     (let ((mrt (when message-use-mail-reply-to
6098                  (message-fetch-field "mail-reply-to")))
6099           (reply-to (message-fetch-field "reply-to")))
6100       (setq to (message-fetch-field "to")
6101             cc (message-fetch-field "cc")
6102             mct (when message-use-mail-copies-to
6103                   (message-fetch-field "mail-copies-to"))
6104             author (or mrt
6105                        reply-to
6106                        (message-fetch-field "from")
6107                        "")
6108             mft (when (and (not (or to-address mrt reply-to))
6109                            message-use-mail-followup-to)
6110                   (message-fetch-field "mail-followup-to"))))
6111
6112     (save-match-data
6113       ;; Handle special values of Mail-Copies-To.
6114       (when mct
6115         (cond ((or (equal (downcase mct) "never")
6116                    (equal (downcase mct) "nobody"))
6117                (when (or (not (eq message-use-mail-copies-to 'ask))
6118                          (message-y-or-n-p
6119                           (concat "Obey Mail-Copies-To: never? ") t "\
6120 You should normally obey the Mail-Copies-To: header.
6121
6122         `Mail-Copies-To: " mct "'
6123 directs you not to send your response to the author."))
6124                  (setq never-mct t))
6125                (setq mct nil))
6126               ((or (equal (downcase mct) "always")
6127                    (equal (downcase mct) "poster"))
6128                (if (or (not (eq message-use-mail-copies-to 'ask))
6129                        (message-y-or-n-p
6130                         (concat "Obey Mail-Copies-To: always? ") t "\
6131 You should normally obey the Mail-Copies-To: header.
6132
6133         `Mail-Copies-To: " mct "'
6134 sends a copy of your response to the author."))
6135                    (setq mct author)
6136                  (setq mct nil)))
6137               ((and (eq message-use-mail-copies-to 'ask)
6138                     (not (message-y-or-n-p
6139                           (concat "Obey Mail-Copies-To: " mct " ? ") t "\
6140 You should normally obey the Mail-Copies-To: header.
6141
6142         `Mail-Copies-To: " mct "'
6143 sends a copy of your response to " (if (string-match "," mct)
6144                                        "the specified addresses"
6145                                      "that address") ".")))
6146                (setq mct nil))))
6147
6148       ;; Build (textual) list of new recipient addresses.
6149       (cond
6150        ((not wide)
6151         (setq recipients (concat ", " author)))
6152        (address-headers
6153         (dolist (header address-headers)
6154           (let ((value (message-fetch-field header)))
6155             (when value
6156               (setq recipients (concat recipients ", " value))))))
6157        ((and mft
6158              (string-match "[^ \t,]" mft)
6159              (or (not (eq message-use-mail-followup-to 'ask))
6160                  (message-y-or-n-p "Obey Mail-Followup-To? " t "\
6161 You should normally obey the Mail-Followup-To: header.  In this
6162 article, it has the value of
6163
6164 " mft "
6165
6166 which directs your response to " (if (string-match "," mft)
6167                                      "the specified addresses"
6168                                    "that address only") ".
6169
6170 Most commonly, Mail-Followup-To is used by a mailing list poster to
6171 express that responses should be sent to just the list, and not the
6172 poster as well.
6173
6174 If a message is posted to several mailing lists, Mail-Followup-To may
6175 also be used to direct the following discussion to one list only,
6176 because discussions that are spread over several lists tend to be
6177 fragmented and very difficult to follow.
6178
6179 Also, some source/announcement lists are not intended for discussion;
6180 responses here are directed to other addresses.")))
6181         (setq recipients (concat ", " mft)))
6182        (to-address
6183         (setq recipients (concat ", " to-address))
6184         ;; If the author explicitly asked for a copy, we don't deny it to them.
6185         (if mct (setq recipients (concat recipients ", " mct))))
6186        (t
6187         (setq recipients (if never-mct "" (concat ", " author)))
6188         (if to  (setq recipients (concat recipients ", " to)))
6189         (if cc  (setq recipients (concat recipients ", " cc)))
6190         (if mct (setq recipients (concat recipients ", " mct)))))
6191       (if (>= (length recipients) 2)
6192           ;; Strip the leading ", ".
6193           (setq recipients (substring recipients 2)))
6194       ;; Squeeze whitespace.
6195       (while (string-match "[ \t][ \t]+" recipients)
6196         (setq recipients (replace-match " " t t recipients)))
6197       ;; Remove addresses that match `rmail-dont-reply-to-names'.
6198       (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
6199         (setq recipients (rmail-dont-reply-to recipients)))
6200       ;; Perhaps "Mail-Copies-To: never" removed the only address?
6201       (if (string-equal recipients "")
6202           (setq recipients author))
6203       ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...).
6204       (setq recipients
6205             (mapcar
6206              (lambda (addr)
6207                (cons (downcase (mail-strip-quoted-names addr)) addr))
6208              (message-tokenize-header recipients)))
6209       ;; Remove first duplicates.  (Why not all duplicates?  Is this a bug?)
6210       (let ((s recipients))
6211         (while s
6212           (setq recipients (delq (assoc (car (pop s)) s) recipients))))
6213
6214       ;; Remove hierarchical lists that are contained within each other,
6215       ;; if message-hierarchical-addresses is defined.
6216       (when message-hierarchical-addresses
6217         (let ((plain-addrs (mapcar 'car recipients))
6218               subaddrs recip)
6219           (while plain-addrs
6220             (setq subaddrs (assoc (car plain-addrs)
6221                                   message-hierarchical-addresses)
6222                   plain-addrs (cdr plain-addrs))
6223             (when subaddrs
6224               (setq subaddrs (cdr subaddrs))
6225               (while subaddrs
6226                 (setq recip (assoc (car subaddrs) recipients)
6227                       subaddrs (cdr subaddrs))
6228                 (if recip
6229                     (setq recipients (delq recip recipients))))))))
6230
6231       ;; Build the header alist.  Allow the user to be asked whether
6232       ;; or not to reply to all recipients in a wide reply.
6233       (setq follow-to (list (cons 'To (cdr (pop recipients)))))
6234       (when (and recipients
6235                  (or (not message-wide-reply-confirm-recipients)
6236                      (y-or-n-p "Reply to all recipients? ")))
6237         (setq recipients (mapconcat
6238                           (lambda (addr) (cdr addr)) recipients ", "))
6239         (if (string-match "^ +" recipients)
6240             (setq recipients (substring recipients (match-end 0))))
6241         (push (cons 'Cc recipients) follow-to)))
6242     follow-to))
6243
6244 ;;;###autoload
6245 (defun message-reply (&optional to-address wide)
6246   "Start editing a reply to the article in the current buffer."
6247   (interactive)
6248   (require 'gnus-sum)                   ; for gnus-list-identifiers
6249   (let ((cur (current-buffer))
6250         from subject date
6251         references message-id follow-to
6252         (inhibit-point-motion-hooks t)
6253         (message-this-is-mail t)
6254         gnus-warning in-reply-to)
6255     (save-restriction
6256       (message-narrow-to-head-1)
6257       ;; Allow customizations to have their say.
6258       (if (not wide)
6259           ;; This is a regular reply.
6260           (when (functionp message-reply-to-function)
6261             (save-excursion
6262               (setq follow-to (funcall message-reply-to-function))))
6263         ;; This is a followup.
6264         (when (functionp message-wide-reply-to-function)
6265           (save-excursion
6266             (setq follow-to
6267                   (funcall message-wide-reply-to-function)))))
6268       (setq message-id (message-fetch-field "message-id" t)
6269             references (message-fetch-field "references")
6270             date (message-fetch-field "date")
6271             from (message-fetch-field "from")
6272             subject (or (message-fetch-field "subject") "none"))
6273       (when gnus-list-identifiers
6274         (setq subject (message-strip-list-identifiers subject)))
6275       (setq subject (message-make-followup-subject subject))
6276       (when message-subject-trailing-was-query
6277         (setq subject (message-strip-subject-trailing-was subject)))
6278
6279       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
6280                  (string-match "<[^>]+>" gnus-warning))
6281         (setq message-id (match-string 0 gnus-warning)))
6282
6283       (unless follow-to
6284         (setq follow-to (message-get-reply-headers wide to-address)))
6285
6286       ;; Get the references from "In-Reply-To" field if there were
6287       ;; no references and "In-Reply-To" field looks promising.
6288       (unless references
6289         (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
6290                    (string-match "<[^>]+>" in-reply-to))
6291           (setq references (match-string 0 in-reply-to)))))
6292
6293     (unless (message-mail-user-agent)
6294       (message-pop-to-buffer
6295        (message-buffer-name
6296         (if wide "wide reply" "reply") from
6297         (if wide to-address nil))))
6298
6299     (setq message-reply-headers
6300           (make-full-mail-header-from-decoded-header
6301            0 subject from date message-id references 0 0 ""))
6302
6303     (message-setup
6304      `((Subject . ,subject)
6305        ,@follow-to)
6306      cur)))
6307
6308 ;;;###autoload
6309 (defun message-wide-reply (&optional to-address)
6310   "Make a \"wide\" reply to the message in the current buffer."
6311   (interactive)
6312   (message-reply to-address t))
6313
6314 ;;;###autoload
6315 (defun message-followup (&optional to-newsgroups)
6316   "Follow up to the message in the current buffer.
6317 If TO-NEWSGROUPS, use that as the new Newsgroups line."
6318   (interactive)
6319   (require 'gnus-sum)                   ; for gnus-list-identifiers
6320   (let ((cur (current-buffer))
6321         from subject date reply-to mrt mct mft
6322         references message-id follow-to
6323         (inhibit-point-motion-hooks t)
6324         (message-this-is-news t)
6325         followup-to distribution newsgroups gnus-warning posted-to)
6326     (save-restriction
6327       (message-narrow-to-head)
6328       (when (functionp message-followup-to-function)
6329         (setq follow-to
6330               (funcall message-followup-to-function)))
6331       (setq from (message-fetch-field "from")
6332             date (message-fetch-field "date")
6333             subject (or (message-fetch-field "subject") "none")
6334             references (message-fetch-field "references")
6335             message-id (message-fetch-field "message-id" t)
6336             followup-to (message-fetch-field "followup-to")
6337             newsgroups (message-fetch-field "newsgroups")
6338             posted-to (message-fetch-field "posted-to")
6339             reply-to (message-fetch-field "reply-to")
6340             mrt (when message-use-mail-reply-to
6341                   (message-fetch-field "mail-reply-to"))
6342             distribution (message-fetch-field "distribution")
6343             mct (when message-use-mail-copies-to
6344                   (message-fetch-field "mail-copies-to"))
6345             mft (when message-use-mail-followup-to
6346                   (message-fetch-field "mail-followup-to")))
6347       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
6348                  (string-match "<[^>]+>" gnus-warning))
6349         (setq message-id (match-string 0 gnus-warning)))
6350       ;; Remove bogus distribution.
6351       (when (and (stringp distribution)
6352                  (let ((case-fold-search t))
6353                    (string-match "world" distribution)))
6354         (setq distribution nil))
6355       (if gnus-list-identifiers
6356           (setq subject (message-strip-list-identifiers subject)))
6357       (setq subject (message-make-followup-subject subject))
6358       (when message-subject-trailing-was-query
6359         (setq subject (message-strip-subject-trailing-was subject)))
6360       (widen))
6361
6362     ;; Handle special values of Mail-Copies-To.
6363     (when mct
6364       (cond
6365        ((and (or (equal (downcase mct) "never")
6366                  (equal (downcase mct) "nobody")))
6367         (setq mct nil))
6368        ((and (or (equal (downcase mct) "always")
6369                  (equal (downcase mct) "poster")))
6370         (if (or (not (eq message-use-mail-copies-to 'ask))
6371                 (message-y-or-n-p
6372                  (concat "Obey Mail-Copies-To: always? ") t "\
6373 You should normally obey the Mail-Copies-To: header.
6374
6375         `Mail-Copies-To: " mct "'
6376 sends a copy of your response to the author."))
6377             (setq mct (or mrt reply-to from))
6378           (setq mct nil)))
6379        ((and (eq message-use-mail-copies-to 'ask)
6380              (not
6381               (message-y-or-n-p
6382                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
6383 You should normally obey the Mail-Copies-To: header.
6384
6385         `Mail-Copies-To: " mct "'
6386 sends a copy of your response to " (if (string-match "," mct)
6387                                        "the specified addresses"
6388                                      "that address") ".")))
6389         (setq mct nil))))
6390
6391     (unless follow-to
6392       (cond
6393        (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups))))
6394        ;; Handle Followup-To.
6395        (followup-to
6396         (cond
6397          ((equal (downcase followup-to) "poster")
6398           (if (or (and followup-to (eq message-use-followup-to 'use))
6399                   (message-y-or-n-p "Obey Followup-To: poster? " t "\
6400 You should normally obey the Followup-To: header.
6401
6402         `Followup-To: poster'
6403 sends your response via e-mail instead of news.
6404
6405 A typical situation where `Followup-To: poster' is used is when the author
6406 does not read the newsgroup, so he wouldn't see any replies sent to it."))
6407               (setq message-this-is-news nil
6408                     distribution nil
6409                     follow-to (list (cons 'To (or mrt reply-to from ""))))
6410             (setq follow-to (list (cons 'Newsgroups newsgroups)))))
6411          (t
6412           (if (or (equal followup-to newsgroups)
6413                   (not (and followup-to (eq message-use-followup-to 'ask)))
6414                   (message-y-or-n-p
6415                    (concat "Obey Followup-To: " followup-to "? ") t "\
6416 You should normally obey the Followup-To: header.
6417
6418         `Followup-To: " followup-to "'
6419 directs your response to " (if (string-match "," followup-to)
6420                                "the specified newsgroups"
6421                              "that newsgroup only") ".
6422
6423 If a message is posted to several newsgroups, Followup-To is often
6424 used to direct the following discussion to one newsgroup only,
6425 because discussions that are spread over several newsgroup tend to
6426 be fragmented and very difficult to follow.
6427
6428 Also, some source/announcement newsgroups are not intended for discussion;
6429 responses here are directed to other newsgroups."))
6430               (setq follow-to (list (cons 'Newsgroups followup-to)))
6431             (setq follow-to (list (cons 'Newsgroups newsgroups)))))))
6432        ;; Handle Mail-Followup-To, followup via e-mail.
6433        ((and mft
6434              (or (not (eq message-use-mail-followup-to 'ask))
6435                  (message-y-or-n-p
6436                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
6437 You should normally obey the Mail-Followup-To: header.
6438
6439         `Mail-Followup-To: " mft "'
6440 directs your response to " (if (string-match "," mft)
6441                                "the specified addresses"
6442                              "that address only") " instead of news.
6443
6444 A typical situation where Mail-Followup-To is used is when the author thinks
6445 that further discussion should take place only in "
6446                              (if (string-match "," mft)
6447                                  "the specified mailing lists"
6448                                "that mailing list") ".")))
6449         (setq message-this-is-news nil
6450               distribution nil
6451               follow-to (list (cons 'To mft))))
6452        (posted-to (setq follow-to (list (cons 'Newsgroups posted-to))))
6453        (t
6454         (setq follow-to (list (cons 'Newsgroups newsgroups))))))
6455
6456     (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
6457
6458     (setq message-reply-headers
6459           (make-full-mail-header-from-decoded-header
6460            0 subject from date message-id references 0 0 ""))
6461
6462     (message-setup
6463      `((Subject . ,subject)
6464        ,@follow-to
6465        ,@(and mct (list (cons 'Cc mct)))
6466        ,@(and distribution (list (cons 'Distribution distribution))))
6467      cur)))
6468
6469 (defun message-is-yours-p ()
6470   "Non-nil means current article is yours.
6471 If you have added 'cancel-messages to 'message-shoot-gnksa-feet', all articles
6472 are yours except those that have Cancel-Lock header not belonging to you.
6473 Instead of shooting GNKSA feet, you should modify 'message-alternative-emails'
6474 regexp to match all of yours addresses."
6475   ;; Canlock-logic as suggested by Per Abrahamsen
6476   ;; <abraham@dina.kvl.dk>
6477   ;;
6478   ;; IF article has cancel-lock THEN
6479   ;;   IF we can verify it THEN
6480   ;;     issue cancel
6481   ;;   ELSE
6482   ;;     error: cancellock: article is not yours
6483   ;; ELSE
6484   ;;   Use old rules, comparing sender...
6485   (save-excursion
6486     (save-restriction
6487       (message-narrow-to-head-1)
6488       (if (message-fetch-field "Cancel-Lock")
6489           (if (null (canlock-verify))
6490               t
6491             (error "Failed to verify Cancel-lock: This article is not yours"))
6492         (let (sender from)
6493           (or
6494            (message-gnksa-enable-p 'cancel-messages)
6495            (and (setq sender (message-fetch-field "sender"))
6496                 (string-equal (downcase sender)
6497                               (downcase (message-make-sender))))
6498            ;; Email address in From field equals to our address
6499            (and (setq from (message-fetch-field "from"))
6500                 (string-equal
6501                  (downcase (cadr (std11-extract-address-components from)))
6502                  (downcase (cadr (std11-extract-address-components
6503                                   (message-make-from))))))
6504            ;; Email address in From field matches
6505            ;; 'message-alternative-emails' regexp
6506            (and from
6507                 message-alternative-emails
6508                 (string-match
6509                  message-alternative-emails
6510                  (cadr (std11-extract-address-components from))))))))))
6511
6512 ;;;###autoload
6513 (defun message-cancel-news (&optional arg)
6514   "Cancel an article you posted.
6515 If ARG, allow editing of the cancellation message."
6516   (interactive "P")
6517   (unless (message-news-p)
6518     (error "This is not a news article; canceling is impossible"))
6519   (let (from newsgroups message-id distribution buf)
6520     (save-excursion
6521       ;; Get header info from original article.
6522       (save-restriction
6523         (message-narrow-to-head-1)
6524         (setq from (message-fetch-field "from")
6525               newsgroups (message-fetch-field "newsgroups")
6526               message-id (message-fetch-field "message-id" t)
6527               distribution (message-fetch-field "distribution")))
6528       ;; Make sure that this article was written by the user.
6529       (unless (message-is-yours-p)
6530         (error "This article is not yours"))
6531       (when (yes-or-no-p "Do you really want to cancel this article? ")
6532         ;; Make control message.
6533         (if arg
6534             (message-news)
6535           (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
6536         (erase-buffer)
6537         (insert "Newsgroups: " newsgroups "\n"
6538                 "From: " from "\n"
6539                 "Subject: cmsg cancel " message-id "\n"
6540                 "Control: cancel " message-id "\n"
6541                 (if distribution
6542                     (concat "Distribution: " distribution "\n")
6543                   "")
6544                 mail-header-separator "\n"
6545                 message-cancel-message)
6546         (run-hooks 'message-cancel-hook)
6547         (unless arg
6548           (message "Canceling your article...")
6549           (if (let ((message-syntax-checks
6550                      'dont-check-for-anything-just-trust-me)
6551                     (message-encoding-buffer (current-buffer))
6552                     (message-edit-buffer (current-buffer)))
6553                 (message-send-news))
6554               (message "Canceling your article...done"))
6555           (kill-buffer buf))))))
6556
6557 (defun message-supersede-setup-for-mime-edit ()
6558   (set (make-local-variable 'message-setup-hook) nil)
6559   (mime-edit-again))
6560
6561 ;;;###autoload
6562 (defun message-supersede ()
6563   "Start composing a message to supersede the current message.
6564 This is done simply by taking the old article and adding a Supersedes
6565 header line with the old Message-ID."
6566   (interactive)
6567   (let ((cur (current-buffer)))
6568     ;; Check whether the user owns the article that is to be superseded.
6569     (unless (message-is-yours-p)
6570       (error "This article is not yours"))
6571     ;; Get a normal message buffer.
6572     (message-pop-to-buffer (message-buffer-name "supersede"))
6573     (insert-buffer-substring cur)
6574     (message-narrow-to-head-1)
6575     ;; Remove unwanted headers.
6576     (when message-ignored-supersedes-headers
6577       (message-remove-header message-ignored-supersedes-headers t))
6578     (goto-char (point-min))
6579     (if (not (re-search-forward "^Message-ID: " nil t))
6580         (error "No Message-ID in this article")
6581       (replace-match "Supersedes: " t t))
6582     (goto-char (point-max))
6583     (insert mail-header-separator)
6584     (widen)
6585     (when message-supersede-setup-function
6586       (funcall message-supersede-setup-function))
6587     (run-hooks 'message-supersede-setup-hook)
6588     (goto-char (point-min))
6589     (search-forward (concat "\n" mail-header-separator "\n") nil t)))
6590
6591 ;;;###autoload
6592 (defun message-recover ()
6593   "Reread contents of current buffer from its last auto-save file."
6594   (interactive)
6595   (let ((file-name (make-auto-save-file-name)))
6596     (cond ((save-window-excursion
6597              (if (not (eq system-type 'vax-vms))
6598                  (with-output-to-temp-buffer "*Directory*"
6599                    (with-current-buffer standard-output
6600                      (fundamental-mode)) ; for Emacs 20.4+
6601                    (buffer-disable-undo standard-output)
6602                    (let ((default-directory "/"))
6603                      (call-process
6604                       "ls" nil standard-output nil "-l" file-name))))
6605              (yes-or-no-p (format "Recover auto save file %s? " file-name)))
6606            (let ((buffer-read-only nil))
6607              (erase-buffer)
6608              (insert-file-contents file-name nil)))
6609           (t (error "message-recover cancelled")))))
6610
6611 ;;; Washing Subject:
6612
6613 (defun message-wash-subject (subject)
6614   "Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT.
6615 Previous forwarders, replyers, etc. may add it."
6616   (with-temp-buffer
6617     (insert subject)
6618     (goto-char (point-min))
6619     ;; strip Re/Fwd stuff off the beginning
6620     (while (re-search-forward
6621             "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
6622       (replace-match ""))
6623
6624     ;; and gnus-style forwards [foo@bar.com] subject
6625     (goto-char (point-min))
6626     (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
6627       (replace-match ""))
6628
6629     ;; and off the end
6630     (goto-char (point-max))
6631     (while (re-search-backward "([Ff][Ww][Dd])" nil t)
6632       (replace-match ""))
6633
6634     ;; and finally, any whitespace that was left-over
6635     (goto-char (point-min))
6636     (while (re-search-forward "^[ \t]+" nil t)
6637       (replace-match ""))
6638     (goto-char (point-max))
6639     (while (re-search-backward "[ \t]+$" nil t)
6640       (replace-match ""))
6641
6642     (buffer-string)))
6643
6644 ;;; Forwarding messages.
6645
6646 (defvar message-forward-decoded-p nil
6647   "Non-nil means the original message is decoded.")
6648
6649 (defun message-forward-subject-author-subject (subject)
6650   "Generate a SUBJECT for a forwarded message.
6651 The form is: [Source] Subject, where if the original message was mail,
6652 Source is the sender, and if the original message was news, Source is
6653 the list of newsgroups is was posted to."
6654   (concat "["
6655           (let ((prefix (message-fetch-field "newsgroups")))
6656             (or prefix
6657                 (and (setq prefix (message-fetch-field "from"))
6658                      (nnheader-decode-from prefix))
6659                 "(nowhere)"))
6660           "] " subject))
6661
6662 (defun message-forward-subject-name-subject (subject)
6663   "Generate a SUBJECT for a forwarded message.
6664 The form is: [Source] Subject, where if the original message was mail,
6665 Source is the name of the sender, and if the original message was
6666 news, Source is the list of newsgroups is was posted to."
6667   (concat "["
6668           (let ((prefix (message-fetch-field "newsgroups")))
6669             (or prefix
6670                 (and (setq prefix (message-fetch-field "from"))
6671                      (car (std11-extract-address-components
6672                            (nnheader-decode-from prefix))))
6673                 "(nowhere)"))
6674           "] " subject))
6675
6676 (defun message-forward-subject-fwd (subject)
6677   "Generate a SUBJECT for a forwarded message.
6678 The form is: Fwd: Subject, where Subject is the original subject of
6679 the message."
6680   (concat "Fwd: " subject))
6681
6682 (defun message-make-forward-subject ()
6683   "Return a Subject header suitable for the message in the current buffer."
6684   (save-excursion
6685     (save-restriction
6686       (message-narrow-to-head-1)
6687       (let ((funcs message-make-forward-subject-function)
6688             (subject (message-fetch-field "Subject")))
6689         (setq subject
6690               (if subject
6691                   (if message-forward-decoded-p
6692                       subject
6693                     (nnheader-decode-subject subject))
6694                 ""))
6695         (if message-wash-forwarded-subjects
6696             (setq subject (message-wash-subject subject)))
6697         ;; Make sure funcs is a list.
6698         (and funcs
6699              (not (listp funcs))
6700              (setq funcs (list funcs)))
6701         ;; Apply funcs in order, passing subject generated by previous
6702         ;; func to the next one.
6703         (while funcs
6704           (when (functionp (car funcs))
6705             (setq subject (funcall (car funcs) subject)))
6706           (setq funcs (cdr funcs)))
6707         subject))))
6708
6709 ;;;###autoload
6710 (defun message-forward (&optional news)
6711   "Forward the current message via mail.
6712 Optional NEWS will use news to forward instead of mail."
6713   (interactive "P")
6714   (let ((cur (current-buffer))
6715         (subject (message-make-forward-subject)))
6716     (if news
6717         (message-news nil subject)
6718       (message-mail nil subject))
6719     (message-forward-make-body cur)))
6720
6721 ;;;###autoload
6722 (defun message-forward-make-body (forward-buffer)
6723   ;; Put point where we want it before inserting the forwarded
6724   ;; message.
6725   ;; Note that this function definition for T-gnus is totally different
6726   ;; from the original Gnus."
6727   (if message-forward-before-signature
6728       (message-goto-body)
6729     (goto-char (point-max)))
6730   ;; Make sure we're at the start of the line.
6731   (unless (bolp)
6732     (insert "\n"))
6733   ;; Narrow to the area we are to insert.
6734   (narrow-to-region (point) (point))
6735   ;; Insert the separators and the forwarded buffer.
6736   (insert message-forward-start-separator)
6737   (let ((art-beg (point)))
6738     (insert-buffer-substring forward-buffer)
6739     (goto-char (point-max))
6740     (insert message-forward-end-separator)
6741     (set-text-properties (point-min) (point-max) nil)
6742     ;; Remove all unwanted headers.
6743     (goto-char art-beg)
6744     (narrow-to-region (point) (if (search-forward "\n\n" nil t)
6745                                   (1- (point))
6746                                 (point)))
6747     (goto-char (point-min))
6748     (message-remove-header message-included-forward-headers t nil t)
6749     (widen)
6750     (message-position-point)))
6751
6752 ;;;###autoload
6753 (defun message-forward-rmail-make-body (forward-buffer)
6754   (save-window-excursion
6755     (set-buffer forward-buffer)
6756     ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs
6757     ;; 20.  FIXIT, or we drop support for rmail in Emacs 20.
6758     (if (rmail-msg-is-pruned)
6759         (rmail-msg-restore-non-pruned-header)))
6760   (message-forward-make-body forward-buffer))
6761
6762 (eval-when-compile (defvar rmail-enable-mime-composing))
6763
6764 ;; Fixme: Should have defcustom.
6765 ;;;###autoload
6766 (defun message-insinuate-rmail ()
6767   "Let RMAIL use message to forward."
6768   (interactive)
6769   (setq rmail-enable-mime-composing t)
6770   (setq rmail-insert-mime-forwarded-message-function
6771         'message-forward-rmail-make-body))
6772
6773 ;;;###autoload
6774 (defun message-resend (address)
6775   "Resend the current article to ADDRESS."
6776   (interactive
6777    (list (message-read-from-minibuffer "Resend message to: ")))
6778   (message "Resending message to %s..." address)
6779   (save-excursion
6780     (let ((cur (current-buffer))
6781           beg)
6782       ;; We first set up a normal mail buffer.
6783       (unless (message-mail-user-agent)
6784         (set-buffer (get-buffer-create " *message resend*"))
6785         (erase-buffer))
6786       (let ((message-this-is-mail t)
6787             message-setup-hook)
6788         (message-setup `((To . ,address))))
6789       ;; Insert our usual headers.
6790       (message-generate-headers '(From Date To))
6791       (message-narrow-to-headers)
6792       ;; Remove X-Draft-From header etc.
6793       (message-remove-header message-ignored-mail-headers t)
6794       ;; Rename them all to "Resent-*".
6795       (goto-char (point-min))
6796       (while (re-search-forward "^[A-Za-z]" nil t)
6797         (forward-char -1)
6798         (insert "Resent-"))
6799       (widen)
6800       (forward-line)
6801       (delete-region (point) (point-max))
6802       (setq beg (point))
6803       ;; Insert the message to be resent.
6804       (insert-buffer-substring cur)
6805       (goto-char (point-min))
6806       (search-forward "\n\n")
6807       (forward-char -1)
6808       (save-restriction
6809         (narrow-to-region beg (point))
6810         (message-remove-header message-ignored-resent-headers t)
6811         (goto-char (point-max)))
6812       (insert mail-header-separator)
6813       ;; Rename all old ("Also-")Resent headers.
6814       (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
6815         (beginning-of-line)
6816         (insert "Also-"))
6817       ;; Quote any "From " lines at the beginning.
6818       (goto-char beg)
6819       (when (looking-at "From ")
6820         (replace-match "X-From-Line: "))
6821       ;; Send it.
6822       (let ((message-encoding-buffer (current-buffer))
6823             (message-edit-buffer (current-buffer))
6824             message-required-mail-headers)
6825         (message-send-mail))
6826       (kill-buffer (current-buffer)))
6827     (message "Resending message to %s...done" address)))
6828
6829 (defun message-bounce-setup-for-mime-edit ()
6830   (set (make-local-variable 'message-setup-hook) nil)
6831   (mime-edit-again))
6832
6833 ;;;###autoload
6834 (defun message-bounce ()
6835   "Re-mail the current message.
6836 This only makes sense if the current message is a bounce message that
6837 contains some mail you have written which has been bounced back to
6838 you."
6839   (interactive)
6840   (let ((cur (current-buffer))
6841         boundary)
6842     (message-pop-to-buffer (message-buffer-name "bounce"))
6843     (insert-buffer-substring cur)
6844     (undo-boundary)
6845     (message-narrow-to-head)
6846     (if (and (message-fetch-field "MIME-Version")
6847              (setq boundary (message-fetch-field "Content-Type")))
6848         (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
6849             (setq boundary (concat (match-string 1 boundary) " *\n"
6850                                    "Content-Type: message/rfc822"))
6851           (setq boundary nil)))
6852     (widen)
6853     (goto-char (point-min))
6854     (search-forward "\n\n" nil t)
6855     (if (or (and boundary
6856                  (re-search-forward boundary nil t)
6857                  (forward-line 2))
6858             (and (re-search-forward message-unsent-separator nil t)
6859                  (forward-line 1))
6860             (re-search-forward "^Return-Path:.*\n" nil t))
6861         ;; We remove everything before the bounced mail.
6862         (delete-region
6863          (point-min)
6864          (if (re-search-forward "^[^ \n\t]+:" nil t)
6865              (match-beginning 0)
6866            (point)))
6867       (when (re-search-backward "^.?From .*\n" nil t)
6868         (delete-region (match-beginning 0) (match-end 0))))
6869     (save-restriction
6870       (message-narrow-to-head-1)
6871       (message-remove-header message-ignored-bounced-headers t)
6872       (goto-char (point-max))
6873       (insert mail-header-separator))
6874     (when message-bounce-setup-function
6875       (funcall message-bounce-setup-function))
6876     (run-hooks 'message-bounce-setup-hook)
6877     (message-position-point)))
6878
6879 ;;;
6880 ;;; Interactive entry points for new message buffers.
6881 ;;;
6882
6883 ;;;###autoload
6884 (defun message-mail-other-window (&optional to subject)
6885   "Like `message-mail' command, but display mail buffer in another window."
6886   (interactive)
6887   (unless (message-mail-user-agent)
6888     (let ((pop-up-windows t)
6889           (special-display-buffer-names nil)
6890           (special-display-regexps nil)
6891           (same-window-buffer-names nil)
6892           (same-window-regexps nil))
6893       (message-pop-to-buffer (message-buffer-name "mail" to))))
6894   (let ((message-this-is-mail t))
6895     (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
6896                    nil nil 'switch-to-buffer-other-window)))
6897
6898 ;;;###autoload
6899 (defun message-mail-other-frame (&optional to subject)
6900   "Like `message-mail' command, but display mail buffer in another frame."
6901   (interactive)
6902   (unless (message-mail-user-agent)
6903     (let ((pop-up-frames t)
6904           (special-display-buffer-names nil)
6905           (special-display-regexps nil)
6906           (same-window-buffer-names nil)
6907           (same-window-regexps nil))
6908       (message-pop-to-buffer (message-buffer-name "mail" to))))
6909   (let ((message-this-is-mail t))
6910     (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
6911                    nil nil 'switch-to-buffer-other-frame)))
6912
6913 ;;;###autoload
6914 (defun message-news-other-window (&optional newsgroups subject)
6915   "Start editing a news article to be sent."
6916   (interactive)
6917   (let ((pop-up-windows t)
6918         (special-display-buffer-names nil)
6919         (special-display-regexps nil)
6920         (same-window-buffer-names nil)
6921         (same-window-regexps nil))
6922     (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
6923   (let ((message-this-is-news t))
6924     (message-setup `((Newsgroups . ,(or newsgroups ""))
6925                      (Subject . ,(or subject ""))))))
6926
6927 ;;;###autoload
6928 (defun message-news-other-frame (&optional newsgroups subject)
6929   "Start editing a news article to be sent."
6930   (interactive)
6931   (let ((pop-up-frames t)
6932         (special-display-buffer-names nil)
6933         (special-display-regexps nil)
6934         (same-window-buffer-names nil)
6935         (same-window-regexps nil))
6936     (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
6937   (let ((message-this-is-news t))
6938     (message-setup `((Newsgroups . ,(or newsgroups ""))
6939                      (Subject . ,(or subject ""))))))
6940
6941 ;;; underline.el
6942
6943 ;; This code should be moved to underline.el (from which it is stolen).
6944
6945 ;;;###autoload
6946 (defun bold-region (start end)
6947   "Bold all nonblank characters in the region.
6948 Works by overstriking characters.
6949 Called from program, takes two arguments START and END
6950 which specify the range to operate on."
6951   (interactive "r")
6952   (save-excursion
6953     (let ((end1 (make-marker)))
6954       (move-marker end1 (max start end))
6955       (goto-char (min start end))
6956       (while (< (point) end1)
6957         (or (looking-at "[_\^@- ]")
6958             (insert (char-after) "\b"))
6959         (forward-char 1)))))
6960
6961 ;;;###autoload
6962 (defun unbold-region (start end)
6963   "Remove all boldness (overstruck characters) in the region.
6964 Called from program, takes two arguments START and END
6965 which specify the range to operate on."
6966   (interactive "r")
6967   (save-excursion
6968     (let ((end1 (make-marker)))
6969       (move-marker end1 (max start end))
6970       (goto-char (min start end))
6971       (while (re-search-forward "\b" end1 t)
6972         (if (eq (char-after) (char-after (- (point) 2)))
6973             (delete-char -2))))))
6974
6975 (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
6976 (defalias 'message-make-overlay 'make-overlay)
6977 (defalias 'message-delete-overlay 'delete-overlay)
6978 (defalias 'message-overlay-put 'overlay-put)
6979 (defun message-kill-all-overlays ()
6980   (if (featurep 'xemacs)
6981       (map-extents (lambda (extent ignore) (delete-extent extent)))
6982     (mapcar #'delete-overlay (overlays-in (point-min) (point-max)))))
6983
6984 ;; Support for toolbar
6985 (eval-when-compile
6986   (defvar tool-bar-map)
6987   (defvar tool-bar-mode))
6988
6989 (defun message-tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props)
6990   ;; We need to make tool bar entries in local keymaps with
6991   ;; `tool-bar-local-item-from-menu' in Emacs > 21.3
6992   (if (fboundp 'tool-bar-local-item-from-menu)
6993       ;; This is for Emacs 21.3
6994       (tool-bar-local-item-from-menu command icon in-map from-map props)
6995     (tool-bar-add-item-from-menu command icon from-map props)))
6996
6997 (defun message-tool-bar-map ()
6998   (or message-tool-bar-map
6999       (setq message-tool-bar-map
7000             (and
7001              (condition-case nil (require 'tool-bar) (error nil))
7002              (fboundp 'tool-bar-add-item-from-menu)
7003              tool-bar-mode
7004              (let ((tool-bar-map (copy-keymap tool-bar-map))
7005                    (load-path (mm-image-load-path)))
7006                ;; Zap some items which aren't so relevant and take
7007                ;; up space.
7008                (dolist (key '(print-buffer kill-buffer save-buffer
7009                                            write-file dired open-file))
7010                  (define-key tool-bar-map (vector key) nil))
7011                (message-tool-bar-local-item-from-menu
7012                 'message-send-and-exit "mail_send" tool-bar-map message-mode-map)
7013                (message-tool-bar-local-item-from-menu
7014                 'message-kill-buffer "close" tool-bar-map message-mode-map)
7015                (message-tool-bar-local-item-from-menu
7016                 'message-dont-send "cancel" tool-bar-map message-mode-map)
7017 ;;             (message-tool-bar-local-item-from-menu
7018 ;;              'mime-edit-insert-file "attach"
7019 ;;              tool-bar-map mime-edit-mode-map)
7020                (message-tool-bar-local-item-from-menu
7021                 'ispell-message "spell" tool-bar-map message-mode-map)
7022 ;;             (message-tool-bar-local-item-from-menu
7023 ;;              'mime-edit-preview-message "preview"
7024 ;;              tool-bar-map mime-edit-mode-map)
7025                (message-tool-bar-local-item-from-menu
7026                 'message-insert-importance-high "important"
7027                 tool-bar-map message-mode-map)
7028                (message-tool-bar-local-item-from-menu
7029                 'message-insert-importance-low "unimportant"
7030                 tool-bar-map message-mode-map)
7031                (message-tool-bar-local-item-from-menu
7032                 'message-insert-disposition-notification-to "receipt"
7033                 tool-bar-map message-mode-map)
7034                tool-bar-map)))))
7035
7036 ;;; Group name completion.
7037
7038 (defcustom message-newgroups-header-regexp
7039   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
7040   "Regexp that match headers that lists groups."
7041   :group 'message
7042   :type 'regexp)
7043
7044 (defcustom message-completion-alist
7045   (list (cons message-newgroups-header-regexp 'message-expand-group)
7046         '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name)
7047         '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
7048           . message-expand-name)
7049         '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):"
7050           . message-expand-name))
7051   "Alist of (RE . FUN).  Use FUN for completion on header lines matching RE."
7052   :group 'message
7053   :type '(alist :key-type regexp :value-type function))
7054
7055 (defcustom message-expand-name-function
7056   (if (fboundp 'bbdb-complete-name)
7057       'bbdb-complete-name
7058     (if (fboundp 'lsdb-complete-name)
7059         'lsdb-complete-name
7060       'expand-abbrev))
7061   "*A function called to expand addresses in field body."
7062   :group 'message
7063   :type 'function)
7064
7065 (defcustom message-tab-body-function nil
7066   "*Function to execute when `message-tab' (TAB) is executed in the body.
7067 If nil, the function bound in `text-mode-map' or `global-map' is executed."
7068   :group 'message
7069   :type 'function)
7070
7071 (defun message-tab ()
7072   "Complete names according to `message-completion-alist'.
7073 Execute function specified by `message-tab-body-function' when not in
7074 those headers."
7075   (interactive)
7076   (let ((alist message-completion-alist))
7077     (while (and alist
7078                 (let ((mail-abbrev-mode-regexp (caar alist)))
7079                   (not (mail-abbrev-in-expansion-header-p))))
7080       (setq alist (cdr alist)))
7081     (funcall (or (cdar alist) message-tab-body-function
7082                  (lookup-key text-mode-map "\t")
7083                  (lookup-key global-map "\t")
7084                  'indent-relative))))
7085
7086 (defun message-expand-group ()
7087   "Expand the group name under point."
7088   (let* ((b (save-excursion
7089               (save-restriction
7090                 (narrow-to-region
7091                  (save-excursion
7092                    (beginning-of-line)
7093                    (skip-chars-forward "^:")
7094                    (1+ (point)))
7095                  (point))
7096                 (skip-chars-backward "^, \t\n") (point))))
7097          (completion-ignore-case t)
7098          (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
7099                                             (point))))
7100          (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
7101          (completions (all-completions string hashtb))
7102          comp)
7103     (delete-region b (point))
7104     (cond
7105      ((= (length completions) 1)
7106       (if (string= (car completions) string)
7107           (progn
7108             (insert string)
7109             (message "Only matching group"))
7110         (insert (car completions))))
7111      ((and (setq comp (try-completion string hashtb))
7112            (not (string= comp string)))
7113       (insert comp))
7114      (t
7115       (insert string)
7116       (if (not comp)
7117           (message "No matching groups")
7118         (save-selected-window
7119           (pop-to-buffer "*Completions*")
7120           (buffer-disable-undo)
7121           (let ((buffer-read-only nil))
7122             (erase-buffer)
7123             (let ((standard-output (current-buffer)))
7124               (display-completion-list (sort completions 'string<)))
7125             (goto-char (point-min))
7126             (delete-region (point) (progn (forward-line 3) (point))))))))))
7127
7128 (defun message-expand-name ()
7129   (funcall message-expand-name-function))
7130
7131 ;;; Help stuff.
7132
7133 (defun message-talkative-question (ask question show &rest text)
7134   "Call FUNCTION with argument QUESTION; optionally display TEXT... args.
7135 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer.
7136 The following arguments may contain lists of values."
7137   (if (and show
7138            (setq text (message-flatten-list text)))
7139       (save-window-excursion
7140         (save-excursion
7141           (with-output-to-temp-buffer " *MESSAGE information message*"
7142             (set-buffer " *MESSAGE information message*")
7143             (fundamental-mode)          ; for Emacs 20.4+
7144             (mapcar 'princ text)
7145             (goto-char (point-min))))
7146         (funcall ask question))
7147     (funcall ask question)))
7148
7149 (defun message-flatten-list (list)
7150   "Return a new, flat list that contains all elements of LIST.
7151
7152 \(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
7153 => (1 2 3 4 5 6 7)"
7154   (cond ((consp list)
7155          (apply 'append (mapcar 'message-flatten-list list)))
7156         (list
7157          (list list))))
7158
7159 (defun message-generate-new-buffer-clone-locals (name &optional varstr)
7160   "Create and return a buffer with name based on NAME using `generate-new-buffer'.
7161 Then clone the local variables and values from the old buffer to the
7162 new one, cloning only the locals having a substring matching the
7163 regexp VARSTR."
7164   (let ((oldbuf (current-buffer)))
7165     (save-excursion
7166       (set-buffer (generate-new-buffer name))
7167       (message-clone-locals oldbuf varstr)
7168       (current-buffer))))
7169
7170 (defun message-clone-locals (buffer &optional varstr)
7171   "Clone the local variables from BUFFER to the current buffer."
7172   (let ((locals (save-excursion
7173                   (set-buffer buffer)
7174                   (buffer-local-variables)))
7175         (regexp
7176          "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
7177     (mapcar
7178      (lambda (local)
7179        (when (and (consp local)
7180                   (car local)
7181                   (string-match regexp (symbol-name (car local)))
7182                   (or (null varstr)
7183                       (string-match varstr (symbol-name (car local)))))
7184          (ignore-errors
7185            (set (make-local-variable (car local))
7186                 (cdr local)))))
7187      locals)))
7188
7189 ;;; @ for MIME Edit mode
7190 ;;;
7191
7192 (defun message-maybe-encode ()
7193   (when message-mime-mode
7194     ;; Inherit the buffer local variable `mime-edit-pgp-processing'.
7195     (let ((pgp-processing (with-current-buffer message-edit-buffer
7196                             mime-edit-pgp-processing)))
7197       (setq mime-edit-pgp-processing pgp-processing))
7198     (run-hooks 'mime-edit-translate-hook)
7199     (if (catch 'mime-edit-error
7200           (save-excursion
7201             (mime-edit-pgp-enclose-buffer)
7202             (mime-edit-translate-body)))
7203         (error "Translation error!"))
7204     (run-hooks 'mime-edit-exit-hook)))
7205
7206 (defun message-mime-insert-article (&optional full-headers)
7207   (interactive "P")
7208   (let ((message-cite-function 'mime-edit-inserted-message-filter)
7209         (message-reply-buffer
7210          (message-get-parameter-with-eval 'original-buffer))
7211         (start (point)))
7212     (message-yank-original nil)
7213     (save-excursion
7214       (narrow-to-region (goto-char start)
7215                         (if (search-forward "\n\n" nil t)
7216                             (1- (point))
7217                           (point-max)))
7218       (goto-char (point-min))
7219       (let ((message-included-forward-headers
7220              (if full-headers "" message-included-forward-headers)))
7221         (message-remove-header message-included-forward-headers t nil t))
7222       (widen))))
7223
7224 (set-alist 'mime-edit-message-inserter-alist
7225            'message-mode (function message-mime-insert-article))
7226
7227 ;;;
7228 ;;; MIME functions
7229 ;;;
7230
7231 (defvar message-inhibit-body-encoding t)
7232
7233 (defun message-encode-message-body ()
7234   (unless message-inhibit-body-encoding
7235     (let ((mail-parse-charset (or mail-parse-charset
7236                                   message-default-charset))
7237           (case-fold-search t)
7238           lines content-type-p)
7239       (message-goto-body)
7240       (save-restriction
7241         (narrow-to-region (point) (point-max))
7242         (let ((new (mml-generate-mime)))
7243           (when new
7244             (delete-region (point-min) (point-max))
7245             (insert new)
7246             (goto-char (point-min))
7247             (if (eq (aref new 0) ?\n)
7248                 (delete-char 1)
7249               (search-forward "\n\n")
7250               (setq lines (buffer-substring (point-min) (1- (point))))
7251               (delete-region (point-min) (point))))))
7252       (save-restriction
7253         (message-narrow-to-headers-or-head)
7254         (message-remove-header "Mime-Version")
7255         (goto-char (point-max))
7256         (insert "MIME-Version: 1.0\n")
7257         (when lines
7258           (insert lines))
7259         (setq content-type-p
7260               (or mml-boundary
7261                   (re-search-backward "^Content-Type:" nil t))))
7262       (save-restriction
7263         (message-narrow-to-headers-or-head)
7264         (message-remove-first-header "Content-Type")
7265         (message-remove-first-header "Content-Transfer-Encoding"))
7266       ;; We always make sure that the message has a Content-Type
7267       ;; header.  This is because some broken MTAs and MUAs get
7268       ;; awfully confused when confronted with a message with a
7269       ;; MIME-Version header and without a Content-Type header.  For
7270       ;; instance, Solaris' /usr/bin/mail.
7271       (unless content-type-p
7272         (goto-char (point-min))
7273         ;; For unknown reason, MIME-Version doesn't exist.
7274         (when (re-search-forward "^MIME-Version:" nil t)
7275           (forward-line 1)
7276           (insert "Content-Type: text/plain; charset=us-ascii\n"))))))
7277
7278 (defun message-read-from-minibuffer (prompt &optional initial-contents)
7279   "Read from the minibuffer while providing abbrev expansion."
7280   (if (fboundp 'mail-abbrevs-setup)
7281       (let ((mail-abbrev-mode-regexp "")
7282             (minibuffer-setup-hook 'mail-abbrevs-setup)
7283             (minibuffer-local-map message-minibuffer-local-map))
7284         (read-from-minibuffer prompt initial-contents))
7285     (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
7286           (minibuffer-local-map message-minibuffer-local-map))
7287       (read-string prompt initial-contents))))
7288
7289 (defun message-use-alternative-email-as-from ()
7290   (require 'mail-utils)
7291   (let* ((fields '("To" "Cc"))
7292          (emails
7293           (split-string
7294            (mail-strip-quoted-names
7295             (mapconcat 'message-fetch-reply-field fields ","))
7296            "[ \f\t\n\r\v,]+"))
7297          email)
7298     (while emails
7299       (if (string-match message-alternative-emails (car emails))
7300           (setq email (car emails)
7301                 emails nil))
7302       (pop emails))
7303     (unless (or (not email) (equal email user-mail-address))
7304       (goto-char (point-max))
7305       (insert "From: " email "\n"))))
7306
7307 (defun message-options-get (symbol)
7308   (cdr (assq symbol message-options)))
7309
7310 (defun message-options-set (symbol value)
7311   (let ((the-cons (assq symbol message-options)))
7312     (if the-cons
7313         (if value
7314             (setcdr the-cons value)
7315           (setq message-options (delq the-cons message-options)))
7316       (and value
7317            (push (cons symbol value) message-options))))
7318   value)
7319
7320 (defun message-options-set-recipient ()
7321   (save-restriction
7322     (message-narrow-to-headers-or-head)
7323     (message-options-set 'message-sender
7324                          (mail-strip-quoted-names
7325                           (message-fetch-field "from")))
7326     (message-options-set 'message-recipients
7327                          (mail-strip-quoted-names
7328                           (let ((to (message-fetch-field "to"))
7329                                 (cc (message-fetch-field "cc"))
7330                                 (bcc (message-fetch-field "bcc")))
7331                             (concat
7332                              (or to "")
7333                              (if (and to cc) ", ")
7334                              (or cc "")
7335                              (if (and (or to cc) bcc) ", ")
7336                              (or bcc "")))))))
7337
7338 (defun message-hide-headers ()
7339   "Hide headers based on the `message-hidden-headers' variable."
7340   (let ((regexps (if (stringp message-hidden-headers)
7341                      (list message-hidden-headers)
7342                    message-hidden-headers))
7343         (inhibit-point-motion-hooks t)
7344         (after-change-functions nil))
7345     (when regexps
7346       (save-excursion
7347         (save-restriction
7348           (message-narrow-to-headers)
7349           (goto-char (point-min))
7350           (while (not (eobp))
7351             (if (not (message-hide-header-p regexps))
7352                 (message-next-header)
7353               (let ((begin (point)))
7354                 (message-next-header)
7355                 (add-text-properties
7356                  begin (point)
7357                  '(invisible t message-hidden t))))))))))
7358
7359 (defun message-hide-header-p (regexps)
7360   (let ((result nil)
7361         (reverse nil))
7362     (when (eq (car regexps) 'not)
7363       (setq reverse t)
7364       (pop regexps))
7365     (dolist (regexp regexps)
7366       (setq result (or result (looking-at regexp))))
7367     (if reverse
7368         (not result)
7369       result)))
7370
7371 (when (featurep 'xemacs)
7372   (require 'messagexmas)
7373   (message-xmas-redefine))
7374
7375 (provide 'message)
7376
7377 (run-hooks 'message-load-hook)
7378
7379 ;; Local Variables:
7380 ;; coding: iso-8859-1
7381 ;; End:
7382
7383 ;;; message.el ends here