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