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

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