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 'rmail)
  36 (require 'nnheader)
  37 (require 'timezone)
  38 (require 'easymenu)
  39 (if (string-match "XEmacs\\|Lucid" emacs-version)
  40     (require 'mail-abbrevs)
  41   (require 'mailabbrev))
  42
  43 (defvar message-directory "~/Mail/"
  44   "*Directory from which all other mail file variables are derived.")
  45
  46 (defvar message-max-buffers 10
  47   "*How many buffers to keep before starting to kill them off.")
  48
  49 (defvar message-send-rename-function nil
  50   "Function called to rename the buffer after sending it.")
  51
  52 ;;;###autoload
  53 (defvar message-fcc-handler-function 'rmail-output
  54   "*A function called to save outgoing articles.
  55 This function will be called with the name of the file to store the
  56 article in. The default function is `rmail-output' which saves in Unix
  57 mailbox format.")
  58
  59 ;;;###autoload
  60 (defvar message-courtesy-message
  61   "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
  62   "*This is inserted at the start of a mailed copy of a posted message.
  63 If this variable is nil, no such courtesy message will be added.")
  64
  65 ;;;###autoload
  66 (defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
  67   "*Regexp that matches headers to be removed in resent bounced mail.")
  68
  69 ;;;###autoload
  70 (defvar message-from-style 'default
  71   "*Specifies how \"From\" headers look.
  72
  73 If `nil', they contain just the return address like:
  74         king@grassland.com
  75 If `parens', they look like:
  76         king@grassland.com (Elvis Parsley)
  77 If `angles', they look like:
  78         Elvis Parsley <king@grassland.com>
  79
  80 Otherwise, most addresses look like `angles', but they look like
  81 `parens' if `angles' would need quoting and `parens' would not.")
  82
  83 ;;;###autoload
  84 (defvar message-syntax-checks nil
  85   "Controls what syntax checks should not be performed on outgoing posts.
  86 To disable checking of long signatures, for instance, add
  87  `(signature . disabled)' to this list.
  88
  89 Don't touch this variable unless you really know what you're doing.
  90
  91 Checks include subject-cmsg multiple-headers sendsys message-id from
  92 long-lines control-chars size new-text redirected-followup signature
  93 approved sender empty empty-headers message-id from subject.")
  94
  95 ;;;###autoload
  96 (defvar message-required-news-headers
  97   '(From Newsgroups Subject Date Message-ID
  98          (optional . Organization) Lines
  99          (optional . X-Newsreader))
 100   "*Headers to be generated or prompted for when posting an article.
 101 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
 102 Message-ID.  Organization, Lines, In-Reply-To, Expires, and
 103 X-Newsreader are optional.  If don't you want message to insert some
 104 header, remove it from this list.")
 105
 106 ;;;###autoload
 107 (defvar message-required-mail-headers
 108   '(From Subject Date (optional . In-Reply-To) Message-ID Lines
 109          (optional . X-Mailer))
 110   "*Headers to be generated or prompted for when mailing a message.
 111 RFC822 required that From, Date, To, Subject and Message-ID be
 112 included.  Organization, Lines and X-Mailer are optional.")
 113
 114 ;;;###autoload
 115 (defvar message-deletable-headers '(Message-ID Date)
 116   "*Headers to be deleted if they already exist and were generated by message previously.")
 117
 118 ;;;###autoload
 119 (defvar message-ignored-news-headers
 120   "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:"
 121   "*Regexp of headers to be removed unconditionally before posting.")
 122
 123 ;;;###autoload
 124 (defvar message-ignored-mail-headers "^Gcc:\\|^Fcc:"
 125   "*Regexp of headers to be removed unconditionally before mailing.")
 126
 127 ;;;###autoload
 128 (defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:"
 129   "*Header lines matching this regexp will be deleted before posting.
 130 It's best to delete old Path and Date headers before posting to avoid
 131 any confusion.")
 132
 133 ;;;###autoload
 134 (defvar message-signature-separator "^-- *$"
 135   "Regexp matching the signature separator.")
 136
 137 ;;;###autoload
 138 (defvar message-interactive nil
 139   "Non-nil means when sending a message wait for and display errors.
 140 nil means let mailer mail back a message to report errors.")
 141
 142 ;;;###autoload
 143 (defvar message-generate-new-buffers t
 144   "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.
 145 If this is a function, call that function with three parameters:  The type,
 146 the to address and the group name.  (Any of these may be nil.)  The function
 147 should return the new buffer name.")
 148
 149 ;;;###autoload
 150 (defvar message-kill-buffer-on-exit nil
 151   "*Non-nil means that the message buffer will be killed after sending a message.")
 152
 153 (defvar gnus-local-organization)
 154 (defvar message-user-organization
 155   (or (and (boundp 'gnus-local-organization)
 156            gnus-local-organization)
 157       (getenv "ORGANIZATION")
 158       t)
 159   "*String to be used as an Organization header.
 160 If t, use `message-user-organization-file'.")
 161
 162 ;;;###autoload
 163 (defvar message-user-organization-file "/usr/lib/news/organization"
 164   "*Local news organization file.")
 165
 166 (defvar message-autosave-directory "~/"
 167   ; (concat (file-name-as-directory message-directory) "drafts/")
 168   "*Directory where message autosaves buffers.
 169 If nil, message won't autosave.")
 170
 171 (defvar message-forward-start-separator
 172   "------- Start of forwarded message -------\n"
 173   "*Delimiter inserted before forwarded messages.")
 174
 175 (defvar message-forward-end-separator
 176   "------- End of forwarded message -------\n"
 177   "*Delimiter inserted after forwarded messages.")
 178
 179 ;;;###autoload
 180 (defvar message-signature-before-forwarded-message t
 181   "*If non-nil, put the signature before any included forwarded message.")
 182
 183 ;;;###autoload
 184 (defvar message-included-forward-headers
 185   "^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:"
 186   "*Regexp matching headers to be included in forwarded messages.")
 187
 188 ;;;###autoload
 189 (defvar message-ignored-resent-headers "^Return-receipt"
 190   "*All headers that match this regexp will be deleted when resending a message.")
 191
 192 ;;;###autoload
 193 (defvar message-ignored-cited-headers "."
 194   "Delete these headers from the messages you yank.")
 195
 196 ;; Useful to set in site-init.el
 197 ;;;###autoload
 198 (defvar message-send-mail-function 'message-send-mail-with-sendmail
 199   "Function to call to send the current buffer as mail.
 200 The headers should be delimited by a line whose contents match the
 201 variable `mail-header-separator'.
 202
 203 Legal values include `message-send-mail-with-mh' and
 204 `message-send-mail-with-sendmail', which is the default.")
 205
 206 ;;;###autoload
 207 (defvar message-send-news-function 'message-send-news
 208   "Function to call to send the current buffer as news.
 209 The headers should be delimited by a line whose contents match the
 210 variable `mail-header-separator'.")
 211
 212 ;;;###autoload
 213 (defvar message-reply-to-function nil
 214   "Function that should return a list of headers.
 215 This function should pick out addresses from the To, Cc, and From headers
 216 and respond with new To and Cc headers.")
 217
 218 ;;;###autoload
 219 (defvar message-wide-reply-to-function nil
 220   "Function that should return a list of headers.
 221 This function should pick out addresses from the To, Cc, and From headers
 222 and respond with new To and Cc headers.")
 223
 224 ;;;###autoload
 225 (defvar message-followup-to-function nil
 226   "Function that should return a list of headers.
 227 This function should pick out addresses from the To, Cc, and From headers
 228 and respond with new To and Cc headers.")
 229
 230 ;;;###autoload
 231 (defvar message-use-followup-to 'ask
 232   "*Specifies what to do with Followup-To header.
 233 If nil, ignore the header. If it is t, use its value, but query before
 234 using the \"poster\" value.  If it is the symbol `ask', query the user
 235 whether to ignore the \"poster\" value.  If it is the symbol `use',
 236 always use the value.")
 237
 238 (defvar gnus-post-method)
 239 (defvar gnus-select-method)
 240 ;;;###autoload
 241 (defvar message-post-method
 242   (cond ((and (boundp 'gnus-post-method)
 243               gnus-post-method)
 244          gnus-post-method)
 245         ((boundp 'gnus-select-method)
 246          gnus-select-method)
 247         (t '(nnspool "")))
 248   "Method used to post news.")
 249
 250 ;;;###autoload
 251 (defvar message-generate-headers-first nil
 252   "*If non-nil, generate all possible headers before composing.")
 253
 254 (defvar message-setup-hook nil
 255   "Normal hook, run each time a new outgoing message is initialized.
 256 The function `message-setup' runs this hook.")
 257
 258 (defvar message-signature-setup-hook nil
 259   "Normal hook, run each time a new outgoing message is initialized.
 260 It is run after the headers have been inserted and before
 261 the signature is inserted.")
 262
 263 (defvar message-mode-hook
 264   (if (fboundp 'mail-abbrevs-setup)
 265       '(mail-abbrevs-setup)
 266     (list (intern "mail-aliases-setup")))
 267   "Hook run in message mode buffers.")
 268
 269 (defvar message-header-hook nil
 270   "Hook run in a message mode buffer narrowed to the headers.")
 271
 272 (defvar message-header-setup-hook nil
 273   "Hook called narrowed to the headers when setting up a message buffer.")
 274
 275 ;;;###autoload
 276 (defvar message-citation-line-function 'message-insert-citation-line
 277   "*Function called to insert the \"Whomever writes:\" line.")
 278
 279 ;;;###autoload
 280 (defvar message-yank-prefix "> "
 281   "*Prefix inserted on the lines of yanked messages.
 282 nil means use indentation.")
 283
 284 (defvar message-indentation-spaces 3
 285   "*Number of spaces to insert at the beginning of each cited line.
 286 Used by `message-yank-original' via `message-yank-cite'.")
 287
 288 ;;;###autoload
 289 (defvar message-cite-function 'message-cite-original
 290   "*Function for citing an original message.")
 291
 292 ;;;###autoload
 293 (defvar message-indent-citation-function 'message-indent-citation
 294   "*Function for modifying a citation just inserted in the mail buffer.
 295 This can also be a list of functions.  Each function can find the
 296 citation between (point) and (mark t).  And each function should leave
 297 point and mark around the citation text as modified.")
 298
 299 (defvar message-abbrevs-loaded nil)
 300
 301 ;;;###autoload
 302 (defvar message-signature t
 303   "*String to be inserted at the end of the message buffer.
 304 If t, the `message-signature-file' file will be inserted instead.
 305 If a function, the result from the function will be used instead.
 306 If a form, the result from the form will be used instead.")
 307
 308 ;;;###autoload
 309 (defvar message-signature-file "~/.signature"
 310   "*File containing the text inserted at end of message. buffer.")
 311
 312 (defvar message-distribution-function nil
 313   "*Function called to return a Distribution header.")
 314
 315 (defvar message-expires 14
 316   "*Number of days before your article expires.")
 317
 318 (defvar message-user-path nil
 319   "If nil, use the NNTP server name in the Path header.
 320 If stringp, use this; if non-nil, use no host name (user name only).")
 321
 322 (defvar message-reply-buffer nil)
 323 (defvar message-reply-headers nil)
 324 (defvar message-newsreader nil)
 325 (defvar message-mailer nil)
 326 (defvar message-sent-message-via nil)
 327 (defvar message-checksum nil)
 328 (defvar message-send-actions nil
 329   "A list of actions to be performed upon successful sending of a message.")
 330 (defvar message-exit-actions nil
 331   "A list of actions to be performed upon exiting after sending a message.")
 332 (defvar message-kill-actions nil
 333   "A list of actions to be performed before killing a message buffer.")
 334 (defvar message-postpone-actions nil
 335   "A list of actions to be performed after postponing a message.")
 336
 337 ;;;###autoload
 338 (defvar message-default-headers nil
 339   "*A string containing header lines to be inserted in outgoing messages.
 340 It is inserted before you edit the message, so you can edit or delete
 341 these lines.")
 342
 343 ;;;###autoload
 344 (defvar message-default-mail-headers nil
 345   "*A string of header lines to be inserted in outgoing mails.")
 346
 347 ;;;###autoload
 348 (defvar message-default-news-headers nil
 349   "*A string of header lines to be inserted in outgoing news articles.")
 350
 351 ;; Note: could use /usr/ucb/mail instead of sendmail;
 352 ;; options -t, and -v if not interactive.
 353 (defvar message-mailer-swallows-blank-line
 354   (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
 355                          system-configuration)
 356            (file-readable-p "/etc/sendmail.cf")
 357            (let ((buffer (get-buffer-create " *temp*")))
 358              (unwind-protect
 359                  (save-excursion
 360                    (set-buffer buffer)
 361                    (insert-file-contents "/etc/sendmail.cf")
 362                    (goto-char (point-min))
 363                    (let ((case-fold-search nil))
 364                      (re-search-forward "^OR\\>" nil t)))
 365                (kill-buffer buffer))))
 366       ;; According to RFC822, "The field-name must be composed of printable
 367       ;; ASCII characters (i.e. characters that have decimal values between
 368       ;; 33 and 126, except colon)", i.e. any chars except ctl chars,
 369       ;; space, or colon.
 370       '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
 371   "Set this non-nil if the system's mailer runs the header and body together.
 372 \(This problem exists on Sunos 4 when sendmail is run in remote mode.)
 373 The value should be an expression to test whether the problem will
 374 actually occur.")
 375
 376 (defvar message-mode-syntax-table
 377   (let ((table (copy-syntax-table text-mode-syntax-table)))
 378     (modify-syntax-entry ?% ". " table)
 379     table)
 380   "Syntax table used while in Message mode.")
 381
 382 (defvar message-font-lock-keywords
 383   (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")))
 384     (list '("^To:" . font-lock-function-name-face)
 385           '("^[GBF]?[Cc][Cc]:\\|^Reply-To:" . font-lock-keyword-face)
 386           '("^\\(Subject:\\)[ \t]*\\(.+\\)?"
 387             (1 font-lock-comment-face) (2 font-lock-type-face nil t))
 388           (list (concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
 389                 1 'font-lock-comment-face)
 390           (cons (concat "^[ \t]*"
 391                         "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
 392                         "[>|}].*")
 393                 'font-lock-reference-face)
 394           '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*"
 395             . font-lock-string-face)))
 396   "Additional expressions to highlight in Message mode.")
 397
 398 (defvar message-face-alist
 399   '((bold . bold-region)
 400     (underline . underline-region)
 401     (default . (lambda (b e)
 402                  (unbold-region b e)
 403                  (ununderline-region b e))))
 404   "Alist of mail and news faces for facemenu.
 405 The cdr of ech entry is a function for applying the face to a region.")
 406
 407 (defvar message-send-hook nil
 408   "Hook run before sending messages.")
 409
 410 (defvar message-sent-hook nil
 411   "Hook run after sending messages.")
 412
 413 ;;; Internal variables.
 414
 415 (defvar message-buffer-list nil)
 416
 417 ;;; Regexp matching the delimiter of messages in UNIX mail format
 418 ;;; (UNIX From lines), minus the initial ^.
 419 (defvar message-unix-mail-delimiter
 420   (let ((time-zone-regexp
 421          (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
 422                  "\\|[-+]?[0-9][0-9][0-9][0-9]"
 423                  "\\|"
 424                  "\\) *")))
 425     (concat
 426      "From "
 427
 428      ;; Username, perhaps with a quoted section that can contain spaces.
 429      "\\("
 430      "[^ \n]*"
 431      "\\(\\|\".*\"[^ \n]*\\)"
 432      "\\|<[^<>\n]+>"
 433      "\\)  ?"
 434
 435      ;; The time the message was sent.
 436      "\\([^ \n]*\\) *"                  ; day of the week
 437      "\\([^ ]*\\) *"                    ; month
 438      "\\([0-9]*\\) *"                   ; day of month
 439      "\\([0-9:]*\\) *"                  ; time of day
 440
 441      ;; Perhaps a time zone, specified by an abbreviation, or by a
 442      ;; numeric offset.
 443      time-zone-regexp
 444
 445      ;; The year.
 446      " [0-9][0-9]\\([0-9]*\\) *"
 447
 448      ;; On some systems the time zone can appear after the year, too.
 449      time-zone-regexp
 450
 451      ;; Old uucp cruft.
 452      "\\(remote from .*\\)?"
 453
 454      "\n")))
 455
 456 (defvar message-unsent-separator
 457   (concat "^ *---+ +Unsent message follows +---+ *$\\|"
 458           "^ *---+ +Returned message +---+ *$\\|"
 459           "^Start of returned message$\\|"
 460           "^ *---+ +Original message +---+ *$\\|"
 461           "^ *--+ +begin message +--+ *$\\|"
 462           "^ *---+ +Original message follows +---+ *$\\|"
 463           "^|? *---+ +Message text follows: +---+ *|?$")
 464   "A regexp that matches the separator before the text of a failed message.")
 465
 466 (defvar message-header-format-alist
 467   `((Newsgroups)
 468     (To . message-fill-address)
 469     (Cc . message-fill-address)
 470     (Subject)
 471     (In-Reply-To)
 472     (Fcc)
 473     (Bcc)
 474     (Date)
 475     (Organization)
 476     (Distribution)
 477     (Lines)
 478     (Expires)
 479     (Message-ID)
 480     (References . message-fill-header)
 481     (X-Mailer)
 482     (X-Newsreader))
 483   "Alist used for formatting headers.")
 484
 485 (eval-and-compile
 486   (autoload 'message-setup-toolbar "messagexmas")
 487   (autoload 'mh-send-letter "mh-comp"))
 488
 489 \f
 490
 491 ;;;
 492 ;;; Utility functions.
 493 ;;;
 494
 495 (defun message-point-at-bol ()
 496   "Return point at the beginning of the line."
 497   (let ((p (point)))
 498     (beginning-of-line)
 499     (prog1
 500         (point)
 501       (goto-char p))))
 502
 503 (defun message-point-at-eol ()
 504   "Return point at the end of the line."
 505   (let ((p (point)))
 506     (end-of-line)
 507     (prog1
 508         (point)
 509       (goto-char p))))
 510
 511 ;; Delete the current line (and the next N lines.);
 512 (defmacro message-delete-line (&optional n)
 513   `(delete-region (progn (beginning-of-line) (point))
 514                   (progn (forward-line ,(or n 1)) (point))))
 515
 516 (defun message-tokenize-header (header &optional separator)
 517   "Split HEADER into a list of header elements.
 518 \",\" is used as the separator."
 519   (let ((regexp (format "[%s]+" (or separator ",")))
 520         (beg 1)
 521         quoted elems)
 522     (save-excursion
 523       (message-set-work-buffer)
 524       (insert header)
 525       (goto-char (point-min))
 526       (while (not (eobp))
 527         (forward-char 1)
 528         (cond ((and (> (point) beg)
 529                     (or (eobp)
 530                         (and (looking-at regexp)
 531                              (not quoted))))
 532                (push (buffer-substring beg (point)) elems)
 533                (setq beg (match-end 0)))
 534               ((= (following-char) ?\")
 535                (setq quoted (not quoted)))))
 536       (nreverse elems))))
 537
 538 (defun message-fetch-field (header)
 539   "The same as `mail-fetch-field', only remove all newlines."
 540   (let ((value (mail-fetch-field header)))
 541     (when value
 542       (nnheader-replace-chars-in-string value ?\n ? ))))
 543
 544 (defun message-fetch-reply-field (header)
 545   "Fetch FIELD from the message we're replying to."
 546   (when (and message-reply-buffer
 547              (buffer-name message-reply-buffer))
 548     (save-excursion
 549       (set-buffer message-reply-buffer)
 550       (message-fetch-field header))))
 551
 552 (defun message-set-work-buffer ()
 553   (if (get-buffer " *message work*")
 554       (progn
 555         (set-buffer " *message work*")
 556         (erase-buffer))
 557     (set-buffer (get-buffer-create " *message work*"))
 558     (kill-all-local-variables)
 559     (buffer-disable-undo (current-buffer))))
 560
 561 (defun message-functionp (form)
 562   "Return non-nil if FORM is funcallable."
 563   (or (and (symbolp form) (fboundp form))
 564       (and (listp form) (eq (car form) 'lambda))))
 565
 566 (defun message-strip-subject-re (subject)
 567   "Remove \"Re:\" from subject lines."
 568   (if (string-match "^[Rr][Ee]: *" subject)
 569       (substring subject (match-end 0))
 570     subject))
 571
 572 (defun message-remove-header (header &optional is-regexp first reverse)
 573   "Remove HEADER in the narrowed buffer.
 574 If REGEXP, HEADER is a regular expression.
 575 If FIRST, only remove the first instance of the header.
 576 Return the number of headers removed."
 577   (goto-char (point-min))
 578   (let ((regexp (if is-regexp header (concat "^" header ":")))
 579         (number 0)
 580         (case-fold-search t)
 581         last)
 582     (while (and (not (eobp))
 583                 (not last))
 584       (if (if reverse
 585               (not (looking-at regexp))
 586             (looking-at regexp))
 587           (progn
 588             (incf number)
 589             (when first
 590               (setq last t))
 591             (delete-region
 592              (point)
 593              ;; There might be a continuation header, so we have to search
 594              ;; until we find a new non-continuation line.
 595              (progn
 596                (forward-line 1)
 597                (if (re-search-forward "^[^ \t]" nil t)
 598                    (goto-char (match-beginning 0))
 599                  (point-max)))))
 600         (forward-line 1)
 601         (if (re-search-forward "^[^ \t]" nil t)
 602             (goto-char (match-beginning 0))
 603           (point-max))))
 604     number))
 605
 606 (defun message-narrow-to-headers ()
 607   "Narrow the buffer to the head of the message."
 608   (widen)
 609   (narrow-to-region
 610    (goto-char (point-min))
 611    (if (re-search-forward
 612         (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 613        (match-beginning 0)
 614      (point-max)))
 615   (goto-char (point-min)))
 616
 617 (defun message-narrow-to-head ()
 618   "Narrow the buffer to the head of the message."
 619   (widen)
 620   (narrow-to-region
 621    (goto-char (point-min))
 622    (if (search-forward "\n\n" nil 1)
 623        (1- (point))
 624      (point-max)))
 625   (goto-char (point-min)))
 626
 627 (defun message-news-p ()
 628   "Say whether the current buffer contains a news message."
 629   (save-excursion
 630     (save-restriction
 631       (message-narrow-to-headers)
 632       (message-fetch-field "newsgroups"))))
 633
 634 (defun message-mail-p ()
 635   "Say whether the current buffer contains a mail message."
 636   (save-excursion
 637     (save-restriction
 638       (message-narrow-to-headers)
 639       (or (message-fetch-field "to")
 640           (message-fetch-field "cc")
 641           (message-fetch-field "bcc")))))
 642
 643 (defun message-next-header ()
 644   "Go to the beginning of the next header."
 645   (beginning-of-line)
 646   (or (eobp) (forward-char 1))
 647   (not (if (re-search-forward "^[^ \t]" nil t)
 648            (beginning-of-line)
 649          (goto-char (point-max)))))
 650
 651 (defun message-sort-headers-1 ()
 652   "Sort the buffer as headers using `message-rank' text props."
 653   (goto-char (point-min))
 654   (sort-subr
 655    nil 'message-next-header
 656    (lambda ()
 657      (message-next-header)
 658      (unless (bobp)
 659        (forward-char -1)))
 660    (lambda ()
 661      (or (get-text-property (point) 'message-rank)
 662          0))))
 663
 664 (defun message-sort-headers ()
 665   "Sort the headers of the current message according to `message-header-format-alist'."
 666   (interactive)
 667   (save-excursion
 668     (save-restriction
 669       (let ((max (1+ (length message-header-format-alist)))
 670             rank)
 671         (message-narrow-to-headers)
 672         (while (re-search-forward "^[^ \n]+:" nil t)
 673           (put-text-property
 674            (match-beginning 0) (1+ (match-beginning 0))
 675            'message-rank
 676            (if (setq rank (length (memq (assq (intern (buffer-substring
 677                                                        (match-beginning 0)
 678                                                        (1- (match-end 0))))
 679                                               message-header-format-alist)
 680                                         message-header-format-alist)))
 681                (- max rank)
 682              (1+ max)))))
 683       (message-sort-headers-1))))
 684
 685 (defmacro message-y-or-n-p (question show &rest text)
 686   "Ask QUESTION, displaying the rest of the arguments in a temporary buffer."
 687   `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
 688
 689 (defun message-talkative-question (ask question show &rest text)
 690   "Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW.
 691 The following arguments may contain lists of values."
 692   (if (and show
 693            (setq text (message-flatten-list text)))
 694       (save-window-excursion
 695         (save-excursion
 696           (with-output-to-temp-buffer " *MESSAGE information message*"
 697             (set-buffer " *MESSAGE information message*")
 698             (mapcar 'princ text)
 699             (goto-char (point-min))))
 700         (funcall ask question))
 701     (funcall ask question)))
 702
 703 (defun message-flatten-list (&rest list)
 704   (message-flatten-list-1 list))
 705
 706 (defun message-flatten-list-1 (list)
 707   (cond ((consp list)
 708          (apply 'nconc (mapcar 'message-flatten-list-1 list)))
 709         (list
 710          (list list))))
 711 \f
 712
 713 ;;;
 714 ;;; Message mode
 715 ;;;
 716
 717 ;;; Set up keymap.
 718
 719 (defvar message-mode-map nil)
 720
 721 (unless message-mode-map
 722   (setq message-mode-map (copy-keymap text-mode-map))
 723   (define-key message-mode-map "\C-c?" 'describe-mode)
 724
 725   (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
 726   (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
 727   (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
 728   (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
 729   (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
 730   (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
 731   (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
 732   (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
 733   (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
 734   (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
 735   (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
 736   (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
 737   (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
 738
 739   (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
 740   (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
 741
 742   (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
 743   (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
 744   (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
 745   (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
 746   (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
 747   (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
 748
 749   (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
 750   (define-key message-mode-map "\C-c\C-s" 'message-send)
 751   (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
 752   (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
 753
 754   (define-key message-mode-map "\t" 'message-tab))
 755
 756 (easy-menu-define message-mode-menu message-mode-map
 757   "Message Menu."
 758   '("Message"
 759     "Go to Field:"
 760     "----"
 761     ["To" message-goto-to t]
 762     ["Subject" message-goto-subject t]
 763     ["Cc" message-goto-cc t]
 764     ["Reply-to" message-goto-reply-to t]
 765     ["Summary" message-goto-summary t]
 766     ["Keywords" message-goto-keywords t]
 767     ["Newsgroups" message-goto-newsgroups t]
 768     ["Followup-To" message-goto-followup-to t]
 769     ["Distribution" message-goto-distribution t]
 770     ["Body" message-goto-body t]
 771     ["Signature" message-goto-signature t]
 772     "----"
 773     "Miscellaneous Commands:"
 774     "----"
 775     ["Sort Headers" message-sort-headers t]
 776     ["Yank Original" message-yank-original t]
 777     ["Fill Yanked Message" message-fill-yanked-message t]
 778     ["Insert Signature" message-insert-signature t]
 779     ["Caesar (rot13) Message" message-caesar-buffer-body t]
 780     ["Rename buffer" message-rename-buffer t]
 781     ["Spellcheck" ispell-message t]
 782     "----"
 783     ["Send Message" message-send-and-exit t]
 784     ["Abort Message" message-dont-send t]))
 785
 786 (defvar facemenu-add-face-function)
 787 (defvar facemenu-remove-face-function)
 788
 789 ;;;###autoload
 790 (defun message-mode ()
 791   "Major mode for editing mail and news to be sent.
 792 Like Text Mode but with these additional commands:
 793 C-c C-s  message-send (send the message)    C-c C-c  message-send-and-exit
 794 C-c C-f  move to a header field (and create it if there isn't):
 795          C-c C-f C-t  move to To        C-c C-f C-s  move to Subject
 796          C-c C-f C-c  move to Cc        C-c C-f C-b  move to Bcc
 797          C-c C-f C-f  move to Fcc       C-c C-f C-r  move to Reply-To
 798          C-c C-f C-u  move to Summary   C-c C-f C-n  move to Newsgroups
 799          C-c C-f C-k  move to Keywords  C-c C-f C-d  move to Distribution
 800          C-c C-f C-o  move to Followup-To
 801 C-c C-t  message-insert-to (add a To header to a news followup)
 802 C-c C-n  message-insert-newsgroups (add a Newsgroup header to a news reply)
 803 C-c C-b  message-goto-body (move to beginning of message text).
 804 C-c C-i  message-goto-signature (move to the beginning of the signature).
 805 C-c C-w  message-insert-signature (insert `message-signature-file' file).
 806 C-c C-y  message-yank-original (insert current message, if any).
 807 C-c C-q  message-fill-yanked-message (fill what was yanked).
 808 C-c C-r  message-caesar-buffer-body (rot13 the message body)."
 809   (interactive)
 810   (kill-all-local-variables)
 811   (make-local-variable 'message-reply-buffer)
 812   (setq message-reply-buffer nil)
 813   (make-local-variable 'message-send-actions)
 814   (make-local-variable 'message-exit-actions)
 815   (make-local-variable 'message-kill-actions)
 816   (make-local-variable 'message-postpone-actions)
 817   (set-syntax-table message-mode-syntax-table)
 818   (use-local-map message-mode-map)
 819   (setq local-abbrev-table text-mode-abbrev-table)
 820   (setq major-mode 'message-mode)
 821   (setq mode-name "Message")
 822   (setq buffer-offer-save t)
 823   (make-local-variable 'font-lock-defaults)
 824   (setq font-lock-defaults '(message-font-lock-keywords t))
 825   (make-local-variable 'facemenu-add-face-function)
 826   (make-local-variable 'facemenu-remove-face-function)
 827   (setq facemenu-add-face-function
 828         (lambda (face end)
 829           (let ((face-fun (cdr (assq face message-face-alist))))
 830             (if face-fun
 831                 (funcall face-fun (point) end)
 832               (error "Face %s not configured for %s mode" face mode-name)))
 833           "")
 834         facemenu-remove-face-function t)
 835   (make-local-variable 'paragraph-separate)
 836   (make-local-variable 'paragraph-start)
 837   (setq paragraph-start (concat (regexp-quote mail-header-separator)
 838                                 "$\\|[ \t]*[-_][-_][-_]+$\\|"
 839                                 "-- $\\|"
 840                                 paragraph-start))
 841   (setq paragraph-separate (concat (regexp-quote mail-header-separator)
 842                                    "$\\|[ \t]*[-_][-_][-_]+$\\|"
 843                                    "-- $\\|"
 844                                    paragraph-separate))
 845   (make-local-variable 'message-reply-headers)
 846   (setq message-reply-headers nil)
 847   (make-local-variable 'message-newsreader)
 848   (make-local-variable 'message-mailer)
 849   (make-local-variable 'message-post-method)
 850   (make-local-variable 'message-sent-message-via)
 851   (setq message-sent-message-via nil)
 852   (make-local-variable 'message-checksum)
 853   (setq message-checksum nil)
 854   ;;(when (fboundp 'mail-hist-define-keys)
 855   ;;  (mail-hist-define-keys))
 856   (when (string-match "XEmacs\\|Lucid" emacs-version)
 857     (message-setup-toolbar))
 858   (easy-menu-add message-mode-menu message-mode-map)
 859   (run-hooks 'text-mode-hook 'message-mode-hook))
 860
 861 \f
 862
 863 ;;;
 864 ;;; Message mode commands
 865 ;;;
 866
 867 ;;; Movement commands
 868
 869 (defun message-goto-to ()
 870   "Move point to the To header."
 871   (interactive)
 872   (message-position-on-field "To"))
 873
 874 (defun message-goto-subject ()
 875   "Move point to the Subject header."
 876   (interactive)
 877   (message-position-on-field "Subject"))
 878
 879 (defun message-goto-cc ()
 880   "Move point to the Cc header."
 881   (interactive)
 882   (message-position-on-field "Cc" "To"))
 883
 884 (defun message-goto-bcc ()
 885   "Move point to the Bcc  header."
 886   (interactive)
 887   (message-position-on-field "Bcc" "Cc" "To"))
 888
 889 (defun message-goto-fcc ()
 890   "Move point to the Fcc header."
 891   (interactive)
 892   (message-position-on-field "Fcc" "To" "Newsgroups"))
 893
 894 (defun message-goto-reply-to ()
 895   "Move point to the Reply-To header."
 896   (interactive)
 897   (message-position-on-field "Reply-To" "Subject"))
 898
 899 (defun message-goto-newsgroups ()
 900   "Move point to the Newsgroups header."
 901   (interactive)
 902   (message-position-on-field "Newsgroups"))
 903
 904 (defun message-goto-distribution ()
 905   "Move point to the Distribution header."
 906   (interactive)
 907   (message-position-on-field "Distribution"))
 908
 909 (defun message-goto-followup-to ()
 910   "Move point to the Followup-To header."
 911   (interactive)
 912   (message-position-on-field "Followup-To" "Newsgroups"))
 913
 914 (defun message-goto-keywords ()
 915   "Move point to the Keywords header."
 916   (interactive)
 917   (message-position-on-field "Keywords" "Subject"))
 918
 919 (defun message-goto-summary ()
 920   "Move point to the Summary header."
 921   (interactive)
 922   (message-position-on-field "Summary" "Subject"))
 923
 924 (defun message-goto-body ()
 925   "Move point to the beginning of the message body."
 926   (interactive)
 927   (if (looking-at "[ \t]*\n") (expand-abbrev))
 928   (goto-char (point-min))
 929   (search-forward (concat "\n" mail-header-separator "\n") nil t))
 930
 931 (defun message-goto-signature ()
 932   "Move point to the beginning of the message signature."
 933   (interactive)
 934   (goto-char (point-min))
 935   (or (re-search-forward message-signature-separator nil t)
 936       (goto-char (point-max))))
 937
 938 \f
 939
 940 (defun message-insert-to ()
 941   "Insert a To header that points to the author of the article being replied to."
 942   (interactive)
 943   (when (and (message-position-on-field "To")
 944              (mail-fetch-field "to")
 945              (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
 946     (insert ", "))
 947   (insert (or (message-fetch-reply-field "reply-to")
 948               (message-fetch-reply-field "from") "")))
 949
 950 (defun message-insert-newsgroups ()
 951   "Insert the Newsgroups header from the article being replied to."
 952   (interactive)
 953   (when (and (message-position-on-field "Newsgroups")
 954              (mail-fetch-field "newsgroups")
 955              (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
 956     (insert ","))
 957   (insert (or (message-fetch-reply-field "newsgroups") "")))
 958
 959 \f
 960
 961 ;;; Various commands
 962
 963 (defun message-insert-signature (&optional force)
 964   "Insert a signature.  See documentation for the `message-signature' variable."
 965   (interactive (list 0))
 966   (let* ((signature
 967           (cond ((and (null message-signature)
 968                       (eq force 0))
 969                  (save-excursion
 970                    (goto-char (point-max))
 971                    (not (re-search-backward
 972                          message-signature-separator nil t))))
 973                 ((and (null message-signature)
 974                       force)
 975                  t)
 976                 ((message-functionp message-signature)
 977                  (funcall message-signature))
 978                 ((listp message-signature)
 979                  (eval message-signature))
 980                 (t message-signature)))
 981          (signature
 982           (cond ((stringp signature)
 983                  signature)
 984                 ((and (eq t signature)
 985                       message-signature-file
 986                       (file-exists-p message-signature-file))
 987                  signature))))
 988     (when signature
 989 ;      ;; Remove blank lines at the end of the message.
 990       (goto-char (point-max))
 991 ;      (skip-chars-backward " \t\n")
 992 ;      (delete-region (point) (point-max))
 993       ;; Insert the signature.
 994       (unless (bolp)
 995         (insert "\n"))
 996       (insert "\n-- \n")
 997       (if (eq signature t)
 998           (insert-file-contents message-signature-file)
 999         (insert signature))
1000       (goto-char (point-max))
1001       (or (bolp) (insert "\n")))))
1002
1003 (defvar message-caesar-translation-table nil)
1004
1005 (defun message-caesar-region (b e &optional n)
1006   "Caesar rotation of region by N, default 13, for decrypting netnews."
1007   (interactive
1008    (list
1009     (min (point) (or (mark t) (point)))
1010     (max (point) (or (mark t) (point)))
1011     (when current-prefix-arg
1012       (prefix-numeric-value current-prefix-arg))))
1013
1014   (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
1015   (unless (or (zerop n)                 ; no action needed for a rot of 0
1016               (= b e))                  ; no region to rotate
1017     ;; We build the table, if necessary.
1018     (when (or (not message-caesar-translation-table)
1019               (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
1020       (let ((i -1)
1021             (table (make-string 256 0)))
1022         (while (< (incf i) 256)
1023           (aset table i i))
1024         (setq table
1025               (concat
1026                (substring table 0 ?A)
1027                (substring table (+ ?A n) (+ ?A n (- 26 n)))
1028                (substring table ?A (+ ?A n))
1029                (substring table (+ ?A 26) ?a)
1030                (substring table (+ ?a n) (+ ?a n (- 26 n)))
1031                (substring table ?a (+ ?a n))
1032                (substring table (+ ?a 26) 255)))
1033         (setq message-caesar-translation-table table)))
1034     ;; Then we translate the region.  Do it this way to retain
1035     ;; text properties.
1036     (while (< b e)
1037       (subst-char-in-region
1038        b (1+ b) (char-after b)
1039        (aref message-caesar-translation-table (char-after b)))
1040       (incf b))))
1041
1042 (defun message-caesar-buffer-body (&optional rotnum)
1043   "Caesar rotates all letters in the current buffer by 13 places.
1044 Used to encode/decode possibly offensive messages (commonly in net.jokes).
1045 With prefix arg, specifies the number of places to rotate each letter forward.
1046 Mail and USENET news headers are not rotated."
1047   (interactive (if current-prefix-arg
1048                    (list (prefix-numeric-value current-prefix-arg))
1049                  (list nil)))
1050   (save-excursion
1051     (save-restriction
1052       (when (message-goto-body)
1053         (narrow-to-region (point) (point-max)))
1054       (message-caesar-region (point-min) (point-max) rotnum))))
1055
1056 (defun message-rename-buffer (&optional enter-string)
1057   "Rename the *message* buffer to \"*message* RECIPIENT\".
1058 If the function is run with a prefix, it will ask for a new buffer
1059 name, rather than giving an automatic name."
1060   (interactive "Pbuffer name: ")
1061   (save-excursion
1062     (save-restriction
1063       (goto-char (point-min))
1064       (narrow-to-region (point)
1065                         (search-forward mail-header-separator nil 'end))
1066       (let* ((mail-to (if (message-news-p) (message-fetch-field "Newsgroups")
1067                         (message-fetch-field "To")))
1068              (mail-trimmed-to
1069               (if (string-match "," mail-to)
1070                   (concat (substring mail-to 0 (match-beginning 0)) ", ...")
1071                 mail-to))
1072              (name-default (concat "*message* " mail-trimmed-to))
1073              (name (if enter-string
1074                        (read-string "New buffer name: " name-default)
1075                      name-default)))
1076         (rename-buffer name t)))))
1077
1078 (defun message-fill-yanked-message (&optional justifyp)
1079   "Fill the paragraphs of a message yanked into this one.
1080 Numeric argument means justify as well."
1081   (interactive "P")
1082   (save-excursion
1083     (goto-char (point-min))
1084     (search-forward (concat "\n" mail-header-separator "\n") nil t)
1085     (let ((fill-prefix message-yank-prefix))
1086       (fill-individual-paragraphs (point) (point-max) justifyp t))))
1087
1088 (defun message-indent-citation ()
1089   "Modify text just inserted from a message to be cited.
1090 The inserted text should be the region.
1091 When this function returns, the region is again around the modified text.
1092
1093 Normally, indent each nonblank line `message-indentation-spaces' spaces.
1094 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
1095   (let ((start (point)))
1096     ;; Remove unwanted headers.
1097     (when message-ignored-cited-headers
1098       (save-restriction
1099         (narrow-to-region
1100          (goto-char start)
1101          (if (search-forward "\n\n" nil t)
1102              (1- (point))
1103            (point)))
1104         (message-remove-header message-ignored-cited-headers t)))
1105     ;; Do the indentation.
1106     (if (null message-yank-prefix)
1107         (indent-rigidly start (mark t) message-indentation-spaces)
1108       (save-excursion
1109         (goto-char start)
1110         (while (< (point) (mark t))
1111           (insert message-yank-prefix)
1112           (forward-line 1)))
1113       (goto-char start))))
1114
1115 (defun message-yank-original (&optional arg)
1116   "Insert the message being replied to, if any.
1117 Puts point before the text and mark after.
1118 Normally indents each nonblank line ARG spaces (default 3).  However,
1119 if `message-yank-prefix' is non-nil, insert that prefix on each line.
1120
1121 This function uses `message-cite-function' to do the actual citing.
1122
1123 Just \\[universal-argument] as argument means don't indent, insert no
1124 prefix, and don't delete any headers."
1125   (interactive "P")
1126   (let ((modified (buffer-modified-p)))
1127     (when (and message-reply-buffer
1128                message-cite-function)
1129       (delete-windows-on message-reply-buffer t)
1130       (insert-buffer message-reply-buffer)
1131       (funcall message-cite-function)
1132       (message-exchange-point-and-mark)
1133       (unless (bolp)
1134         (insert ?\n))
1135       (unless modified
1136         (setq message-checksum (cons (message-checksum) (buffer-size)))))))
1137
1138 (defun message-cite-original ()
1139   (let ((start (point))
1140         (functions
1141          (when message-indent-citation-function
1142            (if (listp message-indent-citation-function)
1143                message-indent-citation-function
1144              (list message-indent-citation-function)))))
1145     (goto-char start)
1146     (while functions
1147       (funcall (pop functions)))
1148     (when message-citation-line-function
1149       (unless (bolp)
1150         (insert "\n"))
1151       (funcall message-citation-line-function))))
1152
1153 (defun message-insert-citation-line ()
1154   "Function that inserts a simple citation line."
1155   (when message-reply-headers
1156     (insert (mail-header-from message-reply-headers) " writes:\n\n")))
1157
1158 (defun message-position-on-field (header &rest afters)
1159   (let ((case-fold-search t))
1160     (save-restriction
1161       (narrow-to-region
1162        (goto-char (point-min))
1163        (progn
1164          (re-search-forward
1165           (concat "^" (regexp-quote mail-header-separator) "$"))
1166          (match-beginning 0)))
1167       (goto-char (point-min))
1168       (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
1169           (progn
1170             (re-search-forward "^[^ \t]" nil 'move)
1171             (beginning-of-line)
1172             (skip-chars-backward "\n")
1173             t)
1174         (while (and afters
1175                     (not (re-search-forward
1176                           (concat "^" (regexp-quote (car afters)) ":")
1177                           nil t)))
1178           (pop afters))
1179         (when afters
1180           (re-search-forward "^[^ \t]" nil 'move)
1181           (beginning-of-line))
1182         (insert header ": \n")
1183         (forward-char -1)
1184         nil))))
1185
1186 (defun message-remove-signature ()
1187   "Remove the signature from the text between point and mark.
1188 The text will also be indented the normal way."
1189   (save-excursion
1190     (let ((start (point))
1191           mark)
1192     (if (not (re-search-forward message-signature-separator (mark t) t))
1193         ;; No signature here, so we just indent the cited text.
1194         (message-indent-citation)
1195       ;; Find the last non-empty line.
1196       (forward-line -1)
1197       (while (looking-at "[ \t]*$")
1198         (forward-line -1))
1199       (forward-line 1)
1200       (setq mark (set-marker (make-marker) (point)))
1201       (goto-char start)
1202       (message-indent-citation)
1203       ;; Enable undoing the deletion.
1204       (undo-boundary)
1205       (delete-region mark (mark t))
1206       (set-marker mark nil)))))
1207
1208 \f
1209
1210 ;;;
1211 ;;; Sending messages
1212 ;;;
1213
1214 (defun message-send-and-exit (&optional arg)
1215   "Send message like `message-send', then, if no errors, exit from mail buffer."
1216   (interactive "P")
1217   (let ((buf (current-buffer))
1218         (actions message-exit-actions))
1219     (when (and (message-send arg)
1220                (buffer-name buf))
1221       (if message-kill-buffer-on-exit
1222           (kill-buffer buf)
1223         (bury-buffer buf)
1224         (when (eq buf (current-buffer))
1225           (message-bury buf)))
1226       (message-do-actions actions))))
1227
1228 (defun message-dont-send ()
1229   "Don't send the message you have been editing."
1230   (interactive)
1231   (message-bury (current-buffer))
1232   (message-do-actions message-postpone-actions))
1233
1234 (defun message-kill-buffer ()
1235   "Kill the current buffer."
1236   (interactive)
1237   (let ((actions message-kill-actions))
1238     (kill-buffer (current-buffer))
1239     (message-do-actions actions)))
1240
1241 (defun message-bury (buffer)
1242   "Bury this mail buffer."
1243   (let ((newbuf (other-buffer buffer)))
1244     (bury-buffer buffer)
1245     (if (and (fboundp 'frame-parameters)
1246              (cdr (assq 'dedicated (frame-parameters)))
1247              (not (null (delq (selected-frame) (visible-frame-list)))))
1248         (delete-frame (selected-frame))
1249       (switch-to-buffer newbuf))))
1250
1251 (defun message-send (&optional arg)
1252   "Send the message in the current buffer.
1253 If `message-interactive' is non-nil, wait for success indication
1254 or error messages, and inform user.
1255 Otherwise any failure is reported in a message back to
1256 the user from the mailer."
1257   (interactive "P")
1258   (when (if buffer-file-name
1259             (y-or-n-p (format "Send buffer contents as %s message? "
1260                               (if (message-mail-p)
1261                                   (if (message-news-p) "mail and news" "mail")
1262                                 "news")))
1263           (or (buffer-modified-p)
1264               (y-or-n-p "No changes in the buffer; really send? ")))
1265     ;; Make it possible to undo the coming changes.
1266     (undo-boundary)
1267     (let ((inhibit-read-only t))
1268       (put-text-property (point-min) (point-max) 'read-only nil))
1269     (message-fix-before-sending)
1270     (run-hooks 'message-send-hook)
1271     (message "Sending...")
1272     (when (and (or (not (message-news-p))
1273                    (and (or (not (memq 'news message-sent-message-via))
1274                             (y-or-n-p
1275                              "Already sent message via news; resend? "))
1276                         (funcall message-send-news-function arg)))
1277                (or (not (message-mail-p))
1278                    (and (or (not (memq 'mail message-sent-message-via))
1279                             (y-or-n-p
1280                              "Already sent message via mail; resend? "))
1281                         (message-send-mail arg))))
1282       (message-do-fcc)
1283       ;;(when (fboundp 'mail-hist-put-headers-into-history)
1284       ;; (mail-hist-put-headers-into-history))
1285       (run-hooks 'message-sent-hook)
1286       (message "Sending...done")
1287       ;; If buffer has no file, mark it as unmodified and delete autosave.
1288       (unless buffer-file-name
1289         (set-buffer-modified-p nil)
1290         (delete-auto-save-file-if-necessary t))
1291       ;; Delete other mail buffers and stuff.
1292       (message-do-send-housekeeping)
1293       (message-do-actions message-send-actions)
1294       ;; Return success.
1295       t)))
1296
1297 (defun message-fix-before-sending ()
1298   "Do various things to make the message nice before sending it."
1299   ;; Make sure there's a newline at the end of the message.
1300   (goto-char (point-max))
1301   (unless (bolp)
1302     (insert "\n")))
1303
1304 (defun message-add-action (action &rest types)
1305   "Add ACTION to be performed when doing an exit of type TYPES."
1306   (let (var)
1307     (while types
1308       (set (setq var (intern (format "message-%s-actions" (pop types))))
1309            (nconc (symbol-value var) (list action))))))
1310
1311 (defun message-do-actions (actions)
1312   "Perform all actions in ACTIONS."
1313   ;; Now perform actions on successful sending.
1314   (while actions
1315     (condition-case nil
1316         (cond
1317          ;; A simple function.
1318          ((message-functionp (car actions))
1319           (funcall (car actions)))
1320          ;; Something to be evaled.
1321          (t
1322           (eval (car actions))))
1323       (error))
1324     (pop actions)))
1325
1326 (defun message-send-mail (&optional arg)
1327   (require 'mail-utils)
1328   (let ((tembuf (generate-new-buffer " message temp"))
1329         (case-fold-search nil)
1330         (news (message-news-p))
1331         (mailbuf (current-buffer)))
1332     (save-restriction
1333       (message-narrow-to-headers)
1334       ;; Insert some headers.
1335       (let ((message-deletable-headers
1336              (if news nil message-deletable-headers)))
1337         (message-generate-headers message-required-mail-headers))
1338       ;; Let the user do all of the above.
1339       (run-hooks 'message-header-hook))
1340     (unwind-protect
1341         (save-excursion
1342           (set-buffer tembuf)
1343           (erase-buffer)
1344           (insert-buffer-substring mailbuf)
1345           ;; Remove some headers.
1346           (save-restriction
1347             (message-narrow-to-headers)
1348             ;; Remove some headers.
1349             (message-remove-header message-ignored-mail-headers t))
1350           (goto-char (point-max))
1351           ;; require one newline at the end.
1352           (or (= (preceding-char) ?\n)
1353               (insert ?\n))
1354           (when (and news
1355                      (or (message-fetch-field "cc")
1356                          (message-fetch-field "to")))
1357             (message-insert-courtesy-copy))
1358           (funcall message-send-mail-function))
1359       (kill-buffer tembuf))
1360     (set-buffer mailbuf)
1361     (push 'mail message-sent-message-via)))
1362
1363 (defun message-send-mail-with-sendmail ()
1364   "Send off the prepared buffer with sendmail."
1365   (let ((errbuf (if message-interactive
1366                     (generate-new-buffer " sendmail errors")
1367                   0))
1368         resend-to-addresses delimline)
1369     (let ((case-fold-search t))
1370       (save-restriction
1371         (message-narrow-to-headers)
1372         (setq resend-to-addresses (message-fetch-field "resent-to")))
1373       ;; Change header-delimiter to be what sendmail expects.
1374       (goto-char (point-min))
1375       (re-search-forward
1376        (concat "^" (regexp-quote mail-header-separator) "\n"))
1377       (replace-match "\n")
1378       (backward-char 1)
1379       (setq delimline (point-marker))
1380       ;; Insert an extra newline if we need it to work around
1381       ;; Sun's bug that swallows newlines.
1382       (goto-char (1+ delimline))
1383       (when (eval message-mailer-swallows-blank-line)
1384         (newline))
1385       (when message-interactive
1386         (save-excursion
1387           (set-buffer errbuf)
1388           (erase-buffer))))
1389     (let ((default-directory "/"))
1390       (apply 'call-process-region
1391              (append (list (point-min) (point-max)
1392                            (if (boundp 'sendmail-program)
1393                                sendmail-program
1394                              "/usr/lib/sendmail")
1395                            nil errbuf nil "-oi")
1396                      ;; Always specify who from,
1397                      ;; since some systems have broken sendmails.
1398                      (list "-f" (user-login-name))
1399                      ;; These mean "report errors by mail"
1400                      ;; and "deliver in background".
1401                      (if (null message-interactive) '("-oem" "-odb"))
1402                      ;; Get the addresses from the message
1403                      ;; unless this is a resend.
1404                      ;; We must not do that for a resend
1405                      ;; because we would find the original addresses.
1406                      ;; For a resend, include the specific addresses.
1407                      (if resend-to-addresses
1408                          (list resend-to-addresses)
1409                        '("-t")))))
1410     (when message-interactive
1411       (save-excursion
1412         (set-buffer errbuf)
1413         (goto-char (point-min))
1414         (while (re-search-forward "\n\n* *" nil t)
1415           (replace-match "; "))
1416         (if (not (zerop (buffer-size)))
1417             (error "Sending...failed to %s"
1418                    (buffer-substring (point-min) (point-max)))))
1419       (when (bufferp errbuf)
1420         (kill-buffer errbuf)))))
1421
1422 (defun message-send-mail-with-mh ()
1423   "Send the prepared message buffer with mh."
1424   (let ((mh-previous-window-config nil)
1425         (name (make-temp-name
1426                (concat (file-name-as-directory message-autosave-directory)
1427                        "msg."))))
1428     (setq buffer-file-name name)
1429     (mh-send-letter)
1430     (condition-case ()
1431         (delete-file name)
1432       (error nil))))
1433
1434 (defun message-send-news (&optional arg)
1435   (let ((tembuf (generate-new-buffer " *message temp*"))
1436         (case-fold-search nil)
1437         (method (if (message-functionp message-post-method)
1438                     (funcall message-post-method arg)
1439                   message-post-method))
1440         (messbuf (current-buffer))
1441         (message-syntax-checks
1442          (if arg
1443              (cons '(existing-newsgroups . disabled)
1444                    message-syntax-checks)
1445            message-syntax-checks))
1446         result)
1447     (save-restriction
1448       (message-narrow-to-headers)
1449       ;; Insert some headers.
1450       (message-generate-headers message-required-news-headers)
1451       ;; Let the user do all of the above.
1452       (run-hooks 'message-header-hook))
1453     (message-cleanup-headers)
1454     (when (message-check-news-syntax)
1455       (unwind-protect
1456           (save-excursion
1457             (set-buffer tembuf)
1458             (buffer-disable-undo (current-buffer))
1459             (erase-buffer)
1460             (insert-buffer-substring messbuf)
1461             ;; Remove some headers.
1462             (save-restriction
1463               (message-narrow-to-headers)
1464               ;; Remove some headers.
1465               (message-remove-header message-ignored-news-headers t))
1466             (goto-char (point-max))
1467             ;; require one newline at the end.
1468             (or (= (preceding-char) ?\n)
1469                 (insert ?\n))
1470             (let ((case-fold-search t))
1471               ;; Remove the delimeter.
1472               (goto-char (point-min))
1473               (re-search-forward
1474                (concat "^" (regexp-quote mail-header-separator) "\n"))
1475               (replace-match "\n")
1476               (backward-char 1))
1477             (require (car method))
1478             (funcall (intern (format "%s-open-server" (car method)))
1479                      (cadr method) (cddr method))
1480             (setq result
1481                   (funcall (intern (format "%s-request-post" (car method))))))
1482         (kill-buffer tembuf))
1483       (set-buffer messbuf)
1484       (if result
1485           (push 'news message-sent-message-via)
1486         (message "Couldn't send message via news: %s"
1487                  (nnheader-get-report (car method)))
1488         nil))))
1489
1490 ;;;
1491 ;;; Header generation & syntax checking.
1492 ;;;
1493
1494 (defun message-check-news-syntax ()
1495   "Check the syntax of the message."
1496   (and
1497    ;; We narrow to the headers and check them first.
1498    (save-excursion
1499      (save-restriction
1500        (message-narrow-to-headers)
1501        (and
1502         ;; Check for commands in Subject.
1503         (or
1504          (message-check-element 'subject-cmsg)
1505          (save-excursion
1506            (if (string-match "^cmsg " (message-fetch-field "subject"))
1507                (y-or-n-p
1508                 "The control code \"cmsg \" is in the subject. Really post? ")
1509              t)))
1510         ;; Check for multiple identical headers.
1511         (or (message-check-element 'multiple-headers)
1512             (save-excursion
1513               (let (found)
1514                 (while (and (not found)
1515                             (re-search-forward "^[^ \t:]+: " nil t))
1516                   (save-excursion
1517                     (or (re-search-forward
1518                          (concat "^" (setq found
1519                                            (buffer-substring
1520                                             (match-beginning 0)
1521                                             (- (match-end 0) 2))))
1522                          nil t)
1523                         (setq found nil))))
1524                 (if found
1525                     (y-or-n-p
1526                      (format "Multiple %s headers. Really post? " found))
1527                   t))))
1528         ;; Check for Version and Sendsys.
1529         (or (message-check-element 'sendsys)
1530             (save-excursion
1531               (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
1532                   (y-or-n-p
1533                    (format "The article contains a %s command. Really post? "
1534                            (buffer-substring (match-beginning 0)
1535                                              (1- (match-end 0)))))
1536                 t)))
1537         ;; See whether we can shorten Followup-To.
1538         (or (message-check-element 'shorten-followup-to)
1539             (let ((newsgroups (message-fetch-field "newsgroups"))
1540                   (followup-to (message-fetch-field "followup-to"))
1541                   to)
1542               (when (and newsgroups (string-match "," newsgroups)
1543                          (not followup-to)
1544                          (not
1545                           (zerop
1546                            (length
1547                             (setq to (completing-read
1548                                       "Followups to: (default all groups) "
1549                                       (mapcar (lambda (g) (list g))
1550                                               (cons "poster"
1551                                                     (message-tokenize-header
1552                                                      newsgroups)))))))))
1553                 (goto-char (point-min))
1554                 (insert "Followup-To: " to "\n"))
1555               t))
1556         ;; Check "Shoot me".
1557         (or (message-check-element 'shoot)
1558             (save-excursion
1559               (if (re-search-forward
1560                    "Message-ID.*.i-have-a-misconfigured-system-so-shoot-me"
1561                    nil t)
1562                   (y-or-n-p
1563                    "You appear to have a misconfigured system.  Really post? ")
1564                 t)))
1565         ;; Check for Approved.
1566         (or (message-check-element 'approved)
1567             (save-excursion
1568               (if (re-search-forward "^Approved:" nil t)
1569                   (y-or-n-p
1570                    "The article contains an Approved header. Really post? ")
1571                 t)))
1572         ;; Check the Message-Id header.
1573         (or (message-check-element 'message-id)
1574             (save-excursion
1575               (let* ((case-fold-search t)
1576                      (message-id (message-fetch-field "message-id")))
1577                 (or (not message-id)
1578                     (and (string-match "@" message-id)
1579                          (string-match "@[^\\.]*\\." message-id))
1580                     (y-or-n-p
1581                      (format
1582                       "The Message-ID looks strange: \"%s\". Really post? "
1583                       message-id))))))
1584         ;; Check the Subject header.
1585         (or
1586          (message-check-element 'subject)
1587          (save-excursion
1588            (let* ((case-fold-search t)
1589                   (subject (message-fetch-field "subject")))
1590              (or
1591               (and subject
1592                    (not (string-match "\\`[ \t]*\\'" subject)))
1593               (progn
1594                 (message
1595                  "The subject field is empty or missing.  Posting is denied.")
1596                 nil)))))
1597         ;; Check the Newsgroups & Followup-To headers.
1598         (or
1599          (message-check-element 'existing-newsgroups)
1600          (let* ((case-fold-search t)
1601                 (newsgroups (message-fetch-field "newsgroups"))
1602                 (followup-to (message-fetch-field "followup-to"))
1603                 (groups (message-tokenize-header
1604                          (if followup-to
1605                              (concat newsgroups "," followup-to)
1606                            newsgroups)))
1607                 (hashtb (and (boundp 'gnus-active-hashtb)
1608                              gnus-active-hashtb))
1609                 errors)
1610            (if (not hashtb)
1611                t
1612              (while groups
1613                (when (and (not (boundp (intern (car groups) hashtb)))
1614                           (not (equal (car groups) "poster")))
1615                  (push (car groups) errors))
1616                (pop groups))
1617              (if (not errors)
1618                  t
1619                (y-or-n-p
1620                 (format
1621                  "Really post to %s unknown group%s: %s "
1622                  (if (= (length errors) 1) "this" "these")
1623                  (if (= (length errors) 1) "" "s")
1624                  (mapconcat 'identity errors ", ")))))))
1625         ;; Check the Newsgroups & Followup-To headers for syntax errors.
1626         (or
1627          (message-check-element 'valid-newsgroups)
1628          (let ((case-fold-search t)
1629                (headers '("Newsgroups" "Followup-To"))
1630                header error)
1631            (while (and headers (not error))
1632              (when (setq header (mail-fetch-field (car headers)))
1633                (if (or
1634                     (not
1635                      (string-match
1636                       "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-.a-zA-Z0-9]+\\)*\\'"
1637                       header))
1638                     (memq
1639                      nil (mapcar
1640                           (lambda (g)
1641                             (not (string-match "\\.\\'\\|\\.\\." g)))
1642                           (message-tokenize-header header ","))))
1643                    (setq error t)))
1644              (unless error
1645                (pop headers)))
1646            (if (not error)
1647                t
1648              (y-or-n-p
1649               (format "The %s header looks odd: \"%s\".  Really post? "
1650                       (car headers) header)))))
1651         ;; Check the From header.
1652         (or
1653          (save-excursion
1654            (let* ((case-fold-search t)
1655                   (from (message-fetch-field "from")))
1656              (cond
1657               ((not from)
1658                (message "There is no From line.  Posting is denied.")
1659                nil)
1660               ((not (string-match "@[^\\.]*\\." from))
1661                (message
1662                 "Denied posting -- the From looks strange: \"%s\"." from)
1663                nil)
1664               ((string-match "@[^@]*@" from)
1665                (message
1666                 "Denied posting -- two \"@\"'s in the From header: %s." from)
1667                nil)
1668               ((string-match "(.*).*(.*)" from)
1669                (message
1670                 "Denied posting -- the From header looks strange: \"%s\"."
1671                 from)
1672                nil)
1673               (t t))))))))
1674    ;; Check for long lines.
1675    (or (message-check-element 'long-lines)
1676        (save-excursion
1677          (goto-char (point-min))
1678          (re-search-forward
1679           (concat "^" (regexp-quote mail-header-separator) "$"))
1680          (while (and
1681                  (progn
1682                    (end-of-line)
1683                    (< (current-column) 80))
1684                  (zerop (forward-line 1))))
1685          (or (bolp)
1686              (eobp)
1687              (y-or-n-p
1688               "You have lines longer than 79 characters.  Really post? "))))
1689    ;; Check whether the article is empty.
1690    (or (message-check-element 'empty)
1691        (save-excursion
1692          (goto-char (point-min))
1693          (re-search-forward
1694           (concat "^" (regexp-quote mail-header-separator) "$"))
1695          (forward-line 1)
1696          (let ((b (point)))
1697            (or (re-search-forward message-signature-separator nil t)
1698                (goto-char (point-max)))
1699            (beginning-of-line)
1700            (or (re-search-backward "[^ \n\t]" b t)
1701                (y-or-n-p "Empty article.  Really post? ")))))
1702    ;; Check for control characters.
1703    (or (message-check-element 'control-chars)
1704        (save-excursion
1705          (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
1706              (y-or-n-p
1707               "The article contains control characters. Really post? ")
1708            t)))
1709    ;; Check excessive size.
1710    (or (message-check-element 'size)
1711        (if (> (buffer-size) 60000)
1712            (y-or-n-p
1713             (format "The article is %d octets long. Really post? "
1714                     (buffer-size)))
1715          t))
1716    ;; Check whether any new text has been added.
1717    (or (message-check-element 'new-text)
1718        (not message-checksum)
1719        (not (and (eq (message-checksum) (car message-checksum))
1720                  (eq (buffer-size) (cdr message-checksum))))
1721        (y-or-n-p
1722         "It looks like no new text has been added.  Really post? "))
1723    ;; Check the length of the signature.
1724    (or
1725     (message-check-element 'signature)
1726     (progn
1727       (goto-char (point-max))
1728       (if (or (not (re-search-backward "^-- $" nil t))
1729               (search-forward message-forward-end-separator nil t))
1730           t
1731         (if (> (count-lines (point) (point-max)) 5)
1732             (y-or-n-p
1733              (format
1734               "Your .sig is %d lines; it should be max 4.  Really post? "
1735               (count-lines (point) (point-max))))
1736           t))))))
1737
1738 (defun message-check-element (type)
1739   "Returns non-nil if this type is not to be checked."
1740   (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
1741       t
1742     (let ((able (assq type message-syntax-checks)))
1743       (and (consp able)
1744            (eq (cdr able) 'disabled)))))
1745
1746 (defun message-checksum ()
1747   "Return a \"checksum\" for the current buffer."
1748   (let ((sum 0))
1749     (save-excursion
1750       (goto-char (point-min))
1751       (re-search-forward
1752        (concat "^" (regexp-quote mail-header-separator) "$"))
1753       (while (not (eobp))
1754         (when (not (looking-at "[ \t\n]"))
1755           (setq sum (logxor (ash sum 1) (following-char))))
1756         (forward-char 1)))
1757     sum))
1758
1759 (defun message-do-fcc ()
1760   "Process Fcc headers in the current buffer."
1761   (let ((case-fold-search t)
1762         (buf (current-buffer))
1763         list file)
1764     (save-excursion
1765       (set-buffer (get-buffer-create " *message temp*"))
1766       (buffer-disable-undo (current-buffer))
1767       (erase-buffer)
1768       (insert-buffer-substring buf)
1769       (save-restriction
1770         (message-narrow-to-headers)
1771         (while (setq file (message-fetch-field "fcc"))
1772           (push file list)
1773           (message-remove-header "fcc" nil t)))
1774       (goto-char (point-min))
1775       (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
1776       (replace-match "" t t)
1777       ;; Process FCC operations.
1778       (while list
1779         (setq file (pop list))
1780         (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
1781             ;; Pipe the article to the program in question.
1782             (call-process-region (point-min) (point-max) shell-file-name
1783                                  nil nil nil shell-command-switch
1784                                  (match-string 1 file))
1785           ;; Save the article.
1786           (setq file (expand-file-name file))
1787           (unless (file-exists-p (file-name-directory file))
1788             (make-directory (file-name-directory file) t))
1789           (if (and message-fcc-handler-function
1790                    (not (eq message-fcc-handler-function 'rmail-output)))
1791               (funcall message-fcc-handler-function file)
1792             (if (and (file-readable-p file) (mail-file-babyl-p file))
1793                 (rmail-output file 1 nil t)
1794               (let ((mail-use-rfc822 t))
1795                 (rmail-output file 1 t t))))))
1796       (kill-buffer (current-buffer)))))
1797
1798 (defun message-cleanup-headers ()
1799   "Do various automatic cleanups of the headers."
1800   ;; Remove empty lines in the header.
1801   (save-restriction
1802     (message-narrow-to-headers)
1803     (while (re-search-forward "^[ \t]*\n" nil t)
1804       (replace-match "" t t)))
1805
1806   ;; Correct Newsgroups and Followup-To headers: change sequence of
1807   ;; spaces to comma and eliminate spaces around commas.  Eliminate
1808   ;; embedded line breaks.
1809   (goto-char (point-min))
1810   (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
1811     (save-restriction
1812       (narrow-to-region
1813        (point)
1814        (if (re-search-forward "^[^ \t]" nil t)
1815            (match-beginning 0)
1816          (forward-line 1)
1817          (point)))
1818       (goto-char (point-min))
1819       (while (re-search-forward "\n[ \t]+" nil t)
1820         (replace-match " " t t))        ;No line breaks (too confusing)
1821       (goto-char (point-min))
1822       (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
1823         (replace-match "," t t))
1824       (goto-char (point-min))
1825       ;; Remove trailing commas.
1826       (when (re-search-forward ",+$" nil t)
1827         (replace-match "" t t)))))
1828
1829 (defun message-make-date ()
1830   "Make a valid data header."
1831   (let ((now (current-time)))
1832     (timezone-make-date-arpa-standard
1833      (current-time-string now) (current-time-zone now))))
1834
1835 (defun message-make-message-id ()
1836   "Make a unique Message-ID."
1837   (concat "<" (message-unique-id)
1838           (let ((psubject (save-excursion (message-fetch-field "subject"))))
1839             (if (and message-reply-headers
1840                      (mail-header-references message-reply-headers)
1841                      (mail-header-subject message-reply-headers)
1842                      psubject
1843                      (mail-header-subject message-reply-headers)
1844                      (not (string=
1845                            (message-strip-subject-re
1846                             (mail-header-subject message-reply-headers))
1847                            (message-strip-subject-re psubject))))
1848                 "_-_" ""))
1849           "@" (message-make-fqdn) ">"))
1850
1851 (defvar message-unique-id-char nil)
1852
1853 ;; If you ever change this function, make sure the new version
1854 ;; cannot generate IDs that the old version could.
1855 ;; You might for example insert a "." somewhere (not next to another dot
1856 ;; or string boundary), or modify the "fsf" string.
1857 (defun message-unique-id ()
1858   ;; Don't use microseconds from (current-time), they may be unsupported.
1859   ;; Instead we use this randomly inited counter.
1860   (setq message-unique-id-char
1861         (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
1862            ;; (current-time) returns 16-bit ints,
1863            ;; and 2^16*25 just fits into 4 digits i base 36.
1864            (* 25 25)))
1865   (let ((tm (current-time)))
1866     (concat
1867      (if (memq system-type '(ms-dos emx vax-vms))
1868          (let ((user (downcase (user-login-name))))
1869            (while (string-match "[^a-z0-9_]" user)
1870              (aset user (match-beginning 0) ?_))
1871            user)
1872        (message-number-base36 (user-uid) -1))
1873      (message-number-base36 (+ (car   tm)
1874                                (lsh (% message-unique-id-char 25) 16)) 4)
1875      (message-number-base36 (+ (nth 1 tm)
1876                                (lsh (/ message-unique-id-char 25) 16)) 4)
1877      ;; Append the newsreader name, because while the generated
1878      ;; ID is unique to this newsreader, other newsreaders might
1879      ;; otherwise generate the same ID via another algorithm.
1880      ".fsf")))
1881
1882 (defun message-number-base36 (num len)
1883   (if (if (< len 0) (<= num 0) (= len 0))
1884       ""
1885     (concat (message-number-base36 (/ num 36) (1- len))
1886             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
1887                                   (% num 36))))))
1888
1889 (defun message-make-organization ()
1890   "Make an Organization header."
1891   (let* ((organization
1892           (or (getenv "ORGANIZATION")
1893               (when message-user-organization
1894                 (if (message-functionp message-user-organization)
1895                     (funcall message-user-organization)
1896                   message-user-organization)))))
1897     (save-excursion
1898       (message-set-work-buffer)
1899       (cond ((stringp organization)
1900              (insert organization))
1901             ((and (eq t organization)
1902                   message-user-organization-file
1903                   (file-exists-p message-user-organization-file))
1904              (insert-file-contents message-user-organization-file)))
1905       (goto-char (point-min))
1906       (while (re-search-forward "[\t\n]+" nil t)
1907         (replace-match "" t t))
1908       (unless (zerop (buffer-size))
1909         (buffer-string)))))
1910
1911 (defun message-make-lines ()
1912   "Count the number of lines and return numeric string."
1913   (save-excursion
1914     (save-restriction
1915       (widen)
1916       (goto-char (point-min))
1917       (re-search-forward
1918        (concat "^" (regexp-quote mail-header-separator) "$"))
1919       (forward-line 1)
1920       (int-to-string (count-lines (point) (point-max))))))
1921
1922 (defun message-make-in-reply-to ()
1923   "Return the In-Reply-To header for this message."
1924   (when message-reply-headers
1925     (let ((from (mail-header-from message-reply-headers))
1926           (date (mail-header-date message-reply-headers)))
1927       (when from
1928         (let ((stop-pos
1929                (string-match "  *at \\|  *@ \\| *(\\| *<" from)))
1930           (concat (if stop-pos (substring from 0 stop-pos) from)
1931                   "'s message of "
1932                   (if (or (not date) (string= date ""))
1933                       "(unknown date)" date)))))))
1934
1935 (defun message-make-distribution ()
1936   "Make a Distribution header."
1937   (let ((orig-distribution (message-fetch-reply-field "distribution")))
1938     (cond ((message-functionp message-distribution-function)
1939            (funcall message-distribution-function))
1940           (t orig-distribution))))
1941
1942 (defun message-make-expires ()
1943   "Return an Expires header based on `message-expires'."
1944   (let ((current (current-time))
1945         (future (* 1.0 message-expires 60 60 24)))
1946     ;; Add the future to current.
1947     (setcar current (+ (car current) (round (/ future (expt 2 16)))))
1948     (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
1949     ;; Return the date in the future in UT.
1950     (timezone-make-date-arpa-standard
1951      (current-time-string current) (current-time-zone current) '(0 "UT"))))
1952
1953 (defun message-make-path ()
1954   "Return uucp path."
1955   (let ((login-name (user-login-name)))
1956     (cond ((null message-user-path)
1957            (concat (system-name) "!" login-name))
1958           ((stringp message-user-path)
1959            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
1960            (concat message-user-path "!" login-name))
1961           (t login-name))))
1962
1963 (defun message-make-from ()
1964   "Make a From header."
1965   (let* ((login (message-make-address))
1966          (fullname
1967           (or (and (boundp 'user-full-name)
1968                    user-full-name)
1969               (user-full-name))))
1970     (when (string= fullname "&")
1971       (setq fullname (user-login-name)))
1972     (save-excursion
1973       (message-set-work-buffer)
1974       (cond
1975        ((or (null message-from-style)
1976             (equal fullname ""))
1977         (insert login))
1978        ((or (eq message-from-style 'angles)
1979             (and (not (eq message-from-style 'parens))
1980                  ;; Use angles if no quoting is needed, or if parens would
1981                  ;; need quoting too.
1982                  (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
1983                      (let ((tmp (concat fullname nil)))
1984                        (while (string-match "([^()]*)" tmp)
1985                          (aset tmp (match-beginning 0) ?-)
1986                          (aset tmp (1- (match-end 0)) ?-))
1987                        (string-match "[\\()]" tmp)))))
1988         (insert fullname)
1989         (goto-char (point-min))
1990         ;; Look for a character that cannot appear unquoted
1991         ;; according to RFC 822.
1992         (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
1993           ;; Quote fullname, escaping specials.
1994           (goto-char (point-min))
1995           (insert "\"")
1996           (while (re-search-forward "[\"\\]" nil 1)
1997             (replace-match "\\\\\\&" t))
1998           (insert "\""))
1999         (insert " <" login ">"))
2000        (t                               ; 'parens or default
2001         (insert login " (")
2002         (let ((fullname-start (point)))
2003           (insert fullname)
2004           (goto-char fullname-start)
2005           ;; RFC 822 says \ and nonmatching parentheses
2006           ;; must be escaped in comments.
2007           ;; Escape every instance of ()\ ...
2008           (while (re-search-forward "[()\\]" nil 1)
2009             (replace-match "\\\\\\&" t))
2010           ;; ... then undo escaping of matching parentheses,
2011           ;; including matching nested parentheses.
2012           (goto-char fullname-start)
2013           (while (re-search-forward
2014                   "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
2015                     nil 1)
2016             (replace-match "\\1(\\3)" t)
2017             (goto-char fullname-start)))
2018         (insert ")")))
2019       (buffer-string))))
2020
2021 (defun message-make-sender ()
2022   "Return the \"real\" user address.
2023 This function tries to ignore all user modifications, and
2024 give as trustworthy answer as possible."
2025   (concat (user-login-name) "@" (system-name)))
2026
2027 (defun message-make-address ()
2028   "Make the address of the user."
2029   (or (message-user-mail-address)
2030       (concat (user-login-name) "@" (message-make-domain))))
2031
2032 (defun message-user-mail-address ()
2033   "Return the pertinent part of `user-mail-address'."
2034   (when user-mail-address
2035     (nth 1 (mail-extract-address-components user-mail-address))))
2036
2037 (defun message-make-fqdn ()
2038   "Return user's fully qualified domain name."
2039   (let ((system-name (system-name))
2040         (user-mail (message-user-mail-address)))
2041     (cond
2042      ((string-match "[^.]\\.[^.]" system-name)
2043       ;; `system-name' returned the right result.
2044       system-name)
2045      ;; Try `mail-host-address'.
2046      ((and (boundp 'mail-host-address)
2047            (stringp mail-host-address)
2048            (string-match "\\." mail-host-address))
2049       mail-host-address)
2050      ;; We try `user-mail-address' as a backup.
2051      ((and (string-match "\\." user-mail)
2052            (string-match "@\\(.*\\)\\'" user-mail))
2053       (match-string 1 user-mail))
2054      ;; Default to this bogus thing.
2055      (t
2056       (concat system-name ".i-have-a-misconfigured-system-so-shoot-me")))))
2057
2058 (defun message-make-host-name ()
2059   "Return the name of the host."
2060   (let ((fqdn (message-make-fqdn)))
2061     (string-match "^[^.]+\\." fqdn)
2062     (substring fqdn 0 (1- (match-end 0)))))
2063
2064 (defun message-make-domain ()
2065   "Return the domain name."
2066   (or mail-host-address
2067       (message-make-fqdn)))
2068
2069 (defun message-generate-headers (headers)
2070   "Prepare article HEADERS.
2071 Headers already prepared in the buffer are not modified."
2072   (save-restriction
2073     (message-narrow-to-headers)
2074     (let* ((Date (message-make-date))
2075            (Message-ID (message-make-message-id))
2076            (Organization (message-make-organization))
2077            (From (message-make-from))
2078            (Path (message-make-path))
2079            (Subject nil)
2080            (Newsgroups nil)
2081            (In-Reply-To (message-make-in-reply-to))
2082            (To nil)
2083            (Distribution (message-make-distribution))
2084            (Lines (message-make-lines))
2085            (X-Newsreader message-newsreader)
2086            (X-Mailer (and (not (message-fetch-field "X-Newsreader"))
2087                           message-mailer))
2088            (Expires (message-make-expires))
2089            (case-fold-search t)
2090            header value elem)
2091       ;; First we remove any old generated headers.
2092       (let ((headers message-deletable-headers))
2093         (while headers
2094           (goto-char (point-min))
2095           (and (re-search-forward
2096                 (concat "^" (symbol-name (car headers)) ": *") nil t)
2097                (get-text-property (1+ (match-beginning 0)) 'message-deletable)
2098                (message-delete-line))
2099           (pop headers)))
2100       ;; Go through all the required headers and see if they are in the
2101       ;; articles already. If they are not, or are empty, they are
2102       ;; inserted automatically - except for Subject, Newsgroups and
2103       ;; Distribution.
2104       (while headers
2105         (goto-char (point-min))
2106         (setq elem (pop headers))
2107         (if (consp elem)
2108             (if (eq (car elem) 'optional)
2109                 (setq header (cdr elem))
2110               (setq header (car elem)))
2111           (setq header elem))
2112         (when (or (not (re-search-forward
2113                         (concat "^" (downcase (symbol-name header)) ":")
2114                         nil t))
2115                   (progn
2116                     ;; The header was found. We insert a space after the
2117                     ;; colon, if there is none.
2118                     (if (/= (following-char) ? ) (insert " ") (forward-char 1))
2119                     ;; Find out whether the header is empty...
2120                     (looking-at "[ \t]*$")))
2121           ;; So we find out what value we should insert.
2122           (setq value
2123                 (cond
2124                  ((and (consp elem) (eq (car elem) 'optional))
2125                   ;; This is an optional header.  If the cdr of this
2126                   ;; is something that is nil, then we do not insert
2127                   ;; this header.
2128                   (setq header (cdr elem))
2129                   (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
2130                       (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
2131                  ((consp elem)
2132                   ;; The element is a cons.  Either the cdr is a
2133                   ;; string to be inserted verbatim, or it is a
2134                   ;; function, and we insert the value returned from
2135                   ;; this function.
2136                   (or (and (stringp (cdr elem)) (cdr elem))
2137                       (and (fboundp (cdr elem)) (funcall (cdr elem)))))
2138                  ((and (boundp header) (symbol-value header))
2139                   ;; The element is a symbol.  We insert the value
2140                   ;; of this symbol, if any.
2141                   (symbol-value header))
2142                  (t
2143                   ;; We couldn't generate a value for this header,
2144                   ;; so we just ask the user.
2145                   (read-from-minibuffer
2146                    (format "Empty header for %s; enter value: " header)))))
2147           ;; Finally insert the header.
2148           (when (and value
2149                      (not (equal value "")))
2150             (save-excursion
2151               (if (bolp)
2152                   (progn
2153                     ;; This header didn't exist, so we insert it.
2154                     (goto-char (point-max))
2155                     (insert (symbol-name header) ": " value "\n")
2156                     (forward-line -1))
2157                 ;; The value of this header was empty, so we clear
2158                 ;; totally and insert the new value.
2159                 (delete-region (point) (message-point-at-eol))
2160                 (insert value))
2161               ;; Add the deletable property to the headers that require it.
2162               (and (memq header message-deletable-headers)
2163                    (progn (beginning-of-line) (looking-at "[^:]+: "))
2164                    (add-text-properties
2165                     (point) (match-end 0)
2166                     '(message-deletable t face italic) (current-buffer)))))))
2167       ;; Insert new Sender if the From is strange.
2168       (let ((from (message-fetch-field "from"))
2169             (sender (message-fetch-field "sender"))
2170             (secure-sender (message-make-sender)))
2171         (when (and from
2172                    (not (message-check-element 'sender))
2173                    (not (string=
2174                          (downcase
2175                           (cadr (mail-extract-address-components from)))
2176                          (downcase secure-sender)))
2177                    (or (null sender)
2178                        (not
2179                         (string=
2180                          (downcase
2181                           (cadr (mail-extract-address-components sender)))
2182                          (downcase secure-sender)))))
2183           (goto-char (point-min))
2184           ;; Rename any old Sender headers to Original-Sender.
2185           (when (re-search-forward "^Sender:" nil t)
2186             (beginning-of-line)
2187             (insert "Original-")
2188             (beginning-of-line))
2189           (insert "Sender: " secure-sender "\n"))))))
2190
2191 (defun message-insert-courtesy-copy ()
2192   "Insert a courtesy message in mail copies of combined messages."
2193   (save-excursion
2194     (save-restriction
2195       (message-narrow-to-headers)
2196       (let ((newsgroups (message-fetch-field "newsgroups")))
2197         (when newsgroups
2198           (goto-char (point-max))
2199           (insert "Posted-To: " newsgroups "\n"))))
2200     (forward-line 1)
2201     (insert message-courtesy-message)))
2202
2203 ;;;
2204 ;;; Setting up a message buffer
2205 ;;;
2206
2207 (defun message-fill-address (header value)
2208   (save-restriction
2209     (narrow-to-region (point) (point))
2210     (insert (capitalize (symbol-name header))
2211             ": "
2212             (if (consp value) (car value) value)
2213             "\n")
2214     (narrow-to-region (point-min) (1- (point-max)))
2215     (let (quoted last)
2216       (goto-char (point-min))
2217       (while (not (eobp))
2218         (skip-chars-forward "^,\"" (point-max))
2219         (if (or (= (following-char) ?,)
2220                 (eobp))
2221             (when (not quoted)
2222               (if (and (> (current-column) 78)
2223                        last)
2224                   (progn
2225                     (save-excursion
2226                       (goto-char last)
2227                       (insert "\n\t"))
2228                     (setq last (1+ (point))))
2229                 (setq last (1+ (point)))))
2230           (setq quoted (not quoted)))
2231         (unless (eobp)
2232           (forward-char 1))))
2233     (goto-char (point-max))
2234     (widen)
2235     (forward-line 1)))
2236
2237 (defun message-fill-header (header value)
2238   (let ((begin (point))
2239         (fill-column 78)
2240         (fill-prefix "\t"))
2241     (insert (capitalize (symbol-name header))
2242             ": "
2243             (if (consp value) (car value) value)
2244             "\n")
2245     (save-restriction
2246       (narrow-to-region begin (point))
2247       (fill-region-as-paragraph begin (point))
2248       ;; Tapdance around looong Message-IDs.
2249       (forward-line -1)
2250       (when (looking-at "[ \t]*$")
2251         (message-delete-line))
2252       (goto-char begin)
2253       (re-search-forward ":" nil t)
2254       (when (looking-at "\n[ \t]+")
2255         (replace-match " " t t))
2256       (goto-char (point-max)))))
2257
2258 (defun message-position-point ()
2259   "Move point to where the user probably wants to find it."
2260   (message-narrow-to-headers)
2261   (cond
2262    ((re-search-forward "^[^:]+:[ \t]*$" nil t)
2263     (search-backward ":" )
2264     (widen)
2265     (forward-char 1)
2266     (if (= (following-char) ? )
2267         (forward-char 1)
2268       (insert " ")))
2269    (t
2270     (goto-char (point-max))
2271     (widen)
2272     (forward-line 1)
2273     (unless (looking-at "$")
2274       (forward-line 2)))
2275    (sit-for 0)))
2276
2277 (defun message-buffer-name (type &optional to group)
2278   "Return a new (unique) buffer name based on TYPE and TO."
2279   (cond
2280    ;; Check whether `message-generate-new-buffers' is a function,
2281    ;; and if so, call it.
2282    ((message-functionp message-generate-new-buffers)
2283     (funcall message-generate-new-buffers type to group))
2284    ;; Generate a new buffer name The Message Way.
2285    (message-generate-new-buffers
2286     (generate-new-buffer-name
2287      (concat "*" type
2288              (if to
2289                  (concat " to "
2290                          (or (car (mail-extract-address-components to))
2291                              to) "")
2292                "")
2293              (if (and group (not (string= group ""))) (concat " on " group) "")
2294              "*")))
2295    ;; Use standard name.
2296    (t
2297     (format "*%s message*" type))))
2298
2299 (defun message-pop-to-buffer (name)
2300   "Pop to buffer NAME, and warn if it already exists and is modified."
2301   (let ((buffer (get-buffer name)))
2302     (if (and buffer
2303              (buffer-name buffer))
2304         (progn
2305           (set-buffer (pop-to-buffer buffer))
2306           (when (and (buffer-modified-p)
2307                      (not (y-or-n-p
2308                            "Message already being composed; erase? ")))
2309             (error "Message being composed")))
2310       (set-buffer (pop-to-buffer name))))
2311   (erase-buffer)
2312   (message-mode))
2313
2314 (defun message-do-send-housekeeping ()
2315   "Kill old message buffers."
2316   ;; We might have sent this buffer already.  Delete it from the
2317   ;; list of buffers.
2318   (setq message-buffer-list (delq (current-buffer) message-buffer-list))
2319   (when (and message-max-buffers
2320              (>= (length message-buffer-list) message-max-buffers))
2321     ;; Kill the oldest buffer -- unless it has been changed.
2322     (let ((buffer (pop message-buffer-list)))
2323       (when (and (buffer-name buffer)
2324                  (not (buffer-modified-p buffer)))
2325         (kill-buffer buffer))))
2326   ;; Rename the buffer.
2327   (if message-send-rename-function
2328       (funcall message-send-rename-function)
2329     (when (string-match "\\`\\*" (buffer-name))
2330       (rename-buffer
2331        (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
2332   ;; Push the current buffer onto the list.
2333   (when message-max-buffers
2334     (setq message-buffer-list
2335           (nconc message-buffer-list (list (current-buffer))))))
2336
2337 (defvar mc-modes-alist)
2338 (defun message-setup (headers &optional replybuffer actions)
2339   (when (and (boundp 'mc-modes-alist)
2340              (not (assq 'message-mode mc-modes-alist)))
2341     (push '(message-mode (encrypt . mc-encrypt-message)
2342                          (sign . mc-sign-message))
2343           mc-modes-alist))
2344   (when actions
2345     (setq message-send-actions actions))
2346   (setq message-reply-buffer replybuffer)
2347   (goto-char (point-min))
2348   ;; Insert all the headers.
2349   (mail-header-format
2350    (let ((h headers)
2351          (alist message-header-format-alist))
2352      (while h
2353        (unless (assq (caar h) message-header-format-alist)
2354          (push (list (caar h)) alist))
2355        (pop h))
2356      alist)
2357    headers)
2358   (delete-region (point) (progn (forward-line -1) (point)))
2359   (when message-default-headers
2360     (insert message-default-headers))
2361   (put-text-property
2362    (point)
2363    (progn
2364      (insert mail-header-separator "\n")
2365      (1- (point)))
2366    'read-only nil)
2367   (forward-line -1)
2368   (when (message-news-p)
2369     (when message-default-news-headers
2370       (insert message-default-news-headers))
2371     (when message-generate-headers-first
2372       (message-generate-headers
2373        (delq 'Lines
2374              (delq 'Subject
2375                    (copy-sequence message-required-news-headers))))))
2376   (when (message-mail-p)
2377     (when message-default-mail-headers
2378       (insert message-default-mail-headers))
2379     (when message-generate-headers-first
2380       (message-generate-headers
2381        (delq 'Lines
2382              (delq 'Subject
2383                    (copy-sequence message-required-mail-headers))))))
2384   (run-hooks 'message-signature-setup-hook)
2385   (message-insert-signature)
2386   (message-set-auto-save-file-name)
2387   (save-restriction
2388     (message-narrow-to-headers)
2389     (run-hooks 'message-header-setup-hook))
2390   (set-buffer-modified-p nil)
2391   (run-hooks 'message-setup-hook)
2392   (message-position-point)
2393   (undo-boundary))
2394
2395 (defun message-set-auto-save-file-name ()
2396   "Associate the message buffer with a file in the drafts directory."
2397   (when message-autosave-directory
2398     (unless (file-exists-p message-autosave-directory)
2399       (make-directory message-autosave-directory t))
2400     (let ((name (make-temp-name
2401                  (concat (file-name-as-directory message-autosave-directory)
2402                          "msg."))))
2403       (setq buffer-auto-save-file-name
2404             (save-excursion
2405               (prog1
2406                   (progn
2407                     (set-buffer (get-buffer-create " *draft tmp*"))
2408                     (setq buffer-file-name name)
2409                     (make-auto-save-file-name))
2410                 (kill-buffer (current-buffer)))))
2411       (clear-visited-file-modtime))))
2412
2413 \f
2414
2415 ;;;
2416 ;;; Commands for interfacing with message
2417 ;;;
2418
2419 ;;;###autoload
2420 (defun message-mail (&optional to subject)
2421   "Start editing a mail message to be sent."
2422   (interactive)
2423   (message-pop-to-buffer (message-buffer-name "mail" to))
2424   (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
2425
2426 ;;;###autoload
2427 (defun message-news (&optional newsgroups subject)
2428   "Start editing a news article to be sent."
2429   (interactive)
2430   (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
2431   (message-setup `((Newsgroups . ,(or newsgroups ""))
2432                    (Subject . ,(or subject "")))))
2433
2434 ;;;###autoload
2435 (defun message-reply (&optional to-address wide ignore-reply-to)
2436   "Start editing a reply to the article in the current buffer."
2437   (interactive)
2438   (let ((cur (current-buffer))
2439         from subject date reply-to to cc
2440         references message-id follow-to
2441         mct never-mct gnus-warning)
2442     (save-restriction
2443       (narrow-to-region
2444        (goto-char (point-min))
2445        (if (search-forward "\n\n" nil t)
2446            (1- (point))
2447          (point-max)))
2448       ;; Allow customizations to have their say.
2449       (if (not wide)
2450           ;; This is a regular reply.
2451           (if (message-functionp message-reply-to-function)
2452               (setq follow-to (funcall message-reply-to-function)))
2453         ;; This is a followup.
2454         (if (message-functionp message-wide-reply-to-function)
2455             (save-excursion
2456               (setq follow-to
2457                     (funcall message-wide-reply-to-function)))))
2458       ;; Find all relevant headers we need.
2459       (setq from (message-fetch-field "from")
2460             date (message-fetch-field "date")
2461             subject (or (message-fetch-field "subject") "none")
2462             to (message-fetch-field "to")
2463             cc (message-fetch-field "cc")
2464             mct (message-fetch-field "mail-copies-to")
2465             reply-to (unless ignore-reply-to (message-fetch-field "reply-to"))
2466             references (message-fetch-field "references")
2467             message-id (message-fetch-field "message-id"))
2468       ;; Remove any (buggy) Re:'s that are present and make a
2469       ;; proper one.
2470       (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
2471         (setq subject (substring subject (match-end 0))))
2472       (setq subject (concat "Re: " subject))
2473
2474       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
2475                  (string-match "<[^>]+>" gnus-warning))
2476         (setq message-id (match-string 0 gnus-warning)))
2477
2478       ;; Handle special values of Mail-Copies-To.
2479       (when mct
2480         (cond ((equal (downcase mct) "never")
2481                (setq never-mct t)
2482                (setq mct nil))
2483               ((equal (downcase mct) "always")
2484                (setq mct (or reply-to from)))))
2485
2486       (unless follow-to
2487         (if (or (not wide)
2488                 to-address)
2489             (setq follow-to (list (cons 'To (or to-address reply-to from))))
2490           (let (ccalist)
2491             (save-excursion
2492               (message-set-work-buffer)
2493               (unless never-mct
2494                 (insert (or reply-to from "")))
2495               (insert
2496                (if (bolp) "" ", ") (or to "")
2497                (if mct (concat (if (bolp) "" ", ") mct) "")
2498                (if cc (concat (if (bolp) "" ", ") cc) ""))
2499               ;; Remove addresses that match `rmail-dont-reply-to-names'.
2500               (insert (prog1 (rmail-dont-reply-to (buffer-string))
2501                         (erase-buffer)))
2502               (goto-char (point-min))
2503               (setq ccalist
2504                     (mapcar
2505                      (lambda (addr)
2506                        (cons (mail-strip-quoted-names addr) addr))
2507                      (nreverse (mail-parse-comma-list))))
2508               (let ((s ccalist))
2509                 (while s
2510                   (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
2511             (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
2512             (when ccalist
2513               (push (cons 'Cc
2514                           (mapconcat (lambda (addr) (cdr addr)) ccalist ", "))
2515                     follow-to)))))
2516       (widen))
2517
2518     (message-pop-to-buffer (message-buffer-name
2519                             (if wide "wide reply" "reply") from
2520                             (if wide to-address nil)))
2521
2522     (setq message-reply-headers
2523           (vector 0 subject from date message-id references 0 0 ""))
2524
2525     (message-setup
2526      `((Subject . ,subject)
2527        ,@follow-to
2528        ,@(if (or references message-id)
2529              `((References . ,(concat (or references "") (and references " ")
2530                                       (or message-id ""))))
2531            nil))
2532      cur)))
2533
2534 ;;;###autoload
2535 (defun message-wide-reply (&optional to-address)
2536   (interactive)
2537   (message-reply to-address t))
2538
2539 ;;;###autoload
2540 (defun message-followup ()
2541   (interactive)
2542   (let ((cur (current-buffer))
2543         from subject date reply-to mct
2544         references message-id follow-to
2545         followup-to distribution newsgroups gnus-warning)
2546     (save-restriction
2547       (narrow-to-region
2548        (goto-char (point-min))
2549        (if (search-forward "\n\n" nil t)
2550            (1- (point))
2551          (point-max)))
2552       (when (message-functionp message-followup-to-function)
2553         (setq follow-to
2554               (funcall message-followup-to-function)))
2555       (setq from (message-fetch-field "from")
2556             date (message-fetch-field "date")
2557             subject (or (message-fetch-field "subject") "none")
2558             references (message-fetch-field "references")
2559             message-id (message-fetch-field "message-id")
2560             followup-to (message-fetch-field "followup-to")
2561             newsgroups (message-fetch-field "newsgroups")
2562             reply-to (message-fetch-field "reply-to")
2563             distribution (message-fetch-field "distribution")
2564             mct (message-fetch-field "mail-copies-to"))
2565       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
2566                  (string-match "<[^>]+>" gnus-warning))
2567         (setq message-id (match-string 0 gnus-warning)))
2568       ;; Remove bogus distribution.
2569       (and (stringp distribution)
2570            (string-match "world" distribution)
2571            (setq distribution nil))
2572       ;; Remove any (buggy) Re:'s that are present and make a
2573       ;; proper one.
2574       (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
2575         (setq subject (substring subject (match-end 0))))
2576       (setq subject (concat "Re: " subject))
2577       (widen))
2578
2579     (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
2580
2581     (message-setup
2582      `((Subject . ,subject)
2583        ,@(cond
2584           (follow-to follow-to)
2585           ((and followup-to message-use-followup-to)
2586            (list
2587             (cond
2588              ((equal (downcase followup-to) "poster")
2589               (if (or (eq message-use-followup-to 'use)
2590                       (message-y-or-n-p "Obey Followup-To: poster? " t "\
2591 You should normally obey the Followup-To: header.
2592
2593 `Followup-To: poster' sends your response via e-mail instead of news.
2594
2595 A typical situation where `Followup-To: poster' is used is when the poster
2596 does not read the newsgroup, so he wouldn't see any replies sent to it."))
2597                   (cons 'To (or reply-to from ""))
2598                 (cons 'Newsgroups newsgroups)))
2599              (t
2600               (if (or (equal followup-to newsgroups)
2601                       (not (eq message-use-followup-to 'ask))
2602                       (message-y-or-n-p
2603                        (concat "Obey Followup-To: " followup-to "? ") t "\
2604 You should normally obey the Followup-To: header.
2605
2606         `Followup-To: " followup-to "'
2607 directs your response to " (if (string-match "," followup-to)
2608                                "the specified newsgroups"
2609                              "that newsgroup only") ".
2610
2611 If a message is posted to several newsgroups, Followup-To is often
2612 used to direct the following discussion to one newsgroup only,
2613 because discussions that are spread over several newsgroup tend to
2614 be fragmented and very difficult to follow.
2615
2616 Also, some source/announcment newsgroups are not indented for discussion;
2617 responses here are directed to other newsgroups."))
2618                   (cons 'Newsgroups followup-to)
2619                 (cons 'Newsgroups newsgroups))))))
2620           (t
2621            `((Newsgroups . ,newsgroups))))
2622        ,@(and distribution (list (cons 'Distribution distribution)))
2623        (References . ,(concat (or references "") (and references " ")
2624                               (or message-id "")))
2625        ,@(when (and mct
2626                     (not (equal (downcase mct) "never")))
2627            (list (cons 'Cc (if (equal (downcase mct) "always")
2628                                (or reply-to from "")
2629                              mct)))))
2630
2631      cur)
2632
2633     (setq message-reply-headers
2634           (vector 0 subject from date message-id references 0 0 ""))))
2635
2636
2637 ;;;###autoload
2638 (defun message-cancel-news ()
2639   "Cancel an article you posted."
2640   (interactive)
2641   (unless (message-news-p)
2642     (error "This is not a news article; canceling is impossible"))
2643   (when (yes-or-no-p "Do you really want to cancel this article? ")
2644     (let (from newsgroups message-id distribution buf)
2645       (save-excursion
2646         ;; Get header info. from original article.
2647         (save-restriction
2648           (message-narrow-to-head)
2649           (setq from (message-fetch-field "from")
2650                 newsgroups (message-fetch-field "newsgroups")
2651                 message-id (message-fetch-field "message-id")
2652                 distribution (message-fetch-field "distribution")))
2653         ;; Make sure that this article was written by the user.
2654         (unless (string-equal
2655                  (downcase (cadr (mail-extract-address-components from)))
2656                  (downcase (message-make-address)))
2657           (error "This article is not yours"))
2658         ;; Make control message.
2659         (setq buf (set-buffer (get-buffer-create " *message cancel*")))
2660         (buffer-disable-undo (current-buffer))
2661         (erase-buffer)
2662         (insert "Newsgroups: " newsgroups "\n"
2663                 "From: " (message-make-from) "\n"
2664                 "Subject: cmsg cancel " message-id "\n"
2665                 "Control: cancel " message-id "\n"
2666                 (if distribution
2667                     (concat "Distribution: " distribution "\n")
2668                   "")
2669                 mail-header-separator "\n"
2670                 "This is a cancel message from " from ".\n")
2671         (message "Canceling your article...")
2672         (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me))
2673           (funcall message-send-news-function))
2674         (message "Canceling your article...done")
2675         (kill-buffer buf)))))
2676
2677 ;;;###autoload
2678 (defun message-supersede ()
2679   "Start composing a message to supersede the current message.
2680 This is done simply by taking the old article and adding a Supersedes
2681 header line with the old Message-ID."
2682   (interactive)
2683   (let ((cur (current-buffer)))
2684     ;; Check whether the user owns the article that is to be superseded.
2685     (unless (string-equal
2686              (downcase (cadr (mail-extract-address-components
2687                               (message-fetch-field "from"))))
2688              (downcase (message-make-address)))
2689       (error "This article is not yours"))
2690     ;; Get a normal message buffer.
2691     (message-pop-to-buffer (message-buffer-name "supersede"))
2692     (insert-buffer-substring cur)
2693     (message-narrow-to-head)
2694     ;; Remove unwanted headers.
2695     (when message-ignored-supersedes-headers
2696       (message-remove-header message-ignored-supersedes-headers t))
2697     (goto-char (point-min))
2698     (if (not (re-search-forward "^Message-ID: " nil t))
2699         (error "No Message-ID in this article")
2700       (replace-match "Supersedes: " t t))
2701     (goto-char (point-max))
2702     (insert mail-header-separator)
2703     (widen)
2704     (forward-line 1)))
2705
2706 ;;;###autoload
2707 (defun message-recover ()
2708   "Reread contents of current buffer from its last auto-save file."
2709   (interactive)
2710   (let ((file-name (make-auto-save-file-name)))
2711     (cond ((save-window-excursion
2712              (if (not (eq system-type 'vax-vms))
2713                  (with-output-to-temp-buffer "*Directory*"
2714                    (buffer-disable-undo standard-output)
2715                    (let ((default-directory "/"))
2716                      (call-process
2717                       "ls" nil standard-output nil "-l" file-name))))
2718              (yes-or-no-p (format "Recover auto save file %s? " file-name)))
2719            (let ((buffer-read-only nil))
2720              (erase-buffer)
2721              (insert-file-contents file-name nil)))
2722           (t (error "message-recover cancelled")))))
2723
2724 ;;; Forwarding messages.
2725
2726 (defun message-make-forward-subject ()
2727   "Return a Subject header suitable for the message in the current buffer."
2728   (concat "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from"))
2729                   "(nowhere)")
2730           "] " (or (message-fetch-field "Subject") "")))
2731
2732 ;;;###autoload
2733 (defun message-forward (&optional news)
2734   "Forward the current message via mail.
2735 Optional NEWS will use news to forward instead of mail."
2736   (interactive "P")
2737   (let ((cur (current-buffer))
2738         (subject (message-make-forward-subject)))
2739     (if news (message-news nil subject) (message-mail nil subject))
2740     ;; Put point where we want it before inserting the forwarded
2741     ;; message.
2742     (if message-signature-before-forwarded-message
2743         (goto-char (point-max))
2744       (message-goto-body))
2745     ;; Make sure we're at the start of the line.
2746     (unless (eolp)
2747       (insert "\n"))
2748     ;; Narrow to the area we are to insert.
2749     (narrow-to-region (point) (point))
2750     ;; Insert the separators and the forwarded buffer.
2751     (insert message-forward-start-separator)
2752     (insert-buffer-substring cur)
2753     (goto-char (point-max))
2754     (insert message-forward-end-separator)
2755     (set-text-properties (point-min) (point-max) nil)
2756     ;; Remove all unwanted headers.
2757     (goto-char (point-min))
2758     (forward-line 1)
2759     (narrow-to-region (point) (if (search-forward "\n\n" nil t)
2760                                   (1- (point))
2761                                 (point)))
2762     (goto-char (point-min))
2763     (message-remove-header message-included-forward-headers t nil t)
2764     (widen)
2765     (message-position-point)))
2766
2767 ;;;###autoload
2768 (defun message-resend (address)
2769   "Resend the current article to ADDRESS."
2770   (interactive "sResend message to: ")
2771   (save-excursion
2772     (let ((cur (current-buffer))
2773           beg)
2774       ;; We first set up a normal mail buffer.
2775       (set-buffer (get-buffer-create " *message resend*"))
2776       (buffer-disable-undo (current-buffer))
2777       (erase-buffer)
2778       (message-setup `((To . ,address)))
2779       ;; Insert our usual headers.
2780       (message-generate-headers '(From Date To))
2781       (message-narrow-to-headers)
2782       ;; Rename them all to "Resent-*".
2783       (while (re-search-forward "^[A-Za-z]" nil t)
2784         (forward-char -1)
2785         (insert "Resent-"))
2786       (widen)
2787       (forward-line)
2788       (delete-region (point) (point-max))
2789       (setq beg (point))
2790       ;; Insert the message to be resent.
2791       (insert-buffer-substring cur)
2792       (goto-char (point-min))
2793       (search-forward "\n\n")
2794       (forward-char -1)
2795       (save-restriction
2796         (narrow-to-region beg (point))
2797         (message-remove-header message-ignored-resent-headers t)
2798         (goto-char (point-max)))
2799       (insert mail-header-separator)
2800       ;; Rename all old ("Also-")Resent headers.
2801       (while (re-search-backward "^\\(Also-\\)?Resent-" beg t)
2802         (beginning-of-line)
2803         (insert "Also-"))
2804       ;; Send it.
2805       (message-send-mail)
2806       (kill-buffer (current-buffer)))))
2807
2808 ;;;###autoload
2809 (defun message-bounce ()
2810   "Re-mail the current message.
2811 This only makes sense if the current message is a bounce message than
2812 contains some mail you have written which has been bounced back to
2813 you."
2814   (interactive)
2815   (let ((cur (current-buffer))
2816         boundary)
2817     (message-pop-to-buffer (message-buffer-name "bounce"))
2818     (insert-buffer-substring cur)
2819     (undo-boundary)
2820     (message-narrow-to-head)
2821     (if (and (message-fetch-field "Mime-Version")
2822              (setq boundary (message-fetch-field "Content-Type")))
2823         (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
2824             (setq boundary (concat (match-string 1 boundary) " *\n"
2825                                    "Content-Type: message/rfc822"))
2826           (setq boundary nil)))
2827     (widen)
2828     (goto-char (point-min))
2829     (search-forward "\n\n" nil t)
2830     (or (and boundary
2831              (re-search-forward boundary nil t)
2832              (forward-line 2))
2833         (and (re-search-forward message-unsent-separator nil t)
2834              (forward-line 1))
2835         (and (search-forward "\n\n" nil t)
2836              (re-search-forward "^Return-Path:.*\n" nil t)))
2837     ;; We remove everything before the bounced mail.
2838     (delete-region
2839      (point-min)
2840      (if (re-search-forward "^[^ \n\t]+:" nil t)
2841          (match-beginning 0)
2842        (point)))
2843     (save-restriction
2844       (message-narrow-to-head)
2845       (message-remove-header message-ignored-bounced-headers t)
2846       (goto-char (point-max))
2847       (insert mail-header-separator))
2848     (message-position-point)))
2849
2850 ;;;
2851 ;;; Interactive entry points for new message buffers.
2852 ;;;
2853
2854 ;;;###autoload
2855 (defun message-mail-other-window (&optional to subject)
2856   "Like `message-mail' command, but display mail buffer in another window."
2857   (interactive)
2858   (let ((pop-up-windows t)
2859         (special-display-buffer-names nil)
2860         (special-display-regexps nil)
2861         (same-window-buffer-names nil)
2862         (same-window-regexps nil))
2863     (message-pop-to-buffer (message-buffer-name "mail" to)))
2864   (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
2865
2866 ;;;###autoload
2867 (defun message-mail-other-frame (&optional to subject)
2868   "Like `message-mail' command, but display mail buffer in another frame."
2869   (interactive)
2870   (let ((pop-up-frames t)
2871         (special-display-buffer-names nil)
2872         (special-display-regexps nil)
2873         (same-window-buffer-names nil)
2874         (same-window-regexps nil))
2875     (message-pop-to-buffer (message-buffer-name "mail" to)))
2876   (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
2877
2878 ;;;###autoload
2879 (defun message-news-other-window (&optional newsgroups subject)
2880   "Start editing a news article to be sent."
2881   (interactive)
2882   (let ((pop-up-windows t)
2883         (special-display-buffer-names nil)
2884         (special-display-regexps nil)
2885         (same-window-buffer-names nil)
2886         (same-window-regexps nil))
2887     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
2888   (message-setup `((Newsgroups . ,(or newsgroups ""))
2889                    (Subject . ,(or subject "")))))
2890
2891 ;;;###autoload
2892 (defun message-news-other-frame (&optional newsgroups subject)
2893   "Start editing a news article to be sent."
2894   (interactive)
2895   (let ((pop-up-frames t)
2896         (special-display-buffer-names nil)
2897         (special-display-regexps nil)
2898         (same-window-buffer-names nil)
2899         (same-window-regexps nil))
2900     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
2901   (message-setup `((Newsgroups . ,(or newsgroups ""))
2902                    (Subject . ,(or subject "")))))
2903
2904 ;;; underline.el
2905
2906 ;; This code should be moved to underline.el (from which it is stolen).
2907
2908 ;;;###autoload
2909 (defun bold-region (start end)
2910   "Bold all nonblank characters in the region.
2911 Works by overstriking characters.
2912 Called from program, takes two arguments START and END
2913 which specify the range to operate on."
2914   (interactive "r")
2915   (save-excursion
2916    (let ((end1 (make-marker)))
2917      (move-marker end1 (max start end))
2918      (goto-char (min start end))
2919      (while (< (point) end1)
2920        (or (looking-at "[_\^@- ]")
2921            (insert (following-char) "\b"))
2922        (forward-char 1)))))
2923
2924 ;;;###autoload
2925 (defun unbold-region (start end)
2926   "Remove all boldness (overstruck characters) in the region.
2927 Called from program, takes two arguments START and END
2928 which specify the range to operate on."
2929   (interactive "r")
2930   (save-excursion
2931    (let ((end1 (make-marker)))
2932      (move-marker end1 (max start end))
2933      (goto-char (min start end))
2934      (while (re-search-forward "\b" end1 t)
2935        (if (eq (following-char) (char-after (- (point) 2)))
2936            (delete-char -2))))))
2937
2938 (fset 'message-exchange-point-and-mark 'exchange-point-and-mark)
2939
2940 ;; Support for toolbar
2941 (when (string-match "XEmacs\\|Lucid" emacs-version)
2942   (require 'messagexmas))
2943
2944 ;;; Group name completion.
2945
2946 (defvar message-newgroups-header-regexp
2947   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\):"
2948   "Regexp that match headers that lists groups.")
2949
2950 (defun message-tab ()
2951   "Expand group names in Newsgroups and Followup-To headers.
2952 Do a `tab-to-tab-stop' if not in those headers."
2953   (interactive)
2954   (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
2955         (mail-abbrev-in-expansion-header-p))
2956       (message-expand-group)
2957     (tab-to-tab-stop)))
2958
2959 (defvar gnus-active-hashtb)
2960 (defun message-expand-group ()
2961   (let* ((b (save-excursion (skip-chars-backward "^, :\t\n") (point)))
2962          (completion-ignore-case t)
2963          (string (buffer-substring b (point)))
2964          (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
2965          (completions (all-completions string hashtb))
2966          (cur (current-buffer))
2967          comp)
2968     (delete-region b (point))
2969     (cond
2970      ((= (length completions) 1)
2971       (if (string= (car completions) string)
2972           (progn
2973             (insert string)
2974             (message "Only matching group"))
2975         (insert (car completions))))
2976      ((and (setq comp (try-completion string hashtb))
2977            (not (string= comp string)))
2978       (insert comp))
2979      (t
2980       (insert string)
2981       (if (not comp)
2982           (message "No matching groups")
2983         (pop-to-buffer "*Completions*")
2984         (buffer-disable-undo (current-buffer))
2985         (let ((buffer-read-only nil))
2986           (erase-buffer)
2987           (let ((standard-output (current-buffer)))
2988             (display-completion-list (sort completions 'string<)))
2989           (goto-char (point-min))
2990           (pop-to-buffer cur)))))))
2991
2992 (run-hooks 'message-load-hook)
2993
2994 (provide 'message)
2995
2996 ;;; message.el ends here