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

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