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

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