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

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