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

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