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