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

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