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

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