cgit.sxemacs.org Git - gnus/blob - lisp/message.el

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