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

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