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

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