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