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

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