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