cgit.sxemacs.org Git - gnus/blob - lisp/message.el

   1 ;;; message.el --- composing mail and news messages
   2 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: mail, news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; This mode provides mail-sending facilities from within Emacs.  It
  27 ;; consists mainly of large chunks of code from the sendmail.el,
  28 ;; gnus-msg.el and rnewspost.el files.
  29
  30 ;;; Code:
  31
  32 (eval-when-compile
  33   (require 'cl))
  34 (require 'mailheader)
  35 (require 'nnheader)
  36 (require 'timezone)
  37 (require 'easymenu)
  38 (if (string-match "XEmacs\\|Lucid" emacs-version)
  39     (require 'mail-abbrevs)
  40   (require 'mailabbrev))
  41
  42 (defvar message-directory "~/Mail/"
  43   "*Directory from which all other mail file variables are derived.")
  44
  45 ;;;###autoload
  46 (defvar message-fcc-handler-function 'rmail-output
  47   "*A function called to save outgoing articles.
  48 This function will be called with the name of the file to store the
  49 article in. The default function is `rmail-output' which saves in Unix
  50 mailbox format.")
  51
  52 ;;;###autoload
  53 (defvar message-courtesy-message
  54   "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
  55   "*This is inserted at the start of a mailed copy of a posted message.
  56 If this variable is nil, no such courtesy message will be added.")
  57
  58 ;;;###autoload
  59 (defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
  60   "*Regexp that matches headers to be removed in resent bounced mail.")
  61
  62 ;;;###autoload
  63 (defvar message-from-style 'default
  64   "*Specifies how \"From\" headers look.
  65
  66 If `nil', they contain just the return address like:
  67         king@grassland.com
  68 If `parens', they look like:
  69         king@grassland.com (Elvis Parsley)
  70 If `angles', they look like:
  71         Elvis Parsley <king@grassland.com>
  72
  73 Otherwise, most addresses look like `angles', but they look like
  74 `parens' if `angles' would need quoting and `parens' would not.")
  75
  76 ;;;###autoload
  77 (defvar message-syntax-checks nil
  78   "Controls what syntax checks should not be performed on outgoing posts.
  79 To disable checking of long signatures, for instance, add
  80  `(signature . disabled)' to this list.
  81
  82 Don't touch this variable unless you really know what you're doing.
  83
  84 Checks include subject-cmsg multiple-headers sendsys message-id from
  85 long-lines control-chars size new-text redirected-followup signature
  86 approved sender empty empty-headers message-id from subject.")
  87
  88 ;;;###autoload
  89 (defvar message-required-news-headers
  90   '(From Newsgroups Subject Date Message-ID
  91          (optional . Organization) Lines
  92          (optional . X-Newsreader))
  93   "*Headers to be generated or prompted for when posting an article.
  94 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
  95 Message-ID.  Organization, Lines, In-Reply-To, Expires, and
  96 X-Newsreader are optional.  If don't you want message to insert some
  97 header, remove it from this list.")
  98
  99 ;;;###autoload
 100 (defvar message-required-mail-headers
 101   '(From Subject Date (optional . In-Reply-To) Message-ID Lines
 102          (optional . X-Mailer))
 103   "*Headers to be generated or prompted for when mailing a message.
 104 RFC822 required that From, Date, To, Subject and Message-ID be
 105 included.  Organization, Lines and X-Mailer are optional.")
 106
 107 ;;;###autoload
 108 (defvar message-deletable-headers '(Message-ID Date)
 109   "*Headers to be deleted if they already exist and were generated by message previously.")
 110
 111 ;;;###autoload
 112 (defvar message-ignored-news-headers
 113   "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:"
 114   "*Regexp of headers to be removed unconditionally before posting.")
 115
 116 ;;;###autoload
 117 (defvar message-ignored-mail-headers "^Gcc:\\|^Fcc:"
 118   "*Regexp of headers to be removed unconditionally before mailing.")
 119
 120 ;;;###autoload
 121 (defvar message-ignored-supersedes-headers
 122   "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:"
 123   "*Header lines matching this regexp will be deleted before posting.
 124 It's best to delete old Path and Date headers before posting to avoid
 125 any confusion.")
 126
 127 ;;;###autoload
 128 (defvar message-signature-separator "^-- *$"
 129   "Regexp matching the signature separator.")
 130
 131 ;;;###autoload
 132 (defvar message-interactive nil
 133   "Non-nil means when sending a message wait for and display errors.
 134 nil means let mailer mail back a message to report errors.")
 135
 136 ;;;###autoload
 137 (defvar message-generate-new-buffers nil
 138   "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.")
 139
 140 ;;;###autoload
 141 (defvar message-kill-buffer-on-exit nil
 142   "*Non-nil means that the message buffer will be killed after sending a message.")
 143
 144 (defvar gnus-local-organization)
 145 ;;;###autoload
 146 (defvar message-user-organization
 147   (or (and (boundp 'gnus-local-organization)
 148            gnus-local-organization)
 149       (getenv "ORGANIZATION")
 150       t)
 151   "*String to be used as an Organization header.
 152 If t, use `message-user-organization-file'.")
 153
 154 ;;;###autoload
 155 (defvar message-user-organization-file "/usr/lib/news/organization"
 156   "*Local news organization file.")
 157
 158 ;;;###autoload
 159 (defvar message-autosave-directory
 160   (concat (file-name-as-directory message-directory) "drafts/")
 161   "*Directory where message autosaves buffers.
 162 If nil, message won't autosave.")
 163
 164 (defvar message-forward-start-separator
 165   "------- Start of forwarded message -------\n"
 166   "*Delimiter inserted before forwarded messages.")
 167
 168 (defvar message-forward-end-separator
 169   "------- End of forwarded message -------\n"
 170   "*Delimiter inserted after forwarded messages.")
 171
 172 ;;;###autoload
 173 (defvar message-signature-before-forwarded-message t
 174   "*If non-nil, put the signature before any included forwarded message.")
 175
 176 ;;;###autoload
 177 (defvar message-included-forward-headers
 178   "^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:"
 179   "*Regexp matching headers to be included in forwarded messages.")
 180
 181 ;;;###autoload
 182 (defvar message-ignored-resent-headers "^Return-receipt"
 183   "*All headers that match this regexp will be deleted when resending a message.")
 184
 185 ;;;###autoload
 186 (defvar message-ignored-cited-headers "."
 187   "Delete these headers from the messages you yank.")
 188
 189 ;; Useful to set in site-init.el
 190 ;;;###autoload
 191 (defvar message-send-mail-function 'message-send-mail-with-sendmail
 192   "Function to call to send the current buffer as mail.
 193 The headers should be delimited by a line whose contents match the
 194 variable `mail-header-separator'.
 195
 196 Legal values include `message-send-mail-with-mh' and
 197 `message-send-mail-with-sendmail', which is the default.")
 198
 199 ;;;###autoload
 200 (defvar message-send-news-function 'message-send-news
 201   "Function to call to send the current buffer as news.
 202 The headers should be delimited by a line whose contents match the
 203 variable `mail-header-separator'.")
 204
 205 ;;;###autoload
 206 (defvar message-reply-to-function nil
 207   "Function that should return a list of headers.
 208 This function should pick out addresses from the To, Cc, and From headers
 209 and respond with new To and Cc headers.")
 210
 211 ;;;###autoload
 212 (defvar message-wide-reply-to-function nil
 213   "Function that should return a list of headers.
 214 This function should pick out addresses from the To, Cc, and From headers
 215 and respond with new To and Cc headers.")
 216
 217 ;;;###autoload
 218 (defvar message-followup-to-function nil
 219   "Function that should return a list of headers.
 220 This function should pick out addresses from the To, Cc, and From headers
 221 and respond with new To and Cc headers.")
 222
 223 ;;;###autoload
 224 (defvar message-use-followup-to 'ask
 225   "*Specifies what to do with Followup-To header.
 226 If nil, ignore the header. If it is t, use its value, but query before
 227 using the \"poster\" value.  If it is the symbol `ask', query the user
 228 whether to ignore the \"poster\" value.  If it is the symbol `use',
 229 always use the value.")
 230
 231 (defvar gnus-post-method)
 232 (defvar gnus-select-method)
 233 ;;;###autoload
 234 (defvar message-post-method
 235   (cond ((and (boundp 'gnus-post-method)
 236               gnus-post-method)
 237          gnus-post-method)
 238         ((boundp 'gnus-select-method)
 239          gnus-select-method)
 240         (t '(nnspool "")))
 241   "Method used to post news.")
 242
 243 ;;;###autoload
 244 (defvar message-generate-headers-first nil
 245   "*If non-nil, generate all possible headers before composing.")
 246
 247 (defvar message-setup-hook nil
 248   "Normal hook, run each time a new outgoing message is initialized.
 249 The function `message-setup' runs this hook.")
 250
 251 (defvar message-mode-hook nil
 252   "Hook run in message mode buffers.")
 253
 254 (defvar message-header-hook nil
 255   "Hook run in a message mode buffer narrowed to the headers.")
 256
 257 (defvar message-header-setup-hook nil
 258   "Hook called narrowed to the headers when setting up a message buffer.")
 259
 260 ;;;###autoload
 261 (defvar message-citation-line-function 'message-insert-citation-line
 262   "*Function called to insert the \"Whomever writes:\" line.")
 263
 264 ;;;###autoload
 265 (defvar message-yank-prefix "> "
 266   "*Prefix inserted on the lines of yanked messages.
 267 nil means use indentation.")
 268
 269 (defvar message-indentation-spaces 3
 270   "*Number of spaces to insert at the beginning of each cited line.
 271 Used by `message-yank-original' via `message-yank-cite'.")
 272
 273 ;;;###autoload
 274 (defvar message-cite-function 'message-cite-original
 275   "*Function for citing an original message.")
 276
 277 ;;;###autoload
 278 (defvar message-indent-citation-function 'message-indent-citation
 279   "*Function for modifying a citation just inserted in the mail buffer.
 280 This can also be a list of functions.  Each function can find the
 281 citation between (point) and (mark t).  And each function should leave
 282 point and mark around the citation text as modified.")
 283
 284 (defvar message-abbrevs-loaded nil)
 285
 286 ;;;###autoload
 287 (defvar message-signature t
 288   "*String to be inserted at the end of the message buffer.
 289 If t, the `message-signature-file' file will be inserted instead.
 290 If a function, the result from the function will be used instead.
 291 If a form, the result from the form will be used instead.")
 292
 293 ;;;###autoload
 294 (defvar message-signature-file "~/.signature"
 295   "*File containing the text inserted at end of message. buffer.")
 296
 297 (defvar message-distribution-function nil
 298   "*Function called to return a Distribution header.")
 299
 300 (defvar message-expires 14
 301   "*Number of days before your article expires.")
 302
 303 (defvar message-user-path nil
 304   "If nil, use the NNTP server name in the Path header.
 305 If stringp, use this; if non-nil, use no host name (user name only).")
 306
 307 (defvar message-reply-buffer nil)
 308 (defvar message-reply-headers nil)
 309 (defvar message-newsreader nil)
 310 (defvar message-mailer nil)
 311 (defvar message-sent-message-via nil)
 312 (defvar message-checksum nil)
 313 (defvar message-send-actions nil
 314   "A list of actions to be performed upon successful sending of a message.")
 315 (defvar message-exit-actions nil
 316   "A list of actions to be performed upon exiting after sending a message.")
 317 (defvar message-kill-actions nil
 318   "A list of actions to be performed before killing a message buffer.")
 319 (defvar message-postpone-actions nil
 320   "A list of actions to be performed after postponing a message.")
 321
 322 ;;;###autoload
 323 (defvar message-default-headers nil
 324   "*A string containing header lines to be inserted in outgoing messages.
 325 It is inserted before you edit the message, so you can edit or delete
 326 these lines.")
 327
 328 ;;;###autoload
 329 (defvar message-default-mail-headers nil
 330   "*A string of header lines to be inserted in outgoing mails.")
 331
 332 ;;;###autoload
 333 (defvar message-default-news-headers nil
 334   "*A string of header lines to be inserted in outgoing news articles.")
 335
 336 ;; Note: could use /usr/ucb/mail instead of sendmail;
 337 ;; options -t, and -v if not interactive.
 338 (defvar message-mailer-swallows-blank-line
 339   (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
 340                          system-configuration)
 341            (file-readable-p "/etc/sendmail.cf")
 342            (let ((buffer (get-buffer-create " *temp*")))
 343              (unwind-protect
 344                  (save-excursion
 345                    (set-buffer buffer)
 346                    (insert-file-contents "/etc/sendmail.cf")
 347                    (goto-char (point-min))
 348                    (let ((case-fold-search nil))
 349                      (re-search-forward "^OR\\>" nil t)))
 350                (kill-buffer buffer))))
 351       ;; According to RFC822, "The field-name must be composed of printable
 352       ;; ASCII characters (i.e. characters that have decimal values between
 353       ;; 33 and 126, except colon)", i.e. any chars except ctl chars,
 354       ;; space, or colon.
 355       '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
 356   "Set this non-nil if the system's mailer runs the header and body together.
 357 \(This problem exists on Sunos 4 when sendmail is run in remote mode.)
 358 The value should be an expression to test whether the problem will
 359 actually occur.")
 360
 361 (defvar message-mode-syntax-table
 362   (let ((table (copy-syntax-table text-mode-syntax-table)))
 363     (modify-syntax-entry ?% ". " table)
 364     table)
 365   "Syntax table used while in Message mode.")
 366
 367 (defvar message-font-lock-keywords
 368   (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")))
 369     (list '("^To:" . font-lock-function-name-face)
 370           '("^[GBF]?[Cc][Cc]:\\|^Reply-To:" . font-lock-keyword-face)
 371           '("^\\(Subject:\\)[ \t]*\\(.+\\)?"
 372             (1 font-lock-comment-face) (2 font-lock-type-face nil t))
 373           (list (concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
 374                 1 'font-lock-comment-face)
 375           (cons (concat "^[ \t]*"
 376                         "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
 377                         "[>|}].*")
 378                 'font-lock-reference-face)
 379           '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*"
 380             . font-lock-string-face)))
 381   "Additional expressions to highlight in Message mode.")
 382
 383 (defvar message-face-alist
 384   '((bold . bold-region)
 385     (underline . underline-region)
 386     (default . (lambda (b e)
 387                  (unbold-region b e)
 388                  (ununderline-region b e))))
 389   "Alist of mail and news faces for facemenu.
 390 The cdr of ech entry is a function for applying the face to a region.")
 391
 392 (defvar message-send-hook nil
 393   "Hook run before sending messages.")
 394
 395 (defvar message-sent-hook nil
 396   "Hook run after sending messages.")
 397
 398 ;;; Internal variables.
 399
 400 ;;; Regexp matching the delimiter of messages in UNIX mail format
 401 ;;; (UNIX From lines), minus the initial ^.
 402 (defvar message-unix-mail-delimiter
 403   (let ((time-zone-regexp
 404          (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
 405                  "\\|[-+]?[0-9][0-9][0-9][0-9]"
 406                  "\\|"
 407                  "\\) *")))
 408     (concat
 409      "From "
 410
 411      ;; Username, perhaps with a quoted section that can contain spaces.
 412      "\\("
 413      "[^ \n]*"
 414      "\\(\\|\".*\"[^ \n]*\\)"
 415      "\\|<[^<>\n]+>"
 416      "\\)  ?"
 417
 418      ;; The time the message was sent.
 419      "\\([^ \n]*\\) *"                  ; day of the week
 420      "\\([^ ]*\\) *"                    ; month
 421      "\\([0-9]*\\) *"                   ; day of month
 422      "\\([0-9:]*\\) *"                  ; time of day
 423
 424      ;; Perhaps a time zone, specified by an abbreviation, or by a
 425      ;; numeric offset.
 426      time-zone-regexp
 427
 428      ;; The year.
 429      " [0-9][0-9]\\([0-9]*\\) *"
 430
 431      ;; On some systems the time zone can appear after the year, too.
 432      time-zone-regexp
 433
 434      ;; Old uucp cruft.
 435      "\\(remote from .*\\)?"
 436
 437      "\n")))
 438
 439 (defvar message-unsent-separator
 440   (concat "^ *---+ +Unsent message follows +---+ *$\\|"
 441           "^ *---+ +Returned message +---+ *$\\|"
 442           "^Start of returned message$\\|"
 443           "^ *---+ +Original message +---+ *$\\|"
 444           "^ *--+ +begin message +--+ *$\\|"
 445           "^ *---+ +Original message follows +---+ *$\\|"
 446           "^|? *---+ +Message text follows: +---+ *|?$")
 447   "A regexp that matches the separator before the text of a failed message.")
 448
 449 (defvar message-header-format-alist
 450   `((Newsgroups)
 451     (To . message-fill-header)
 452     (Cc . message-fill-header)
 453     (Subject)
 454     (In-Reply-To)
 455     (Fcc)
 456     (Bcc)
 457     (Date)
 458     (Organization)
 459     (Distribution)
 460     (Lines)
 461     (Expires)
 462     (Message-ID)
 463     (References . message-fill-header)
 464     (X-Mailer)
 465     (X-Newsreader))
 466   "Alist used for formatting headers.")
 467
 468 (eval-and-compile
 469   (autoload 'message-setup-toolbar "messagexmas")
 470   (autoload 'mh-send-letter "mh-comp"))
 471
 472 \f
 473
 474 ;;;
 475 ;;; Utility functions.
 476 ;;;
 477
 478 (defun message-point-at-bol ()
 479   "Return point at the beginning of the line."
 480   (let ((p (point)))
 481     (beginning-of-line)
 482     (prog1
 483         (point)
 484       (goto-char p))))
 485
 486 (defun message-point-at-eol ()
 487   "Return point at the end of the line."
 488   (let ((p (point)))
 489     (end-of-line)
 490     (prog1
 491         (point)
 492       (goto-char p))))
 493
 494 ;; Delete the current line (and the next N lines.);
 495 (defmacro message-delete-line (&optional n)
 496   `(delete-region (progn (beginning-of-line) (point))
 497                   (progn (forward-line ,(or n 1)) (point))))
 498
 499 (defun message-tokenize-header (header &optional separator)
 500   "Split HEADER into a list of header elements.
 501 \",\" is used as the separator."
 502   (let* ((beg 0)
 503          (separator (or separator ","))
 504          (regexp
 505           (format "[ \t]*\\([^%s]+\\)?\\([%s]+\\|\\'\\)" separator separator))
 506          elems)
 507     (while (and (string-match regexp header beg)
 508                 (< beg (length header)))
 509       (when (match-beginning 1)
 510         (push (match-string 1 header) elems))
 511       (setq beg (match-end 0)))
 512     (nreverse elems)))
 513
 514 (defun message-fetch-field (header)
 515   "The same as `mail-fetch-field', only remove all newlines."
 516   (let ((value (mail-fetch-field header)))
 517     (when value
 518       (nnheader-replace-chars-in-string value ?\n ? ))))
 519
 520 (defun message-fetch-reply-field (header)
 521   "Fetch FIELD from the message we're replying to."
 522   (when (and message-reply-buffer
 523              (buffer-name message-reply-buffer))
 524     (save-excursion
 525       (set-buffer message-reply-buffer)
 526       (message-fetch-field header))))
 527
 528 (defun message-set-work-buffer ()
 529   (if (get-buffer " *message work*")
 530       (progn
 531         (set-buffer " *message work*")
 532         (erase-buffer))
 533     (set-buffer (get-buffer-create " *message work*"))
 534     (kill-all-local-variables)
 535     (buffer-disable-undo (current-buffer))))
 536
 537 (defun message-functionp (form)
 538   "Return non-nil if FORM is funcallable."
 539   (or (and (symbolp form) (fboundp form))
 540       (and (listp form) (eq (car form) 'lambda))))
 541
 542 (defun message-strip-subject-re (subject)
 543   "Remove \"Re:\" from subject lines."
 544   (if (string-match "^[Rr][Ee]: *" subject)
 545       (substring subject (match-end 0))
 546     subject))
 547
 548 (defun message-remove-header (header &optional is-regexp first reverse)
 549   "Remove HEADER in the narrowed buffer.
 550 If REGEXP, HEADER is a regular expression.
 551 If FIRST, only remove the first instance of the header.
 552 Return the number of headers removed."
 553   (goto-char (point-min))
 554   (let ((regexp (if is-regexp header (concat "^" header ":")))
 555         (number 0)
 556         (case-fold-search t)
 557         last)
 558     (while (and (not (eobp))
 559                 (not last))
 560       (if (if reverse
 561               (not (looking-at regexp))
 562             (looking-at regexp))
 563           (progn
 564             (incf number)
 565             (when first
 566               (setq last t))
 567             (delete-region
 568              (point)
 569              ;; There might be a continuation header, so we have to search
 570              ;; until we find a new non-continuation line.
 571              (progn
 572                (forward-line 1)
 573                (if (re-search-forward "^[^ \t]" nil t)
 574                    (goto-char (match-beginning 0))
 575                  (point-max)))))
 576         (forward-line 1)
 577         (if (re-search-forward "^[^ \t]" nil t)
 578             (goto-char (match-beginning 0))
 579           (point-max))))
 580     number))
 581
 582 (defun message-narrow-to-headers ()
 583   "Narrow the buffer to the head of the message."
 584   (widen)
 585   (narrow-to-region
 586    (goto-char (point-min))
 587    (if (re-search-forward
 588         (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 589        (match-beginning 0)
 590      (point-max)))
 591   (goto-char (point-min)))
 592
 593 (defun message-narrow-to-head ()
 594   "Narrow the buffer to the head of the message."
 595   (widen)
 596   (narrow-to-region
 597    (goto-char (point-min))
 598    (if (search-forward "\n\n" nil 1)
 599        (1- (point))
 600      (point-max)))
 601   (goto-char (point-min)))
 602
 603 (defun message-news-p ()
 604   "Say whether the current buffer contains a news message."
 605   (save-excursion
 606     (save-restriction
 607       (message-narrow-to-headers)
 608       (message-fetch-field "newsgroups"))))
 609
 610 (defun message-mail-p ()
 611   "Say whether the current buffer contains a mail message."
 612   (save-excursion
 613     (save-restriction
 614       (message-narrow-to-headers)
 615       (or (message-fetch-field "to")
 616           (message-fetch-field "cc")
 617           (message-fetch-field "bcc")))))
 618
 619 (defun message-next-header ()
 620   "Go to the beginning of the next header."
 621   (beginning-of-line)
 622   (or (eobp) (forward-char 1))
 623   (not (if (re-search-forward "^[^ \t]" nil t)
 624            (beginning-of-line)
 625          (goto-char (point-max)))))
 626
 627 (defun message-sort-headers-1 ()
 628   "Sort the buffer as headers using `message-rank' text props."
 629   (goto-char (point-min))
 630   (sort-subr
 631    nil 'message-next-header
 632    (lambda ()
 633      (message-next-header)
 634      (unless (bobp)
 635        (forward-char -1)))
 636    (lambda ()
 637      (or (get-text-property (point) 'message-rank)
 638          0))))
 639
 640 (defun message-sort-headers ()
 641   "Sort the headers of the current message according to `message-header-format-alist'."
 642   (interactive)
 643   (save-excursion
 644     (save-restriction
 645       (let ((max (1+ (length message-header-format-alist)))
 646             rank)
 647         (message-narrow-to-headers)
 648         (while (re-search-forward "^[^ \n]+:" nil t)
 649           (put-text-property
 650            (match-beginning 0) (1+ (match-beginning 0))
 651            'message-rank
 652            (if (setq rank (length (memq (assq (intern (buffer-substring
 653                                                        (match-beginning 0)
 654                                                        (1- (match-end 0))))
 655                                               message-header-format-alist)
 656                                         message-header-format-alist)))
 657                (- max rank)
 658              (1+ max)))))
 659       (message-sort-headers-1))))
 660
 661 \f
 662
 663 ;;;
 664 ;;; Message mode
 665 ;;;
 666
 667 ;;; Set up keymap.
 668
 669 (defvar message-mode-map nil)
 670
 671 (unless message-mode-map
 672   (setq message-mode-map (copy-keymap text-mode-map))
 673   (define-key message-mode-map "\C-c?" 'describe-mode)
 674
 675   (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
 676   (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
 677   (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
 678   (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
 679   (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
 680   (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
 681   (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
 682   (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
 683   (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
 684   (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
 685   (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
 686   (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
 687   (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
 688
 689   (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
 690   (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
 691
 692   (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
 693   (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
 694   (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
 695   (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
 696   (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
 697   (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
 698
 699   (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
 700   (define-key message-mode-map "\C-c\C-s" 'message-send)
 701   (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
 702   (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
 703
 704   (define-key message-mode-map "\t" 'message-tab))
 705
 706 (easy-menu-define message-mode-menu message-mode-map
 707   "Message Menu."
 708   '("Message"
 709     "Go to Field:"
 710     "----"
 711     ["To" message-goto-to t]
 712     ["Subject" message-goto-subject t]
 713     ["Cc" message-goto-cc t]
 714     ["Reply-to" message-goto-reply-to t]
 715     ["Summary" message-goto-summary t]
 716     ["Keywords" message-goto-keywords t]
 717     ["Newsgroups" message-goto-newsgroups t]
 718     ["Followup-To" message-goto-followup-to t]
 719     ["Distribution" message-goto-distribution t]
 720     ["Body" message-goto-body t]
 721     ["Signature" message-goto-signature t]
 722     "----"
 723     "Miscellaneous Commands:"
 724     "----"
 725     ["Sort Headers" message-sort-headers t]
 726     ["Yank Original" message-yank-original t]
 727     ["Fill Yanked Message" message-fill-yanked-message t]
 728     ["Insert Signature" message-insert-signature t]
 729     ["Caesar (rot13) Message" message-caesar-buffer-body t]
 730     ["Rename buffer" message-rename-buffer t]
 731     ["Spellcheck" ispell-message t]
 732     "----"
 733     ["Send Message" message-send-and-exit t]
 734     ["Abort Message" message-dont-send t]))
 735
 736 (defvar facemenu-add-face-function)
 737 (defvar facemenu-remove-face-function)
 738
 739 ;;;###autoload
 740 (defun message-mode ()
 741   "Major mode for editing mail and news to be sent.
 742 Like Text Mode but with these additional commands:
 743 C-c C-s  message-send (send the message)    C-c C-c  message-send-and-exit
 744 C-c C-f  move to a header field (and create it if there isn't):
 745          C-c C-f C-t  move to To        C-c C-f C-s  move to Subject
 746          C-c C-f C-c  move to Cc        C-c C-f C-b  move to Bcc
 747          C-c C-f C-f  move to Fcc       C-c C-f C-r  move to Reply-To
 748          C-c C-f C-u  move to Summary   C-c C-f C-n  move to Newsgroups
 749          C-c C-f C-k  move to Keywords  C-c C-f C-d  move to Distribution
 750          C-c C-f C-o  move to Followup-To
 751 C-c C-t  message-insert-to (add a To header to a news followup)
 752 C-c C-n  message-insert-newsgroups (add a Newsgroup header to a news reply)
 753 C-c C-b  message-goto-body (move to beginning of message text).
 754 C-c C-i  message-goto-signature (move to the beginning of the signature).
 755 C-c C-w  message-insert-signature (insert `message-signature-file' file).
 756 C-c C-y  message-yank-original (insert current message, if any).
 757 C-c C-q  message-fill-yanked-message (fill what was yanked).
 758 C-c C-r  message-ceasar-buffer-body (rot13 the message body)."
 759   (interactive)
 760   (kill-all-local-variables)
 761   (make-local-variable 'message-reply-buffer)
 762   (setq message-reply-buffer nil)
 763   (make-local-variable 'message-send-actions)
 764   (make-local-variable 'message-exit-actions)
 765   (make-local-variable 'message-kill-actions)
 766   (make-local-variable 'message-postpone-actions)
 767   (set-syntax-table message-mode-syntax-table)
 768   (use-local-map message-mode-map)
 769   (setq local-abbrev-table text-mode-abbrev-table)
 770   (setq major-mode 'message-mode)
 771   (setq mode-name "Message")
 772   (setq buffer-offer-save t)
 773   (make-local-variable 'font-lock-defaults)
 774   (setq font-lock-defaults '(message-font-lock-keywords t))
 775   (make-local-variable 'facemenu-add-face-function)
 776   (make-local-variable 'facemenu-remove-face-function)
 777   (setq facemenu-add-face-function
 778         (lambda (face end)
 779           (let ((face-fun (cdr (assq face message-face-alist))))
 780             (if face-fun
 781                 (funcall face-fun (point) end)
 782               (error "Face %s not configured for %s mode" face mode-name)))
 783           "")
 784         facemenu-remove-face-function t)
 785   (make-local-variable 'paragraph-separate)
 786   (make-local-variable 'paragraph-start)
 787   (setq paragraph-start (concat (regexp-quote mail-header-separator)
 788                                 "$\\|[ \t]*[-_][-_][-_]+$\\|"
 789                                 paragraph-start))
 790   (setq paragraph-separate (concat (regexp-quote mail-header-separator)
 791                                    "$\\|[ \t]*[-_][-_][-_]+$\\|"
 792                                    paragraph-separate))
 793   (make-local-variable 'message-reply-headers)
 794   (setq message-reply-headers nil)
 795   (make-local-variable 'message-newsreader)
 796   (make-local-variable 'message-mailer)
 797   (make-local-variable 'message-post-method)
 798   (make-local-variable 'message-sent-message-via)
 799   (setq message-sent-message-via nil)
 800   (make-local-variable 'message-checksum)
 801   (setq message-checksum nil)
 802   (when (fboundp 'mail-hist-define-keys)
 803     (mail-hist-define-keys))
 804   (when (string-match "XEmacs\\|Lucid" emacs-version)
 805     (message-setup-toolbar))
 806   (easy-menu-add message-mode-menu message-mode-map)
 807   ;; Allow mail alias things.
 808   (if (fboundp 'mail-abbrevs-setup)
 809       (mail-abbrevs-setup)
 810     (funcall (intern "mail-aliases-setup")))
 811   (run-hooks 'text-mode-hook 'message-mode-hook))
 812
 813 \f
 814
 815 ;;;
 816 ;;; Message mode commands
 817 ;;;
 818
 819 ;;; Movement commands
 820
 821 (defun message-goto-to ()
 822   "Move point to the To header."
 823   (interactive)
 824   (message-position-on-field "To"))
 825
 826 (defun message-goto-subject ()
 827   "Move point to the Subject header."
 828   (interactive)
 829   (message-position-on-field "Subject"))
 830
 831 (defun message-goto-cc ()
 832   "Move point to the Cc header."
 833   (interactive)
 834   (message-position-on-field "Cc" "To"))
 835
 836 (defun message-goto-bcc ()
 837   "Move point to the Bcc  header."
 838   (interactive)
 839   (message-position-on-field "Bcc" "Cc" "To"))
 840
 841 (defun message-goto-fcc ()
 842   "Move point to the Fcc header."
 843   (interactive)
 844   (message-position-on-field "Fcc" "To" "Newsgroups"))
 845
 846 (defun message-goto-reply-to ()
 847   "Move point to the Reply-To header."
 848   (interactive)
 849   (message-position-on-field "Reply-To" "Subject"))
 850
 851 (defun message-goto-newsgroups ()
 852   "Move point to the Newsgroups header."
 853   (interactive)
 854   (message-position-on-field "Newsgroups"))
 855
 856 (defun message-goto-distribution ()
 857   "Move point to the Distribution header."
 858   (interactive)
 859   (message-position-on-field "Distribution"))
 860
 861 (defun message-goto-followup-to ()
 862   "Move point to the Followup-To header."
 863   (interactive)
 864   (message-position-on-field "Followup-To" "Newsgroups"))
 865
 866 (defun message-goto-keywords ()
 867   "Move point to the Keywords header."
 868   (interactive)
 869   (message-position-on-field "Keywords" "Subject"))
 870
 871 (defun message-goto-summary ()
 872   "Move point to the Summary header."
 873   (interactive)
 874   (message-position-on-field "Summary" "Subject"))
 875
 876 (defun message-goto-body ()
 877   "Move point to the beginning of the message body."
 878   (interactive)
 879   (goto-char (point-min))
 880   (search-forward (concat "\n" mail-header-separator "\n") nil t))
 881
 882 (defun message-goto-signature ()
 883   "Move point to the beginning of the message signature."
 884   (interactive)
 885   (goto-char (point-min))
 886   (or (re-search-forward message-signature-separator nil t)
 887       (goto-char (point-max))))
 888
 889 \f
 890
 891 (defun message-insert-to ()
 892   "Insert a To header that points to the author of the article being replied to."
 893   (interactive)
 894   (when (message-position-on-field "To")
 895     (insert ", "))
 896   (insert (or (message-fetch-reply-field "reply-to")
 897               (message-fetch-reply-field "from") "")))
 898
 899 (defun message-insert-newsgroups ()
 900   "Insert the Newsgroups header from the article being replied to."
 901   (interactive)
 902   (when (message-position-on-field "Newsgroups")
 903     (insert ","))
 904   (insert (or (message-fetch-reply-field "newsgroups") "")))
 905
 906 \f
 907
 908 ;;; Various commands
 909
 910 (defun message-insert-signature (&optional force)
 911   "Insert a signature.  See documentation for the `message-signature' variable."
 912   (interactive (list t))
 913   (let* ((signature
 914           (cond ((and (null message-signature)
 915                       force)
 916                  t)
 917                 ((message-functionp message-signature)
 918                  (funcall message-signature))
 919                 ((listp message-signature)
 920                  (eval message-signature))
 921                 (t message-signature)))
 922          (signature
 923           (cond ((stringp signature)
 924                  signature)
 925                 ((and (eq t signature)
 926                       message-signature-file
 927                       (file-exists-p message-signature-file))
 928                  signature))))
 929     (when signature
 930       ;; Remove blank lines at the end of the message.
 931       (goto-char (point-max))
 932       (skip-chars-backward " \t\n")
 933       (end-of-line)
 934       (delete-region (point) (point-max))
 935       ;; Insert the signature.
 936       (insert "\n\n-- \n")
 937       (if (eq signature t)
 938           (insert-file-contents message-signature-file)
 939         (insert signature))
 940       (goto-char (point-max))
 941       (or (bolp) (insert "\n")))))
 942
 943 (defvar message-caesar-translation-table nil)
 944
 945 (defun message-caesar-region (b e &optional n)
 946   "Caesar rotation of region by N, default 13, for decrypting netnews."
 947   (interactive
 948    (list
 949     (min (point) (or (mark t) (point)))
 950     (max (point) (or (mark t) (point)))
 951     (when current-prefix-arg
 952       (prefix-numeric-value current-prefix-arg))))
 953
 954   (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
 955   (unless (or (zerop n)                 ; no action needed for a rot of 0
 956               (= b e))                  ; no region to rotate
 957     ;; We build the table, if necessary.
 958     (when (or (not message-caesar-translation-table)
 959               (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
 960       (let ((i -1)
 961             (table (make-string 256 0)))
 962         (while (< (incf i) 256)
 963           (aset table i i))
 964         (setq table
 965               (concat
 966                (substring table 0 ?A)
 967                (substring table (+ ?A n) (+ ?A n (- 26 n)))
 968                (substring table ?A (+ ?A n))
 969                (substring table (+ ?A 26) ?a)
 970                (substring table (+ ?a n) (+ ?a n (- 26 n)))
 971                (substring table ?a (+ ?a n))
 972                (substring table (+ ?a 26) 255)))
 973         (setq message-caesar-translation-table table)))
 974     ;; Then we translate the region.  Do it this way to retain
 975     ;; text properties.
 976     (while (< b e)
 977       (subst-char-in-region
 978        b (1+ b) (char-after b)
 979        (aref message-caesar-translation-table (char-after b)))
 980       (incf b))))
 981
 982 (defun message-caesar-buffer-body (&optional rotnum)
 983   "Caesar rotates all letters in the current buffer by 13 places.
 984 Used to encode/decode possibly offensive messages (commonly in net.jokes).
 985 With prefix arg, specifies the number of places to rotate each letter forward.
 986 Mail and USENET news headers are not rotated."
 987   (interactive (if current-prefix-arg
 988                    (list (prefix-numeric-value current-prefix-arg))
 989                  (list nil)))
 990   (save-excursion
 991     (save-restriction
 992       (when (message-goto-body)
 993         (narrow-to-region (point) (point-max)))
 994       (message-caesar-region (point-min) (point-max) rotnum))))
 995
 996 (defun message-rename-buffer (&optional enter-string)
 997   "Rename the *message* buffer to \"*message* RECIPIENT\".
 998 If the function is run with a prefix, it will ask for a new buffer
 999 name, rather than giving an automatic name."
1000   (interactive "Pbuffer name: ")
1001   (save-excursion
1002     (save-restriction
1003       (goto-char (point-min))
1004       (narrow-to-region (point)
1005                         (search-forward mail-header-separator nil 'end))
1006       (let* ((mail-to (if (message-news-p) (message-fetch-field "Newsgroups")
1007                         (message-fetch-field "To")))
1008              (mail-trimmed-to
1009               (if (string-match "," mail-to)
1010                   (concat (substring mail-to 0 (match-beginning 0)) ", ...")
1011                 mail-to))
1012              (name-default (concat "*message* " mail-trimmed-to))
1013              (name (if enter-string
1014                        (read-string "New buffer name: " name-default)
1015                      name-default)))
1016         (rename-buffer name t)))))
1017
1018 (defun message-fill-yanked-message (&optional justifyp)
1019   "Fill the paragraphs of a message yanked into this one.
1020 Numeric argument means justify as well."
1021   (interactive "P")
1022   (save-excursion
1023     (goto-char (point-min))
1024     (search-forward (concat "\n" mail-header-separator "\n") nil t)
1025     (let ((fill-prefix message-yank-prefix))
1026       (fill-individual-paragraphs (point) (point-max) justifyp t))))
1027
1028 (defun message-indent-citation ()
1029   "Modify text just inserted from a message to be cited.
1030 The inserted text should be the region.
1031 When this function returns, the region is again around the modified text.
1032
1033 Normally, indent each nonblank line `message-indentation-spaces' spaces.
1034 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
1035   (let ((start (point)))
1036     ;; Remove unwanted headers.
1037     (when message-ignored-cited-headers
1038       (save-restriction
1039         (narrow-to-region
1040          (goto-char start)
1041          (if (search-forward "\n\n" nil t)
1042              (1- (point))
1043            (point)))
1044         (message-remove-header message-ignored-cited-headers t)))
1045     ;; Do the indentation.
1046     (if (null message-yank-prefix)
1047         (indent-rigidly start (mark t) message-indentation-spaces)
1048       (save-excursion
1049         (goto-char start)
1050         (while (< (point) (mark t))
1051           (insert message-yank-prefix)
1052           (forward-line 1)))
1053       (goto-char start))))
1054
1055 (defun message-yank-original (&optional arg)
1056   "Insert the message being replied to, if any.
1057 Puts point before the text and mark after.
1058 Normally indents each nonblank line ARG spaces (default 3).  However,
1059 if `message-yank-prefix' is non-nil, insert that prefix on each line.
1060
1061 Just \\[universal-argument] as argument means don't indent, insert no
1062 prefix, and don't delete any headers."
1063   (interactive "P")
1064   (let ((modified (buffer-modified-p)))
1065     (when (and message-reply-buffer
1066                message-cite-function)
1067       (delete-windows-on message-reply-buffer t)
1068       (insert-buffer message-reply-buffer)
1069       (funcall message-cite-function)
1070       (exchange-point-and-mark)
1071       (unless (bolp)
1072         (insert ?\n))
1073       (unless modified
1074         (setq message-checksum (message-checksum))))))
1075
1076 (defun message-cite-original ()
1077   (let ((start (point))
1078         (functions
1079          (when message-indent-citation-function
1080            (if (listp message-indent-citation-function)
1081                message-indent-citation-function
1082              (list message-indent-citation-function)))))
1083     (goto-char start)
1084     (while functions
1085       (funcall (pop functions)))
1086     (when message-citation-line-function
1087       (unless (bolp)
1088         (insert "\n"))
1089       (funcall message-citation-line-function))))
1090
1091 (defun message-insert-citation-line ()
1092   "Function that inserts a simple citation line."
1093   (when message-reply-headers
1094     (insert (mail-header-from message-reply-headers) " writes:\n\n")))
1095
1096 (defun message-position-on-field (header &rest afters)
1097   (let ((case-fold-search t))
1098     (save-restriction
1099       (narrow-to-region
1100        (goto-char (point-min))
1101        (progn
1102          (re-search-forward
1103           (concat "^" (regexp-quote mail-header-separator) "$"))
1104          (match-beginning 0)))
1105       (goto-char (point-min))
1106       (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
1107           (progn
1108             (re-search-forward "^[^ \t]" nil 'move)
1109             (beginning-of-line)
1110             (skip-chars-backward "\n")
1111             t)
1112         (while (and afters
1113                     (not (re-search-forward
1114                           (concat "^" (regexp-quote (car afters)) ":")
1115                           nil t)))
1116           (pop afters))
1117         (when afters
1118           (re-search-forward "^[^ \t]" nil 'move)
1119           (beginning-of-line))
1120         (insert header ": \n")
1121         (forward-char -1)
1122         nil))))
1123
1124 (defun message-remove-signature ()
1125   "Remove the signature from the text between point and mark.
1126 The text will also be indented the normal way."
1127   (save-excursion
1128     (let ((start (point))
1129           mark)
1130     (if (not (re-search-forward message-signature-separator (mark t) t))
1131         ;; No signature here, so we just indent the cited text.
1132         (message-indent-citation)
1133       ;; Find the last non-empty line.
1134       (forward-line -1)
1135       (while (looking-at "[ \t]*$")
1136         (forward-line -1))
1137       (forward-line 1)
1138       (setq mark (set-marker (make-marker) (point)))
1139       (goto-char start)
1140       (message-indent-citation)
1141       ;; Enable undoing the deletion.
1142       (undo-boundary)
1143       (delete-region mark (mark t))
1144       (set-marker mark nil)))))
1145
1146 \f
1147
1148 ;;;
1149 ;;; Sending messages
1150 ;;;
1151
1152 (defun message-send-and-exit (&optional arg)
1153   "Send message like `message-send', then, if no errors, exit from mail buffer."
1154   (interactive "P")
1155   (let ((buf (current-buffer))
1156         (actions message-exit-actions))
1157     (when (and (message-send arg)
1158                (buffer-name buf))
1159       (if message-kill-buffer-on-exit
1160           (kill-buffer buf)
1161         (bury-buffer buf)
1162         (when (eq buf (current-buffer))
1163           (message-bury buf)))
1164       (message-do-actions actions))))
1165
1166 (defun message-dont-send ()
1167   "Don't send the message you have been editing."
1168   (interactive)
1169   (message-bury (current-buffer))
1170   (message-do-actions message-postpone-actions))
1171
1172 (defun message-kill-buffer ()
1173   "Kill the current buffer."
1174   (interactive)
1175   (let ((actions message-kill-actions))
1176     (kill-buffer (current-buffer))
1177     (message-do-actions actions)))
1178
1179 (defun message-bury (buffer)
1180   "Bury this mail buffer."
1181   (let ((newbuf (other-buffer buffer)))
1182     (bury-buffer buffer)
1183     (if (and (fboundp 'frame-parameters)
1184              (cdr (assq 'dedicated (frame-parameters)))
1185              (not (null (delq (selected-frame) (visible-frame-list)))))
1186         (delete-frame (selected-frame))
1187       (switch-to-buffer newbuf))))
1188
1189 (defun message-send (&optional arg)
1190   "Send the message in the current buffer.
1191 If `message-interactive' is non-nil, wait for success indication
1192 or error messages, and inform user.
1193 Otherwise any failure is reported in a message back to
1194 the user from the mailer."
1195   (interactive "P")
1196   (when (if buffer-file-name
1197             (y-or-n-p (format "Send buffer contents as %s message? "
1198                               (if (message-mail-p)
1199                                   (if (message-news-p) "mail and news" "mail")
1200                                 "news")))
1201           (or (buffer-modified-p)
1202               (y-or-n-p "No changes in the buffer; really send? ")))
1203     ;; Make it possible to undo the coming changes.
1204     (undo-boundary)
1205     (message-fix-before-sending)
1206     (run-hooks 'message-send-hook)
1207     (message "Sending...")
1208     (when (and (or (not (message-news-p))
1209                    (and (or (not (memq 'news message-sent-message-via))
1210                             (y-or-n-p
1211                              "Already sent message via news; resend? "))
1212                         (funcall message-send-news-function arg)))
1213                (or (not (message-mail-p))
1214                    (and (or (not (memq 'mail message-sent-message-via))
1215                             (y-or-n-p
1216                              "Already sent message via mail; resend? "))
1217                         (message-send-mail arg))))
1218       (message-do-fcc)
1219       (when (fboundp 'mail-hist-put-headers-into-history)
1220         (mail-hist-put-headers-into-history))
1221       (run-hooks 'message-sent-hook)
1222       (message "Sending...done")
1223       ;; If buffer has no file, mark it as unmodified and delete autosave.
1224       (unless buffer-file-name
1225         (set-buffer-modified-p nil)
1226         (delete-auto-save-file-if-necessary t))
1227       (message-do-actions message-send-actions)
1228       ;; Return success.
1229       t)))
1230
1231 (defun message-fix-before-sending ()
1232   "Do various things to make the message nice before sending it."
1233   ;; Make sure there's a newline at the end of the message.
1234   (goto-char (point-max))
1235   (unless (bolp)
1236     (insert "\n")))
1237
1238 (defun message-add-action (action &rest types)
1239   "Add ACTION to be performed when doing an exit of type TYPES."
1240   (let (var)
1241     (while types
1242       (set (setq var (intern (format "message-%s-actions" (pop types))))
1243            (nconc (symbol-value var) (list action))))))
1244
1245 (defun message-do-actions (actions)
1246   "Perform all actions in ACTIONS."
1247   ;; Now perform actions on successful sending.
1248   (while actions
1249     (condition-case nil
1250         (cond
1251          ;; A simple function.
1252          ((message-functionp (car actions))
1253           (funcall (car actions)))
1254          ;; Something to be evaled.
1255          (t
1256           (eval (car actions))))
1257       (error))
1258     (pop actions)))
1259
1260 (defun message-send-mail (&optional arg)
1261   (require 'mail-utils)
1262   (let ((tembuf (generate-new-buffer " message temp"))
1263         (case-fold-search nil)
1264         (news (message-news-p))
1265         (mailbuf (current-buffer)))
1266     (save-restriction
1267       (message-narrow-to-headers)
1268       ;; Insert some headers.
1269       (let ((message-deletable-headers
1270              (if news nil message-deletable-headers)))
1271         (message-generate-headers message-required-mail-headers))
1272       ;; Let the user do all of the above.
1273       (run-hooks 'message-header-hook))
1274     (unwind-protect
1275         (save-excursion
1276           (set-buffer tembuf)
1277           (erase-buffer)
1278           (insert-buffer-substring mailbuf)
1279           ;; Remove some headers.
1280           (save-restriction
1281             (message-narrow-to-headers)
1282             ;; Remove some headers.
1283             (message-remove-header message-ignored-mail-headers t))
1284           (goto-char (point-max))
1285           ;; require one newline at the end.
1286           (or (= (preceding-char) ?\n)
1287               (insert ?\n))
1288           (when (and news
1289                      (or (message-fetch-field "cc")
1290                          (message-fetch-field "to")))
1291             (message-insert-courtesy-copy))
1292           (funcall message-send-mail-function))
1293       (kill-buffer tembuf))
1294     (set-buffer mailbuf)
1295     (push 'mail message-sent-message-via)))
1296
1297 (defun message-send-mail-with-sendmail ()
1298   "Send off the prepared buffer with sendmail."
1299   (let ((errbuf (if message-interactive
1300                     (generate-new-buffer " sendmail errors")
1301                   0))
1302         resend-to-addresses delimline)
1303     (let ((case-fold-search t))
1304       (save-restriction
1305         (message-narrow-to-headers)
1306         (setq resend-to-addresses (message-fetch-field "resent-to")))
1307       ;; Change header-delimiter to be what sendmail expects.
1308       (goto-char (point-min))
1309       (re-search-forward
1310        (concat "^" (regexp-quote mail-header-separator) "\n"))
1311       (replace-match "\n")
1312       (backward-char 1)
1313       (setq delimline (point-marker))
1314       ;; Insert an extra newline if we need it to work around
1315       ;; Sun's bug that swallows newlines.
1316       (goto-char (1+ delimline))
1317       (when (eval message-mailer-swallows-blank-line)
1318         (newline))
1319       (when message-interactive
1320         (save-excursion
1321           (set-buffer errbuf)
1322           (erase-buffer))))
1323     (let ((default-directory "/"))
1324       (apply 'call-process-region
1325              (append (list (point-min) (point-max)
1326                            (if (boundp 'sendmail-program)
1327                                sendmail-program
1328                              "/usr/lib/sendmail")
1329                            nil errbuf nil "-oi")
1330                      ;; Always specify who from,
1331                      ;; since some systems have broken sendmails.
1332                      (list "-f" (user-login-name))
1333                      ;; These mean "report errors by mail"
1334                      ;; and "deliver in background".
1335                      (if (null message-interactive) '("-oem" "-odb"))
1336                      ;; Get the addresses from the message
1337                      ;; unless this is a resend.
1338                      ;; We must not do that for a resend
1339                      ;; because we would find the original addresses.
1340                      ;; For a resend, include the specific addresses.
1341                      (if resend-to-addresses
1342                          (list resend-to-addresses)
1343                        '("-t")))))
1344     (when message-interactive
1345       (save-excursion
1346         (set-buffer errbuf)
1347         (goto-char (point-min))
1348         (while (re-search-forward "\n\n* *" nil t)
1349           (replace-match "; "))
1350         (if (not (zerop (buffer-size)))
1351             (error "Sending...failed to %s"
1352                    (buffer-substring (point-min) (point-max)))))
1353       (when (bufferp errbuf)
1354         (kill-buffer errbuf)))))
1355
1356 (defun message-send-mail-with-mh ()
1357   "Send the prepared message buffer with mh."
1358   (let ((mh-previous-window-config nil)
1359         (name (make-temp-name
1360                (concat (file-name-as-directory message-autosave-directory)
1361                        "msg."))))
1362     (setq buffer-file-name name)
1363     (mh-send-letter)
1364     (condition-case ()
1365         (delete-file name)
1366       (error nil))))
1367
1368 (defun message-send-news (&optional arg)
1369   (let ((tembuf (generate-new-buffer " *message temp*"))
1370         (case-fold-search nil)
1371         (method (if (message-functionp message-post-method)
1372                     (funcall message-post-method arg)
1373                   message-post-method))
1374         (messbuf (current-buffer))
1375         result)
1376     (save-restriction
1377       (message-narrow-to-headers)
1378       ;; Insert some headers.
1379       (message-generate-headers message-required-news-headers)
1380       ;; Let the user do all of the above.
1381       (run-hooks 'message-header-hook))
1382     (when (message-check-news-syntax)
1383       (unwind-protect
1384           (save-excursion
1385             (set-buffer tembuf)
1386             (buffer-disable-undo (current-buffer))
1387             (erase-buffer)
1388             (insert-buffer-substring messbuf)
1389             ;; Remove some headers.
1390             (save-restriction
1391               (message-narrow-to-headers)
1392               ;; Remove some headers.
1393               (message-remove-header message-ignored-news-headers t))
1394             (goto-char (point-max))
1395             ;; require one newline at the end.
1396             (or (= (preceding-char) ?\n)
1397                 (insert ?\n))
1398             (let ((case-fold-search t))
1399               ;; Remove the delimeter.
1400               (goto-char (point-min))
1401               (re-search-forward
1402                (concat "^" (regexp-quote mail-header-separator) "\n"))
1403               (replace-match "\n")
1404               (backward-char 1))
1405             (require (car method))
1406             (funcall (intern (format "%s-open-server" (car method)))
1407                      (cadr method) (cddr method))
1408             (setq result
1409                   (funcall (intern (format "%s-request-post" (car method))))))
1410         (kill-buffer tembuf))
1411       (set-buffer messbuf)
1412       (if result
1413           (push 'news message-sent-message-via)
1414         (message "Couldn't send message via news: %s"
1415                  (nnheader-get-report (car method)))
1416         nil))))
1417
1418 ;;;
1419 ;;; Header generation & syntax checking.
1420 ;;;
1421
1422 (defun message-check-news-syntax ()
1423   "Check the syntax of the message."
1424   (and
1425    ;; We narrow to the headers and check them first.
1426    (save-excursion
1427      (save-restriction
1428        (message-narrow-to-headers)
1429        (and
1430         ;; Check for commands in Subject.
1431         (or
1432          (message-check-element 'subject-cmsg)
1433          (save-excursion
1434            (if (string-match "^cmsg " (message-fetch-field "subject"))
1435                (y-or-n-p
1436                 "The control code \"cmsg \" is in the subject. Really post? ")
1437              t)))
1438         ;; Check for multiple identical headers.
1439         (or (message-check-element 'multiple-headers)
1440             (save-excursion
1441               (let (found)
1442                 (while (and (not found)
1443                             (re-search-forward "^[^ \t:]+: " nil t))
1444                   (save-excursion
1445                     (or (re-search-forward
1446                          (concat "^" (setq found
1447                                            (buffer-substring
1448                                             (match-beginning 0)
1449                                             (- (match-end 0) 2))))
1450                          nil t)
1451                         (setq found nil))))
1452                 (if found
1453                     (y-or-n-p
1454                      (format "Multiple %s headers. Really post? " found))
1455                   t))))
1456         ;; Check for Version and Sendsys.
1457         (or (message-check-element 'sendsys)
1458             (save-excursion
1459               (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
1460                   (y-or-n-p
1461                    (format "The article contains a %s command. Really post? "
1462                            (buffer-substring (match-beginning 0)
1463                                              (1- (match-end 0)))))
1464                 t)))
1465         ;; See whether we can shorten Followup-To.
1466         (or (message-check-element 'shorten-followup-to)
1467             (let ((newsgroups (message-fetch-field "newsgroups"))
1468                   (followup-to (message-fetch-field "followup-to"))
1469                   to)
1470               (when (and newsgroups (string-match "," newsgroups)
1471                          (not followup-to)
1472                          (not
1473                           (zerop
1474                            (length
1475                             (setq to (completing-read
1476                                       "Followups to: (default all groups) "
1477                                       (mapcar (lambda (g) (list g))
1478                                               (cons "poster"
1479                                                     (message-tokenize-header
1480                                                      newsgroups)))))))))
1481                 (goto-char (point-min))
1482                 (insert "Followup-To: " to "\n"))
1483               t))
1484
1485         ;; Check for Approved.
1486         (or (message-check-element 'approved)
1487             (save-excursion
1488               (if (re-search-forward "^Approved:" nil t)
1489                   (y-or-n-p
1490                    "The article contains an Approved header. Really post? ")
1491                 t)))
1492         ;; Check the Message-Id header.
1493         (or (message-check-element 'message-id)
1494             (save-excursion
1495               (let* ((case-fold-search t)
1496                      (message-id (message-fetch-field "message-id")))
1497                 (or (not message-id)
1498                     (and (string-match "@" message-id)
1499                          (string-match "@[^\\.]*\\." message-id))
1500                     (y-or-n-p
1501                      (format
1502                       "The Message-ID looks strange: \"%s\". Really post? "
1503                       message-id))))))
1504         ;; Check the Subject header.
1505         (or
1506          (message-check-element 'subject)
1507          (save-excursion
1508            (let* ((case-fold-search t)
1509                   (subject (message-fetch-field "subject")))
1510              (or
1511               (and subject
1512                    (not (string-match "\\`[ \t]*\\'" subject)))
1513               (progn
1514                 (message
1515                  "The subject field is empty or missing.  Posting is denied.")
1516                 nil)))))
1517         ;; Check the Newsgroups & Followup-To headers.
1518         (or
1519          (message-check-element 'existing-newsgroups)
1520          (let* ((case-fold-search t)
1521                 (newsgroups (message-fetch-field "newsgroups"))
1522                 (followup-to (message-fetch-field "followup-to"))
1523                 (groups (message-tokenize-header
1524                          (if followup-to
1525                              (concat newsgroups "," followup-to)
1526                            newsgroups)))
1527                 (hashtb (and (boundp 'gnus-active-hashtb)
1528                              gnus-active-hashtb))
1529                 errors)
1530            (if (not hashtb)
1531                t
1532              (while groups
1533                (unless (boundp (intern (car groups) hashtb))
1534                  (push (car groups) errors))
1535                (pop groups))
1536              (if (not errors)
1537                  t
1538                (y-or-n-p
1539                 (format
1540                  "Really post to %s unknown group%s: %s "
1541                  (if (= (length errors) 1) "this" "these")
1542                  (if (= (length errors) 1) "" "s")
1543                  (mapconcat 'identity errors ", ")))))))
1544         ;; Check the Newsgroups & Followup-To headers for syntax errors.
1545         (or
1546          (message-check-element 'valid-newsgroups)
1547          (let ((case-fold-search t)
1548                (headers '("Newsgroups" "Followup-To"))
1549                header error)
1550            (while (and headers (not error))
1551              (when (setq header (mail-fetch-field (car headers)))
1552                (if (or
1553                     (not (string-match
1554                           "\\`\\([-.a-zA-Z0-9]+\\)?\\(,[-.a-zA-Z0-9]+\\)*\\'"
1555                           header))
1556                     (memq
1557                      nil (mapcar
1558                           (lambda (g)
1559                             (not (string-match "\\.\\'\\|\\.\\." g)))
1560                           (message-tokenize-header header ","))))
1561                    (setq error t)))
1562              (unless error
1563                (pop headers)))
1564            (if (not error)
1565                t
1566              (y-or-n-p
1567               (format "The %s header looks odd: \"%s\".  Really post? "
1568                       (car headers) header)))))
1569         ;; Check the From header.
1570         (or
1571          (message-check-element 'from)
1572          (save-excursion
1573            (let* ((case-fold-search t)
1574                   (from (message-fetch-field "from")))
1575              (cond
1576               ((not from)
1577                (message "There is no From line.  Posting is denied.")
1578                nil)
1579               ((not (string-match "@[^\\.]*\\." from))
1580                (message
1581                 "Denied posting -- the From looks strange: \"%s\"." from)
1582                nil)
1583               ((string-match "@[^@]*@" from)
1584                (message
1585                 "Denied posting -- two \"@\"'s in the From header: %s." from)
1586                nil)
1587               ((string-match "(.*).*(.*)" from)
1588                (message
1589                 "Denied posting -- the From header looks strange: \"%s\"."
1590                 from)
1591                nil)
1592               (t t))))))))
1593    ;; Check for long lines.
1594    (or (message-check-element 'long-lines)
1595        (save-excursion
1596          (goto-char (point-min))
1597          (re-search-forward
1598           (concat "^" (regexp-quote mail-header-separator) "$"))
1599          (while (and
1600                  (progn
1601                    (end-of-line)
1602                    (< (current-column) 80))
1603                  (zerop (forward-line 1))))
1604          (or (bolp)
1605              (eobp)
1606              (y-or-n-p
1607               "You have lines longer than 79 characters.  Really post? "))))
1608    ;; Check whether the article is empty.
1609    (or (message-check-element 'empty)
1610        (save-excursion
1611          (goto-char (point-min))
1612          (re-search-forward
1613           (concat "^" (regexp-quote mail-header-separator) "$"))
1614          (forward-line 1)
1615          (let ((b (point)))
1616            (or (re-search-forward message-signature-separator nil t)
1617                (goto-char (point-max)))
1618            (beginning-of-line)
1619            (or (re-search-backward "[^ \n\t]" b t)
1620                (y-or-n-p "Empty article.  Really post? ")))))
1621    ;; Check for control characters.
1622    (or (message-check-element 'control-chars)
1623        (save-excursion
1624          (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
1625              (y-or-n-p
1626               "The article contains control characters. Really post? ")
1627            t)))
1628    ;; Check excessive size.
1629    (or (message-check-element 'size)
1630        (if (> (buffer-size) 60000)
1631            (y-or-n-p
1632             (format "The article is %d octets long. Really post? "
1633                     (buffer-size)))