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

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