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