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