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

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