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

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