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