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

   1 ;;; message.el --- composing mail and news messages  -*- coding: iso-latin-1 -*-
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;;      Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
   8 ;;      Keiichi Suzuki   <kei-suzu@mail.wbs.ne.jp>
   9 ;;      Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
  10 ;;      Katsumi Yamaoka  <yamaoka@jpl.org>
  11 ;;      Kiyokazu SUTO    <suto@merry.xmath.ous.ac.jp>
  12 ;; Keywords: mail, news, MIME
  13
  14 ;; This file is part of GNU Emacs.
  15
  16 ;; GNU Emacs is free software; you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation; either version 2, or (at your option)
  19 ;; any later version.
  20
  21 ;; GNU Emacs is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29 ;; Boston, MA 02111-1307, USA.
  30
  31 ;;; Commentary:
  32
  33 ;; This mode provides mail-sending facilities from within Emacs.  It
  34 ;; consists mainly of large chunks of code from the sendmail.el,
  35 ;; gnus-msg.el and rnewspost.el files.
  36
  37 ;;; Code:
  38
  39 (eval-when-compile
  40   (require 'cl)
  41   (require 'smtp)
  42   (defvar gnus-list-identifiers))       ; gnus-sum is required where necessary
  43 (require 'mailheader)
  44 (require 'nnheader)
  45 ;; This is apparently necessary even though things are autoloaded:
  46 (if (featurep 'xemacs)
  47     (require 'mail-abbrevs))
  48 (require 'mime-edit)
  49 (eval-when-compile (require 'static))
  50
  51 ;; Avoid byte-compile warnings.
  52 (eval-when-compile
  53   (require 'mail-parse)
  54   (require 'mml))
  55
  56 (defgroup message '((user-mail-address custom-variable)
  57                     (user-full-name custom-variable))
  58   "Mail and news message composing."
  59   :link '(custom-manual "(message)Top")
  60   :group 'mail
  61   :group 'news)
  62
  63 (put 'user-mail-address 'custom-type 'string)
  64 (put 'user-full-name 'custom-type 'string)
  65
  66 (defgroup message-various nil
  67   "Various Message Variables"
  68   :link '(custom-manual "(message)Various Message Variables")
  69   :group 'message)
  70
  71 (defgroup message-buffers nil
  72   "Message Buffers"
  73   :link '(custom-manual "(message)Message Buffers")
  74   :group 'message)
  75
  76 (defgroup message-sending nil
  77   "Message Sending"
  78   :link '(custom-manual "(message)Sending Variables")
  79   :group 'message)
  80
  81 (defgroup message-interface nil
  82   "Message Interface"
  83   :link '(custom-manual "(message)Interface")
  84   :group 'message)
  85
  86 (defgroup message-forwarding nil
  87   "Message Forwarding"
  88   :link '(custom-manual "(message)Forwarding")
  89   :group 'message-interface)
  90
  91 (defgroup message-insertion nil
  92   "Message Insertion"
  93   :link '(custom-manual "(message)Insertion")
  94   :group 'message)
  95
  96 (defgroup message-headers nil
  97   "Message Headers"
  98   :link '(custom-manual "(message)Message Headers")
  99   :group 'message)
 100
 101 (defgroup message-news nil
 102   "Composing News Messages"
 103   :group 'message)
 104
 105 (defgroup message-mail nil
 106   "Composing Mail Messages"
 107   :group 'message)
 108
 109 (defgroup message-faces nil
 110   "Faces used for message composing."
 111   :group 'message
 112   :group 'faces)
 113
 114 (defgroup message-frames nil
 115   "Message frames"
 116   :group 'message)
 117
 118 (defcustom message-directory "~/Mail/"
 119   "*Directory from which all other mail file variables are derived."
 120   :group 'message-various
 121   :type 'directory)
 122
 123 (defcustom message-max-buffers 10
 124   "*How many buffers to keep before starting to kill them off."
 125   :group 'message-buffers
 126   :type 'integer)
 127
 128 (defcustom message-send-rename-function nil
 129   "Function called to rename the buffer after sending it."
 130   :group 'message-buffers
 131   :type '(choice function (const nil)))
 132
 133 (defcustom message-fcc-handler-function 'message-output
 134   "*A function called to save outgoing articles.
 135 This function will be called with the name of the file to store the
 136 article in.  The default function is `message-output' which saves in Unix
 137 mailbox format."
 138   :type '(radio (function-item message-output)
 139                 (function :tag "Other"))
 140   :group 'message-sending)
 141
 142 (defcustom message-encode-function 'message-maybe-encode
 143   "*A function called to encode messages."
 144   :group 'message-sending
 145   :type 'function)
 146
 147 (defcustom message-8bit-encoding-list '(8bit binary)
 148   "*8bit encoding type in Content-Transfer-Encoding field."
 149   :group 'message-sending
 150   :type '(repeat (symbol :tag "Type")))
 151
 152 (defcustom message-courtesy-message
 153   "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"
 154   "*This is inserted at the start of a mailed copy of a posted message.
 155 If the string contains the format spec \"%s\", the Newsgroups
 156 the article has been posted to will be inserted there.
 157 If this variable is nil, no such courtesy message will be added."
 158   :group 'message-sending
 159   :type 'string)
 160
 161 (defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
 162   "*Regexp that matches headers to be removed in resent bounced mail."
 163   :group 'message-interface
 164   :type 'regexp)
 165
 166 (defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit
 167   "Function to setup a re-sending bounced message."
 168   :group 'message-sending
 169   :type 'function)
 170
 171 ;;;###autoload
 172 (defcustom message-from-style 'default
 173   "*Specifies how \"From\" headers look.
 174
 175 If nil, they contain just the return address like:
 176         king@grassland.com
 177 If `parens', they look like:
 178         king@grassland.com (Elvis Parsley)
 179 If `angles', they look like:
 180         Elvis Parsley <king@grassland.com>
 181
 182 Otherwise, most addresses look like `angles', but they look like
 183 `parens' if `angles' would need quoting and `parens' would not."
 184   :type '(choice (const :tag "simple" nil)
 185                  (const parens)
 186                  (const angles)
 187                  (const default))
 188   :group 'message-headers)
 189
 190 (defcustom message-syntax-checks nil
 191   ;; Guess this one shouldn't be easy to customize...
 192   "*Controls what syntax checks should not be performed on outgoing posts.
 193 To disable checking of long signatures, for instance, add
 194  `(signature . disabled)' to this list.
 195
 196 Don't touch this variable unless you really know what you're doing.
 197
 198 Checks include `subject-cmsg', `multiple-headers', `sendsys',
 199 `message-id', `from', `long-lines', `control-chars', `size',
 200 `new-text', `quoting-style', `redirected-followup', `signature',
 201 `approved', `sender', `empty', `empty-headers', `message-id', `from',
 202 `subject', `shorten-followup-to', `existing-newsgroups',
 203 `buffer-file-name', `unchanged', `newsgroups', `reply-to'."
 204   :group 'message-news
 205   :type '(repeat sexp))                 ; Fixme: improve this
 206
 207 (defcustom message-required-news-headers
 208   '(From Newsgroups Subject Date Message-ID
 209          (optional . Organization) Lines
 210          (optional . User-Agent))
 211   "*Headers to be generated or prompted for when posting an article.
 212 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
 213 Message-ID.  Organization, Lines, In-Reply-To, Expires, and
 214 User-Agent are optional.  If don't you want message to insert some
 215 header, remove it from this list."
 216   :group 'message-news
 217   :group 'message-headers
 218   :type '(repeat sexp))
 219
 220 (defcustom message-required-mail-headers
 221   '(From Subject Date (optional . In-Reply-To) Message-ID Lines
 222          (optional . User-Agent))
 223   "*Headers to be generated or prompted for when mailing a message.
 224 RFC822 required that From, Date, To, Subject and Message-ID be
 225 included.  Organization, Lines and User-Agent are optional."
 226   :group 'message-mail
 227   :group 'message-headers
 228   :type '(repeat sexp))
 229
 230 (defcustom message-deletable-headers '(Message-ID Date Lines)
 231   "Headers to be deleted if they already exist and were generated by message previously."
 232   :group 'message-headers
 233   :type 'sexp)
 234
 235 (defcustom message-ignored-news-headers
 236   "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:"
 237   "*Regexp of headers to be removed unconditionally before posting."
 238   :group 'message-news
 239   :group 'message-headers
 240   :type 'regexp)
 241
 242 (defcustom message-ignored-mail-headers
 243   "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:"
 244   "*Regexp of headers to be removed unconditionally before mailing."
 245   :group 'message-mail
 246   :group 'message-headers
 247   :type 'regexp)
 248
 249 (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:"
 250   "*Header lines matching this regexp will be deleted before posting.
 251 It's best to delete old Path and Date headers before posting to avoid
 252 any confusion."
 253   :group 'message-interface
 254   :type 'regexp)
 255
 256 (defcustom message-supersede-setup-function
 257   'message-supersede-setup-for-mime-edit
 258   "Function to setup a supersede message."
 259   :group 'message-sending
 260   :type 'function)
 261
 262 (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"
 263   "*Regexp matching \"Re: \" in the subject line."
 264   :group 'message-various
 265   :type 'regexp)
 266
 267 ;;; Some sender agents encode the whole subject including leading "Re: ".
 268 ;;; And if followup agent does not decode it for some reason (e.g. unknown
 269 ;;; charset) and just add a new "Re: " in front of the encoded-word, the
 270 ;;; result will contain multiple "Re: "'s.
 271 (defcustom message-subject-encoded-re-regexp
 272   (concat
 273    "^[ \t]*"
 274    (regexp-quote "=?")
 275    "[-!#$%&'*+0-9A-Z^_`a-z{|}~]+" ; charset
 276    (regexp-quote "?")
 277    "\\("
 278    "[Bb]" (regexp-quote "?") ; B encoding
 279    "\\(\\(CQk\\|CSA\\|IAk\\|ICA\\)[Jg]\\)*" ; \([ \t][ \t][ \t]\)*
 280    "\\("
 281    "[Uc][km]U6" ; [Rr][Ee]:
 282    "\\|"
 283    "\\(C[VX]\\|I[FH]\\)J[Fl]O[g-v]" ; [ \t][Rr][Ee]:
 284    "\\|"
 285    "\\(CQl\\|CSB\\|IAl\\|ICB\\)[Sy][RZ]T[o-r]" ; [ \t][ \t][Rr][Ee]:
 286    "\\)"
 287    "\\|"
 288    "[Qb]" (regexp-quote "?") ; Q encoding
 289    "\\(_\\|=09\\|=20\\)*"
 290    "\\([Rr]\\|=[57]2\\)\\([Ee]\\|=[46]5\\)\\(:\\|=3[Aa]\\)"
 291    "\\)"
 292    )
 293   "*Regexp matching \"Re: \" in the subject line.
 294 Unlike `message-subject-re-regexp', this regexp matches \"Re: \" within
 295 an encoded-word."
 296   :group 'message-various
 297   :type 'regexp)
 298
 299 (defcustom message-use-subject-re t
 300   "*If t, remove any (buggy) \"Re: \"'s from the subject of the precursor
 301 and add a new \"Re: \".  If it is nil, use the subject \"as-is\".  If it
 302 is the symbol `guess', try to detect \"Re: \" within an encoded-word."
 303   :group 'message-various
 304   :type '(choice (const :tag "off" nil)
 305                  (const :tag "on" t)
 306                  (const guess)))
 307
 308 ;;;###autoload
 309 (defcustom message-signature-separator "^-- *$"
 310   "Regexp matching the signature separator."
 311   :type 'regexp
 312   :group 'message-various)
 313
 314 (defcustom message-elide-ellipsis "\n[...]\n\n"
 315   "*The string which is inserted for elided text."
 316   :type 'string
 317   :group 'message-various)
 318
 319 (defcustom message-interactive nil
 320   "Non-nil means when sending a message wait for and display errors.
 321 nil means let mailer mail back a message to report errors."
 322   :group 'message-sending
 323   :group 'message-mail
 324   :type 'boolean)
 325
 326 (defcustom message-generate-new-buffers 'unique
 327   "*Non-nil means create a new message buffer whenever `message-setup' is called.
 328 If this is a function, call that function with three parameters:  The type,
 329 the to address and the group name.  (Any of these may be nil.)  The function
 330 should return the new buffer name."
 331   :group 'message-buffers
 332   :type '(choice (const :tag "off" nil)
 333                  (const :tag "unique" unique)
 334                  (const :tag "unsent" unsent)
 335                  (function fun)))
 336
 337 (defcustom message-kill-buffer-on-exit nil
 338   "*Non-nil means that the message buffer will be killed after sending a message."
 339   :group 'message-buffers
 340   :type 'boolean)
 341
 342 (defcustom message-kill-buffer-query-function 'yes-or-no-p
 343   "*A function called to query the user whether to kill buffer anyway or not.
 344 If it is t, the buffer will be killed peremptorily."
 345   :type '(radio (function-item yes-or-no-p)
 346                 (function-item y-or-n-p)
 347                 (function-item nnheader-Y-or-n-p)
 348                 (function :tag "Other" t))
 349   :group 'message-buffers)
 350
 351 (eval-when-compile
 352   (defvar gnus-local-organization))
 353 (defcustom message-user-organization
 354   (or (and (boundp 'gnus-local-organization)
 355            (stringp gnus-local-organization)
 356            gnus-local-organization)
 357       (getenv "ORGANIZATION")
 358       t)
 359   "*String to be used as an Organization header.
 360 If t, use `message-user-organization-file'."
 361   :group 'message-headers
 362   :type '(choice string
 363                  (const :tag "consult file" t)))
 364
 365 ;;;###autoload
 366 (defcustom message-user-organization-file "/usr/lib/news/organization"
 367   "*Local news organization file."
 368   :type 'file
 369   :group 'message-headers)
 370
 371 (defcustom message-forward-start-separator
 372   (concat (mime-make-tag "message" "rfc822") "\n")
 373   "*Delimiter inserted before forwarded messages."
 374   :group 'message-forwarding
 375   :type 'string)
 376
 377 (defcustom message-forward-end-separator
 378   (concat (mime-make-tag "text" "plain") "\n")
 379   "*Delimiter inserted after forwarded messages."
 380   :group 'message-forwarding
 381   :type 'string)
 382
 383 (defcustom message-included-forward-headers
 384   "^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:"
 385   "*Regexp matching headers to be included in forwarded messages."
 386   :group 'message-forwarding
 387   :type 'regexp)
 388
 389 (defcustom message-make-forward-subject-function
 390   'message-forward-subject-author-subject
 391   "*List of functions called to generate subject headers for forwarded messages.
 392 The subject generated by the previous function is passed into each
 393 successive function.
 394
 395 The provided functions are:
 396
 397 * `message-forward-subject-author-subject' (Source of article (author or
 398       newsgroup)), in brackets followed by the subject
 399 * `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended
 400       to it."
 401   :group 'message-forwarding
 402   :type '(radio (function-item message-forward-subject-author-subject)
 403                 (function-item message-forward-subject-fwd)
 404                 (repeat :tag "List of functions" function)))
 405
 406 (defcustom message-forward-as-mime t
 407   "*If non-nil, forward messages as an inline/rfc822 MIME section.  Otherwise, directly inline the old message in the forwarded message."
 408   :version "21.1"
 409   :group 'message-forwarding
 410   :type 'boolean)
 411
 412 (defcustom message-forward-show-mml t
 413   "*If non-nil, forward messages are shown as mml.  Otherwise, forward messages are unchanged."
 414   :version "21.1"
 415   :group 'message-forwarding
 416   :type 'boolean)
 417
 418 (defcustom message-forward-before-signature t
 419   "*If non-nil, put forwarded message before signature, else after."
 420   :group 'message-forwarding
 421   :type 'boolean)
 422
 423 (defcustom message-wash-forwarded-subjects nil
 424   "*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."
 425   :group 'message-forwarding
 426   :type 'boolean)
 427
 428 (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"
 429   "*All headers that match this regexp will be deleted when resending a message."
 430   :group 'message-interface
 431   :type 'regexp)
 432
 433 (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
 434   "*All headers that match this regexp will be deleted when forwarding a message."
 435   :version "21.1"
 436   :group 'message-forwarding
 437   :type '(choice (const :tag "None" nil)
 438                  regexp))
 439
 440 (defcustom message-ignored-cited-headers "."
 441   "*Delete these headers from the messages you yank."
 442   :group 'message-insertion
 443   :type 'regexp)
 444
 445 (defcustom message-cite-prefix-regexp
 446   (if (string-match "[[:digit:]]" "1") ;; support POSIX?
 447       "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>»|:}+]\\)+"
 448     ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
 449     "\\([ \t]*\\(\\w\\|[-_.]\\)+>+\\|[ \t]*[]>»|:}+]\\)+")
 450   "*Regexp matching the longest possible citation prefix on a line."
 451   :group 'message-insertion
 452   :type 'regexp)
 453
 454 (defcustom message-cancel-message "I am canceling my own article.\n"
 455   "Message to be inserted in the cancel message."
 456   :group 'message-interface
 457   :type 'string)
 458
 459 ;; Useful to set in site-init.el
 460 ;;;###autoload
 461 (defcustom message-send-mail-function 'message-send-mail-with-sendmail
 462   "Function to call to send the current buffer as mail.
 463 The headers should be delimited by a line whose contents match the
 464 variable `mail-header-separator'.
 465
 466 Valid values include `message-send-mail-with-sendmail' (the default),
 467 `message-send-mail-with-mh', `message-send-mail-with-qmail',
 468 `message-send-mail-with-smtp', `smtpmail-send-it' and `feedmail-send-it'.
 469
 470 See also `send-mail-function'."
 471   :type '(radio (function-item message-send-mail-with-sendmail)
 472                 (function-item message-send-mail-with-mh)
 473                 (function-item message-send-mail-with-qmail)
 474                 (function-item message-send-mail-with-smtp)
 475                 (function-item smtpmail-send-it)
 476                 (function-item feedmail-send-it)
 477                 (function :tag "Other"))
 478   :group 'message-sending
 479   :group 'message-mail)
 480
 481 ;; 1997-09-29 by MORIOKA Tomohiko
 482 (defcustom message-send-news-function 'message-send-news-with-gnus
 483   "Function to call to send the current buffer as news.
 484 The headers should be delimited by a line whose contents match the
 485 variable `mail-header-separator'."
 486   :group 'message-sending
 487   :group 'message-news
 488   :type 'function)
 489
 490 (defcustom message-reply-to-function nil
 491   "If non-nil, function that should return a list of headers.
 492 This function should pick out addresses from the To, Cc, and From headers
 493 and respond with new To and Cc headers."
 494   :group 'message-interface
 495   :type '(choice function (const nil)))
 496
 497 (defcustom message-wide-reply-to-function nil
 498   "If non-nil, function that should return a list of headers.
 499 This function should pick out addresses from the To, Cc, and From headers
 500 and respond with new To and Cc headers."
 501   :group 'message-interface
 502   :type '(choice function (const nil)))
 503
 504 (defcustom message-followup-to-function nil
 505   "If non-nil, function that should return a list of headers.
 506 This function should pick out addresses from the To, Cc, and From headers
 507 and respond with new To and Cc headers."
 508   :group 'message-interface
 509   :type '(choice function (const nil)))
 510
 511 (defcustom message-use-followup-to t
 512   "*Specifies what to do with Followup-To header.
 513 If nil, always ignore the header.  If it is t, use its value, but
 514 query before using the \"poster\" value.  If it is the symbol `ask',
 515 always query the user whether to use the value.  If it is the symbol
 516 `use', always use the value."
 517   :group 'message-interface
 518   :type '(choice (const :tag "ignore" nil)
 519                  (const :tag "use & query" t)
 520                  (const :tag "maybe" t)
 521                  (const :tag "always" use)
 522                  (const :tag "ask" ask)))
 523
 524 (defcustom message-use-mail-copies-to 'ask
 525   "*Specifies what to do with Mail-Copies-To header.
 526 If nil, always ignore the header.  If it is t, use its value, but
 527 query before using the value other than \"always\" or \"never\".
 528 If it is the symbol `ask', always query the user whether to use
 529 the value.  If it is the symbol `use', always use the value."
 530   :group 'message-interface
 531   :type '(choice (const :tag "ignore" nil)
 532                  (const :tag "maybe" t)
 533                  (const :tag "always" use)
 534                  (const :tag "ask" ask)))
 535
 536 (defcustom message-use-mail-followup-to 'ask
 537   "*Specifies what to do with Mail-Followup-To header.
 538 If nil, always ignore the header.  If it is the symbol `ask', always
 539 query the user whether to use the value.  If it is t or the symbol
 540 `use', always use the value."
 541   :group 'message-interface
 542   :type '(choice (const :tag "ignore" nil)
 543                  (const :tag "maybe" t)
 544                  (const :tag "always" use)
 545                  (const :tag "ask" ask)))
 546
 547 ;;; XXX: 'ask and 'use are not implemented yet.
 548 (defcustom message-use-mail-reply-to 'ask
 549   "*Specifies what to do with Mail-Reply-To/Reply-To header.
 550 If nil, always ignore the header.  If it is t or the symbol `use', use
 551 its value.  If it is the symbol `ask', always query the user whether to
 552 use the value.  Note that if \"Reply-To\" is marked as \"broken\", its value
 553 is never used."
 554   :group 'message-interface
 555   :type '(choice (const :tag "ignore" nil)
 556                  (const :tag "maybe" t)
 557                  (const :tag "always" use)
 558                  (const :tag "ask" ask)))
 559
 560 (defcustom message-sendmail-f-is-evil nil
 561   "*Non-nil means don't add \"-f username\" to the sendmail command line.
 562 Doing so would be even more evil than leaving it out."
 563   :group 'message-sending
 564   :type 'boolean)
 565
 566 ;; qmail-related stuff
 567 (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
 568   "Location of the qmail-inject program."
 569   :group 'message-sending
 570   :type 'file)
 571
 572 (defcustom message-qmail-inject-args nil
 573   "Arguments passed to qmail-inject programs.
 574 This should be a list of strings, one string for each argument.
 575
 576 For e.g., if you wish to set the envelope sender address so that bounces
 577 go to the right place or to deal with listserv's usage of that address, you
 578 might set this variable to '(\"-f\" \"you@some.where\")."
 579   :group 'message-sending
 580   :type '(repeat string))
 581
 582 (defvar message-cater-to-broken-inn t
 583   "Non-nil means Gnus should not fold the `References' header.
 584 Folding `References' makes ancient versions of INN create incorrect
 585 NOV lines.")
 586
 587 (eval-when-compile
 588   (defvar gnus-post-method)
 589   (defvar gnus-select-method))
 590 (defcustom message-post-method
 591   (cond ((and (boundp 'gnus-post-method)
 592               (listp gnus-post-method)
 593               gnus-post-method)
 594          gnus-post-method)
 595         ((boundp 'gnus-select-method)
 596          gnus-select-method)
 597         (t '(nnspool "")))
 598   "*Method used to post news.
 599 Note that when posting from inside Gnus, for instance, this
 600 variable isn't used."
 601   :group 'message-news
 602   :group 'message-sending
 603   ;; This should be the `gnus-select-method' widget, but that might
 604   ;; create a dependence to `gnus.el'.
 605   :type 'sexp)
 606
 607 (defcustom message-generate-headers-first nil
 608   "*If non-nil, generate all required headers before composing.
 609 The variables `message-required-news-headers' and
 610 `message-required-mail-headers' specify which headers to generate.
 611
 612 Note that the variable `message-deletable-headers' specifies headers which
 613 are to be deleted and then re-generated before sending, so this variable
 614 will not have a visible effect for those headers."
 615   :group 'message-headers
 616   :type 'boolean)
 617
 618 (defcustom message-setup-hook '(turn-on-mime-edit)
 619   "Normal hook, run each time a new outgoing message is initialized.
 620 The function `message-setup' runs this hook."
 621   :group 'message-various
 622   :type 'hook)
 623
 624 (defcustom message-cancel-hook nil
 625   "Hook run when cancelling articles."
 626   :group 'message-various
 627   :type 'hook)
 628
 629 (defcustom message-signature-setup-hook nil
 630   "Normal hook, run each time a new outgoing message is initialized.
 631 It is run after the headers have been inserted and before
 632 the signature is inserted."
 633   :group 'message-various
 634   :type 'hook)
 635
 636 (defcustom message-bounce-setup-hook nil
 637   "Normal hook, run each time a re-sending bounced message is initialized.
 638 The function `message-bounce' runs this hook."
 639   :group 'message-various
 640   :type 'hook)
 641
 642 (defcustom message-supersede-setup-hook nil
 643   "Normal hook, run each time a supersede message is initialized.
 644 The function `message-supersede' runs this hook."
 645   :group 'message-various
 646   :type 'hook)
 647
 648 (defcustom message-mode-hook nil
 649   "Hook run in message mode buffers."
 650   :group 'message-various
 651   :type 'hook)
 652
 653 (defcustom message-header-hook '((lambda () (eword-encode-header t)))
 654   "Hook run in a message mode buffer narrowed to the headers."
 655   :group 'message-various
 656   :type 'hook)
 657
 658 (defcustom message-header-setup-hook nil
 659   "Hook called narrowed to the headers when setting up a message buffer."
 660   :group 'message-various
 661   :type 'hook)
 662
 663 (defcustom message-minibuffer-local-map
 664   (let ((map (make-sparse-keymap 'message-minibuffer-local-map)))
 665     (set-keymap-parent map minibuffer-local-map)
 666     map)
 667   "Keymap for `message-read-from-minibuffer'.")
 668
 669 ;;;###autoload
 670 (defcustom message-citation-line-function 'message-insert-citation-line
 671   "*Function called to insert the \"Whomever writes:\" line."
 672   :type 'function
 673   :group 'message-insertion)
 674
 675 ;;;###autoload
 676 (defcustom message-yank-prefix "> "
 677   "*Prefix inserted on the lines of yanked messages.
 678 Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
 679 See also `message-yank-cited-prefix'."
 680   :type 'string
 681   :group 'message-insertion)
 682
 683 (defcustom message-yank-add-new-references t
 684   "Non-nil means new IDs will be added to \"References\" field when an
 685 article is yanked by the command `message-yank-original' interactively.
 686 If it is a symbol `message-id-only', only an ID from \"Message-ID\" field
 687 is used, otherwise IDs extracted from \"References\", \"In-Reply-To\" and
 688 \"Message-ID\" fields are used."
 689   :type '(radio (const :tag "Do not add anything" nil)
 690                 (const :tag "From Message-Id, References and In-Reply-To fields" t)
 691                 (const :tag "From only Message-Id field." message-id-only))
 692   :group 'message-insertion)
 693
 694 (defcustom message-list-references-add-position nil
 695   "Integer value means position for adding to \"References\" field when
 696 an article is yanked by the command `message-yank-original' interactively."
 697   :type '(radio (const :tag "Add to last" nil)
 698                 (integer :tag "Position from last ID"))
 699   :group 'message-insertion)
 700
 701 (defcustom message-yank-cited-prefix ">"
 702   "*Prefix inserted on cited lines of yanked messages.
 703 Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
 704 See also `message-yank-prefix'."
 705   :type 'string
 706   :group 'message-insertion)
 707
 708 (defcustom message-indentation-spaces 3
 709   "*Number of spaces to insert at the beginning of each cited line.
 710 Used by `message-yank-original' via `message-yank-cite'."
 711   :group 'message-insertion
 712   :type 'integer)
 713
 714 ;;;###autoload
 715 (defcustom message-cite-function 'message-cite-original
 716   "*Function for citing an original message.
 717 Predefined functions include `message-cite-original' and
 718 `message-cite-original-without-signature'.
 719 Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil."
 720   :type '(radio (function-item message-cite-original)
 721                 (function-item message-cite-original-without-signature)
 722                 (function-item mu-cite-original)
 723                 (function-item sc-cite-original)
 724                 (function :tag "Other"))
 725   :group 'message-insertion)
 726
 727 ;;;###autoload
 728 (defcustom message-indent-citation-function 'message-indent-citation
 729   "*Function for modifying a citation just inserted in the mail buffer.
 730 This can also be a list of functions.  Each function can find the
 731 citation between (point) and (mark t).  And each function should leave
 732 point and mark around the citation text as modified."
 733   :type 'function
 734   :group 'message-insertion)
 735
 736 (defvar message-abbrevs-loaded nil)
 737
 738 ;;;###autoload
 739 (defcustom message-signature t
 740   "*String to be inserted at the end of the message buffer.
 741 If t, the `message-signature-file' file will be inserted instead.
 742 If a function, the result from the function will be used instead.
 743 If a form, the result from the form will be used instead."
 744   :type 'sexp
 745   :group 'message-insertion)
 746
 747 ;;;###autoload
 748 (defcustom message-signature-file "~/.signature"
 749   "*Name of file containing the text inserted at end of message buffer.
 750 Ignored if the named file doesn't exist.
 751 If nil, don't insert a signature."
 752   :type '(choice file (const :tags "None" nil))
 753   :group 'message-insertion)
 754
 755 (defcustom message-distribution-function nil
 756   "*Function called to return a Distribution header."
 757   :group 'message-news
 758   :group 'message-headers
 759   :type '(choice function (const nil)))
 760
 761 (defcustom message-expires 14
 762   "Number of days before your article expires."
 763   :group 'message-news
 764   :group 'message-headers
 765   :link '(custom-manual "(message)News Headers")
 766   :type 'integer)
 767
 768 (defcustom message-user-path nil
 769   "If nil, use the NNTP server name in the Path header.
 770 If stringp, use this; if non-nil, use no host name (user name only)."
 771   :group 'message-news
 772   :group 'message-headers
 773   :link '(custom-manual "(message)News Headers")
 774   :type '(choice (const :tag "nntp" nil)
 775                  (string :tag "name")
 776                  (sexp :tag "none" :format "%t" t)))
 777
 778 (defvar message-reply-buffer nil)
 779 (defvar message-reply-headers nil)
 780 (defvar message-sent-message-via nil)
 781 (defvar message-checksum nil)
 782 (defvar message-send-actions nil
 783   "A list of actions to be performed upon successful sending of a message.")
 784 (defvar message-exit-actions nil
 785   "A list of actions to be performed upon exiting after sending a message.")
 786 (defvar message-kill-actions nil
 787   "A list of actions to be performed before killing a message buffer.")
 788 (defvar message-postpone-actions nil
 789   "A list of actions to be performed after postponing a message.")
 790 (defvar message-original-frame nil)
 791 (defvar message-parameter-alist nil)
 792 (defvar message-startup-parameter-alist nil)
 793
 794 (define-widget 'message-header-lines 'text
 795   "All header lines must be LFD terminated."
 796   :format "%{%t%}:%n%v"
 797   :valid-regexp "^\\'"
 798   :error "All header lines must be newline terminated")
 799
 800 (defcustom message-default-headers ""
 801   "*A string containing header lines to be inserted in outgoing messages.
 802 It is inserted before you edit the message, so you can edit or delete
 803 these lines."
 804   :group 'message-headers
 805   :type 'message-header-lines)
 806
 807 (defcustom message-default-mail-headers ""
 808   "*A string of header lines to be inserted in outgoing mails."
 809   :group 'message-headers
 810   :group 'message-mail
 811   :type 'message-header-lines)
 812
 813 (defcustom message-default-news-headers ""
 814   "*A string of header lines to be inserted in outgoing news articles."
 815   :group 'message-headers
 816   :group 'message-news
 817   :type 'message-header-lines)
 818
 819 ;; Note: could use /usr/ucb/mail instead of sendmail;
 820 ;; options -t, and -v if not interactive.
 821 (defcustom message-mailer-swallows-blank-line
 822   (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
 823                          system-configuration)
 824            (file-readable-p "/etc/sendmail.cf")
 825            (let ((buffer (get-buffer-create " *temp*")))
 826              (unwind-protect
 827                  (save-excursion
 828                    (set-buffer buffer)
 829                    (insert-file-contents "/etc/sendmail.cf")
 830                    (goto-char (point-min))
 831                    (let ((case-fold-search nil))
 832                      (re-search-forward "^OR\\>" nil t)))
 833                (kill-buffer buffer))))
 834       ;; According to RFC822, "The field-name must be composed of printable
 835       ;; ASCII characters (i. e., characters that have decimal values between
 836       ;; 33 and 126, except colon)", i. e., any chars except ctl chars,
 837       ;; space, or colon.
 838       '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
 839   "*Set this non-nil if the system's mailer runs the header and body together.
 840 \(This problem exists on Sunos 4 when sendmail is run in remote mode.)
 841 The value should be an expression to test whether the problem will
 842 actually occur."
 843   :group 'message-sending
 844   :type 'sexp)
 845
 846 ;;; XXX: This symbol is overloaded!  See below.
 847 (defvar message-user-agent nil
 848   "String of the form of PRODUCT/VERSION.  Used for User-Agent header field.")
 849
 850 (static-when (boundp 'MULE)
 851   (require 'reporter));; `define-mail-user-agent' is here.
 852
 853 ;;;###autoload
 854 (define-mail-user-agent 'message-user-agent
 855   'message-mail 'message-send-and-exit
 856   'message-kill-buffer 'message-send-hook)
 857
 858 (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
 859   "If non-nil, delete the deletable headers before feeding to mh.")
 860
 861 (defvar message-send-method-alist
 862   '((news message-news-p message-send-via-news)
 863     (mail message-mail-p message-send-via-mail))
 864   "Alist of ways to send outgoing messages.
 865 Each element has the form
 866
 867   \(TYPE PREDICATE FUNCTION)
 868
 869 where TYPE is a symbol that names the method; PREDICATE is a function
 870 called without any parameters to determine whether the message is
 871 a message of type TYPE; and FUNCTION is a function to be called if
 872 PREDICATE returns non-nil.  FUNCTION is called with one parameter --
 873 the prefix.")
 874
 875 (defcustom message-mail-alias-type 'abbrev
 876   "*What alias expansion type to use in Message buffers.
 877 The default is `abbrev', which uses mailabbrev.  nil switches
 878 mail aliases off."
 879   :group 'message
 880   :link '(custom-manual "(message)Mail Aliases")
 881   :type '(choice (const :tag "Use Mailabbrev" abbrev)
 882                  (const :tag "No expansion" nil)))
 883
 884 (defcustom message-auto-save-directory
 885   (file-name-as-directory (nnheader-concat message-directory "drafts"))
 886   "*Directory where Message auto-saves buffers if Gnus isn't running.
 887 If nil, Message won't auto-save."
 888   :group 'message-buffers
 889   :type '(choice directory (const :tag "Don't auto-save" nil)))
 890
 891 (defcustom message-buffer-naming-style 'unique
 892   "*The way new message buffers are named.
 893 Valid valued are `unique' and `unsent'."
 894   :version "21.1"
 895   :group 'message-buffers
 896   :type '(choice (const :tag "unique" unique)
 897                  (const :tag "unsent" unsent)))
 898
 899 (defcustom message-default-charset
 900   (and (featurep 'xemacs) (not (featurep 'mule)) 'iso-8859-1)
 901   "Default charset used in non-MULE XEmacsen."
 902   :version "21.1"
 903   :group 'message
 904   :type 'symbol)
 905
 906 (defcustom message-dont-reply-to-names
 907   (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
 908   "*A regexp specifying addresses to prune when doing wide replies.
 909 A value of nil means exclude your own user name only."
 910   :version "21.1"
 911   :group 'message
 912   :type '(choice (const :tag "Yourself" nil)
 913                  regexp))
 914
 915 (defvar message-shoot-gnksa-feet nil
 916   "*A list of GNKSA feet you are allowed to shoot.
 917 Gnus gives you all the opportunity you could possibly want for
 918 shooting yourself in the foot.  Also, Gnus allows you to shoot the
 919 feet of Good Net-Keeping Seal of Approval. The following are foot
 920 candidates:
 921 `empty-article'     Allow you to post an empty article;
 922 `quoted-text-only'  Allow you to post quoted text only;
 923 `multiple-copies'   Allow you to post multiple copies.")
 924 ;; `cancel-messages'   Allow you to cancel or supersede others' messages.
 925
 926 (defsubst message-gnksa-enable-p (feature)
 927   (or (not (listp message-shoot-gnksa-feet))
 928       (memq feature message-shoot-gnksa-feet)))
 929
 930 ;;; Internal variables.
 931 ;;; Well, not really internal.
 932
 933 (defvar message-mode-syntax-table
 934   (let ((table (copy-syntax-table text-mode-syntax-table)))
 935     (modify-syntax-entry ?% ". " table)
 936     (modify-syntax-entry ?> ". " table)
 937     (modify-syntax-entry ?< ". " table)
 938     table)
 939   "Syntax table used while in Message mode.")
 940
 941 (defvar message-mode-abbrev-table text-mode-abbrev-table
 942   "Abbrev table used in Message mode buffers.
 943 Defaults to `text-mode-abbrev-table'.")
 944
 945 (defface message-header-to-face
 946   '((((class color)
 947       (background dark))
 948      (:foreground "green2" :bold t))
 949     (((class color)
 950       (background light))
 951      (:foreground "MidnightBlue" :bold t))
 952     (t
 953      (:bold t :italic t)))
 954   "Face used for displaying From headers."
 955   :group 'message-faces)
 956
 957 (defface message-header-cc-face
 958   '((((class color)
 959       (background dark))
 960      (:foreground "green4" :bold t))
 961     (((class color)
 962       (background light))
 963      (:foreground "MidnightBlue"))
 964     (t
 965      (:bold t)))
 966   "Face used for displaying Cc headers."
 967   :group 'message-faces)
 968
 969 (defface message-header-subject-face
 970   '((((class color)
 971       (background dark))
 972      (:foreground "green3"))
 973     (((class color)
 974       (background light))
 975      (:foreground "navy blue" :bold t))
 976     (t
 977      (:bold t)))
 978   "Face used for displaying subject headers."
 979   :group 'message-faces)
 980
 981 (defface message-header-newsgroups-face
 982   '((((class color)
 983       (background dark))
 984      (:foreground "yellow" :bold t :italic t))
 985     (((class color)
 986       (background light))
 987      (:foreground "blue4" :bold t :italic t))
 988     (t
 989      (:bold t :italic t)))
 990   "Face used for displaying newsgroups headers."
 991   :group 'message-faces)
 992
 993 (defface message-header-other-face
 994   '((((class color)
 995       (background dark))
 996      (:foreground "#b00000"))
 997     (((class color)
 998       (background light))
 999      (:foreground "steel blue"))
1000     (t
1001      (:bold t :italic t)))
1002   "Face used for displaying newsgroups headers."
1003   :group 'message-faces)
1004
1005 (defface message-header-name-face
1006   '((((class color)
1007       (background dark))
1008      (:foreground "DarkGreen"))
1009     (((class color)
1010       (background light))
1011      (:foreground "cornflower blue"))
1012     (t
1013      (:bold t)))
1014   "Face used for displaying header names."
1015   :group 'message-faces)
1016
1017 (defface message-header-xheader-face
1018   '((((class color)
1019       (background dark))
1020      (:foreground "blue"))
1021     (((class color)
1022       (background light))
1023      (:foreground "blue"))
1024     (t
1025      (:bold t)))
1026   "Face used for displaying X-Header headers."
1027   :group 'message-faces)
1028
1029 (defface message-separator-face
1030   '((((class color)
1031       (background dark))
1032      (:foreground "blue3"))
1033     (((class color)
1034       (background light))
1035      (:foreground "brown"))
1036     (t
1037      (:bold t)))
1038   "Face used for displaying the separator."
1039   :group 'message-faces)
1040
1041 (defface message-cited-text-face
1042   '((((class color)
1043       (background dark))
1044      (:foreground "red"))
1045     (((class color)
1046       (background light))
1047      (:foreground "red"))
1048     (t
1049      (:bold t)))
1050   "Face used for displaying cited text names."
1051   :group 'message-faces)
1052
1053 (defface message-mml-face
1054   '((((class color)
1055       (background dark))
1056      (:foreground "ForestGreen"))
1057     (((class color)
1058       (background light))
1059      (:foreground "ForestGreen"))
1060     (t
1061      (:bold t)))
1062   "Face used for displaying MML."
1063   :group 'message-faces)
1064
1065 (defvar message-font-lock-fence-open-regexp "[+|]"
1066   "*Regexp that matches fence open string.")
1067
1068 (defvar message-font-lock-fence-close-regexp "|"
1069   "*Regexp that matches fence close string.")
1070
1071 (defvar message-font-lock-fence-open-position nil
1072   "*Cons of SYMBOL of a function or a variable and a number of OFFSET that
1073 indicate the fence open position.  If it is non-nil,
1074 `message-font-lock-fence-open-regexp' is not used for searching for the
1075 fence open position.  If SYMBOL is a function, it is called with one argument
1076 last cursor position and should return the fence open position as a number
1077 or a marker.  If SYMBOL is a variable symbol, the value is examined with
1078 `symbol-value'.  OFFSET is added to the position to compensate the value.
1079 For example, the following combinations of variable symbol and offset value
1080 can be used:
1081
1082 Egg v3: '(egg:*region-start* . -1)
1083 Canna:  '(canna:*region-start* . 0)
1084 ")
1085
1086 (defvar message-font-lock-fence-close-position nil
1087   "*Cons of SYMBOL of a function or a variable and a number of OFFSET that
1088 indicate the fence close position.  If it is non-nil,
1089 `message-font-lock-fence-close-regexp' is not used for searching for the
1090 fence close position.  If SYMBOL is a function, it is called with one argument
1091 last cursor position and should return the fence close position as a number
1092 or a marker.  If SYMBOL is a variable symbol, the value is examined with
1093 `symbol-value'.  OFFSET is added to the position to compensate the value.
1094 For example, the following combinations of variable symbol and offset value
1095 can be used:
1096
1097 Egg v3: '(egg:*region-end* . 0)
1098 Canna:  '(canna:*region-end* . 0)
1099 ")
1100
1101 (defvar message-font-lock-cited-text-regexp
1102   "^[\t ]*\\([^\000- :>|}\177]*\\)[:>|}].*"
1103   "*Regexp that matches cited text.  It should have a grouping for the
1104 citation prefix which is ended at the beginning of citation mark string.")
1105
1106 (defvar message-font-lock-citation-name-max-column 10
1107   "*Maximun number of column for citation name for fontifying.")
1108
1109 (defvar message-font-lock-last-position nil
1110   "Internal buffer local variable to save the last cursor position
1111 before fontifying.")
1112
1113 (eval-after-load "font-lock"
1114   '(defadvice font-lock-after-change-function
1115      (before message-font-lock-save-last-position activate)
1116      "Save last cursor position before fontifying."
1117      (if (eq 'message-mode major-mode)
1118          (setq message-font-lock-last-position (point)))))
1119
1120 (defun message-font-lock-cited-text-matcher (limit)
1121   "Search for a cited text containing `message-font-lock-cited-text-regexp'
1122 forward.  Argument LIMIT bounds the search.  If a cited text is found, it
1123 returns t and sets match data 1 and 2, otherwise it returns nil.  Normally,
1124 match data 2 has zero length, but if the FENCE (for input method) is detected
1125 in matched text, result is divided into match data 1 and 2 across the FENCE.
1126 See also the documentations for the following variables:
1127  `message-font-lock-fence-open-regexp'
1128  `message-font-lock-fence-close-regexp'
1129  `message-font-lock-fence-open-position'
1130  `message-font-lock-fence-close-position'
1131 "
1132   (prog1
1133       (when (re-search-forward message-font-lock-cited-text-regexp limit t)
1134         (let* ((start0 (match-beginning 0))
1135                (end0 (match-end 0))
1136                (cite-mark (match-end 1))
1137                (should-fontify
1138                 (progn
1139                   (goto-char cite-mark)
1140                   (<= (current-column)
1141                       message-font-lock-citation-name-max-column)))
1142                end1 start2)
1143           (and
1144            should-fontify
1145            message-font-lock-last-position
1146            (>= message-font-lock-last-position start0)
1147            (<= message-font-lock-last-position end0)
1148            (cond
1149             (message-font-lock-fence-open-position
1150              (let* ((symbol (car message-font-lock-fence-open-position))
1151                     (open
1152                      (cond ((functionp symbol)
1153                             (funcall symbol message-font-lock-last-position))
1154                            ((and (symbolp symbol)
1155                                  (boundp symbol))
1156                             (symbol-value symbol)))))
1157                (when (markerp open)
1158                  (setq open (marker-position open)))
1159                (and (numberp open)
1160                     (setq open
1161                           (+ open
1162                              (cdr message-font-lock-fence-open-position)))
1163                     (>= message-font-lock-last-position open)
1164                     (goto-char open)
1165                     (or (not message-font-lock-fence-open-regexp)
1166                         (looking-at message-font-lock-fence-open-regexp))
1167                     (setq end1 open))))
1168             (message-font-lock-fence-open-regexp
1169              (goto-char message-font-lock-last-position)
1170              (when (re-search-backward
1171                     message-font-lock-fence-open-regexp start0 t)
1172                (setq end1 (match-beginning 0)))))
1173            (setq should-fontify
1174                  (and message-font-lock-fence-open-position
1175                       (not (eq cite-mark end1))))
1176            (cond
1177             (message-font-lock-fence-close-position
1178              (let* ((symbol (car message-font-lock-fence-close-position))
1179                     (close
1180                      (cond ((functionp symbol)
1181                             (funcall symbol message-font-lock-last-position))
1182                            ((and (symbolp symbol)
1183                                  (boundp symbol))
1184                             (symbol-value symbol)))))
1185                (when (markerp close)
1186                  (setq close (marker-position close)))
1187                (and (numberp close)
1188                     (setq close
1189                           (+ close
1190                              (cdr message-font-lock-fence-close-position)))
1191                     (<= message-font-lock-last-position close)
1192                     (setq start2 close))))
1193             (message-font-lock-fence-close-regexp
1194              (goto-char message-font-lock-last-position)
1195              (when (looking-at message-font-lock-fence-close-regexp)
1196                (setq start2 (match-end 0)))))
1197            (setq should-fontify
1198                  (and (not (and (not message-font-lock-fence-open-position)
1199                                 (eq cite-mark end1)))
1200                       (not (eq cite-mark start2)))))
1201           (goto-char end0)
1202           (when should-fontify
1203             (if start2
1204                 (store-match-data (list start0 end0 start0 end1 start2 end0))
1205               (store-match-data (list start0 end0 start0 end0 end0 end0)))
1206             t)))
1207     (setq message-font-lock-last-position nil)))
1208
1209 (defvar message-font-lock-keywords-1
1210   (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
1211     `((,(concat "^\\([Tt]o:\\)" content)
1212        (1 'message-header-name-face)
1213        (2 'message-header-to-face nil t))
1214       (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
1215                 "[Mm]ail-[Cc]opies-[Tt]o:\\|"
1216                 "[Mm]ail-[Rr]eply-[Tt]o:\\|"
1217                 "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content)
1218        (1 'message-header-name-face)
1219        (2 'message-header-cc-face nil t))
1220       (,(concat "^\\([Ss]ubject:\\)" content)
1221        (1 'message-header-name-face)
1222        (2 'message-header-subject-face nil t))
1223       (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
1224        (1 'message-header-name-face)
1225        (2 'message-header-newsgroups-face nil t))
1226       (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
1227        (1 'message-header-name-face)
1228        (2 'message-header-other-face nil t))
1229       (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
1230        (1 'message-header-name-face)
1231        (2 'message-header-name-face))
1232       ,@(if (and mail-header-separator
1233                  (not (equal mail-header-separator "")))
1234             `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1235                1 'message-separator-face))
1236           nil))))
1237
1238 (defvar message-font-lock-keywords-2
1239   (append message-font-lock-keywords-1
1240           `((message-font-lock-cited-text-matcher
1241              (1 'message-cited-text-face)
1242              (2 'message-cited-text-face))
1243             (,(concat "^\\(" message-cite-prefix-regexp "\\).*")
1244              (0 'message-cited-text-face))
1245             ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>"
1246              (0 'message-mml-face)))))
1247
1248 (defvar message-font-lock-keywords message-font-lock-keywords-2
1249   "Additional expressions to highlight in Message mode.")
1250
1251 ;; XEmacs does it like this.  For Emacs, we have to set the
1252 ;; `font-lock-defaults' buffer-local variable.
1253 (put 'message-mode 'font-lock-defaults
1254      '((message-font-lock-keywords
1255         message-font-lock-keywords-1
1256         message-font-lock-keywords-2)
1257        nil nil nil nil
1258        (font-lock-mark-block-function . mark-paragraph)))
1259
1260 (defvar message-face-alist
1261   '((bold . bold-region)
1262     (underline . underline-region)
1263     (default . (lambda (b e)
1264                  (unbold-region b e)
1265                  (ununderline-region b e))))
1266   "Alist of mail and news faces for facemenu.
1267 The cdr of ech entry is a function for applying the face to a region.")
1268
1269 (defcustom message-send-hook nil
1270   "Hook run before sending messages."
1271   :group 'message-various
1272   :options '(ispell-message)
1273   :type 'hook)
1274
1275 (defcustom message-send-mail-hook nil
1276   "Hook run before sending mail messages."
1277   :group 'message-various
1278   :type 'hook)
1279
1280 (defcustom message-send-news-hook nil
1281   "Hook run before sending news messages."
1282   :group 'message-various
1283   :type 'hook)
1284
1285 (defcustom message-sent-hook nil
1286   "Hook run after sending messages."
1287   :group 'message-various
1288   :type 'hook)
1289
1290 (defcustom message-use-multi-frames nil
1291   "Make new frame when sending messages."
1292   :group 'message-frames
1293   :type 'boolean)
1294
1295 (defcustom message-delete-frame-on-exit nil
1296   "Delete frame after sending messages."
1297   :group 'message-frames
1298   :type '(choice (const :tag "off" nil)
1299                  (const :tag "always" t)
1300                  (const :tag "ask" ask)))
1301
1302 (defvar message-draft-coding-system
1303   (cond
1304    ((boundp 'MULE) '*junet*)
1305    ((not (fboundp 'find-coding-system)) nil)
1306    ((find-coding-system 'emacs-mule)
1307     (if (memq system-type '(windows-nt ms-dos ms-windows))
1308         'emacs-mule-dos 'emacs-mule))
1309    ((find-coding-system 'escape-quoted) 'escape-quoted)
1310    ((find-coding-system 'no-conversion) 'no-conversion)
1311    (t nil))
1312   "Coding system to compose mail.")
1313
1314 (defcustom message-send-mail-partially-limit 1000000
1315   "The limitation of messages sent as message/partial.
1316 The lower bound of message size in characters, beyond which the message
1317 should be sent in several parts.  If it is nil, the size is unlimited."
1318   :version "21.1"
1319   :group 'message-buffers
1320   :type '(choice (const :tag "unlimited" nil)
1321                  (integer 1000000)))
1322
1323 (defcustom message-alternative-emails nil
1324   "A regexp to match the alternative email addresses.
1325 The first matched address (not primary one) is used in the From field."
1326   :group 'message-headers
1327   :type '(choice (const :tag "Always use primary" nil)
1328                  regexp))
1329
1330 (defcustom message-mail-user-agent nil
1331   "Like `mail-user-agent'.
1332 Except if it is nil, use Gnus native MUA; if it is t, use
1333 `mail-user-agent'."
1334   :type '(radio (const :tag "Gnus native"
1335                        :format "%t\n"
1336                        nil)
1337                 (const :tag "`mail-user-agent'"
1338                        :format "%t\n"
1339                        t)
1340                 (function-item :tag "Default Emacs mail"
1341                                :format "%t\n"
1342                                sendmail-user-agent)
1343                 (function-item :tag "Emacs interface to MH"
1344                                :format "%t\n"
1345                                mh-e-user-agent)
1346                 (function :tag "Other"))
1347   :version "21.1"
1348   :group 'message)
1349
1350 (defcustom message-wide-reply-confirm-recipients nil
1351   "Whether to confirm a wide reply to multiple email recipients.
1352 If this variable is nil, don't ask whether to reply to all recipients.
1353 If this variable is non-nil, pose the question \"Reply to all
1354 recipients?\" before a wide reply to multiple recipients.  If the user
1355 answers yes, reply to all recipients as usual.  If the user answers
1356 no, only reply back to the author."
1357   :group 'message-headers
1358   :type 'boolean)
1359
1360 ;;; Internal variables.
1361
1362 (defvar message-sending-message "Sending...")
1363 (defvar message-buffer-list nil)
1364 (defvar message-this-is-news nil)
1365 (defvar message-this-is-mail nil)
1366 (defvar message-draft-article nil)
1367 (defvar message-mime-part nil)
1368 (defvar message-posting-charset nil)
1369
1370 ;; Byte-compiler warning
1371 (eval-when-compile
1372   (defvar gnus-active-hashtb)
1373   (defvar gnus-read-active-file))
1374
1375 ;;; Regexp matching the delimiter of messages in UNIX mail format
1376 ;;; (UNIX From lines), minus the initial ^.  It should be a copy
1377 ;;; of rmail.el's rmail-unix-mail-delimiter.
1378 (defvar message-unix-mail-delimiter
1379   (let ((time-zone-regexp
1380          (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
1381                  "\\|[-+]?[0-9][0-9][0-9][0-9]"
1382                  "\\|"
1383                  "\\) *")))
1384     (concat
1385      "From "
1386
1387      ;; Many things can happen to an RFC 822 mailbox before it is put into
1388      ;; a `From' line.  The leading phrase can be stripped, e.g.
1389      ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'.  The <> can be stripped, e.g.
1390      ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'.  Everything starting with a CRLF
1391      ;; can be removed, e.g.
1392      ;;         From: joe@y.z (Joe      K
1393      ;;                 User)
1394      ;; can yield `From joe@y.z (Joe    K Fri Mar 22 08:11:15 1996', and
1395      ;;         From: Joe User
1396      ;;                 <joe@y.z>
1397      ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.
1398      ;; The mailbox can be removed or be replaced by white space, e.g.
1399      ;;         From: "Joe User"{space}{tab}
1400      ;;                 <joe@y.z>
1401      ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996',
1402      ;; where {space} and {tab} represent the Ascii space and tab characters.
1403      ;; We want to match the results of any of these manglings.
1404      ;; The following regexp rejects names whose first characters are
1405      ;; obviously bogus, but after that anything goes.
1406      "\\([^\0-\b\n-\r\^?].*\\)? "
1407
1408      ;; The time the message was sent.
1409      "\\([^\0-\r \^?]+\\) +"            ; day of the week
1410      "\\([^\0-\r \^?]+\\) +"            ; month
1411      "\\([0-3]?[0-9]\\) +"              ; day of month
1412      "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
1413
1414      ;; Perhaps a time zone, specified by an abbreviation, or by a
1415      ;; numeric offset.
1416      time-zone-regexp
1417
1418      ;; The year.
1419      " \\([0-9][0-9]+\\) *"
1420
1421      ;; On some systems the time zone can appear after the year, too.
1422      time-zone-regexp
1423
1424      ;; Old uucp cruft.
1425      "\\(remote from .*\\)?"
1426
1427      "\n"))
1428   "Regexp matching the delimiter of messages in UNIX mail format.")
1429
1430 (defvar message-unsent-separator
1431   (concat "^ *---+ +Unsent message follows +---+ *$\\|"
1432           "^ *---+ +Returned message +---+ *$\\|"
1433           "^Start of returned message$\\|"
1434           "^ *---+ +Original message +---+ *$\\|"
1435           "^ *--+ +begin message +--+ *$\\|"
1436           "^ *---+ +Original message follows +---+ *$\\|"
1437           "^ *---+ +Undelivered message follows +---+ *$\\|"
1438           "^|? *---+ +Message text follows: +---+ *|?$")
1439   "A regexp that matches the separator before the text of a failed message.")
1440
1441 (defvar message-header-format-alist
1442   `((Newsgroups)
1443     (To . message-fill-address)
1444     (Cc . message-fill-address)
1445     (Subject)
1446     (In-Reply-To)
1447     (Fcc)
1448     (Bcc)
1449     (Date)
1450     (Organization)
1451     (Distribution)
1452     (Lines)
1453     (Expires)
1454     (Message-ID)
1455     (References . message-shorten-references)
1456     (User-Agent))
1457   "Alist used for formatting headers.")
1458
1459 (defvar message-options nil
1460   "Some saved answers when sending message.")
1461
1462 (eval-and-compile
1463   (autoload 'message-setup-toolbar "messagexmas")
1464   (autoload 'mh-new-draft-name "mh-comp")
1465   (autoload 'mh-send-letter "mh-comp")
1466   (autoload 'gnus-point-at-eol "gnus-util")
1467   (autoload 'gnus-point-at-bol "gnus-util")
1468   (autoload 'gnus-output-to-rmail "gnus-util")
1469   (autoload 'gnus-output-to-mail "gnus-util")
1470   (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")
1471   (autoload 'nndraft-request-associate-buffer "nndraft")
1472   (autoload 'nndraft-request-expire-articles "nndraft")
1473   (autoload 'gnus-open-server "gnus-int")
1474   (autoload 'gnus-request-post "gnus-int")
1475   (autoload 'gnus-copy-article-buffer "gnus-msg")
1476   (autoload 'gnus-alive-p "gnus-util")
1477   (autoload 'gnus-server-string "gnus")
1478   (autoload 'gnus-group-name-charset "gnus-group")
1479   (autoload 'rmail-output "rmailout")
1480   (autoload 'mu-cite-original "mu-cite"))
1481
1482 \f
1483
1484 ;;;
1485 ;;; Utility functions.
1486 ;;;
1487 (defun message-eval-parameter (parameter)
1488   (condition-case ()
1489       (if (symbolp parameter)
1490           (if (functionp parameter)
1491               (funcall parameter)
1492             (eval parameter))
1493         parameter)
1494     (error nil)))
1495
1496 (defsubst message-get-parameter (key &optional alist)
1497   (unless alist
1498     (setq alist message-parameter-alist))
1499   (cdr (assq key alist)))
1500
1501 (defmacro message-get-parameter-with-eval (key &optional alist)
1502   `(message-eval-parameter (message-get-parameter ,key ,alist)))
1503
1504 (defmacro message-y-or-n-p (question show &rest text)
1505   "Ask QUESTION, displaying remaining args in a temporary buffer if SHOW."
1506   `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
1507
1508 (defmacro message-delete-line (&optional n)
1509   "Delete the current line (and the next N lines)."
1510   `(delete-region (progn (beginning-of-line) (point))
1511                   (progn (forward-line ,(or n 1)) (point))))
1512
1513 (defun message-unquote-tokens (elems)
1514   "Remove double quotes (\") from strings in list ELEMS."
1515   (mapcar (lambda (item)
1516             (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)
1517               (setq item (concat (match-string 1 item)
1518                                  (match-string 2 item))))
1519             item)
1520           elems))
1521
1522 (defun message-tokenize-header (header &optional separator)
1523   "Split HEADER into a list of header elements.
1524 SEPARATOR is a string of characters to be used as separators.  \",\"
1525 is used by default."
1526   (if (not header)
1527       nil
1528     (let ((regexp (format "[%s]+" (or separator ",")))
1529           (beg 1)
1530           (first t)
1531           quoted elems paren)
1532       (save-excursion
1533         (message-set-work-buffer)
1534         (insert header)
1535         (goto-char (point-min))
1536         (while (not (eobp))
1537           (if first
1538               (setq first nil)
1539             (forward-char 1))
1540           (cond ((and (> (point) beg)
1541                       (or (eobp)
1542                           (and (looking-at regexp)
1543                                (not quoted)
1544                                (not paren))))
1545                  (push (buffer-substring beg (point)) elems)
1546                  (setq beg (match-end 0)))
1547                 ((eq (char-after) ?\")
1548                  (setq quoted (not quoted)))
1549                 ((and (eq (char-after) ?\()
1550                       (not quoted))
1551                  (setq paren t))
1552                 ((and (eq (char-after) ?\))
1553                       (not quoted))
1554                  (setq paren nil))))
1555         (nreverse elems)))))
1556
1557 (defun message-mail-file-mbox-p (file)
1558   "Say whether FILE looks like a Unix mbox file."
1559   (when (and (file-exists-p file)
1560              (file-readable-p file)
1561              (file-regular-p file))
1562     (with-temp-buffer
1563       (nnheader-insert-file-contents file)
1564       (goto-char (point-min))
1565       (looking-at message-unix-mail-delimiter))))
1566
1567 (defun message-fetch-field (header &optional not-all)
1568   "The same as `mail-fetch-field', only remove all newlines."
1569   (let* ((inhibit-point-motion-hooks t)
1570          (case-fold-search t)
1571          (value (mail-fetch-field header nil (not not-all))))
1572     (when value
1573       (while (string-match "\n[\t ]+" value)
1574         (setq value (replace-match " " t t value)))
1575       (set-text-properties 0 (length value) nil value)
1576       value)))
1577
1578 (defun message-narrow-to-field ()
1579   "Narrow the buffer to the header on the current line."
1580   (beginning-of-line)
1581   (narrow-to-region
1582    (point)
1583    (progn
1584      (forward-line 1)
1585      (if (re-search-forward "^[^ \n\t]" nil t)
1586          (progn
1587            (beginning-of-line)
1588            (point))
1589        (point-max))))
1590   (goto-char (point-min)))
1591
1592 (defun message-add-header (&rest headers)
1593   "Add the HEADERS to the message header, skipping those already present."
1594   (while headers
1595     (let (hclean)
1596       (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers))
1597         (error "Invalid header `%s'" (car headers)))
1598       (setq hclean (match-string 1 (car headers)))
1599       (save-restriction
1600         (message-narrow-to-headers)
1601         (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
1602           (goto-char (point-max))
1603           (if (string-match "\n$" (car headers))
1604               (insert (car headers))
1605             (insert (car headers) ?\n)))))
1606     (setq headers (cdr headers))))
1607
1608
1609 (defun message-fetch-reply-field (header)
1610   "Fetch field HEADER from the message we're replying to."
1611   (let ((buffer (message-eval-parameter message-reply-buffer)))
1612     (when (and buffer
1613                (buffer-name buffer))
1614       (save-excursion
1615         (set-buffer buffer)
1616         (message-fetch-field header)))))
1617
1618 (defun message-set-work-buffer ()
1619   (if (get-buffer " *message work*")
1620       (progn
1621         (set-buffer " *message work*")
1622         (erase-buffer))
1623     (set-buffer (get-buffer-create " *message work*"))
1624     (kill-all-local-variables)))
1625
1626 (defun message-functionp (form)
1627   "Return non-nil if FORM is funcallable."
1628   (or (and (symbolp form) (fboundp form))
1629       (and (listp form) (eq (car form) 'lambda))
1630       (byte-code-function-p form)))
1631
1632 (defun message-strip-list-identifiers (subject)
1633   "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT."
1634   (require 'gnus-sum)                   ; for gnus-list-identifiers
1635   (let ((regexp (if (stringp gnus-list-identifiers)
1636                     gnus-list-identifiers
1637                   (mapconcat 'identity gnus-list-identifiers " *\\|"))))
1638     (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
1639                               " *\\)\\)+\\(Re: +\\)?\\)") subject)
1640         (concat (substring subject 0 (match-beginning 1))
1641                 (or (match-string 3 subject)
1642                     (match-string 5 subject))
1643                 (substring subject
1644                            (match-end 1)))
1645       subject)))
1646
1647 (defun message-strip-subject-re (subject)
1648   "Remove \"Re:\" from subject lines in string SUBJECT."
1649   (if (string-match message-subject-re-regexp subject)
1650       (substring subject (match-end 0))
1651     subject))
1652
1653 (defun message-remove-header (header &optional is-regexp first reverse)
1654   "Remove HEADER in the narrowed buffer.
1655 If IS-REGEXP, HEADER is a regular expression.
1656 If FIRST, only remove the first instance of the header.
1657 Return the number of headers removed."
1658   (goto-char (point-min))
1659   (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":")))
1660         (number 0)
1661         (case-fold-search t)
1662         last)
1663     (while (and (not (eobp))
1664                 (not last))
1665       (if (if reverse
1666               (not (looking-at regexp))
1667             (looking-at regexp))
1668           (progn
1669             (incf number)
1670             (when first
1671               (setq last t))
1672             (delete-region
1673              (point)
1674              ;; There might be a continuation header, so we have to search
1675              ;; until we find a new non-continuation line.
1676              (progn
1677                (forward-line 1)
1678                (if (re-search-forward "^[^ \t]" nil t)
1679                    (goto-char (match-beginning 0))
1680                  (point-max)))))
1681         (forward-line 1)
1682         (if (re-search-forward "^[^ \t]" nil t)
1683             (goto-char (match-beginning 0))
1684           (goto-char (point-max)))))
1685     number))
1686
1687 (defun message-remove-first-header (header)
1688   "Remove the first instance of HEADER if there is more than one."
1689   (let ((count 0)
1690         (regexp (concat "^" (regexp-quote header) ":")))
1691     (save-excursion
1692       (goto-char (point-min))
1693       (while (re-search-forward regexp nil t)
1694         (incf count)))
1695     (while (> count 1)
1696       (message-remove-header header nil t)
1697       (decf count))))
1698
1699 (defun message-narrow-to-headers ()
1700   "Narrow the buffer to the head of the message."
1701   (widen)
1702   (narrow-to-region
1703    (goto-char (point-min))
1704    (if (re-search-forward
1705         (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1706        (match-beginning 0)
1707      (point-max)))
1708   (goto-char (point-min)))
1709
1710 (defun message-narrow-to-head-1 ()
1711   "Like `message-narrow-to-head'.  Don't widen."
1712   (narrow-to-region
1713    (goto-char (point-min))
1714    (if (search-forward "\n\n" nil 1)
1715        (1- (point))
1716      (point-max)))
1717   (goto-char (point-min)))
1718
1719 (defun message-narrow-to-head ()
1720   "Narrow the buffer to the head of the message.
1721 Point is left at the beginning of the narrowed-to region."
1722   (widen)
1723   (message-narrow-to-head-1))
1724
1725 (defun message-narrow-to-headers-or-head ()
1726   "Narrow the buffer to the head of the message."
1727   (widen)
1728   (narrow-to-region
1729    (goto-char (point-min))
1730    (cond
1731     ((re-search-forward
1732       (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1733      (match-beginning 0))
1734     ((search-forward "\n\n" nil t)
1735      (1- (point)))
1736     (t
1737      (point-max))))
1738   (goto-char (point-min)))
1739
1740 (defun message-news-p ()
1741   "Say whether the current buffer contains a news message."
1742   (and (not message-this-is-mail)
1743        (or message-this-is-news
1744            (save-excursion
1745              (save-restriction
1746                (message-narrow-to-headers)
1747                (and (message-fetch-field "newsgroups")
1748                     (not (message-fetch-field "posted-to"))))))))
1749
1750 (defun message-mail-p ()
1751   "Say whether the current buffer contains a mail message."
1752   (and (not message-this-is-news)
1753        (or message-this-is-mail
1754            (save-excursion
1755              (save-restriction
1756                (message-narrow-to-headers)
1757                (or (message-fetch-field "to")
1758                    (message-fetch-field "cc")
1759                    (message-fetch-field "bcc")))))))
1760
1761 (defun message-next-header ()
1762   "Go to the beginning of the next header."
1763   (beginning-of-line)
1764   (or (eobp) (forward-char 1))
1765   (not (if (re-search-forward "^[^ \t]" nil t)
1766            (beginning-of-line)
1767          (goto-char (point-max)))))
1768
1769 (defun message-sort-headers-1 ()
1770   "Sort the buffer as headers using `message-rank' text props."
1771   (goto-char (point-min))
1772   (require 'sort)
1773   (sort-subr
1774    nil 'message-next-header
1775    (lambda ()
1776      (message-next-header)
1777      (unless (bobp)
1778        (forward-char -1)))
1779    (lambda ()
1780      (or (get-text-property (point) 'message-rank)
1781          10000))))
1782
1783 (defun message-sort-headers ()
1784   "Sort the headers of the current message according to `message-header-format-alist'."
1785   (interactive)
1786   (save-excursion
1787     (save-restriction
1788       (let ((max (1+ (length message-header-format-alist)))
1789             rank)
1790         (message-narrow-to-headers)
1791         (while (re-search-forward "^[^ \n]+:" nil t)
1792           (put-text-property
1793            (match-beginning 0) (1+ (match-beginning 0))
1794            'message-rank
1795            (if (setq rank (length (memq (assq (intern (buffer-substring
1796                                                        (match-beginning 0)
1797                                                        (1- (match-end 0))))
1798                                               message-header-format-alist)
1799                                         message-header-format-alist)))
1800                (- max rank)
1801              (1+ max)))))
1802       (message-sort-headers-1))))
1803
1804 \f
1805
1806 ;;;
1807 ;;; Message mode
1808 ;;;
1809
1810 ;;; Set up keymap.
1811
1812 (defvar message-mode-map nil)
1813
1814 (unless message-mode-map
1815   (setq message-mode-map (make-keymap))
1816   (set-keymap-parent message-mode-map text-mode-map)
1817   (define-key message-mode-map "\C-c?" 'describe-mode)
1818
1819   (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
1820   (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
1821   (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
1822   (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
1823   (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
1824   ;; (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
1825   (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-mail-reply-to)
1826   (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
1827   (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
1828   (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
1829   (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
1830   (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
1831   (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
1832   (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
1833   (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
1834   (define-key message-mode-map "\C-c\C-fc" 'message-goto-mail-copies-to)
1835
1836   (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
1837   (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
1838
1839   (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
1840   (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)
1841   (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
1842   (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
1843   (define-key message-mode-map "\C-c\M-h" 'message-insert-headers)
1844   (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
1845   (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
1846   (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
1847
1848   (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
1849   (define-key message-mode-map "\C-c\C-s" 'message-send)
1850   (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
1851   (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
1852
1853   (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
1854   (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
1855   (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
1856   (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
1857   ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
1858
1859   (define-key message-mode-map "\t" 'message-tab)
1860   (define-key message-mode-map "\M-;" 'comment-region)
1861
1862   (define-key message-mode-map "\C-x\C-s" 'message-save-drafts)
1863   (define-key message-mode-map "\C-xk" 'message-mimic-kill-buffer))
1864
1865 (easy-menu-define
1866  message-mode-menu message-mode-map "Message Menu."
1867  `("Message"
1868    ["Sort Headers" message-sort-headers t]
1869    ["Yank Original" message-yank-original t]
1870    ["Fill Yanked Message" message-fill-yanked-message t]
1871    ["Insert Signature" message-insert-signature t]
1872    ["Caesar (rot13) Message" message-caesar-buffer-body t]
1873    ["Caesar (rot13) Region" message-caesar-region (mark t)]
1874    ["Elide Region" message-elide-region (mark t)]
1875    ["Delete Outside Region" message-delete-not-region (mark t)]
1876    ["Kill To Signature" message-kill-to-signature t]
1877    ["Newline and Reformat" message-newline-and-reformat t]
1878    ["Rename buffer" message-rename-buffer t]
1879    ["Spellcheck" ispell-message
1880     ,@(if (featurep 'xemacs) '(t)
1881         '(:help "Spellcheck this message"))]
1882    ["Attach file as MIME" mime-edit-insert-file
1883     ,@(if (featurep 'xemacs) '(t)
1884         '(:help "Attach a file at point"))]
1885    "----"
1886    ["Send Message" message-send-and-exit
1887     ,@(if (featurep 'xemacs) '(t)
1888         '(:help "Send this message"))]
1889    ["Abort Message" message-dont-send
1890     ,@(if (featurep 'xemacs) '(t)
1891         '(:help "File this draft message and exit"))]
1892    ["Kill Message" message-kill-buffer
1893     ,@(if (featurep 'xemacs) '(t)
1894         '(:help "Delete this message without sending"))]))
1895
1896 (easy-menu-define
1897  message-mode-field-menu message-mode-map ""
1898  '("Field"
1899    ["Fetch To" message-insert-to t]
1900    ["Fetch Newsgroups" message-insert-newsgroups t]
1901    "----"
1902    ["To" message-goto-to t]
1903    ["Subject" message-goto-subject t]
1904    ["Cc" message-goto-cc t]
1905    ["Reply-To" message-goto-reply-to t]
1906    ["Mail-Reply-To" message-goto-mail-reply-to t]
1907    ["Mail-Followup-To" message-goto-mail-followup-to t]
1908    ["Mail-Copies-To" message-goto-mail-copies-to t]
1909    ["Summary" message-goto-summary t]
1910    ["Keywords" message-goto-keywords t]
1911    ["Newsgroups" message-goto-newsgroups t]
1912    ["Followup-To" message-goto-followup-to t]
1913    ["Distribution" message-goto-distribution t]
1914    ["Body" message-goto-body t]
1915    ["Signature" message-goto-signature t]))
1916
1917 (defvar message-tool-bar-map nil)
1918
1919 (eval-when-compile
1920   (defvar facemenu-add-face-function)
1921   (defvar facemenu-remove-face-function))
1922
1923 ;;;###autoload
1924 (defun message-mode ()
1925   "Major mode for editing mail and news to be sent.
1926 Like Text Mode but with these additional commands:\\<message-mode-map>
1927 C-c C-s  `message-send' (send the message)  C-c C-c  `message-send-and-exit'
1928 C-c C-d  Postpone sending the message       C-c C-k  Kill the message
1929 C-c C-f  move to a header field (and create it if there isn't):
1930          C-c C-f C-t  move to To        C-c C-f C-s  move to Subject
1931          C-c C-f C-c  move to Cc        C-c C-f C-b  move to Bcc
1932          C-c C-f C-w  move to Fcc       C-c C-f C-r  move to Reply-To
1933          C-c C-f C-u  move to Summary   C-c C-f C-n  move to Newsgroups
1934          C-c C-f C-k  move to Keywords  C-c C-f C-d  move to Distribution
1935          C-c C-f C-m  move to Mail-Followup-To
1936          C-c C-f C-f  move to Followup-To
1937 C-c C-t  `message-insert-to' (add a To header to a news followup)
1938 C-c C-n  `message-insert-newsgroups' (add a Newsgroup header to a news reply)
1939 C-c C-b  `message-goto-body' (move to beginning of message text).
1940 C-c C-i  `message-goto-signature' (move to the beginning of the signature).
1941 C-c C-w  `message-insert-signature' (insert `message-signature-file' file).
1942 C-c C-y  `message-yank-original' (insert current message, if any).
1943 C-c C-q  `message-fill-yanked-message' (fill what was yanked).
1944 C-c C-e  `message-elide-region' (elide the text between point and mark).
1945 C-c C-v  `message-delete-not-region' (remove the text outside the region).
1946 C-c C-z  `message-kill-to-signature' (kill the text up to the signature).
1947 C-c C-r  `message-caesar-buffer-body' (rot13 the message body).
1948 M-RET    `message-newline-and-reformat' (break the line and reformat)."
1949   (interactive)
1950   (kill-all-local-variables)
1951   (set (make-local-variable 'message-reply-buffer) nil)
1952   (make-local-variable 'message-send-actions)
1953   (make-local-variable 'message-exit-actions)
1954   (make-local-variable 'message-kill-actions)
1955   (make-local-variable 'message-postpone-actions)
1956   (make-local-variable 'message-draft-article)
1957   (make-local-hook 'kill-buffer-hook)
1958   (set-syntax-table message-mode-syntax-table)
1959   (use-local-map message-mode-map)
1960   (setq local-abbrev-table message-mode-abbrev-table)
1961   (setq major-mode 'message-mode)
1962   (setq mode-name "Message")
1963   (setq buffer-offer-save t)
1964   (make-local-variable 'facemenu-add-face-function)
1965   (make-local-variable 'facemenu-remove-face-function)
1966   (setq facemenu-add-face-function
1967         (lambda (face end)
1968           (let ((face-fun (cdr (assq face message-face-alist))))
1969             (if face-fun
1970                 (funcall face-fun (point) end)
1971               (error "Face %s not configured for %s mode" face mode-name)))
1972           "")
1973         facemenu-remove-face-function t)
1974   (make-local-variable 'message-reply-headers)
1975   (setq message-reply-headers nil)
1976   (make-local-variable 'message-user-agent)
1977   (make-local-variable 'message-post-method)
1978   (set (make-local-variable 'message-sent-message-via) nil)
1979   (set (make-local-variable 'message-checksum) nil)
1980   (make-local-variable 'message-parameter-alist)
1981   (setq message-parameter-alist
1982         (copy-sequence message-startup-parameter-alist))
1983   (message-setup-fill-variables)
1984   ;; Allow using comment commands to add/remove quoting.
1985   (set (make-local-variable 'comment-start) message-yank-prefix)
1986   (if (featurep 'xemacs)
1987       (message-setup-toolbar)
1988     (set (make-local-variable 'font-lock-defaults)
1989          '((message-font-lock-keywords
1990             message-font-lock-keywords-1
1991             message-font-lock-keywords-2)
1992            nil nil nil nil
1993            (font-lock-mark-block-function . mark-paragraph)))
1994     (if (boundp 'tool-bar-map)
1995         (set (make-local-variable 'tool-bar-map) (message-tool-bar-map))))
1996   (set (make-local-variable 'message-font-lock-last-position) nil)
1997   (easy-menu-add message-mode-menu message-mode-map)
1998   (easy-menu-add message-mode-field-menu message-mode-map)
1999   ;; Allow mail alias things.
2000   (when (eq message-mail-alias-type 'abbrev)
2001     (if (fboundp 'mail-abbrevs-setup)
2002         (mail-abbrevs-setup)
2003       (mail-aliases-setup)))
2004   (message-set-auto-save-file-name)
2005   (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
2006   (setq indent-tabs-mode nil)
2007   (run-hooks 'text-mode-hook 'message-mode-hook))
2008
2009 (defun message-setup-fill-variables ()
2010   "Setup message fill variables."
2011   (set (make-local-variable 'fill-paragraph-function)
2012        'message-fill-paragraph)
2013   (make-local-variable 'paragraph-separate)
2014   (make-local-variable 'paragraph-start)
2015   (make-local-variable 'adaptive-fill-regexp)
2016   (unless (boundp 'adaptive-fill-first-line-regexp)
2017     (setq adaptive-fill-first-line-regexp nil))
2018   (make-local-variable 'adaptive-fill-first-line-regexp)
2019   (make-local-variable 'auto-fill-inhibit-regexp)
2020   (let ((quote-prefix-regexp
2021          ;; User should change message-cite-prefix-regexp if
2022          ;; message-yank-prefix is set to an abnormal value.
2023          (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
2024     (setq paragraph-start
2025           (concat
2026            (regexp-quote mail-header-separator) "$\\|"
2027            "[ \t]*$\\|"                 ; blank lines
2028            "-- $\\|"                    ; signature delimiter
2029            "---+$\\|"                   ; delimiters for forwarded messages
2030            page-delimiter "$\\|"        ; spoiler warnings
2031            ".*wrote:$\\|"               ; attribution lines
2032            quote-prefix-regexp "$"))    ; empty lines in quoted text
2033     (setq paragraph-separate paragraph-start)
2034     (setq adaptive-fill-regexp
2035           (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
2036     (setq adaptive-fill-first-line-regexp
2037           (concat quote-prefix-regexp "\\|"
2038                   adaptive-fill-first-line-regexp))
2039     (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")))
2040
2041 \f
2042
2043 ;;;
2044 ;;; Message mode commands
2045 ;;;
2046
2047 ;;; Movement commands
2048
2049 (defun message-goto-to ()
2050   "Move point to the To header."
2051   (interactive)
2052   (message-position-on-field "To"))
2053
2054 (defun message-goto-subject ()
2055   "Move point to the Subject header."
2056   (interactive)
2057   (message-position-on-field "Subject"))
2058
2059 (defun message-goto-cc ()
2060   "Move point to the Cc header."
2061   (interactive)
2062   (message-position-on-field "Cc" "To"))
2063
2064 (defun message-goto-bcc ()
2065   "Move point to the Bcc  header."
2066   (interactive)
2067   (message-position-on-field "Bcc" "Cc" "To"))
2068
2069 (defun message-goto-fcc ()
2070   "Move point to the Fcc header."
2071   (interactive)
2072   (message-position-on-field "Fcc" "To" "Newsgroups"))
2073
2074 (defun message-goto-reply-to ()
2075   "Move point to the Reply-To header."
2076   (interactive)
2077   (message-position-on-field "Reply-To" "Subject"))
2078
2079 (defun message-goto-mail-reply-to ()
2080   "Move point to the Mail-Reply-To header."
2081   (interactive)
2082   (message-position-on-field "Mail-Reply-To" "Subject"))
2083
2084 (defun message-goto-mail-followup-to ()
2085   "Move point to the Mail-Followup-To header.  If the header is newly created
2086 and To field contains only one address, the address is inserted in default."
2087   (interactive)
2088   (unless (message-position-on-field "Mail-Followup-To" "Subject")
2089     (let ((start (point))
2090           addresses)
2091       (save-restriction
2092         (message-narrow-to-headers)
2093         (setq addresses (split-string (mail-strip-quoted-names
2094                                        (or (std11-fetch-field "to") ""))
2095                                       "[ \f\t\n\r\v,]+"))
2096         (when (eq 1 (length addresses))
2097           (goto-char start)
2098           (insert (car addresses))
2099           (goto-char start))))))
2100
2101 (defun message-goto-mail-copies-to ()
2102   "Move point to the Mail-Copies-To header.  If the header is newly created,
2103 a string \"never\" is inserted in default."
2104   (interactive)
2105   (unless (message-position-on-field "Mail-Copies-To" "Subject")
2106     (insert "never")
2107     (backward-char 5)))
2108
2109 (defun message-goto-newsgroups ()
2110   "Move point to the Newsgroups header."
2111   (interactive)
2112   (message-position-on-field "Newsgroups"))
2113
2114 (defun message-goto-distribution ()
2115   "Move point to the Distribution header."
2116   (interactive)
2117   (message-position-on-field "Distribution"))
2118
2119 (defun message-goto-followup-to ()
2120   "Move point to the Followup-To header."
2121   (interactive)
2122   (message-position-on-field "Followup-To" "Newsgroups"))
2123
2124 (defun message-goto-keywords ()
2125   "Move point to the Keywords header."
2126   (interactive)
2127   (message-position-on-field "Keywords" "Subject"))
2128
2129 (defun message-goto-summary ()
2130   "Move point to the Summary header."
2131   (interactive)
2132   (message-position-on-field "Summary" "Subject"))
2133
2134 (defun message-goto-body (&optional interactivep)
2135   "Move point to the beginning of the message body."
2136   (interactive (list t))
2137   (when (and interactivep
2138              (looking-at "[ \t]*\n"))
2139     (expand-abbrev))
2140   (goto-char (point-min))
2141   (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
2142       (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
2143
2144 (defun message-goto-eoh ()
2145   "Move point to the end of the headers."
2146   (interactive)
2147   (message-goto-body)
2148   (forward-line -1))
2149
2150 (defun message-goto-signature ()
2151   "Move point to the beginning of the message signature.
2152 If there is no signature in the article, go to the end and
2153 return nil."
2154   (interactive)
2155   (goto-char (point-min))
2156   (if (re-search-forward message-signature-separator nil t)
2157       (forward-line 1)
2158     (goto-char (point-max))
2159     nil))
2160
2161 \f
2162
2163 (defun message-insert-to (&optional force)
2164   "Insert a To header that points to the author of the article being replied to.
2165 If the original author requested not to be sent mail, the function signals
2166 an error.
2167 With the prefix argument FORCE, insert the header anyway."
2168   (interactive "P")
2169   (let ((co (message-fetch-reply-field "mail-copies-to")))
2170     (when (and (null force)
2171                co
2172                (or (equal (downcase co) "never")
2173                    (equal (downcase co) "nobody")))
2174       (error "The user has requested not to have copies sent via mail")))
2175   (when (and (message-position-on-field "To")
2176              (mail-fetch-field "to")
2177              (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
2178     (insert ", "))
2179   (insert (or (message-fetch-reply-field "mail-reply-to")
2180               (message-fetch-reply-field "reply-to")
2181               (message-fetch-reply-field "from") "")))
2182
2183 (defun message-widen-reply ()
2184   "Widen the reply to include maximum recipients."
2185   (interactive)
2186   (let ((follow-to
2187          (and message-reply-buffer
2188               (buffer-name message-reply-buffer)
2189               (save-excursion
2190                 (set-buffer message-reply-buffer)
2191                 (message-get-reply-headers t)))))
2192     (save-excursion
2193       (save-restriction
2194         (message-narrow-to-headers)
2195         (dolist (elem follow-to)
2196           (message-remove-header (symbol-name (car elem)))
2197           (goto-char (point-min))
2198           (insert (symbol-name (car elem)) ": "
2199                   (cdr elem) "\n"))))))
2200
2201 (defun message-insert-newsgroups ()
2202   "Insert the Newsgroups header from the article being replied to."
2203   (interactive)
2204   (when (and (message-position-on-field "Newsgroups")
2205              (mail-fetch-field "newsgroups")
2206              (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
2207     (insert ","))
2208   (insert (or (message-fetch-reply-field "newsgroups") "")))
2209
2210 \f
2211
2212 ;;; Various commands
2213
2214 (defun message-delete-not-region (beg end)
2215   "Delete everything in the body of the current message outside of the region."
2216   (interactive "r")
2217   (let (citeprefix)
2218     (save-excursion
2219       (goto-char beg)
2220       ;; snarf citation prefix, if appropriate
2221       (unless (eq (point) (progn (beginning-of-line) (point)))
2222         (when (looking-at message-cite-prefix-regexp)
2223           (setq citeprefix (match-string 0))))
2224       (goto-char end)
2225       (delete-region (point) (if (not (message-goto-signature))
2226                                  (point)
2227                                (forward-line -2)
2228                                (point)))
2229       (insert "\n")
2230       (goto-char beg)
2231       (delete-region beg (progn (message-goto-body)
2232                                 (forward-line 2)
2233                                 (point)))
2234       (when citeprefix
2235         (insert citeprefix))))
2236   (when (message-goto-signature)
2237     (forward-line -2)))
2238
2239 (defun message-kill-to-signature ()
2240   "Deletes all text up to the signature."
2241   (interactive)
2242   (let ((point (point)))
2243     (message-goto-signature)
2244     (unless (eobp)
2245       (forward-line -2))
2246     (kill-region point (point))
2247     (unless (bolp)
2248       (insert "\n"))))
2249
2250 (defun message-newline-and-reformat (&optional arg not-break)
2251   "Insert four newlines, and then reformat if inside quoted text.
2252 Prefix arg means justify as well."
2253   (interactive (list (if current-prefix-arg 'full)))
2254   (let (quoted point beg end leading-space bolp)
2255     (setq point (point))
2256     (beginning-of-line)
2257     (setq beg (point))
2258     (setq bolp (= beg point))
2259     ;; Find first line of the paragraph.
2260     (if not-break
2261         (while (and (not (eobp))
2262                     (not (looking-at message-cite-prefix-regexp))
2263                 (looking-at paragraph-start))
2264           (forward-line 1)))
2265     ;; Find the prefix
2266     (when (looking-at message-cite-prefix-regexp)
2267       (setq quoted (match-string 0))
2268       (goto-char (match-end 0))
2269       (looking-at "[ \t]*")
2270       (setq leading-space (match-string 0)))
2271     (if (and quoted
2272              (not not-break)
2273              (not bolp)
2274              (< (- point beg) (length quoted)))
2275         ;; break inside the cite prefix.
2276         (setq quoted nil
2277               end nil))
2278     (if quoted
2279         (progn
2280           (forward-line 1)
2281           (while (and (not (eobp))
2282                       (not (looking-at paragraph-separate))
2283                       (looking-at message-cite-prefix-regexp)
2284                       (equal quoted (match-string 0)))
2285             (goto-char (match-end 0))
2286             (looking-at "[ \t]*")
2287             (if (> (length leading-space) (length (match-string 0)))
2288                 (setq leading-space (match-string 0)))
2289             (forward-line 1))
2290           (setq end (point))
2291           (goto-char beg)
2292           (while (and (if (bobp) nil (forward-line -1) t)
2293                       (not (looking-at paragraph-start))
2294                       (looking-at message-cite-prefix-regexp)
2295                       (equal quoted (match-string 0)))
2296             (setq beg (point))
2297             (goto-char (match-end 0))
2298             (looking-at "[ \t]*")
2299             (if (> (length leading-space) (length (match-string 0)))
2300                 (setq leading-space (match-string 0)))))
2301       (while (and (not (eobp))
2302                   (not (looking-at paragraph-separate))
2303                   (not (looking-at message-cite-prefix-regexp)))
2304         (forward-line 1))
2305       (setq end (point))
2306       (goto-char beg)
2307       (while (and (if (bobp) nil (forward-line -1) t)
2308                   (not (looking-at paragraph-start))
2309                   (not (looking-at message-cite-prefix-regexp)))
2310         (setq beg (point))))
2311     (goto-char point)
2312     (save-restriction
2313       (narrow-to-region beg end)
2314       (if not-break
2315           (setq point nil)
2316         (if bolp
2317             (insert "\n")
2318           (insert "\n\n"))
2319         (setq point (point))
2320         (insert "\n\n")
2321         (delete-region (point) (re-search-forward "[ \t]*"))
2322         (when (and quoted (not bolp))
2323           (insert quoted leading-space)))
2324       (if quoted
2325           (let* ((adaptive-fill-regexp
2326                  (regexp-quote (concat quoted leading-space)))
2327                  (adaptive-fill-first-line-regexp
2328                   adaptive-fill-regexp ))
2329             (fill-paragraph arg))
2330         (fill-paragraph arg))
2331       (if point (goto-char point)))))
2332
2333 (defun message-fill-paragraph (&optional arg)
2334   "Like `fill-paragraph'."
2335   (interactive (list (if current-prefix-arg 'full)))
2336   (message-newline-and-reformat arg t)
2337   t)
2338
2339 (defun message-insert-signature (&optional force)
2340   "Insert a signature.  See documentation for variable `message-signature'."
2341   (interactive (list 0))
2342   (let* ((signature
2343           (cond
2344            ((and (null message-signature)
2345                  (eq force 0))
2346             (save-excursion
2347               (goto-char (point-max))
2348               (not (re-search-backward message-signature-separator nil t))))
2349            ((and (null message-signature)
2350                  force)
2351             t)
2352            ((message-functionp message-signature)
2353             (funcall message-signature))
2354            ((listp message-signature)
2355             (eval message-signature))
2356            (t message-signature)))
2357          (signature
2358           (cond ((stringp signature)
2359                  signature)
2360                 ((and (eq t signature)
2361                       message-signature-file
2362                       (file-exists-p message-signature-file))
2363                  signature))))
2364     (when signature
2365       (goto-char (point-max))
2366       ;; Insert the signature.
2367       (unless (bolp)
2368         (insert "\n"))
2369       (insert "\n-- \n")
2370       (if (eq signature t)
2371           (insert-file-contents message-signature-file)
2372         (insert signature))
2373       (goto-char (point-max))
2374       (or (bolp) (insert "\n")))))
2375
2376 (defun message-elide-region (b e)
2377   "Elide the text in the region.
2378 An ellipsis (from `message-elide-ellipsis') will be inserted where the
2379 text was killed."
2380   (interactive "r")
2381   (kill-region b e)
2382   (insert message-elide-ellipsis))
2383
2384 (defvar message-caesar-translation-table nil)
2385
2386 (defun message-caesar-region (b e &optional n)
2387   "Caesar rotate region B to E by N, default 13, for decrypting netnews."
2388   (interactive
2389    (list
2390     (min (point) (or (mark t) (point)))
2391     (max (point) (or (mark t) (point)))
2392     (when current-prefix-arg
2393       (prefix-numeric-value current-prefix-arg))))
2394
2395   (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
2396   (unless (or (zerop n)                 ; no action needed for a rot of 0
2397               (= b e))                  ; no region to rotate
2398     ;; We build the table, if necessary.
2399     (when (or (not message-caesar-translation-table)
2400               (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
2401       (setq message-caesar-translation-table
2402             (message-make-caesar-translation-table n)))
2403     (translate-region b e message-caesar-translation-table)))
2404
2405 (defun message-make-caesar-translation-table (n)
2406   "Create a rot table with offset N."
2407   (let ((i -1)
2408         (table (make-string 256 0)))
2409     (while (< (incf i) 256)
2410       (aset table i i))
2411     (concat
2412      (substring table 0 ?A)
2413      (substring table (+ ?A n) (+ ?A n (- 26 n)))
2414      (substring table ?A (+ ?A n))
2415      (substring table (+ ?A 26) ?a)
2416      (substring table (+ ?a n) (+ ?a n (- 26 n)))
2417      (substring table ?a (+ ?a n))
2418      (substring table (+ ?a 26) 255))))
2419
2420 (defun message-caesar-buffer-body (&optional rotnum)
2421   "Caesar rotate all letters in the current buffer by 13 places.
2422 Used to encode/decode possibly offensive messages (commonly in rec.humor).
2423 With prefix arg, specifies the number of places to rotate each letter forward.
2424 Mail and USENET news headers are not rotated."
2425   (interactive (if current-prefix-arg
2426                    (list (prefix-numeric-value current-prefix-arg))
2427                  (list nil)))
2428   (save-excursion
2429     (save-restriction
2430       (when (message-goto-body)
2431         (narrow-to-region (point) (point-max)))
2432       (message-caesar-region (point-min) (point-max) rotnum))))
2433
2434 (defun message-pipe-buffer-body (program)
2435   "Pipe the message body in the current buffer through PROGRAM."
2436   (save-excursion
2437     (save-restriction
2438       (when (message-goto-body)
2439         (narrow-to-region (point) (point-max)))
2440       (shell-command-on-region
2441        (point-min) (point-max) program nil t))))
2442
2443 (defun message-rename-buffer (&optional enter-string)
2444   "Rename the *message* buffer to \"*message* RECIPIENT\".
2445 If the function is run with a prefix, it will ask for a new buffer
2446 name, rather than giving an automatic name."
2447   (interactive "Pbuffer name: ")
2448   (save-excursion
2449     (save-restriction
2450       (goto-char (point-min))
2451       (narrow-to-region (point)
2452                         (search-forward mail-header-separator nil 'end))
2453       (let* ((mail-to (or
2454                        (if (message-news-p) (message-fetch-field "Newsgroups")
2455                          (message-fetch-field "To"))
2456                        ""))
2457              (mail-trimmed-to
2458               (if (string-match "," mail-to)
2459                   (concat (substring mail-to 0 (match-beginning 0)) ", ...")
2460                 mail-to))
2461              (name-default (concat "*message* " mail-trimmed-to))
2462              (name (if enter-string
2463                        (read-string "New buffer name: " name-default)
2464                      name-default)))
2465         (rename-buffer name t)))))
2466
2467 (defun message-fill-yanked-message (&optional justifyp)
2468   "Fill the paragraphs of a message yanked into this one.
2469 Numeric argument means justify as well."
2470   (interactive "P")
2471   (save-excursion
2472     (goto-char (point-min))
2473     (search-forward (concat "\n" mail-header-separator "\n") nil t)
2474     (let ((fill-prefix message-yank-prefix))
2475       (fill-individual-paragraphs (point) (point-max) justifyp))))
2476
2477 (defun message-indent-citation ()
2478   "Modify text just inserted from a message to be cited.
2479 The inserted text should be the region.
2480 When this function returns, the region is again around the modified text.
2481
2482 Normally, indent each nonblank line `message-indentation-spaces' spaces.
2483 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
2484   (let ((start (point)))
2485     ;; Remove unwanted headers.
2486     (when message-ignored-cited-headers
2487       (let (all-removed)
2488         (save-restriction
2489           (narrow-to-region
2490            (goto-char start)
2491            (if (search-forward "\n\n" nil t)
2492                (1- (point))
2493              (point)))
2494           (message-remove-header message-ignored-cited-headers t)
2495           (when (= (point-min) (point-max))
2496             (setq all-removed t))
2497           (goto-char (point-max)))
2498         (if all-removed
2499             (goto-char start)
2500           (forward-line 1))))
2501     ;; Delete blank lines at the start of the buffer.
2502     (while (and (point-min)
2503                 (eolp)
2504                 (not (eobp)))
2505       (message-delete-line))
2506     ;; Delete blank lines at the end of the buffer.
2507     (goto-char (point-max))
2508     (unless (bolp)
2509       (insert "\n"))
2510     (while (and (zerop (forward-line -1))
2511                 (looking-at "$"))
2512       (message-delete-line))
2513     ;; Do the indentation.
2514     (if (null message-yank-prefix)
2515         (indent-rigidly start (mark t) message-indentation-spaces)
2516       (save-excursion
2517         (goto-char start)
2518         (while (< (point) (mark t))
2519           (if (looking-at message-cite-prefix-regexp)
2520               (insert message-yank-cited-prefix)
2521             (insert message-yank-prefix))
2522           (forward-line 1))))
2523     (goto-char start)))
2524
2525 (defun message-list-references (refs-list &rest refs-strs)
2526   "Add `Message-ID's which appear in REFS-STRS but not in REFS-LIST,
2527 to REFS-LIST."
2528   (let (refs ref id saved-id)
2529     (when (and refs-list
2530                (integerp message-list-references-add-position))
2531       (let ((pos message-list-references-add-position))
2532         (while (and refs-list
2533                     (> pos 0))
2534           (push (pop refs-list) saved-id)
2535           (setq pos (1- pos)))))
2536     (while refs-strs
2537       (when (setq refs (pop refs-strs))
2538         (setq refs (std11-parse-msg-ids (std11-lexical-analyze refs)))
2539         (while refs
2540           (when (eq (car (setq ref (pop refs))) 'msg-id)
2541             (setq id (concat "<" (mapconcat 'cdr (cdr ref) "") ">"))
2542             (or (member id refs-list)
2543                 (member id saved-id)
2544                 (push id refs-list))))))
2545     (while saved-id
2546       (push (pop saved-id) refs-list))
2547     refs-list))
2548
2549 (defvar gnus-article-copy)
2550 (defun message-yank-original (&optional arg)
2551   "Insert the message being replied to, if any.
2552 Puts point before the text and mark after.
2553 Normally indents each nonblank line ARG spaces (default 3).  However,
2554 if `message-yank-prefix' is non-nil, insert that prefix on each line.
2555
2556 This function uses `message-cite-function' to do the actual citing.
2557
2558 Just \\[universal-argument] as argument means don't indent, insert no
2559 prefix, and don't delete any headers.
2560
2561 In addition, if `message-yank-add-new-references' is non-nil and this
2562 command is called interactively, new IDs from the yanked article will
2563 be added to \"References\" field.
2564 \(See also `message-yank-add-new-references'.)"
2565   (interactive "P")
2566   (let ((modified (buffer-modified-p))
2567         (buffer (message-eval-parameter message-reply-buffer))
2568         start end refs)
2569     (when (and buffer
2570                message-cite-function)
2571       (delete-windows-on buffer t)
2572       (insert-buffer buffer) ; mark will be set at the end of article.
2573       (setq start (point)
2574             end (mark t))
2575
2576       ;; Add new IDs to References field.
2577       (when (and message-yank-add-new-references (interactive-p))
2578         (save-excursion
2579           (save-restriction
2580             (message-narrow-to-headers)
2581             (setq refs (message-list-references
2582                         nil
2583                         (message-fetch-field "References")))
2584             (widen)
2585             (narrow-to-region start end)
2586             (std11-narrow-to-header)
2587             (when (setq refs (message-list-references
2588                               refs
2589                               (unless (eq message-yank-add-new-references
2590                                           'message-id-only)
2591                                 (or (message-fetch-field "References")
2592                                     (message-fetch-field "In-Reply-To")))
2593                               (message-fetch-field "Message-ID")))
2594               (widen)
2595               (message-narrow-to-headers)
2596               (goto-char (point-min))
2597               (let ((case-fold-search t))
2598                 (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t)
2599                     (replace-match "")
2600                   (goto-char (point-max))))
2601               (mail-header-format
2602                (list (or (assq 'References message-header-format-alist)
2603                          '(References . message-fill-references)))
2604                (list (cons 'References
2605                            (mapconcat 'identity (nreverse refs) " "))))
2606               (backward-delete-char 1)))))
2607
2608       (unless arg
2609         (funcall message-cite-function))
2610       (message-exchange-point-and-mark)
2611       (unless (bolp)
2612         (insert ?\n))
2613       (unless modified
2614         (setq message-checksum (message-checksum))))))
2615
2616 (defun message-yank-buffer (buffer)
2617   "Insert BUFFER into the current buffer and quote it."
2618   (interactive "bYank buffer: ")
2619   (let ((message-reply-buffer buffer))
2620     (save-window-excursion
2621       (message-yank-original))))
2622
2623 (defun message-buffers ()
2624   "Return a list of active message buffers."
2625   (let (buffers)
2626     (save-excursion
2627       (dolist (buffer (buffer-list t))
2628         (set-buffer buffer)
2629         (when (and (eq major-mode 'message-mode)
2630                    (null message-sent-message-via))
2631           (push (buffer-name buffer) buffers))))
2632     (nreverse buffers)))
2633
2634 (defun message-cite-original-without-signature ()
2635   "Cite function in the standard Message manner."
2636   (let ((start (point))
2637         (end (mark t))
2638         (functions
2639          (when message-indent-citation-function
2640            (if (listp message-indent-citation-function)
2641                message-indent-citation-function
2642              (list message-indent-citation-function))))
2643         (message-reply-headers (or message-reply-headers
2644                                    (make-mail-header))))
2645     (mail-header-set-from message-reply-headers
2646                           (save-restriction
2647                             (narrow-to-region
2648                              (point)
2649                              (if (search-forward "\n\n" nil t)
2650                                  (1- (point))
2651                                (point-max)))
2652                             (or (message-fetch-field "from")
2653                                 "unknown sender")))
2654     ;; Allow undoing.
2655     (undo-boundary)
2656     (goto-char end)
2657     (when (re-search-backward message-signature-separator start t)
2658       ;; Also peel off any blank lines before the signature.
2659       (forward-line -1)
2660       (while (looking-at "^[ \t]*$")
2661         (forward-line -1))
2662       (forward-line 1)
2663       (delete-region (point) end)
2664       (unless (search-backward "\n\n" start t)
2665         ;; Insert a blank line if it is peeled off.
2666         (insert "\n")))
2667     (goto-char start)
2668     (while functions
2669       (funcall (pop functions)))
2670     (when message-citation-line-function
2671       (unless (bolp)
2672         (insert "\n"))
2673       (funcall message-citation-line-function))))
2674
2675 (eval-when-compile (defvar mail-citation-hook))         ;Compiler directive
2676 (defun message-cite-original ()
2677   "Cite function in the standard Message manner."
2678   (if (and (boundp 'mail-citation-hook)
2679            mail-citation-hook)
2680       (run-hooks 'mail-citation-hook)
2681     (let ((start (point))
2682           (end (mark t))
2683           (functions
2684            (when message-indent-citation-function
2685              (if (listp message-indent-citation-function)
2686                  message-indent-citation-function
2687                (list message-indent-citation-function))))
2688           (message-reply-headers (or message-reply-headers
2689                                      (make-mail-header))))
2690       (mail-header-set-from message-reply-headers
2691                             (save-restriction
2692                               (narrow-to-region
2693                                (point)
2694                                (if (search-forward "\n\n" nil t)
2695                                    (1- (point))
2696                                  (point-max)))
2697                               (or (message-fetch-field "from")
2698                                   "unknown sender")))
2699       (goto-char start)
2700       (while functions
2701         (funcall (pop functions)))
2702       (when message-citation-line-function
2703         (unless (bolp)
2704           (insert "\n"))
2705         (funcall message-citation-line-function)))))
2706
2707 (defun message-insert-citation-line ()
2708   "Insert a simple citation line."
2709   (when message-reply-headers
2710     (insert (mail-header-from message-reply-headers) " writes:\n\n")))
2711
2712 (defun message-position-on-field (header &rest afters)
2713   (let ((case-fold-search t))
2714     (save-restriction
2715       (narrow-to-region
2716        (goto-char (point-min))
2717        (progn
2718          (re-search-forward
2719           (concat "^" (regexp-quote mail-header-separator) "$"))
2720          (match-beginning 0)))
2721       (goto-char (point-min))
2722       (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
2723           (progn
2724             (re-search-forward "^[^ \t]" nil 'move)
2725             (beginning-of-line)
2726             (skip-chars-backward "\n")
2727             t)
2728         (while (and afters
2729                     (not (re-search-forward
2730                           (concat "^" (regexp-quote (car afters)) ":")
2731                           nil t)))
2732           (pop afters))
2733         (when afters
2734           (re-search-forward "^[^ \t]" nil 'move)
2735           (beginning-of-line))
2736         (insert header ": \n")
2737         (forward-char -1)
2738         nil))))
2739
2740 (defun message-remove-signature ()
2741   "Remove the signature from the text between point and mark.
2742 The text will also be indented the normal way."
2743   (save-excursion
2744     (let ((start (point))
2745           mark)
2746       (if (not (re-search-forward message-signature-separator (mark t) t))
2747           ;; No signature here, so we just indent the cited text.
2748           (message-indent-citation)
2749         ;; Find the last non-empty line.
2750         (forward-line -1)
2751         (while (looking-at "[ \t]*$")
2752           (forward-line -1))
2753         (forward-line 1)
2754         (setq mark (set-marker (make-marker) (point)))
2755         (goto-char start)
2756         (message-indent-citation)
2757         ;; Enable undoing the deletion.
2758         (undo-boundary)
2759         (delete-region mark (mark t))
2760         (set-marker mark nil)))))
2761
2762 \f
2763
2764 ;;;
2765 ;;; Sending messages
2766 ;;;
2767
2768 ;; Avoid byte-compile warning.
2769 (defvar message-encoding-buffer nil)
2770 (defvar message-edit-buffer nil)
2771 (defvar message-mime-mode nil)
2772
2773 (defun message-send-and-exit (&optional arg)
2774   "Send message like `message-send', then, if no errors, exit from mail buffer."
2775   (interactive "P")
2776   (let ((buf (current-buffer))
2777         (actions message-exit-actions)
2778         (frame (selected-frame))
2779         (org-frame message-original-frame))
2780     (when (and (message-send arg)
2781                (buffer-name buf))
2782       (if message-kill-buffer-on-exit
2783           (kill-buffer buf)
2784         (bury-buffer buf)
2785         (when (eq buf (current-buffer))
2786           (message-bury buf)))
2787       (message-do-actions actions)
2788       (message-delete-frame frame org-frame)
2789       t)))
2790
2791 (defun message-dont-send ()
2792   "Don't send the message you have been editing."
2793   (interactive)
2794   (message-save-drafts)
2795   (let ((actions message-postpone-actions)
2796         (frame (selected-frame))
2797         (org-frame message-original-frame))
2798     (message-bury (current-buffer))
2799     (message-do-actions actions)
2800     (message-delete-frame frame org-frame)))
2801
2802 (defun message-kill-buffer ()
2803   "Kill the current buffer."
2804   (interactive)
2805   (when (or (not (buffer-modified-p))
2806             (eq t message-kill-buffer-query-function)
2807             (funcall message-kill-buffer-query-function
2808                      "The buffer modified; kill anyway? "))
2809     (let ((actions message-kill-actions)
2810           (frame (selected-frame))
2811           (org-frame message-original-frame))
2812       (setq buffer-file-name nil)
2813       (kill-buffer (current-buffer))
2814       (message-do-actions actions)
2815       (message-delete-frame frame org-frame)))
2816   (message ""))
2817
2818 (defun message-mimic-kill-buffer ()
2819   "Kill the current buffer with query."
2820   (interactive)
2821   (unless (eq 'message-mode major-mode)
2822     (error "%s must be invoked from a message buffer." this-command))
2823   (let ((command this-command)
2824         (bufname (read-buffer (format "Kill buffer: (default %s) "
2825                                       (buffer-name)))))
2826     (if (or (not bufname)
2827             (string-equal bufname "")
2828             (string-equal bufname (buffer-name)))
2829         (message-kill-buffer)
2830       (message "%s must be invoked only for the current buffer." command))))
2831
2832 (defun message-delete-frame (frame org-frame)
2833   "Delete frame for editing message."
2834   (when (and (or (static-if (featurep 'xemacs)
2835                      (device-on-window-system-p)
2836                    window-system)
2837                  (>= emacs-major-version 20))
2838              (or (and (eq message-delete-frame-on-exit t)
2839                       (select-frame frame)
2840                       (or (eq frame org-frame)
2841                           (prog1
2842                               (y-or-n-p "Delete this frame?")
2843                             (message ""))))
2844                  (and (eq message-delete-frame-on-exit 'ask)
2845                       (select-frame frame)
2846                       (prog1
2847                           (y-or-n-p "Delete this frame?")
2848                         (message "")))))
2849     (delete-frame frame)))
2850
2851 (defun message-bury (buffer)
2852   "Bury this mail BUFFER."
2853   (let ((newbuf (other-buffer buffer)))
2854     (bury-buffer buffer)
2855     (if (and (fboundp 'frame-parameters)
2856              (cdr (assq 'dedicated (frame-parameters)))
2857              (not (null (delq (selected-frame) (visible-frame-list)))))
2858         (delete-frame (selected-frame))
2859       (switch-to-buffer newbuf))))
2860
2861 (defun message-send (&optional arg)
2862   "Send the message in the current buffer.
2863 If `message-interactive' is non-nil, wait for success indication or
2864 error messages, and inform user.
2865 Otherwise any failure is reported in a message back to the user from
2866 the mailer.
2867 The usage of ARG is defined by the instance that called Message.
2868 It should typically alter the sending method in some way or other."
2869   (interactive "P")
2870   ;; Disabled test.
2871   (when (or (buffer-modified-p)
2872             (message-check-element 'unchanged)
2873             (y-or-n-p "No changes in the buffer; really send? "))
2874     ;; Make it possible to undo the coming changes.
2875     (undo-boundary)
2876     (let ((inhibit-read-only t))
2877       (put-text-property (point-min) (point-max) 'read-only nil))
2878     (run-hooks 'message-send-hook)
2879     (message-fix-before-sending)
2880     (message message-sending-message)
2881     (let ((message-encoding-buffer
2882            (message-generate-new-buffer-clone-locals " message encoding"))
2883           (message-edit-buffer (current-buffer))
2884           (message-mime-mode mime-edit-mode-flag)
2885           (alist message-send-method-alist)
2886           (success t)
2887           elem sent
2888           (message-options message-options))
2889       (message-options-set-recipient)
2890       (save-excursion
2891         (set-buffer message-encoding-buffer)
2892         (erase-buffer)
2893         ;; Avoid copying text props.
2894         (let (message-invisibles)
2895           (insert
2896            (with-current-buffer message-edit-buffer
2897              (setq message-invisibles (message-find-invisible-regions))
2898              (buffer-substring-no-properties (point-min) (point-max))))
2899           ;; Inherit the invisible property of texts to make MIME-Edit
2900           ;; find the MIME part boundaries.
2901           (dolist (region message-invisibles)
2902             (put-text-property (car region) (cdr region) 'invisible t)))
2903         (funcall message-encode-function)
2904         (while (and success
2905                     (setq elem (pop alist)))
2906           (when (funcall (cadr elem))
2907             (when (and (or (not (memq (car elem)
2908                                       message-sent-message-via))
2909                            (if (or (message-gnksa-enable-p 'multiple-copies)
2910                                    (not (eq (car elem) 'news)))
2911                                (y-or-n-p
2912                                 (format
2913                                  "Already sent message via %s; resend? "
2914                                  (car elem)))
2915                              (error "Denied posting -- multiple copies.")))
2916                        (setq success (funcall (caddr elem) arg)))
2917               (setq sent t)))))
2918       (unless (or sent (not success))
2919         (error "No methods specified to send by"))
2920       (prog1
2921           (when (and success sent)
2922             (message-do-fcc)
2923             (save-excursion
2924               (run-hooks 'message-sent-hook))
2925             (message "Sending...done")
2926             ;; Mark the buffer as unmodified and delete auto-save.
2927             (set-buffer-modified-p nil)
2928             (delete-auto-save-file-if-necessary t)
2929             (message-disassociate-draft)
2930             ;; Delete other mail buffers and stuff.
2931             (message-do-send-housekeeping)
2932             (message-do-actions message-send-actions)
2933             ;; Return success.
2934             t)
2935         (kill-buffer message-encoding-buffer)))))
2936
2937 (defun message-send-via-mail (arg)
2938   "Send the current message via mail."
2939   (message-send-mail arg))
2940
2941 (defun message-send-via-news (arg)
2942   "Send the current message via news."
2943   (message-send-news arg))
2944
2945 (defmacro message-check (type &rest forms)
2946   "Eval FORMS if TYPE is to be checked."
2947   `(or (message-check-element ,type)
2948        (save-excursion
2949          ,@forms)))
2950
2951 (put 'message-check 'lisp-indent-function 1)
2952 (put 'message-check 'edebug-form-spec '(form body))
2953
2954 ;; This function will be used by MIME-Edit when inserting invisible parts.
2955 (defun message-invisible-region (start end)
2956   (if (featurep 'xemacs)
2957       (if (save-excursion
2958             (goto-char start)
2959             (eq (following-char) ?\n))
2960           (setq start (1+ start)))
2961     (if (save-excursion
2962           (goto-char (1- end))
2963           (eq (following-char) ?\n))
2964         (setq end (1- end))))
2965   (put-text-property start end 'invisible t)
2966   (if (eq 'message-mode major-mode)
2967       (put-text-property start end 'message-invisible t)))
2968
2969 (eval-after-load "invisible"
2970   '(defalias 'invisible-region 'message-invisible-region))
2971
2972 (defun message-find-invisible-regions ()
2973   "Find invisible texts with the property `message-invisible' and
2974 return a list of points."
2975   (let (from
2976         (to (point-min))
2977         regions)
2978     (while (setq from (text-property-any to (point-max)
2979                                          'message-invisible t))
2980       (setq to (or (text-property-not-all from (point-max)
2981                                           'message-invisible t)
2982                    (point-max)))
2983       (push (cons from to) regions))
2984     regions))
2985
2986 (defun message-fix-before-sending ()
2987   "Do various things to make the message nice before sending it."
2988   ;; Make sure there's a newline at the end of the message.
2989   (widen)
2990   (goto-char (point-max))
2991   (unless (bolp)
2992     (insert "\n"))
2993   ;; Expose all invisible text with the property `message-invisible'.
2994   ;; We should believe that the things might be created by MIME-Edit.
2995   (let ((message-invisibles (message-find-invisible-regions)))
2996     (dolist (region message-invisibles)
2997       (put-text-property (car region) (cdr region) 'invisible nil))
2998     ;; Expose all invisible text.
2999     (message-check 'invisible-text
3000       (when (text-property-any (point-min) (point-max) 'invisible t)
3001         (put-text-property (point-min) (point-max) 'invisible nil)
3002         (unless (yes-or-no-p
3003                  "Invisible text found and made visible; continue posting? ")
3004           (error "Invisible text found and made visible"))))
3005     ;; Hide again all text with the property `message-invisible'.
3006     ;; It is needed to make MIME-Edit find the MIME part boundaries.
3007     (dolist (region message-invisibles)
3008       (put-text-property (car region) (cdr region) 'invisible t))))
3009
3010 (defun message-add-action (action &rest types)
3011   "Add ACTION to be performed when doing an exit of type TYPES."
3012   (let (var)
3013     (while types
3014       (set (setq var (intern (format "message-%s-actions" (pop types))))
3015            (nconc (symbol-value var) (list action))))))
3016
3017 (defun message-do-actions (actions)
3018   "Perform all actions in ACTIONS."
3019   ;; Now perform actions on successful sending.
3020   (while actions
3021     (ignore-errors
3022       (cond
3023        ;; A simple function.
3024        ((message-functionp (car actions))
3025         (funcall (car actions)))
3026        ;; Something to be evaled.
3027        (t
3028         (eval (car actions)))))
3029     (pop actions)))
3030
3031 (defsubst message-maybe-split-and-send-mail ()
3032   "Split a message if necessary, and send it via mail.
3033 Returns nil if sending succeeded, returns any string if sending failed.
3034 This sub function is for exclusive use of `message-send-mail'."
3035   (let ((mime-edit-split-ignored-field-regexp
3036          mime-edit-split-ignored-field-regexp)
3037         (case-fold-search t)
3038         failure)
3039     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
3040       (setq mime-edit-split-ignored-field-regexp
3041             (concat (substring mime-edit-split-ignored-field-regexp
3042                                0 (match-beginning 0))
3043                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
3044                     "_so_don't_rape_it!"
3045                     (substring mime-edit-split-ignored-field-regexp
3046                                (match-end 0)))))
3047     (setq failure
3048           (or
3049            (catch 'message-sending-mail-failure
3050              (mime-edit-maybe-split-and-send
3051               (function
3052                (lambda ()
3053                  (interactive)
3054                  (save-restriction
3055                    (std11-narrow-to-header mail-header-separator)
3056                    (goto-char (point-min))
3057                    (when (re-search-forward "^Message-ID:" nil t)
3058                      (delete-region (match-end 0) (std11-field-end))
3059                      (insert " " (message-make-message-id))))
3060                  (condition-case err
3061                      (funcall message-send-mail-function)
3062                    (error
3063                     (throw 'message-sending-mail-failure err))))))
3064              nil)
3065            (condition-case err
3066                (progn
3067                  (funcall message-send-mail-function)
3068                  nil)
3069              (error err))))
3070     (when failure
3071       (if (eq 'error (car failure))
3072           (cadr failure)
3073         (prin1-to-string failure)))))
3074
3075 (defun message-send-mail-partially ()
3076   "Send mail as message/partial."
3077   ;; replace the header delimiter with a blank line
3078   (goto-char (point-min))
3079   (re-search-forward
3080    (concat "^" (regexp-quote mail-header-separator) "\n"))
3081   (replace-match "\n")
3082   (run-hooks 'message-send-mail-hook)
3083   (let ((p (goto-char (point-min)))
3084         (tembuf (message-generate-new-buffer-clone-locals " message temp"))
3085         (curbuf (current-buffer))
3086         (id (message-make-message-id)) (n 1)
3087         plist total  header required-mail-headers)
3088     (while (not (eobp))
3089       (if (< (point-max) (+ p message-send-mail-partially-limit))
3090           (goto-char (point-max))
3091         (goto-char (+ p message-send-mail-partially-limit))
3092         (beginning-of-line)
3093         (if (<= (point) p) (forward-line 1))) ;; In case of bad message.
3094       (push p plist)
3095       (setq p (point)))
3096     (setq total (length plist))
3097     (push (point-max) plist)
3098     (setq plist (nreverse plist))
3099     (unwind-protect
3100         (save-excursion
3101           (setq p (pop plist))
3102           (while plist
3103             (set-buffer curbuf)
3104             (copy-to-buffer tembuf p (car plist))
3105             (set-buffer tembuf)
3106             (goto-char (point-min))
3107             (if header
3108                 (progn
3109                   (goto-char (point-min))
3110                   (narrow-to-region (point) (point))
3111                   (insert header))
3112               (message-goto-eoh)
3113               (setq header (buffer-substring (point-min) (point)))
3114               (goto-char (point-min))
3115               (narrow-to-region (point) (point))
3116               (insert header)
3117               (message-remove-header "Mime-Version")
3118               (message-remove-header "Content-Type")
3119               (message-remove-header "Content-Transfer-Encoding")
3120               (message-remove-header "Message-ID")
3121               (message-remove-header "Lines")
3122               (goto-char (point-max))
3123               (insert "Mime-Version: 1.0\n")
3124               (setq header (buffer-substring (point-min) (point-max))))
3125             (goto-char (point-max))
3126             (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n"
3127                             id n total))
3128             (let ((mail-header-separator ""))
3129               (when (memq 'Message-ID message-required-mail-headers)
3130                 (insert "Message-ID: " (message-make-message-id) "\n"))
3131               (when (memq 'Lines message-required-mail-headers)
3132                 (let ((mail-header-separator ""))
3133                   (insert "Lines: " (message-make-lines) "\n")))
3134               (message-goto-subject)
3135               (end-of-line)
3136               (insert (format " (%d/%d)" n total))
3137               (goto-char (point-max))
3138               (insert "\n")
3139               (widen)
3140               (mm-with-unibyte-current-buffer
3141                 (funcall message-send-mail-function)))
3142             (setq n (+ n 1))
3143             (setq p (pop plist))
3144             (erase-buffer)))
3145       (kill-buffer tembuf))))
3146
3147 (defun message-send-mail (&optional arg)
3148   (require 'mail-utils)
3149   (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
3150          (case-fold-search nil)
3151          (news (message-news-p))
3152          (message-this-is-mail t)
3153          failure)
3154     (save-restriction
3155       (message-narrow-to-headers)
3156       ;; Insert some headers.
3157       (let ((message-deletable-headers
3158              (if news nil message-deletable-headers)))
3159         (message-generate-headers message-required-mail-headers))
3160       ;; Let the user do all of the above.
3161       (run-hooks 'message-header-hook))
3162     (if (not (message-check-mail-syntax))
3163         (progn
3164           (message "")
3165           nil)
3166       (unwind-protect
3167           (save-excursion
3168             (set-buffer tembuf)
3169             (erase-buffer)
3170             (insert-buffer message-encoding-buffer)
3171             ;; Remove some headers.
3172             (save-restriction
3173               (message-narrow-to-headers)
3174 ;; We Semi-gnus people have no use for it.
3175 ;;            ;; We (re)generate the Lines header.
3176 ;;            (when (memq 'Lines message-required-mail-headers)
3177 ;;              (message-generate-headers '(Lines)))
3178               ;; Remove some headers.
3179               (message-remove-header message-ignored-mail-headers t))
3180             (goto-char (point-max))
3181             ;; require one newline at the end.
3182             (or (= (preceding-char) ?\n)
3183                 (insert ?\n))
3184             (when
3185                 (save-restriction
3186                   (message-narrow-to-headers)
3187                   (and news
3188                        (or (message-fetch-field "cc")
3189                            (message-fetch-field "to"))
3190                        (let ((ct (mime-read-Content-Type)))
3191                          (or (not ct)
3192                              (and (eq 'text (cdr (assq 'type ct)))
3193                                   (eq 'plain (cdr (assq 'subtype ct))))))))
3194               (message-insert-courtesy-copy))
3195             (setq failure (message-maybe-split-and-send-mail)))
3196         (kill-buffer tembuf))
3197       (set-buffer message-edit-buffer)
3198       (if failure
3199           (progn
3200             (message "Couldn't send message via mail: %s" failure)
3201             nil)
3202         (push 'mail message-sent-message-via)))))
3203
3204 (defun message-send-mail-with-sendmail ()
3205   "Send off the prepared buffer with sendmail."
3206   (let ((errbuf (if message-interactive
3207                     (message-generate-new-buffer-clone-locals
3208                      " sendmail errors")
3209                   0))
3210         resend-to-addresses delimline)
3211     (let ((case-fold-search t))
3212       (save-restriction
3213         (message-narrow-to-headers)
3214         (setq resend-to-addresses (message-fetch-field "resent-to")))
3215       ;; Change header-delimiter to be what sendmail expects.
3216       (goto-char (point-min))
3217       (re-search-forward
3218        (concat "^" (regexp-quote mail-header-separator) "\n"))
3219       (replace-match "\n")
3220       (backward-char 1)
3221       (setq delimline (point-marker))
3222       (run-hooks 'message-send-mail-hook)
3223       ;; Insert an extra newline if we need it to work around
3224       ;; Sun's bug that swallows newlines.
3225       (goto-char (1+ delimline))
3226       (when (eval message-mailer-swallows-blank-line)
3227         (newline))
3228       (when message-interactive
3229         (save-excursion
3230           (set-buffer errbuf)
3231           (erase-buffer))))
3232     (let ((default-directory "/"))
3233       (as-binary-process
3234        (apply 'call-process-region
3235               (append (list (point-min) (point-max)
3236                             (if (boundp 'sendmail-program)
3237                                 sendmail-program
3238                               "/usr/lib/sendmail")
3239                             nil errbuf nil "-oi")
3240                       ;; Always specify who from,
3241                       ;; since some systems have broken sendmails.
3242                       ;; But some systems are more broken with -f, so
3243                       ;; we'll let users override this.
3244                       (if (null message-sendmail-f-is-evil)
3245                           (list "-f" (message-make-address)))
3246                       ;; These mean "report errors by mail"
3247                       ;; and "deliver in background".
3248                       (if (null message-interactive) '("-oem" "-odb"))
3249                       ;; Get the addresses from the message
3250                       ;; unless this is a resend.
3251                       ;; We must not do that for a resend
3252                       ;; because we would find the original addresses.
3253                       ;; For a resend, include the specific addresses.
3254                       (if resend-to-addresses
3255                           (list resend-to-addresses)
3256                         '("-t"))))))
3257     (when message-interactive
3258       (save-excursion
3259         (set-buffer errbuf)
3260         (goto-char (point-min))
3261         (while (re-search-forward "\n\n* *" nil t)
3262           (replace-match "; "))
3263         (if (not (zerop (buffer-size)))
3264             (error "Sending...failed to %s"
3265                    (buffer-substring (point-min) (point-max)))))
3266       (when (bufferp errbuf)
3267         (kill-buffer errbuf)))))
3268
3269 (defun message-send-mail-with-qmail ()
3270   "Pass the prepared message buffer to qmail-inject.
3271 Refer to the documentation for the variable `message-send-mail-function'
3272 to find out how to use this."
3273   ;; replace the header delimiter with a blank line
3274   (goto-char (point-min))
3275   (re-search-forward
3276    (concat "^" (regexp-quote mail-header-separator) "\n"))
3277   (replace-match "\n")
3278   (backward-char 1)
3279   (run-hooks 'message-send-mail-hook)
3280   ;; send the message
3281   (case
3282       (as-binary-process
3283        (apply
3284         'call-process-region 1 (point-max) message-qmail-inject-program
3285         nil nil nil
3286         ;; qmail-inject's default behaviour is to look for addresses on the
3287         ;; command line; if there're none, it scans the headers.
3288         ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
3289         ;;
3290         ;; in general, ALL of qmail-inject's defaults are perfect for simply
3291         ;; reading a formatted (i. e., at least a To: or Resent-To header)
3292         ;; message from stdin.
3293         ;;
3294         ;; qmail also has the advantage of not having been raped by
3295         ;; various vendors, so we don't have to allow for that, either --
3296         ;; compare this with message-send-mail-with-sendmail and weep
3297         ;; for sendmail's lost innocence.
3298         ;;
3299         ;; all this is way cool coz it lets us keep the arguments entirely
3300         ;; free for -inject-arguments -- a big win for the user and for us
3301         ;; since we don't have to play that double-guessing game and the user
3302         ;; gets full control (no gestapo'ish -f's, for instance).  --sj
3303         message-qmail-inject-args))
3304     ;; qmail-inject doesn't say anything on it's stdout/stderr,
3305     ;; we have to look at the retval instead
3306     (0 nil)
3307     (100 (error "qmail-inject reported permanent failure"))
3308     (111 (error "qmail-inject reported transient failure"))
3309     ;; should never happen
3310     (t   (error "qmail-inject reported unknown failure"))))
3311
3312 (defun message-send-mail-with-mh ()
3313   "Send the prepared message buffer with mh."
3314   (let ((mh-previous-window-config nil)
3315         (name (mh-new-draft-name)))
3316     (setq buffer-file-name name)
3317     ;; MH wants to generate these headers itself.
3318     (when message-mh-deletable-headers
3319       (let ((headers message-mh-deletable-headers))
3320         (while headers
3321           (goto-char (point-min))
3322           (and (re-search-forward
3323                 (concat "^" (symbol-name (car headers)) ": *") nil t)
3324                (message-delete-line))
3325           (pop headers))))
3326     (run-hooks 'message-send-mail-hook)
3327     ;; Pass it on to mh.
3328     (mh-send-letter)))
3329
3330 (defun message-send-mail-with-smtp ()
3331   "Send off the prepared buffer with SMTP."
3332   (require 'smtp) ; XXX
3333   (let ((case-fold-search t)
3334         recipients)
3335     (save-restriction
3336       (message-narrow-to-headers)
3337       (setq recipients
3338             ;; XXX: Should be replaced by better one.
3339             (smtp-deduce-address-list (current-buffer)
3340                                       (point-min) (point-max)))
3341       ;; Remove BCC lines.
3342       (message-remove-header "bcc"))
3343     ;; replace the header delimiter with a blank line.
3344     (goto-char (point-min))
3345     (re-search-forward
3346      (concat "^" (regexp-quote mail-header-separator) "\n"))
3347     (replace-match "\n")
3348     (backward-char 1)
3349     (run-hooks 'message-send-mail-hook)
3350     (if recipients
3351         (static-if (fboundp 'smtp-send-buffer)
3352             (smtp-send-buffer user-mail-address recipients
3353                               (current-buffer))
3354           (let ((result (smtp-via-smtp user-mail-address recipients
3355                                        (current-buffer))))
3356             (unless (eq result t)
3357               (error "Sending failed; %s" result))))
3358       (error "Sending failed; no recipients"))))
3359
3360 (defsubst message-maybe-split-and-send-news (method)
3361   "Split a message if necessary, and send it via news.
3362 Returns nil if sending succeeded, returns t if sending failed.
3363 This sub function is for exclusive use of `message-send-news'."
3364   (let ((mime-edit-split-ignored-field-regexp
3365          mime-edit-split-ignored-field-regexp)
3366         (case-fold-search t))
3367     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
3368       (setq mime-edit-split-ignored-field-regexp
3369             (concat (substring mime-edit-split-ignored-field-regexp
3370                                0 (match-beginning 0))
3371                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
3372                     "_so_don't_rape_it!"
3373                     (substring mime-edit-split-ignored-field-regexp
3374                                (match-end 0)))))
3375     (or
3376      (catch 'message-sending-news-failure
3377        (mime-edit-maybe-split-and-send
3378         (function
3379          (lambda ()
3380            (interactive)
3381            (save-restriction
3382              (std11-narrow-to-header mail-header-separator)
3383              (goto-char (point-min))
3384              (when (re-search-forward "^Message-ID:" nil t)
3385                (delete-region (match-end 0) (std11-field-end))
3386                (insert " " (message-make-message-id))))
3387            (unless (funcall message-send-news-function method)
3388              (throw 'message-sending-news-failure t)))))
3389        nil)
3390      (not (funcall message-send-news-function method)))))
3391
3392 (defun message-send-news (&optional arg)
3393   (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
3394          (case-fold-search nil)
3395          (method (if (message-functionp message-post-method)
3396                      (funcall message-post-method arg)
3397                    message-post-method))
3398          (group-name-charset (gnus-group-name-charset method ""))
3399          (message-syntax-checks
3400           (if arg
3401               (cons '(existing-newsgroups . disabled)
3402                     message-syntax-checks)
3403             message-syntax-checks))
3404          (message-this-is-news t)
3405          result)
3406     (save-restriction
3407       (message-narrow-to-headers)
3408       ;; Insert some headers.
3409       (message-generate-headers message-required-news-headers)
3410       ;; Let the user do all of the above.
3411       (run-hooks 'message-header-hook))
3412     (when group-name-charset
3413       (setq message-syntax-checks
3414             (cons '(valid-newsgroups . disabled)
3415                   message-syntax-checks)))
3416     (message-cleanup-headers)
3417     (if (not (message-check-news-syntax))
3418         nil
3419       (unwind-protect
3420           (save-excursion
3421             (set-buffer tembuf)
3422             (buffer-disable-undo)
3423             (erase-buffer)
3424             (insert-buffer message-encoding-buffer)
3425             ;; Remove some headers.
3426             (save-restriction
3427               (message-narrow-to-headers)
3428 ;; We Semi-gnus people have no use for it.
3429 ;;            ;; We (re)generate the Lines header.
3430 ;;            (when (memq 'Lines message-required-mail-headers)
3431 ;;              (message-generate-headers '(Lines)))
3432               ;; Remove some headers.
3433               (message-remove-header message-ignored-news-headers t))
3434             (goto-char (point-max))
3435             ;; require one newline at the end.
3436             (or (= (preceding-char) ?\n)
3437                 (insert ?\n))
3438             (setq result (message-maybe-split-and-send-news method)))
3439         (kill-buffer tembuf))
3440       (set-buffer message-edit-buffer)
3441       (if result
3442           (progn
3443             (message "Couldn't send message via news: %s"
3444                      (nnheader-get-report (car method)))
3445             nil)
3446         (push 'news message-sent-message-via)))))
3447
3448 ;; 1997-09-29 by MORIOKA Tomohiko
3449 (defun message-send-news-with-gnus (method)
3450   (let ((case-fold-search t))
3451     ;; Remove the delimiter.
3452     (goto-char (point-min))
3453     (re-search-forward
3454      (concat "^" (regexp-quote mail-header-separator) "\n"))
3455     (replace-match "\n")
3456     (backward-char 1)
3457     (run-hooks 'message-send-news-hook)
3458     (gnus-open-server method)
3459     (message "Sending news with %s..." (gnus-server-string method))
3460     (gnus-request-post method)
3461     ))
3462
3463 ;;;
3464 ;;; Header generation & syntax checking.
3465 ;;;
3466
3467 (defun message-check-element (type)
3468   "Return non-nil if this TYPE is not to be checked."
3469   (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
3470       t
3471     (let ((able (assq type message-syntax-checks)))
3472       (and (consp able)
3473            (eq (cdr able) 'disabled)))))
3474
3475 (defun message-check-news-syntax ()
3476   "Check the syntax of the message."
3477   (save-excursion
3478     (save-restriction
3479       (widen)
3480       (and
3481        ;; We narrow to the headers and check them first.
3482        (save-excursion
3483          (save-restriction
3484            (message-narrow-to-headers)
3485            (message-check-news-header-syntax)))
3486        ;; Check the body.
3487        (save-excursion
3488          (set-buffer message-edit-buffer)
3489          (message-check-news-body-syntax))))))
3490
3491 (defun message-check-news-header-syntax ()
3492   (and
3493    ;; Check Newsgroups header.
3494    (message-check 'newsgroups
3495      (let ((group (message-fetch-field "newsgroups")))
3496        (or
3497         (and group
3498              (not (string-match "\\`[ \t]*\\'" group)))
3499         (ignore
3500          (message
3501           "The newsgroups field is empty or missing.  Posting is denied.")))))
3502    ;; Check the Subject header.
3503    (message-check 'subject
3504      (let* ((case-fold-search t)
3505             (subject (message-fetch-field "subject")))
3506        (or
3507         (and subject
3508              (not (string-match "\\`[ \t]*\\'" subject)))
3509         (ignore
3510          (message
3511           "The subject field is empty or missing.  Posting is denied.")))))
3512    ;; Check for commands in Subject.
3513    (message-check 'subject-cmsg
3514      (if (string-match "^cmsg " (message-fetch-field "subject"))
3515          (y-or-n-p
3516           "The control code \"cmsg\" is in the subject.  Really post? ")
3517        t))
3518    ;; Check for multiple identical headers.
3519    (message-check 'multiple-headers
3520      (let (found)
3521        (while (and (not found)
3522                    (re-search-forward "^[^ \t:]+: " nil t))
3523          (save-excursion
3524            (or (re-search-forward
3525                 (concat "^"
3526                         (regexp-quote
3527                          (setq found
3528                                (buffer-substring
3529                                 (match-beginning 0) (- (match-end 0) 2))))
3530                         ":")
3531                 nil t)
3532                (setq found nil))))
3533        (if found
3534            (y-or-n-p (format "Multiple %s headers.  Really post? " found))
3535          t)))
3536    ;; Check for Version and Sendsys.
3537    (message-check 'sendsys
3538      (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
3539          (y-or-n-p
3540           (format "The article contains a %s command.  Really post? "
3541                   (buffer-substring (match-beginning 0)
3542                                     (1- (match-end 0)))))
3543        t))
3544    ;; See whether we can shorten Followup-To.
3545    (message-check 'shorten-followup-to
3546      (let ((newsgroups (message-fetch-field "newsgroups"))
3547            (followup-to (message-fetch-field "followup-to"))
3548            to)
3549        (when (and newsgroups
3550                   (string-match "," newsgroups)
3551                   (not followup-to)
3552                   (not
3553                    (zerop
3554                     (length
3555                      (setq to (completing-read
3556                                "Followups to: (default all groups) "
3557                                (mapcar (lambda (g) (list g))
3558                                        (cons "poster"
3559                                              (message-tokenize-header
3560                                               newsgroups)))))))))
3561          (goto-char (point-min))
3562          (insert "Followup-To: " to "\n"))
3563        t))
3564    ;; Check "Shoot me".
3565    (message-check 'shoot
3566      (if (re-search-forward
3567           "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
3568          (y-or-n-p "You appear to have a misconfigured system.  Really post? ")
3569        t))
3570    ;; Check for Approved.
3571    (message-check 'approved
3572      (if (re-search-forward "^Approved:" nil t)
3573          (y-or-n-p "The article contains an Approved header.  Really post? ")
3574        t))
3575    ;; Check the Message-ID header.
3576    (message-check 'message-id
3577      (let* ((case-fold-search t)
3578             (message-id (message-fetch-field "message-id" t)))
3579        (or (not message-id)
3580            ;; Is there an @ in the ID?
3581            (and (string-match "@" message-id)
3582                 ;; Is there a dot in the ID?
3583                 (string-match "@[^.]*\\." message-id)
3584                 ;; Does the ID end with a dot?
3585                 (not (string-match "\\.>" message-id)))
3586            (y-or-n-p
3587             (format "The Message-ID looks strange: \"%s\".  Really post? "
3588                     message-id)))))
3589    ;; Check the Newsgroups & Followup-To headers.
3590    (message-check 'existing-newsgroups
3591      (let* ((case-fold-search t)
3592             (newsgroups (message-fetch-field "newsgroups"))
3593             (followup-to (message-fetch-field "followup-to"))
3594             (groups (message-tokenize-header
3595                      (if followup-to
3596                          (concat newsgroups "," followup-to)
3597                        newsgroups)))
3598             (hashtb (and (boundp 'gnus-active-hashtb)
3599                          gnus-active-hashtb))
3600             errors)
3601        (while groups
3602          (when (and (not (boundp (intern (car groups) hashtb)))
3603                     (not (equal (car groups) "poster")))
3604            (push (car groups) errors))
3605          (pop groups))
3606        (cond
3607         ;; Gnus is not running.
3608         ((or (not hashtb)
3609              (not (boundp 'gnus-read-active-file)))
3610          t)
3611         ;; We don't have all the group names.
3612         ((and (or (not gnus-read-active-file)
3613                   (eq gnus-read-active-file 'some))
3614               errors)
3615          (y-or-n-p
3616           (format
3617            "Really post to %s possibly unknown group%s: %s? "
3618            (if (= (length errors) 1) "this" "these")
3619            (if (= (length errors) 1) "" "s")
3620            (mapconcat 'identity errors ", "))))
3621         ;; There were no errors.
3622         ((not errors)
3623          t)
3624         ;; There are unknown groups.
3625         (t
3626          (y-or-n-p
3627           (format
3628            "Really post to %s unknown group%s: %s? "
3629            (if (= (length errors) 1) "this" "these")
3630            (if (= (length errors) 1) "" "s")
3631            (mapconcat 'identity errors ", ")))))))
3632      ;; Check the Newsgroups & Followup-To headers for syntax errors.
3633      (message-check 'valid-newsgroups
3634        (let ((case-fold-search t)
3635              (headers '("Newsgroups" "Followup-To"))
3636              header error)
3637          (while (and headers (not error))
3638            (when (setq header (mail-fetch-field (car headers)))
3639              (if (or
3640                   (not
3641                    (string-match
3642                     "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
3643                     header))
3644                   (memq
3645                    nil (mapcar
3646                         (lambda (g)
3647                           (not (string-match "\\.\\'\\|\\.\\." g)))
3648                         (message-tokenize-header header ","))))
3649                  (setq error t)))
3650            (unless error
3651              (pop headers)))
3652          (if (not error)
3653              t
3654            (y-or-n-p
3655             (format "The %s header looks odd: \"%s\".  Really post? "
3656                     (car headers) header)))))
3657      (message-check 'repeated-newsgroups
3658        (let ((case-fold-search t)
3659              (headers '("Newsgroups" "Followup-To"))
3660              header error groups group)
3661          (while (and headers
3662                      (not error))
3663            (when (setq header (mail-fetch-field (pop headers)))
3664              (setq groups (message-tokenize-header header ","))
3665              (while (setq group (pop groups))
3666                (when (member group groups)
3667                  (setq error group
3668                        groups nil)))))
3669          (if (not error)
3670              t
3671            (y-or-n-p
3672             (format "Group %s is repeated in headers.  Really post? " error)))))
3673      ;; Check the From header.
3674      (message-check 'from
3675        (let* ((case-fold-search t)
3676               (from (message-fetch-field "from"))
3677               ad)
3678          (cond
3679           ((not from)
3680            (message "There is no From line.  Posting is denied.")
3681            nil)
3682           ((or (not (string-match
3683                      "@[^\\.]*\\."
3684                      (setq ad (nth 1 (mail-extract-address-components
3685                                       from))))) ;larsi@ifi
3686                (string-match "\\.\\." ad) ;larsi@ifi..uio
3687                (string-match "@\\." ad) ;larsi@.ifi.uio
3688                (string-match "\\.$" ad) ;larsi@ifi.uio.
3689                (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
3690                (string-match "(.*).*(.*)" from)) ;(lars) (lars)
3691            (message
3692             "Denied posting -- the From looks strange: \"%s\"." from)
3693            nil)
3694           (t t))))
3695      ;; Check the Reply-To header.
3696      (message-check 'reply-to
3697        (let* ((case-fold-search t)
3698               (reply-to (message-fetch-field "reply-to"))
3699               ad)
3700          (cond
3701           ((not reply-to)
3702            t)
3703           ((string-match "," reply-to)
3704            (y-or-n-p
3705             (format "Multiple Reply-To addresses: \"%s\". Really post? "
3706                     reply-to)))
3707           ((or (not (string-match
3708                      "@[^\\.]*\\."
3709                      (setq ad (nth 1 (mail-extract-address-components
3710                                       reply-to))))) ;larsi@ifi
3711                (string-match "\\.\\." ad) ;larsi@ifi..uio
3712                (string-match "@\\." ad) ;larsi@.ifi.uio
3713                (string-match "\\.$" ad) ;larsi@ifi.uio.
3714                (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
3715                (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars)
3716            (y-or-n-p
3717             (format
3718              "The Reply-To looks strange: \"%s\". Really post? "
3719              reply-to)))
3720           (t t))))))
3721
3722 (defun message-check-news-body-syntax ()
3723   (and
3724    ;; Check for long lines.
3725    (message-check 'long-lines
3726      (goto-char (point-min))
3727      (re-search-forward
3728       (concat "^" (regexp-quote mail-header-separator) "$"))
3729      (forward-line 1)
3730      (while (and
3731              (or (looking-at
3732                   mime-edit-tag-regexp)
3733                  (let ((p (point)))
3734                    (end-of-line)
3735                    (< (- (point) p) 80)))
3736              (zerop (forward-line 1))))
3737      (or (bolp)
3738          (eobp)
3739          (y-or-n-p
3740           "You have lines longer than 79 characters.  Really post? ")))
3741    ;; Check whether the article is empty.
3742    (message-check 'empty
3743      (goto-char (point-min))
3744      (re-search-forward
3745       (concat "^" (regexp-quote mail-header-separator) "$"))
3746      (forward-line 1)
3747      (let ((b (point)))
3748        (goto-char (point-max))
3749        (re-search-backward message-signature-separator nil t)
3750        (beginning-of-line)
3751        (or (re-search-backward "[^ \n\t]" b t)
3752            (if (message-gnksa-enable-p 'empty-article)
3753                (y-or-n-p "Empty article.  Really post? ")
3754              (message "Denied posting -- Empty article.")
3755              nil))))
3756    ;; Check for control characters.
3757    (message-check 'control-chars
3758      (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
3759          (y-or-n-p
3760           "The article contains control characters.  Really post? ")
3761        t))
3762    ;; Check 8bit characters.
3763    (message-check '8bit
3764      (message-check-8bit))
3765    ;; Check excessive size.
3766    (message-check 'size
3767      (if (> (buffer-size) 60000)
3768          (y-or-n-p
3769           (format "The article is %d octets long.  Really post? "
3770                   (buffer-size)))
3771        t))
3772    ;; Check whether any new text has been added.
3773    (message-check 'new-text
3774      (or
3775       (not message-checksum)
3776       (not (eq (message-checksum) message-checksum))
3777       (if (message-gnksa-enable-p 'quoted-text-only)
3778           (y-or-n-p
3779            "It looks like no new text has been added.  Really post? ")
3780         (message "Denied posting -- no new text has been added.")
3781         nil)))
3782    ;; Check the length of the signature.
3783    (message-check 'signature
3784      (goto-char (point-max))
3785      (if (> (count-lines (point) (point-max)) 5)
3786          (y-or-n-p
3787           (format
3788            "Your .sig is %d lines; it should be max 4.  Really post? "
3789            (1- (count-lines (point) (point-max)))))
3790        t))
3791    ;; Ensure that text follows last quoted portion.
3792    (message-check 'quoting-style
3793      (goto-char (point-max))
3794      (let ((no-problem t))
3795        (when (search-backward-regexp "^>[^\n]*\n" nil t)
3796          (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t)))
3797        (if no-problem
3798            t
3799          (if (message-gnksa-enable-p 'quoted-text-only)
3800              (y-or-n-p "Your text should follow quoted text.  Really post? ")
3801            ;; Ensure that
3802            (goto-char (point-min))
3803            (re-search-forward
3804             (concat "^" (regexp-quote mail-header-separator) "$"))
3805            (if (search-forward-regexp "^[ \t]*[^>\n]" nil t)
3806                (y-or-n-p "Your text should follow quoted text.  Really post? ")
3807              (message "Denied posting -- only quoted text.")
3808              nil)))))))
3809
3810 (defun message-check-mail-syntax ()
3811   "Check the syntax of the message."
3812   (save-excursion
3813     (save-restriction
3814       (widen)
3815       (and
3816        ;; We narrow to the headers and check them first.
3817        (save-excursion
3818          (save-restriction
3819            (message-narrow-to-headers)
3820            (message-check-mail-header-syntax)))
3821        ;; Check the body.
3822        (save-excursion
3823          (set-buffer message-edit-buffer)
3824          (message-check-mail-body-syntax))))))
3825
3826 (defun message-check-mail-header-syntax ()
3827   t)
3828
3829 (defun message-check-mail-body-syntax ()
3830   (and
3831    ;; Check 8bit characters.
3832    (message-check '8bit
3833      (message-check-8bit)
3834      )))
3835
3836 (defun message-check-8bit ()
3837   "Check the article contains 8bit characters."
3838   (save-excursion
3839     (set-buffer message-encoding-buffer)
3840     (message-narrow-to-headers)
3841     (let* ((case-fold-search t)
3842            (field-value (message-fetch-field "content-transfer-encoding")))
3843       (if (and field-value
3844                (member (downcase field-value) message-8bit-encoding-list))
3845           t
3846         (widen)
3847         (set-buffer (get-buffer-create " message syntax"))
3848         (erase-buffer)
3849         (goto-char (point-min))
3850         (set-buffer-multibyte nil)
3851         (insert-buffer message-encoding-buffer)
3852         (goto-char (point-min))
3853         (if (re-search-forward "[^\x00-\x7f]" nil t)
3854             (y-or-n-p
3855              "The article contains 8bit characters.  Really post? ")
3856           t)))))
3857
3858 (defun message-checksum ()
3859   "Return a \"checksum\" for the current buffer."
3860   (let ((sum 0))
3861     (save-excursion
3862       (goto-char (point-min))
3863       (re-search-forward
3864        (concat "^" (regexp-quote mail-header-separator) "$"))
3865       (while (not (eobp))
3866         (when (not (looking-at "[ \t\n]"))
3867           (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
3868                             (char-after))))
3869         (forward-char 1)))
3870     sum))
3871
3872 (defun message-do-fcc ()
3873   "Process Fcc headers in the current buffer."
3874   (let ((case-fold-search t)
3875         (coding-system-for-write 'raw-text)
3876         (output-coding-system 'raw-text)
3877         list file)
3878     (save-excursion
3879       (save-restriction
3880         (message-narrow-to-headers)
3881         (setq file (message-fetch-field "fcc" t)))
3882       (when file
3883         (set-buffer (get-buffer-create " *message temp*"))
3884         (erase-buffer)
3885         (insert-buffer-substring message-encoding-buffer)
3886         (save-restriction
3887           (message-narrow-to-headers)
3888           (while (setq file (message-fetch-field "fcc"))
3889             (push file list)
3890             (message-remove-header "fcc" nil t)))
3891         (goto-char (point-min))
3892         (when (re-search-forward
3893                (concat "^" (regexp-quote mail-header-separator) "$")
3894                nil t)
3895           (replace-match "" t t))
3896         ;; Process FCC operations.
3897         (while list
3898           (setq file (pop list))
3899           (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
3900               ;; Pipe the article to the program in question.
3901               (call-process-region (point-min) (point-max) shell-file-name
3902                                    nil nil nil shell-command-switch
3903                                    (match-string 1 file))
3904             ;; Save the article.
3905             (setq file (expand-file-name file))
3906             (unless (file-exists-p (file-name-directory file))
3907               (make-directory (file-name-directory file) t))
3908             (if (and message-fcc-handler-function
3909                      (not (eq message-fcc-handler-function 'rmail-output)))
3910                 (funcall message-fcc-handler-function file)
3911               (if (and (file-readable-p file) (mail-file-babyl-p file))
3912                   (rmail-output file 1 nil t)
3913                 (let ((mail-use-rfc822 t))
3914                   (rmail-output file 1 t t))))))
3915         (kill-buffer (current-buffer))))))
3916
3917 (defun message-output (filename)
3918   "Append this article to Unix/babyl mail file FILENAME."
3919   (if (and (file-readable-p filename)
3920            (mail-file-babyl-p filename))
3921       (gnus-output-to-rmail filename t)
3922     (gnus-output-to-mail filename t)))
3923
3924 (defun message-cleanup-headers ()
3925   "Do various automatic cleanups of the headers."
3926   ;; Remove empty lines in the header.
3927   (save-restriction
3928     (message-narrow-to-headers)
3929     ;; Remove blank lines.
3930     (while (re-search-forward "^[ \t]*\n" nil t)
3931       (replace-match "" t t))
3932
3933     ;; Correct Newsgroups and Followup-To headers:  Change sequence of
3934     ;; spaces to comma and eliminate spaces around commas.  Eliminate
3935     ;; embedded line breaks.
3936     (goto-char (point-min))
3937     (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
3938       (save-restriction
3939         (narrow-to-region
3940          (point)
3941          (if (re-search-forward "^[^ \t]" nil t)
3942              (match-beginning 0)
3943            (forward-line 1)
3944            (point)))
3945         (goto-char (point-min))
3946         (while (re-search-forward "\n[ \t]+" nil t)
3947           (replace-match " " t t))      ;No line breaks (too confusing)
3948         (goto-char (point-min))
3949         (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
3950           (replace-match "," t t))
3951         (goto-char (point-min))
3952         ;; Remove trailing commas.
3953         (when (re-search-forward ",+$" nil t)
3954           (replace-match "" t t))))))
3955
3956 (defun message-make-date (&optional now)
3957   "Make a valid data header.
3958 If NOW, use that time instead."
3959   (let* ((now (or now (current-time)))
3960          (zone (nth 8 (decode-time now)))
3961          (sign "+"))
3962     (when (< zone 0)
3963       (setq sign "-")
3964       (setq zone (- zone)))
3965     (concat
3966      (format-time-string "%a, %d" now)
3967      ;; The month name of the %b spec is locale-specific.  Pfff.
3968      (format " %s "
3969              (capitalize (car (rassoc (nth 4 (decode-time now))
3970                                       parse-time-months))))
3971      (format-time-string "%Y %H:%M:%S " now)
3972      ;; We do all of this because XEmacs doesn't have the %z spec.
3973      (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
3974
3975 (defun message-make-followup-subject (subject)
3976   "Make a followup Subject."
3977   (cond
3978    ((and (eq message-use-subject-re 'guess)
3979          (string-match message-subject-encoded-re-regexp subject))
3980     subject)
3981    (message-use-subject-re
3982     (concat "Re: " (message-strip-subject-re subject)))
3983    (t subject)))
3984
3985 (defun message-make-message-id ()
3986   "Make a unique Message-ID."
3987   (concat "<" (message-unique-id)
3988           (let ((psubject (save-excursion (message-fetch-field "subject")))
3989                 (psupersedes
3990                  (save-excursion (message-fetch-field "supersedes"))))
3991             (if (or
3992                  (and message-reply-headers
3993                       (mail-header-references message-reply-headers)
3994                       (mail-header-subject message-reply-headers)
3995                       psubject
3996                       (not (string=
3997                             (message-strip-subject-re
3998                              (mail-header-subject message-reply-headers))
3999                             (message-strip-subject-re psubject))))
4000                  (and psupersedes
4001                       (string-match "_-_@" psupersedes)))
4002                 "_-_" ""))
4003           "@" (message-make-fqdn) ">"))
4004
4005 (defvar message-unique-id-char nil)
4006
4007 ;; If you ever change this function, make sure the new version
4008 ;; cannot generate IDs that the old version could.
4009 ;; You might for example insert a "." somewhere (not next to another dot
4010 ;; or string boundary), or modify the "fsf" string.
4011 (defun message-unique-id ()
4012   ;; Don't use microseconds from (current-time), they may be unsupported.
4013   ;; Instead we use this randomly inited counter.
4014   (setq message-unique-id-char
4015         (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
4016            ;; (current-time) returns 16-bit ints,
4017            ;; and 2^16*25 just fits into 4 digits i base 36.
4018            (* 25 25)))
4019   (let ((tm (current-time)))
4020     (concat
4021      (if (memq system-type '(ms-dos emx vax-vms))
4022          (let ((user (downcase (user-login-name))))
4023            (while (string-match "[^a-z0-9_]" user)
4024              (aset user (match-beginning 0) ?_))
4025            user)
4026        (message-number-base36 (user-uid) -1))
4027      (message-number-base36 (+ (car   tm)
4028                                (lsh (% message-unique-id-char 25) 16)) 4)
4029      (message-number-base36 (+ (nth 1 tm)
4030                                (lsh (/ message-unique-id-char 25) 16)) 4)
4031      ;; Append the newsreader name, because while the generated
4032      ;; ID is unique to this newsreader, other newsreaders might
4033      ;; otherwise generate the same ID via another algorithm.
4034      ".fsf")))
4035
4036 (defun message-number-base36 (num len)
4037   (if (if (< len 0)
4038           (<= num 0)
4039         (= len 0))
4040       ""
4041     (concat (message-number-base36 (/ num 36) (1- len))
4042             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
4043                                   (% num 36))))))
4044
4045 (defun message-make-organization ()
4046   "Make an Organization header."
4047   (let* ((organization
4048           (when message-user-organization
4049             (if (message-functionp message-user-organization)
4050                 (funcall message-user-organization)
4051               message-user-organization))))
4052     (save-excursion
4053       (message-set-work-buffer)
4054       (cond ((stringp organization)
4055              (insert organization))
4056             ((and (eq t organization)
4057                   message-user-organization-file
4058                   (file-exists-p message-user-organization-file))
4059              (insert-file-contents message-user-organization-file)))
4060       (goto-char (point-min))
4061       (while (re-search-forward "[\t\n]+" nil t)
4062         (replace-match "" t t))
4063       (unless (zerop (buffer-size))
4064         (buffer-string)))))
4065
4066 (defun message-make-lines ()
4067   "Count the number of lines and return numeric string."
4068   (save-excursion
4069     (save-restriction
4070       (widen)
4071       (message-goto-body)
4072       (int-to-string (count-lines (point) (point-max))))))
4073
4074 (defun message-make-in-reply-to ()
4075   "Return the In-Reply-To header for this message."
4076   (when message-reply-headers
4077     (let ((from (mail-header-from message-reply-headers))
4078           (date (mail-header-date message-reply-headers))
4079           (msg-id (mail-header-message-id message-reply-headers)))
4080       (when msg-id
4081         (concat msg-id
4082                 (when from
4083                   (let ((pair (std11-extract-address-components from)))
4084                     (concat "\n ("
4085                             (or (car pair) (cadr pair))
4086                             "'s message of \""
4087                             (if (or (not date) (string= date ""))
4088                                 "(unknown date)" date)
4089                             "\")"))))))))
4090
4091 (defun message-make-distribution ()
4092   "Make a Distribution header."
4093   (let ((orig-distribution (message-fetch-reply-field "distribution")))
4094     (cond ((message-functionp message-distribution-function)
4095            (funcall message-distribution-function))
4096           (t orig-distribution))))
4097
4098 (defun message-make-expires ()
4099   "Return an Expires header based on `message-expires'."
4100   (let ((current (current-time))
4101         (future (* 1.0 message-expires 60 60 24)))
4102     ;; Add the future to current.
4103     (setcar current (+ (car current) (round (/ future (expt 2 16)))))
4104     (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
4105     (message-make-date current)))
4106
4107 (defun message-make-path ()
4108   "Return uucp path."
4109   (let ((login-name (user-login-name)))
4110     (cond ((null message-user-path)
4111            (concat (system-name) "!" login-name))
4112           ((stringp message-user-path)
4113            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
4114            (concat message-user-path "!" login-name))
4115           (t login-name))))
4116
4117 (defun message-make-from ()
4118   "Make a From header."
4119   (let* ((style message-from-style)
4120          (login (message-make-address))
4121          (fullname
4122           (or (and (boundp 'user-full-name)
4123                    user-full-name)
4124               (user-full-name))))
4125     (when (string= fullname "&")
4126       (setq fullname (user-login-name)))
4127     (save-excursion
4128       (message-set-work-buffer)
4129       (cond
4130        ((or (null style)
4131             (equal fullname ""))
4132         (insert login))
4133        ((or (eq style 'angles)
4134             (and (not (eq style 'parens))
4135                  ;; Use angles if no quoting is needed, or if parens would
4136                  ;; need quoting too.
4137                  (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
4138                      (let ((tmp (concat fullname nil)))
4139                        (while (string-match "([^()]*)" tmp)
4140                          (aset tmp (match-beginning 0) ?-)
4141                          (aset tmp (1- (match-end 0)) ?-))
4142                        (string-match "[\\()]" tmp)))))
4143         (insert fullname)
4144         (goto-char (point-min))
4145         ;; Look for a character that cannot appear unquoted
4146         ;; according to RFC 822.
4147         (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
4148           ;; Quote fullname, escaping specials.
4149           (goto-char (point-min))
4150           (insert "\"")
4151           (while (re-search-forward "[\"\\]" nil 1)
4152             (replace-match "\\\\\\&" t))
4153           (insert "\""))
4154         (insert " <" login ">"))
4155        (t                               ; 'parens or default
4156         (insert login " (")
4157         (let ((fullname-start (point)))
4158           (insert fullname)
4159           (goto-char fullname-start)
4160           ;; RFC 822 says \ and nonmatching parentheses
4161           ;; must be escaped in comments.
4162           ;; Escape every instance of ()\ ...
4163           (while (re-search-forward "[()\\]" nil 1)
4164             (replace-match "\\\\\\&" t))
4165           ;; ... then undo escaping of matching parentheses,
4166           ;; including matching nested parentheses.
4167           (goto-char fullname-start)
4168           (while (re-search-forward
4169                   "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
4170                   nil 1)
4171             (replace-match "\\1(\\3)" t)
4172             (goto-char fullname-start)))
4173         (insert ")")))
4174       (buffer-string))))
4175
4176 (defun message-make-sender ()
4177   "Return the \"real\" user address.
4178 This function tries to ignore all user modifications, and
4179 give as trustworthy answer as possible."
4180   (concat (user-login-name) "@" (system-name)))
4181
4182 (defun message-make-address ()
4183   "Make the address of the user."
4184   (or (message-user-mail-address)
4185       (concat (user-login-name) "@" (message-make-domain))))
4186
4187 (defun message-user-mail-address ()
4188   "Return the pertinent part of `user-mail-address'."
4189   (when user-mail-address
4190     (if (string-match " " user-mail-address)
4191         (nth 1 (std11-extract-address-components user-mail-address))
4192       user-mail-address)))
4193
4194 (defun message-make-fqdn ()
4195   "Return user's fully qualified domain name."
4196   (let ((system-name (system-name))
4197         (user-mail (message-user-mail-address)))
4198     (cond
4199      ((string-match "[^.]\\.[^.]" system-name)
4200       ;; `system-name' returned the right result.
4201       system-name)
4202      ;; Try `mail-host-address'.
4203      ((and (boundp 'mail-host-address)
4204            (stringp mail-host-address)
4205            (string-match "\\." mail-host-address))
4206       mail-host-address)
4207      ;; We try `user-mail-address' as a backup.
4208      ((and user-mail
4209            (string-match "\\." user-mail)
4210            (string-match "@\\(.*\\)\\'" user-mail))
4211       (match-string 1 user-mail))
4212      ;; Default to this bogus thing.
4213      (t
4214       (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me")))))
4215
4216 (defun message-make-host-name ()
4217   "Return the name of the host."
4218   (let ((fqdn (message-make-fqdn)))
4219     (string-match "^[^.]+\\." fqdn)
4220     (substring fqdn 0 (1- (match-end 0)))))
4221
4222 (defun message-make-domain ()
4223   "Return the domain name."
4224   (or mail-host-address
4225       (message-make-fqdn)))
4226
4227 ;; Dummy to avoid byte-compile warning.
4228 (defvar mule-version)
4229 (defvar emacs-beta-version)
4230 (defvar xemacs-codename)
4231 (defvar gnus-inviolable-extended-version)
4232
4233 (defun message-make-user-agent ()
4234   "Return user-agent info if the value `message-user-agent' is non-nil. If the
4235 \"User-Agent\" field has already exist, it's value will be added in the return
4236 string."
4237   (when message-user-agent
4238     (save-excursion
4239       (goto-char (point-min))
4240       (let ((case-fold-search t)
4241             user-agent start p end)
4242         (if (re-search-forward "^User-Agent:[\t ]*" nil t)
4243             (progn
4244               (setq start (match-beginning 0)
4245                     p (match-end 0)
4246                     end (std11-field-end)
4247                     user-agent (buffer-substring-no-properties p end))
4248               (delete-region start (1+ end))
4249               (concat message-user-agent " " user-agent))
4250           message-user-agent)))))
4251
4252 (defun message-generate-headers (headers)
4253   "Prepare article HEADERS.
4254 Headers already prepared in the buffer are not modified."
4255   (save-restriction
4256     (message-narrow-to-headers)
4257     (let* ((Date (message-make-date))
4258            (Message-ID (message-make-message-id))
4259            (Organization (message-make-organization))
4260            (From (message-make-from))
4261            (Path (message-make-path))
4262            (Subject nil)
4263            (Newsgroups nil)
4264            (In-Reply-To (message-make-in-reply-to))
4265            (To nil)
4266            (Distribution (message-make-distribution))
4267            (Lines (message-make-lines))
4268            (User-Agent (message-make-user-agent))
4269            (Expires (message-make-expires))
4270            (case-fold-search t)
4271            header value elem)
4272       ;; First we remove any old generated headers.
4273       (let ((headers message-deletable-headers))
4274         (unless (buffer-modified-p)
4275           (setq headers (delq 'Message-ID (copy-sequence headers))))
4276         (while headers
4277           (goto-char (point-min))
4278           (and (re-search-forward
4279                 (concat "^" (symbol-name (car headers)) ": *") nil t)
4280                (get-text-property (1+ (match-beginning 0)) 'message-deletable)
4281                (message-delete-line))
4282           (pop headers)))
4283       ;; Go through all the required headers and see if they are in the
4284       ;; articles already.  If they are not, or are empty, they are
4285       ;; inserted automatically - except for Subject, Newsgroups and
4286       ;; Distribution.
4287       (while headers
4288         (goto-char (point-min))
4289         (setq elem (pop headers))
4290         (if (consp elem)
4291             (if (eq (car elem) 'optional)
4292                 (setq header (cdr elem))
4293               (setq header (car elem)))
4294           (setq header elem))
4295         (when (or (not (re-search-forward
4296                         (concat "^"
4297                                 (regexp-quote
4298                                  (downcase
4299                                   (if (stringp header)
4300                                       header
4301                                     (symbol-name header))))
4302                                 ":")
4303                         nil t))
4304                   (progn
4305                     ;; The header was found.  We insert a space after the
4306                     ;; colon, if there is none.
4307                     (if (/= (char-after) ? ) (insert " ") (forward-char 1))
4308                     ;; Find out whether the header is empty...
4309                     (looking-at "[ \t]*\n[^ \t]")))
4310           ;; So we find out what value we should insert.
4311           (setq value
4312                 (cond
4313                  ((and (consp elem) (eq (car elem) 'optional))
4314                   ;; This is an optional header.  If the cdr of this
4315                   ;; is something that is nil, then we do not insert
4316                   ;; this header.
4317                   (setq header (cdr elem))
4318                   (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
4319                       (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
4320                  ((consp elem)
4321                   ;; The element is a cons.  Either the cdr is a
4322                   ;; string to be inserted verbatim, or it is a
4323                   ;; function, and we insert the value returned from
4324                   ;; this function.
4325                   (or (and (stringp (cdr elem)) (cdr elem))
4326                       (and (fboundp (cdr elem)) (funcall (cdr elem)))))
4327                  ((and (boundp header) (symbol-value header))
4328                   ;; The element is a symbol.  We insert the value
4329                   ;; of this symbol, if any.
4330                   (symbol-value header))
4331                  ((not (message-check-element header))
4332                   ;; We couldn't generate a value for this header,
4333                   ;; so we just ask the user.
4334                   (read-from-minibuffer
4335                    (format "Empty header for %s; enter value: " header)))))
4336           ;; Finally insert the header.
4337           (when (and value
4338                      (not (equal value "")))
4339             (save-excursion
4340               (if (bolp)
4341                   (progn
4342                     ;; This header didn't exist, so we insert it.
4343                     (goto-char (point-max))
4344                     (insert (if (stringp header) header (symbol-name header))
4345                             ": " value)
4346                     (unless (bolp)
4347                       (insert "\n"))
4348                     (forward-line -1))
4349                 ;; The value of this header was empty, so we clear
4350                 ;; totally and insert the new value.
4351                 (delete-region (point) (gnus-point-at-eol))
4352                 (insert value)
4353                 (when (bolp)
4354                   (delete-char -1)))
4355               ;; Add the deletable property to the headers that require it.
4356               (and (memq header message-deletable-headers)
4357                    (progn (beginning-of-line) (looking-at "[^:]+: "))
4358                    (add-text-properties
4359                     (point) (match-end 0)
4360                     '(message-deletable t face italic) (current-buffer)))))))
4361       ;; Insert new Sender if the From is strange.
4362       (let ((from (message-fetch-field "from"))
4363             (sender (message-fetch-field "sender"))
4364             (secure-sender (message-make-sender)))
4365         (when (and from
4366                    (not (message-check-element 'sender))
4367                    (not (string=
4368                          (downcase
4369                           (cadr (std11-extract-address-components from)))
4370                          (downcase secure-sender)))
4371                    (or (null sender)
4372                        (not
4373                         (string=
4374                          (downcase
4375                           (cadr (std11-extract-address-components sender)))
4376                          (downcase secure-sender)))))
4377           (goto-char (point-min))
4378           ;; Rename any old Sender headers to Original-Sender.
4379           (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
4380             (beginning-of-line)
4381             (insert "Original-")
4382             (beginning-of-line))
4383           (when (or (message-news-p)
4384                     (string-match "@.+\\.." secure-sender))
4385             (insert "Sender: " secure-sender "\n")))))))
4386
4387 (defun message-insert-courtesy-copy ()
4388   "Insert a courtesy message in mail copies of combined messages."
4389   (let (newsgroups)
4390     (save-excursion
4391       (save-restriction
4392         (message-narrow-to-headers)
4393         (when (setq newsgroups (message-fetch-field "newsgroups"))
4394           (goto-char (point-max))
4395           (insert "Posted-To: " newsgroups "\n")))
4396       (forward-line 1)
4397       (when message-courtesy-message
4398         (cond
4399          ((string-match "%s" message-courtesy-message)
4400           (insert (format message-courtesy-message newsgroups)))
4401          (t
4402           (insert message-courtesy-message)))))))
4403
4404 ;;;
4405 ;;; Setting up a message buffer
4406 ;;;
4407
4408 (defun message-fill-address (header value)
4409   (save-restriction
4410     (narrow-to-region (point) (point))
4411     (insert (capitalize (symbol-name header))
4412             ": "
4413             (if (consp value) (car value) value)
4414             "\n")
4415     (narrow-to-region (point-min) (1- (point-max)))
4416     (let (quoted last)
4417       (goto-char (point-min))
4418       (while (not (eobp))
4419         (skip-chars-forward "^,\"" (point-max))
4420         (if (or (eq (char-after) ?,)
4421                 (eobp))
4422             (when (not quoted)
4423               (if (and (> (current-column) 78)
4424                        last)
4425                   (save-excursion
4426                     (goto-char last)
4427                     (looking-at "[ \t]*")
4428                     (replace-match "\n " t t)))
4429               (setq last (1+ (point))))
4430           (setq quoted (not quoted)))
4431         (unless (eobp)
4432           (forward-char 1))))
4433     (goto-char (point-max))
4434     (widen)
4435     (forward-line 1)))
4436
4437 (defun message-fill-references (header value)
4438   (insert (capitalize (symbol-name header))
4439           ": "
4440           (std11-fill-msg-id-list-string
4441           (if (consp value) (car value) value))
4442           "\n"))
4443
4444 (defun message-fill-header (header value)
4445   (let ((begin (point))
4446         (fill-column 78)
4447         (fill-prefix " "))
4448     (insert (capitalize (symbol-name header))
4449             ": "
4450             (if (consp value) (car value) value)
4451             "\n")
4452     (save-restriction
4453       (narrow-to-region begin (point))
4454       (fill-region-as-paragraph begin (point))
4455       ;; Tapdance around looong Message-IDs.
4456       (forward-line -1)
4457       (when (looking-at "[ \t]*$")
4458         (message-delete-line))
4459       (goto-char begin)
4460       (re-search-forward ":" nil t)
4461       (when (looking-at "\n[ \t]+")
4462         (replace-match " " t t))
4463       (goto-char (point-max)))))
4464
4465 (defun message-shorten-1 (list cut surplus)
4466   "Cut SURPLUS elements out of LIST, beginning with CUTth one."
4467   (setcdr (nthcdr (- cut 2) list)
4468           (nthcdr (+ (- cut 2) surplus 1) list)))
4469
4470 (defun message-shorten-references (header references)
4471   "Trim REFERENCES to be less than 31 Message-ID long, and fold them.
4472 If folding is disallowed, also check that the REFERENCES are less
4473 than 988 characters long, and if they are not, trim them until they are."
4474   (let ((maxcount 31)
4475         (count 0)
4476         (cut 6)
4477         refs)
4478     (with-temp-buffer
4479       (insert references)
4480       (goto-char (point-min))
4481       ;; Cons a list of valid references.
4482       (while (re-search-forward "<[^>]+>" nil t)
4483         (push (match-string 0) refs))
4484       (setq refs (nreverse refs)
4485             count (length refs)))
4486
4487     ;; If the list has more than MAXCOUNT elements, trim it by
4488     ;; removing the CUTth element and the required number of
4489     ;; elements that follow.
4490     (when (> count maxcount)
4491       (let ((surplus (- count maxcount)))
4492         (message-shorten-1 refs cut surplus)
4493         (decf count surplus)))
4494
4495     ;; If folding is disallowed, make sure the total length (including
4496     ;; the spaces between) will be less than MAXSIZE characters.
4497     ;;
4498     ;; Only disallow folding for News messages. At this point the headers
4499     ;; have not been generated, thus we use message-this-is-news directly.
4500     (when (and message-this-is-news message-cater-to-broken-inn)
4501       (let ((maxsize 988)
4502             (totalsize (+ (apply #'+ (mapcar #'length refs))
4503                           (1- count)))
4504             (surplus 0)
4505             (ptr (nthcdr (1- cut) refs)))
4506         ;; Decide how many elements to cut off...
4507         (while (> totalsize maxsize)
4508           (decf totalsize (1+ (length (car ptr))))
4509           (incf surplus)
4510           (setq ptr (cdr ptr)))
4511         ;; ...and do it.
4512         (when (> surplus 0)
4513           (message-shorten-1 refs cut surplus))))
4514
4515     ;; Finally, collect the references back into a string and insert
4516     ;; it into the buffer.
4517     (let ((refstring (mapconcat #'identity refs " ")))
4518       (if (and message-this-is-news message-cater-to-broken-inn)
4519           (insert (capitalize (symbol-name header)) ": "
4520                   refstring "\n")
4521         (message-fill-header header refstring)))))
4522
4523 (defun message-position-point ()
4524   "Move point to where the user probably wants to find it."
4525   (message-narrow-to-headers)
4526   (cond
4527    ((re-search-forward "^[^:]+:[ \t]*$" nil t)
4528     (search-backward ":" )
4529     (widen)
4530     (forward-char 1)
4531     (if (eq (char-after) ? )
4532         (forward-char 1)
4533       (insert " ")))
4534    (t
4535     (goto-char (point-max))
4536     (widen)
4537     (forward-line 1)
4538     (unless (looking-at "$")
4539       (forward-line 2)))
4540    (sit-for 0)))
4541
4542 (defun message-buffer-name (type &optional to group)
4543   "Return a new (unique) buffer name based on TYPE and TO."
4544   (cond
4545    ;; Generate a new buffer name The Message Way.
4546    ((eq message-generate-new-buffers 'unique)
4547     (generate-new-buffer-name
4548      (concat "*" type
4549              (if to
4550                  (concat " to "
4551                          (or (car (std11-extract-address-components to))
4552                              to) "")
4553                "")
4554              (if (and group (not (string= group ""))) (concat " on " group) "")
4555              "*")))
4556    ;; Check whether `message-generate-new-buffers' is a function,
4557    ;; and if so, call it.
4558    ((message-functionp message-generate-new-buffers)
4559     (funcall message-generate-new-buffers type to group))
4560    ((eq message-generate-new-buffers 'unsent)
4561     (generate-new-buffer-name
4562      (concat "*unsent " type
4563              (if to
4564                  (concat " to "
4565                          (or (car (mail-extract-address-components to))
4566                              to) "")
4567                "")
4568              (if (and group (not (string= group ""))) (concat " on " group) "")
4569              "*")))
4570    ;; Use standard name.
4571    (t
4572     (format "*%s message*" type))))
4573
4574 (defmacro message-pop-to-buffer-1 (buffer)
4575   `(if pop-up-frames
4576        (let (special-display-buffer-names
4577              special-display-regexps
4578              same-window-buffer-names
4579              same-window-regexps)
4580          (pop-to-buffer ,buffer))
4581      (pop-to-buffer ,buffer)))
4582
4583 (defun message-pop-to-buffer (name)
4584   "Pop to buffer NAME, and warn if it already exists and is modified."
4585   (let ((buffer (get-buffer name))
4586         (pop-up-frames (and (or (static-if (featurep 'xemacs)
4587                                     (device-on-window-system-p)
4588                                   window-system)
4589                                 (>= emacs-major-version 20))
4590                             message-use-multi-frames)))
4591     (if (and buffer
4592              (buffer-name buffer))
4593         (progn
4594           (message-pop-to-buffer-1 buffer)
4595           (when (and (buffer-modified-p)
4596                      (not (y-or-n-p
4597                            "Message already being composed; erase? ")))
4598             (error "Message being composed")))
4599       (message-pop-to-buffer-1 name))
4600     (erase-buffer)
4601     (message-mode)
4602     (when pop-up-frames
4603       (set (make-local-variable 'message-original-frame) (selected-frame)))))
4604
4605 (defun message-do-send-housekeeping ()
4606   "Kill old message buffers."
4607   ;; We might have sent this buffer already.  Delete it from the
4608   ;; list of buffers.
4609   (setq message-buffer-list (delq (current-buffer) message-buffer-list))
4610   (while (and message-max-buffers
4611               message-buffer-list
4612               (>= (length message-buffer-list) message-max-buffers))
4613     ;; Kill the oldest buffer -- unless it has been changed.
4614     (let ((buffer (pop message-buffer-list)))
4615       (when (and (buffer-name buffer)
4616                  (not (buffer-modified-p buffer)))
4617         (kill-buffer buffer))))
4618   ;; Rename the buffer.
4619   (if message-send-rename-function
4620       (funcall message-send-rename-function)
4621     ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
4622     (when (string-match
4623            "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
4624            (buffer-name))
4625       (let ((name (match-string 2 (buffer-name)))
4626             to group)
4627         (if (not (or (null name)
4628                      (string-equal name "mail")
4629                      (string-equal name "news")))
4630             (setq name (concat "*sent " name "*"))
4631           (setq to (message-fetch-field "to"))
4632           (setq group (message-fetch-field "newsgroups"))
4633           (setq name
4634                 (cond
4635                  (to (concat "*sent mail to "
4636                              (or (car (mail-extract-address-components to))
4637                                  to) "*"))
4638                  ((and group (not (string= group "")))
4639                   (concat "*sent news on " group "*"))
4640                  (t "*sent mail*"))))
4641         (unless (string-equal name (buffer-name))
4642           (rename-buffer name t)))))
4643   ;; Push the current buffer onto the list.
4644   (when message-max-buffers
4645     (setq message-buffer-list
4646           (nconc message-buffer-list (list (current-buffer))))))
4647
4648 (defun message-mail-user-agent ()
4649   (let ((mua (cond
4650               ((not message-mail-user-agent) nil)
4651               ((eq message-mail-user-agent t) mail-user-agent)
4652               (t message-mail-user-agent))))
4653     (if (memq mua '(message-user-agent gnus-user-agent))
4654         nil
4655       mua)))
4656
4657 (defun message-setup (headers &optional replybuffer actions switch-function)
4658   (let ((mua (message-mail-user-agent))
4659         subject to field yank-action)
4660     (if (not (and message-this-is-mail mua))
4661         (message-setup-1 headers replybuffer actions)
4662       (if replybuffer
4663           (setq yank-action (list 'insert-buffer replybuffer)))
4664       (setq headers (copy-sequence headers))
4665       (setq field (assq 'Subject headers))
4666       (when field
4667         (setq subject (cdr field))
4668         (setq headers (delq field headers)))
4669       (setq field (assq 'To headers))
4670       (when field
4671         (setq to (cdr field))
4672         (setq headers (delq field headers)))
4673       (let ((mail-user-agent mua))
4674         (compose-mail to subject
4675                       (mapcar (lambda (item)
4676                                 (cons
4677                                  (format "%s" (car item))
4678                                  (cdr item)))
4679                               headers)
4680                       nil switch-function yank-action actions)))))
4681
4682 ;;;(defvar mc-modes-alist)
4683 (defun message-setup-1 (headers &optional replybuffer actions)
4684 ;;;   (when (and (boundp 'mc-modes-alist)
4685 ;;;          (not (assq 'message-mode mc-modes-alist)))
4686 ;;;     (push '(message-mode (encrypt . mc-encrypt-message)
4687 ;;;                      (sign . mc-sign-message))
4688 ;;;       mc-modes-alist))
4689   (when actions
4690     (setq message-send-actions actions))
4691   (setq message-reply-buffer
4692         (or (message-get-parameter 'reply-buffer)
4693             replybuffer))
4694   (goto-char (point-min))
4695   ;; Insert all the headers.
4696   (mail-header-format
4697    (let ((h headers)
4698          (alist message-header-format-alist))
4699      (while h
4700        (unless (assq (caar h) message-header-format-alist)
4701          (push (list (caar h)) alist))
4702        (pop h))
4703      alist)
4704    headers)
4705   (delete-region (point) (progn (forward-line -1) (point)))
4706   (when message-default-headers
4707     (insert message-default-headers)
4708     (or (bolp) (insert ?\n)))
4709   (put-text-property
4710    (point)
4711    (progn
4712      (insert mail-header-separator "\n")
4713      (1- (point)))
4714    'read-only nil)
4715   (forward-line -1)
4716   (when (message-news-p)
4717     (when message-default-news-headers
4718       (insert message-default-news-headers)
4719       (or (bolp) (insert ?\n)))
4720     (when message-generate-headers-first
4721       (message-generate-headers
4722        (delq 'Lines
4723              (delq 'Subject
4724                    (copy-sequence message-required-news-headers))))))
4725   (when (message-mail-p)
4726     (when message-default-mail-headers
4727       (insert message-default-mail-headers)
4728       (or (bolp) (insert ?\n)))
4729     (when message-generate-headers-first
4730       (message-generate-headers
4731        (delq 'Lines
4732              (delq 'Subject
4733                    (copy-sequence message-required-mail-headers))))))
4734   (run-hooks 'message-signature-setup-hook)
4735   (message-insert-signature)
4736   (save-restriction
4737     (message-narrow-to-headers)
4738     (if message-alternative-emails
4739         (message-use-alternative-email-as-from))
4740     (run-hooks 'message-header-setup-hook))
4741   (set-buffer-modified-p nil)
4742   (setq buffer-undo-list nil)
4743   (run-hooks 'message-setup-hook)
4744   (message-position-point)
4745   (undo-boundary))
4746
4747 (defun message-set-auto-save-file-name ()
4748   "Associate the message buffer with a file in the drafts directory."
4749   (when message-auto-save-directory
4750     (unless (file-directory-p
4751              (directory-file-name message-auto-save-directory))
4752       (gnus-make-directory message-auto-save-directory))
4753     (if (gnus-alive-p)
4754         (setq message-draft-article
4755               (nndraft-request-associate-buffer "drafts"))
4756       (setq buffer-file-name (expand-file-name
4757                               (if (eq system-type 'windows-nt)
4758                                   "message"
4759                                 "*message*")
4760                               message-auto-save-directory))
4761       (setq buffer-auto-save-file-name (make-auto-save-file-name)))
4762     (clear-visited-file-modtime)
4763     (static-if (boundp 'MULE)
4764         (set-file-coding-system message-draft-coding-system)
4765       (setq buffer-file-coding-system message-draft-coding-system))))
4766
4767 (defun message-disassociate-draft ()
4768   "Disassociate the message buffer from the drafts directory."
4769   (when message-draft-article
4770     (nndraft-request-expire-articles
4771      (list message-draft-article) "drafts" nil t)))
4772
4773 (defun message-insert-headers ()
4774   "Generate the headers for the article."
4775   (interactive)
4776   (save-excursion
4777     (save-restriction
4778       (message-narrow-to-headers)
4779       (when (message-news-p)
4780         (message-generate-headers
4781          (delq 'Lines
4782                (delq 'Subject
4783                      (copy-sequence message-required-news-headers)))))
4784       (when (message-mail-p)
4785         (message-generate-headers
4786          (delq 'Lines
4787                (delq 'Subject
4788                      (copy-sequence message-required-mail-headers))))))))
4789
4790 \f
4791
4792 ;;;
4793 ;;; Commands for interfacing with message
4794 ;;;
4795
4796 ;;;###autoload
4797 (defun message-mail (&optional to subject
4798                                other-headers continue switch-function
4799                                yank-action send-actions)
4800   "Start editing a mail message to be sent.
4801 OTHER-HEADERS is an alist of header/value pairs."
4802   (interactive)
4803   (let ((message-this-is-mail t) replybuffer)
4804     (unless (message-mail-user-agent)
4805       (message-pop-to-buffer (message-buffer-name "mail" to)))
4806     ;; FIXME: message-mail should do something if YANK-ACTION is not
4807     ;; insert-buffer.
4808     (and (consp yank-action) (eq (car yank-action) 'insert-buffer)
4809          (setq replybuffer (nth 1 yank-action)))
4810     (message-setup
4811      (nconc
4812       `((To . ,(or to "")) (Subject . ,(or subject "")))
4813       (when other-headers other-headers))
4814      replybuffer send-actions)
4815     ;; FIXME: Should return nil if failure.
4816     t))
4817
4818 ;;;###autoload
4819 (defun message-news (&optional newsgroups subject)
4820   "Start editing a news article to be sent."
4821   (interactive)
4822   (let ((message-this-is-news t))
4823     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
4824     (message-setup `((Newsgroups . ,(or newsgroups ""))
4825                      (Subject . ,(or subject ""))))))
4826
4827 (defun message-get-reply-headers (wide &optional to-address)
4828   (let (follow-to mct never-mct from to cc reply-to mrt mft)
4829     ;; Find all relevant headers we need.
4830     (setq from (message-fetch-field "from")
4831           to (message-fetch-field "to")
4832           cc (message-fetch-field "cc")
4833           mct (when message-use-mail-copies-to
4834                 (message-fetch-field "mail-copies-to"))
4835           reply-to (message-fetch-field "reply-to")
4836           mrt (when message-use-mail-reply-to
4837                 (message-fetch-field "mail-reply-to"))
4838           mft (when (and (not (or to-address mrt reply-to))
4839                          (or message-use-followup-to
4840                              message-use-mail-followup-to))
4841                 (message-fetch-field "mail-followup-to")))
4842
4843     ;; Handle special values of Mail-Copies-To.
4844     (when mct
4845       (cond
4846        ((and (or (equal (downcase mct) "never")
4847                  (equal (downcase mct) "nobody")))
4848         (when (or (not (eq message-use-mail-copies-to 'ask))
4849                   (message-y-or-n-p
4850                    (concat "Obey Mail-Copies-To: never? ") t "\
4851 You should normally obey the Mail-Copies-To: header.
4852
4853         `Mail-Copies-To: " mct "'
4854 directs you not to send your response to the author."))
4855           (setq never-mct t))
4856         (setq mct nil))
4857        ((and (or (equal (downcase mct) "always")
4858                  (equal (downcase mct) "poster")))
4859         (if (or (not (eq message-use-mail-copies-to 'ask))
4860                 (message-y-or-n-p
4861                  (concat "Obey Mail-Copies-To: always? ") t "\
4862 You should normally obey the Mail-Copies-To: header.
4863
4864         `Mail-Copies-To: " mct "'
4865 sends a copy of your response to the author."))
4866             (setq mct (or mrt reply-to from))
4867           (setq mct nil)))
4868        ((and (eq message-use-mail-copies-to 'ask)
4869              (not (message-y-or-n-p
4870                    (concat "Obey Mail-Copies-To: " mct " ? ") t "\
4871 You should normally obey the Mail-Copies-To: header.
4872
4873         `Mail-Copies-To: " mct "'
4874 sends a copy of your response to " (if (string-match "," mct)
4875                                        "the specified addresses"
4876                                      "that address") ".")))
4877         (setq mct nil))))
4878
4879     ;; Handle Mail-Followup-To.
4880     (when (and mft
4881                (eq (or message-use-followup-to
4882                        message-use-mail-followup-to) 'ask)
4883                (not (message-y-or-n-p
4884                      (concat "Obey Mail-Followup-To: " mft "? ") t "\
4885 You should normally obey the Mail-Followup-To: header.
4886
4887         `Mail-Followup-To: " mft "'
4888 directs your response to " (if (string-match "," mft)
4889                                "the specified addresses"
4890                              "that address only") ".
4891
4892 A typical situation where Mail-Followup-To is used is when the author thinks
4893 that further discussion should take place only in "
4894                              (if (string-match "," mft)
4895                                  "the specified mailing lists"
4896                                "that mailing list") ".")))
4897       (setq mft nil))
4898
4899     (if (and (not mft)
4900              (or (not wide)
4901                  to-address))
4902         (progn
4903           (setq follow-to (list (cons 'To
4904                                       (or to-address mrt reply-to mft from))))
4905           (when (and wide mct
4906                      (not (member (cons 'To mct) follow-to)))
4907             (push (cons 'Cc mct) follow-to)))
4908       (let (ccalist)
4909         (save-excursion
4910           (message-set-work-buffer)
4911           (if (and mft
4912                    message-use-followup-to
4913                    wide
4914                    (or (not (eq message-use-followup-to 'ask))
4915                        (message-y-or-n-p "Obey Mail-Followup-To? " t "\
4916 You should normally obey the Mail-Followup-To: header.  In this
4917 article, it has the value of
4918
4919 " mft "
4920
4921 which directs your response to " (if (string-match "," mft)
4922                                      "the specified addresses"
4923                                    "that address only") ".
4924
4925 If a message is posted to several mailing lists, Mail-Followup-To is
4926 often used to direct the following discussion to one list only,
4927 because discussions that are spread over several lists tend to be
4928 fragmented and very difficult to follow.
4929
4930 Also, some source/announcement lists are not intended for discussion;
4931 responses here are directed to other addresses.")))
4932               (insert mft)
4933             (unless never-mct
4934               (insert (or mrt reply-to from "")))
4935             (insert (if to (concat (if (bolp) "" ", ") to) ""))
4936             (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
4937             (insert (if cc (concat (if (bolp) "" ", ") cc) "")))
4938           (goto-char (point-min))
4939           (while (re-search-forward "[ \t]+" nil t)
4940             (replace-match " " t t))
4941           ;; Remove addresses that match `rmail-dont-reply-to-names'.
4942           (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
4943             (insert (prog1 (rmail-dont-reply-to (buffer-string))
4944                       (erase-buffer))))
4945           (goto-char (point-min))
4946           ;; Perhaps "Mail-Copies-To: never" removed the only address?
4947           (when (eobp)
4948             (insert (or mrt reply-to from "")))
4949           (setq ccalist
4950                 (mapcar
4951                  (lambda (addr)
4952                    (cons (mail-strip-quoted-names addr) addr))
4953                  (message-tokenize-header (buffer-string))))
4954           (let ((s ccalist))
4955             (while s
4956               (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
4957         (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
4958         (when ccalist
4959           (let ((ccs (cons 'Cc (mapconcat
4960                                 (lambda (addr) (cdr addr)) ccalist ", "))))
4961             (when (string-match "^ +" (cdr ccs))
4962               (setcdr ccs (substring (cdr ccs) (match-end 0))))
4963             (push ccs follow-to)))
4964         ;; Allow the user to be asked whether or not to reply to all
4965         ;; recipients in a wide reply.
4966         (if (and ccalist wide message-wide-reply-confirm-recipients
4967                  (not (y-or-n-p "Reply to all recipients?")))
4968             (setq follow-to (delq (assoc 'Cc follow-to) follow-to)))))
4969     follow-to))
4970
4971 ;;;###autoload
4972 (defun message-reply (&optional to-address wide)
4973   "Start editing a reply to the article in the current buffer."
4974   (interactive)
4975   (require 'gnus-sum)                   ; for gnus-list-identifiers
4976   (let ((cur (current-buffer))
4977         from subject date
4978         references message-id follow-to
4979         (inhibit-point-motion-hooks t)
4980         (message-this-is-mail t)
4981         gnus-warning in-reply-to)
4982     (save-restriction
4983       (message-narrow-to-head-1)
4984       ;; Allow customizations to have their say.
4985       (if (not wide)
4986           ;; This is a regular reply.
4987           (when (message-functionp message-reply-to-function)
4988             (save-excursion
4989               (setq follow-to (funcall message-reply-to-function))))
4990         ;; This is a followup.
4991         (when (message-functionp message-wide-reply-to-function)
4992           (save-excursion
4993             (setq follow-to
4994                   (funcall message-wide-reply-to-function)))))
4995       (setq message-id (message-fetch-field "message-id" t)
4996             references (message-fetch-field "references")
4997             date (message-fetch-field "date")
4998             from (message-fetch-field "from")
4999             subject (or (message-fetch-field "subject") "none"))
5000       (when gnus-list-identifiers
5001         (setq subject (message-strip-list-identifiers subject)))
5002       (setq subject (message-make-followup-subject subject))
5003
5004       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
5005                  (string-match "<[^>]+>" gnus-warning))
5006         (setq message-id (match-string 0 gnus-warning)))
5007
5008       (unless follow-to
5009         (setq follow-to (message-get-reply-headers wide to-address)))
5010
5011       ;; Get the references from "In-Reply-To" field if there were
5012       ;; no references and "In-Reply-To" field looks promising.
5013       (unless references
5014         (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
5015                    (string-match "<[^>]+>" in-reply-to))
5016           (setq references (match-string 0 in-reply-to)))))
5017
5018     (unless (message-mail-user-agent)
5019       (message-pop-to-buffer
5020        (message-buffer-name
5021         (if wide "wide reply" "reply") from
5022         (if wide to-address nil))))
5023
5024     (setq message-reply-headers
5025           (make-full-mail-header-from-decoded-header
5026            0 subject from date message-id references 0 0 ""))
5027
5028     (message-setup
5029      `((Subject . ,subject)
5030        ,@follow-to
5031        ,@(if (or references message-id)
5032              `((References . ,(concat (or references "") (and references " ")
5033                                       (or message-id ""))))
5034            nil))
5035      cur)))
5036
5037 ;;;###autoload
5038 (defun message-wide-reply (&optional to-address)
5039   "Make a \"wide\" reply to the message in the current buffer."
5040   (interactive)
5041   (message-reply to-address t))
5042
5043 ;;;###autoload
5044 (defun message-followup (&optional to-newsgroups)
5045   "Follow up to the message in the current buffer.
5046 If TO-NEWSGROUPS, use that as the new Newsgroups line."
5047   (interactive)
5048   (require 'gnus-sum)                   ; for gnus-list-identifiers
5049   (let ((cur (current-buffer))
5050         from subject date reply-to mrt mct mft
5051         references message-id follow-to
5052         (inhibit-point-motion-hooks t)
5053         (message-this-is-news t)
5054         followup-to distribution newsgroups gnus-warning posted-to)
5055     (save-restriction
5056       (message-narrow-to-head)
5057       (when (message-functionp message-followup-to-function)
5058         (setq follow-to
5059               (funcall message-followup-to-function)))
5060       (setq from (message-fetch-field "from")
5061             date (message-fetch-field "date")
5062             subject (or (message-fetch-field "subject") "none")
5063             references (message-fetch-field "references")
5064             message-id (message-fetch-field "message-id" t)
5065             followup-to (message-fetch-field "followup-to")
5066             newsgroups (message-fetch-field "newsgroups")
5067             posted-to (message-fetch-field "posted-to")
5068             reply-to (message-fetch-field "reply-to")
5069             mrt (when message-use-mail-reply-to
5070                   (message-fetch-field "mail-reply-to"))
5071             distribution (message-fetch-field "distribution")
5072             mct (when message-use-mail-copies-to
5073                   (message-fetch-field "mail-copies-to"))
5074             mft (when (or message-use-followup-to
5075                           message-use-mail-followup-to)
5076                   (message-fetch-field "mail-followup-to")))
5077       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
5078                  (string-match "<[^>]+>" gnus-warning))
5079         (setq message-id (match-string 0 gnus-warning)))
5080       ;; Remove bogus distribution.
5081       (when (and (stringp distribution)
5082                  (let ((case-fold-search t))
5083                    (string-match "world" distribution)))
5084         (setq distribution nil))
5085       (if gnus-list-identifiers
5086           (setq subject (message-strip-list-identifiers subject)))
5087       (setq subject (message-make-followup-subject subject))
5088       (widen))
5089
5090     ;; Handle special values of Mail-Copies-To.
5091     (when mct
5092       (cond
5093        ((and (or (equal (downcase mct) "never")
5094                  (equal (downcase mct) "nobody")))
5095         (setq mct nil))
5096        ((and (or (equal (downcase mct) "always")
5097                  (equal (downcase mct) "poster")))
5098         (if (or (not (eq message-use-mail-copies-to 'ask))
5099                 (message-y-or-n-p
5100                  (concat "Obey Mail-Copies-To: always? ") t "\
5101 You should normally obey the Mail-Copies-To: header.
5102
5103         `Mail-Copies-To: " mct "'
5104 sends a copy of your response to the author."))
5105             (setq mct (or mrt reply-to from))
5106           (setq mct nil)))
5107        ((and (eq message-use-mail-copies-to 'ask)
5108              (not
5109               (message-y-or-n-p
5110                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
5111 You should normally obey the Mail-Copies-To: header.
5112
5113         `Mail-Copies-To: " mct "'
5114 sends a copy of your response to " (if (string-match "," mct)
5115                                        "the specified addresses"
5116                                      "that address") ".")))
5117         (setq mct nil))))
5118
5119     (unless follow-to
5120       (cond
5121        (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups))))
5122        ;; Handle Followup-To.
5123        (followup-to
5124         (cond
5125          ((equal (downcase followup-to) "poster")
5126           (if (or (and followup-to (eq message-use-followup-to 'use))
5127                   (message-y-or-n-p "Obey Followup-To: poster? " t "\
5128 You should normally obey the Followup-To: header.
5129
5130         `Followup-To: poster'
5131 sends your response via e-mail instead of news.
5132
5133 A typical situation where `Followup-To: poster' is used is when the author
5134 does not read the newsgroup, so he wouldn't see any replies sent to it."))
5135               (setq message-this-is-news nil
5136                     distribution nil
5137                     follow-to (list (cons 'To (or mrt reply-to from ""))))
5138             (setq follow-to (list (cons 'Newsgroups newsgroups)))))
5139          (t
5140           (if (or (equal followup-to newsgroups)
5141                   (not (and followup-to (eq message-use-followup-to 'ask)))
5142                   (message-y-or-n-p
5143                    (concat "Obey Followup-To: " followup-to "? ") t "\
5144 You should normally obey the Followup-To: header.
5145
5146         `Followup-To: " followup-to "'
5147 directs your response to " (if (string-match "," followup-to)
5148                                "the specified newsgroups"
5149                              "that newsgroup only") ".
5150
5151 If a message is posted to several newsgroups, Followup-To is often
5152 used to direct the following discussion to one newsgroup only,
5153 because discussions that are spread over several newsgroup tend to
5154 be fragmented and very difficult to follow.
5155
5156 Also, some source/announcement newsgroups are not intended for discussion;
5157 responses here are directed to other newsgroups."))
5158               (setq follow-to (list (cons 'Newsgroups followup-to)))
5159             (setq follow-to (list (cons 'Newsgroups newsgroups)))))))
5160        ;; Handle Mail-Followup-To, followup via e-mail.
5161        ((and mft
5162              (or (not (eq (or message-use-followup-to
5163                               message-use-mail-followup-to) 'ask))
5164                  (message-y-or-n-p
5165                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
5166 You should normally obey the Mail-Followup-To: header.
5167
5168         `Mail-Followup-To: " mft "'
5169 directs your response to " (if (string-match "," mft)
5170                                "the specified addresses"
5171                              "that address only") " instead of news.
5172
5173 A typical situation where Mail-Followup-To is used is when the author thinks
5174 that further discussion should take place only in "
5175                              (if (string-match "," mft)
5176                                  "the specified mailing lists"
5177                                "that mailing list") ".")))
5178         (setq message-this-is-news nil
5179               distribution nil
5180               follow-to (list (cons 'To mft))))
5181        (posted-to (setq follow-to (list (cons 'Newsgroups posted-to))))
5182        (t
5183         (setq follow-to (list (cons 'Newsgroups newsgroups))))))
5184
5185     (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
5186
5187     (message-setup
5188      `((Subject . ,subject)
5189        ,@follow-to
5190        ,@(and mct (list (cons 'Cc mct)))
5191        ,@(and distribution (list (cons 'Distribution distribution)))
5192        ,@(if (or references message-id)
5193              `((References . ,(concat (or references "") (and references " ")
5194                                       (or message-id ""))))))
5195      cur)
5196
5197     (setq message-reply-headers
5198           (make-full-mail-header-from-decoded-header
5199            0 subject from date message-id references 0 0 ""))))
5200
5201 ;;;###autoload
5202 (defun message-cancel-news (&optional arg)
5203   "Cancel an article you posted.
5204 If ARG, allow editing of the cancellation message."
5205   (interactive "P")
5206   (unless (message-news-p)
5207     (error "This is not a news article; canceling is impossible"))
5208   (let (from newsgroups message-id distribution buf sender)
5209     (save-excursion
5210       ;; Get header info from original article.
5211       (save-restriction
5212         (message-narrow-to-head-1)
5213         (setq from (message-fetch-field "from")
5214               sender (message-fetch-field "sender")
5215               newsgroups (message-fetch-field "newsgroups")
5216               message-id (message-fetch-field "message-id" t)
5217               distribution (message-fetch-field "distribution")))
5218       ;; Make sure that this article was written by the user.
5219       (unless (or (message-gnksa-enable-p 'cancel-messages)
5220                   (and sender
5221                        (string-equal
5222                         (downcase sender)
5223                         (downcase (message-make-sender))))
5224                   (string-equal
5225                    (downcase (cadr (std11-extract-address-components from)))
5226                    (downcase (cadr (std11-extract-address-components
5227                                     (message-make-from))))))
5228         (error "This article is not yours"))
5229       (when (yes-or-no-p "Do you really want to cancel this article? ")
5230         ;; Make control message.
5231         (if arg
5232             (message-news)
5233           (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
5234         (erase-buffer)
5235         (insert "Newsgroups: " newsgroups "\n"
5236                 "From: " from "\n"
5237                 "Subject: cmsg cancel " message-id "\n"
5238                 "Control: cancel " message-id "\n"
5239                 (if distribution
5240                     (concat "Distribution: " distribution "\n")
5241                   "")
5242                 mail-header-separator "\n"
5243                 message-cancel-message)
5244         (run-hooks 'message-cancel-hook)
5245         (unless arg
5246           (message "Canceling your article...")
5247           (if (let ((message-syntax-checks
5248                      'dont-check-for-anything-just-trust-me)
5249                     (message-encoding-buffer (current-buffer))
5250                     (message-edit-buffer (current-buffer)))
5251                 (message-send-news))
5252               (message "Canceling your article...done"))
5253           (kill-buffer buf))))))
5254
5255 (defun message-supersede-setup-for-mime-edit ()
5256   (set (make-local-variable 'message-setup-hook) nil)
5257   (mime-edit-again))
5258
5259 ;;;###autoload
5260 (defun message-supersede ()
5261   "Start composing a message to supersede the current message.
5262 This is done simply by taking the old article and adding a Supersedes
5263 header line with the old Message-ID."
5264   (interactive)
5265   (let ((cur (current-buffer))
5266         (sender (message-fetch-field "sender"))
5267         (from (message-fetch-field "from")))
5268     ;; Check whether the user owns the article that is to be superseded.
5269     (unless (or (message-gnksa-enable-p 'cancel-messages)
5270                 (and sender
5271                      (string-equal
5272                       (downcase sender)
5273                       (downcase (message-make-sender))))
5274                 (string-equal
5275                  (downcase (cadr (std11-extract-address-components from)))
5276                  (downcase (cadr (std11-extract-address-components
5277                                   (message-make-from))))))
5278       (error "This article is not yours"))
5279     ;; Get a normal message buffer.
5280     (message-pop-to-buffer (message-buffer-name "supersede"))
5281     (insert-buffer-substring cur)
5282     (message-narrow-to-head-1)
5283     ;; Remove unwanted headers.
5284     (when message-ignored-supersedes-headers
5285       (message-remove-header message-ignored-supersedes-headers t))
5286     (goto-char (point-min))
5287     (if (not (re-search-forward "^Message-ID: " nil t))
5288         (error "No Message-ID in this article")
5289       (replace-match "Supersedes: " t t))
5290     (goto-char (point-max))
5291     (insert mail-header-separator)
5292     (widen)
5293     (when message-supersede-setup-function
5294       (funcall message-supersede-setup-function))
5295     (run-hooks 'message-supersede-setup-hook)
5296     (goto-char (point-min))
5297     (search-forward (concat "\n" mail-header-separator "\n") nil t)))
5298
5299 ;;;###autoload
5300 (defun message-recover ()
5301   "Reread contents of current buffer from its last auto-save file."
5302   (interactive)
5303   (let ((file-name (make-auto-save-file-name)))
5304     (cond ((save-window-excursion
5305              (if (not (eq system-type 'vax-vms))
5306                  (with-output-to-temp-buffer "*Directory*"
5307                    (with-current-buffer standard-output
5308                      (fundamental-mode)) ; for Emacs 20.4+
5309                    (buffer-disable-undo standard-output)
5310                    (let ((default-directory "/"))
5311                      (call-process
5312                       "ls" nil standard-output nil "-l" file-name))))
5313              (yes-or-no-p (format "Recover auto save file %s? " file-name)))
5314            (let ((buffer-read-only nil))
5315              (erase-buffer)
5316              (insert-file-contents file-name nil)))
5317           (t (error "message-recover cancelled")))))
5318
5319 ;;; Washing Subject:
5320
5321 (defun message-wash-subject (subject)
5322   "Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT.
5323 Previous forwarders, replyers, etc. may add it."
5324   (with-temp-buffer
5325     (insert-string subject)
5326     (goto-char (point-min))
5327     ;; strip Re/Fwd stuff off the beginning
5328     (while (re-search-forward
5329             "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
5330       (replace-match ""))
5331
5332     ;; and gnus-style forwards [foo@bar.com] subject
5333     (goto-char (point-min))
5334     (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
5335       (replace-match ""))
5336
5337     ;; and off the end
5338     (goto-char (point-max))
5339     (while (re-search-backward "([Ff][Ww][Dd])" nil t)
5340       (replace-match ""))
5341
5342     ;; and finally, any whitespace that was left-over
5343     (goto-char (point-min))
5344     (while (re-search-forward "^[ \t]+" nil t)
5345       (replace-match ""))
5346     (goto-char (point-max))
5347     (while (re-search-backward "[ \t]+$" nil t)
5348       (replace-match ""))
5349
5350     (buffer-string)))
5351
5352 ;;; Forwarding messages.
5353
5354 (defvar message-forward-decoded-p nil
5355   "Non-nil means the original message is decoded.")
5356
5357 (defun message-forward-subject-author-subject (subject)
5358   "Generate a SUBJECT for a forwarded message.
5359 The form is: [Source] Subject, where if the original message was mail,
5360 Source is the sender, and if the original message was news, Source is
5361 the list of newsgroups is was posted to."
5362   (concat "["
5363           (if (message-news-p)
5364               (or (message-fetch-field "newsgroups")
5365                   "(nowhere)")
5366             (let ((from (message-fetch-field "from")))
5367               (if from
5368                   (nnheader-decode-from from)
5369                 "(nobody)")))
5370           "] " subject))
5371
5372 (defun message-forward-subject-fwd (subject)
5373   "Generate a SUBJECT for a forwarded message.
5374 The form is: Fwd: Subject, where Subject is the original subject of
5375 the message."
5376   (concat "Fwd: " subject))
5377
5378 (defun message-make-forward-subject ()
5379   "Return a Subject header suitable for the message in the current buffer."
5380   (save-excursion
5381     (save-restriction
5382       (message-narrow-to-head-1)
5383       (let ((funcs message-make-forward-subject-function)
5384             (subject (message-fetch-field "Subject")))
5385         (setq subject
5386               (if subject
5387                   (if message-forward-decoded-p
5388                       subject
5389                     (nnheader-decode-subject subject))
5390                 ""))
5391         (if message-wash-forwarded-subjects
5392             (setq subject (message-wash-subject subject)))
5393         ;; Make sure funcs is a list.
5394         (and funcs
5395              (not (listp funcs))
5396              (setq funcs (list funcs)))
5397         ;; Apply funcs in order, passing subject generated by previous
5398         ;; func to the next one.
5399         (while funcs
5400           (when (message-functionp (car funcs))
5401             (setq subject (funcall (car funcs) subject)))
5402           (setq funcs (cdr funcs)))
5403         subject))))
5404
5405 ;;;###autoload
5406 (defun message-forward (&optional news)
5407   "Forward the current message via mail.
5408 Optional NEWS will use news to forward instead of mail."
5409   (interactive "P")
5410   (let ((cur (current-buffer))
5411         (subject (message-make-forward-subject))
5412         art-beg)
5413     (if news
5414         (message-news nil subject)
5415       (message-mail nil subject))
5416     ;; Put point where we want it before inserting the forwarded
5417     ;; message.
5418     (if message-forward-before-signature
5419         (message-goto-body)
5420       (goto-char (point-max)))
5421     ;; Make sure we're at the start of the line.
5422     (unless (bolp)
5423       (insert "\n"))
5424     ;; Narrow to the area we are to insert.
5425     (narrow-to-region (point) (point))
5426     ;; Insert the separators and the forwarded buffer.
5427     (insert message-forward-start-separator)
5428     (setq art-beg (point))
5429     (insert-buffer-substring cur)
5430     (goto-char (point-max))
5431     (insert message-forward-end-separator)
5432     (set-text-properties (point-min) (point-max) nil)
5433     ;; Remove all unwanted headers.
5434     (goto-char art-beg)
5435     (narrow-to-region (point) (if (search-forward "\n\n" nil t)
5436                                   (1- (point))
5437                                 (point)))
5438     (goto-char (point-min))
5439     (message-remove-header message-included-forward-headers t nil t)
5440     (widen)
5441     (message-position-point)))
5442
5443 ;;;###autoload
5444 (defun message-resend (address)
5445   "Resend the current article to ADDRESS."
5446   (interactive
5447    (list (message-read-from-minibuffer "Resend message to: ")))
5448   (message "Resending message to %s..." address)
5449   (save-excursion
5450     (let ((cur (current-buffer))
5451           beg)
5452       ;; We first set up a normal mail buffer.
5453       (unless (message-mail-user-agent)
5454         (set-buffer (get-buffer-create " *message resend*"))
5455         (erase-buffer)
5456         (let ((message-this-is-mail t)
5457               ;; avoid to turn-on-mime-edit
5458               message-setup-hook)
5459           (message-setup `((To . ,address)))))
5460       ;; Insert our usual headers.
5461       (message-generate-headers '(From Date To))
5462       (message-narrow-to-headers)
5463       ;; Rename them all to "Resent-*".
5464       (while (re-search-forward "^[A-Za-z]" nil t)
5465         (forward-char -1)
5466         (insert "Resent-"))
5467       (widen)
5468       (forward-line)
5469       (delete-region (point) (point-max))
5470       (setq beg (point))
5471       ;; Insert the message to be resent.
5472       (insert-buffer-substring cur)
5473       (goto-char (point-min))
5474       (search-forward "\n\n")
5475       (forward-char -1)
5476       (save-restriction
5477         (narrow-to-region beg (point))
5478         (message-remove-header message-ignored-resent-headers t)
5479         (goto-char (point-max)))
5480       (insert mail-header-separator)
5481       ;; Rename all old ("Also-")Resent headers.
5482       (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
5483         (beginning-of-line)
5484         (insert "Also-"))
5485       ;; Quote any "From " lines at the beginning.
5486       (goto-char beg)
5487       (when (looking-at "From ")
5488         (replace-match "X-From-Line: "))
5489       ;; Send it.
5490       (let ((message-encoding-buffer (current-buffer))
5491             (message-edit-buffer (current-buffer)))
5492         (let (message-required-mail-headers)
5493           (message-send-mail)))
5494       (kill-buffer (current-buffer)))
5495     (message "Resending message to %s...done" address)))
5496
5497 (defun message-bounce-setup-for-mime-edit ()
5498   (set (make-local-variable 'message-setup-hook) nil)
5499   (mime-edit-again))
5500
5501 ;;;###autoload
5502 (defun message-bounce ()
5503   "Re-mail the current message.
5504 This only makes sense if the current message is a bounce message that
5505 contains some mail you have written which has been bounced back to
5506 you."
5507   (interactive)
5508   (let ((cur (current-buffer))
5509         boundary)
5510     (message-pop-to-buffer (message-buffer-name "bounce"))
5511     (insert-buffer-substring cur)
5512     (undo-boundary)
5513     (message-narrow-to-head)
5514     (if (and (message-fetch-field "MIME-Version")
5515              (setq boundary (message-fetch-field "Content-Type")))
5516         (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
5517             (setq boundary (concat (match-string 1 boundary) " *\n"
5518                                    "Content-Type: message/rfc822"))
5519           (setq boundary nil)))
5520     (widen)
5521     (goto-char (point-min))
5522     (search-forward "\n\n" nil t)
5523     (or (and boundary
5524              (re-search-forward boundary nil t)
5525              (forward-line 2))
5526         (and (re-search-forward message-unsent-separator nil t)
5527              (forward-line 1))
5528         (re-search-forward "^Return-Path:.*\n" nil t))
5529     ;; We remove everything before the bounced mail.
5530     (delete-region
5531      (point-min)
5532      (if (re-search-forward "^[^ \n\t]+:" nil t)
5533          (match-beginning 0)
5534        (point)))
5535     (save-restriction
5536       (message-narrow-to-head-1)
5537       (message-remove-header message-ignored-bounced-headers t)
5538       (goto-char (point-max))
5539       (insert mail-header-separator))
5540     (when message-bounce-setup-function
5541       (funcall message-bounce-setup-function))
5542     (run-hooks 'message-bounce-setup-hook)
5543     (message-position-point)))
5544
5545 ;;;
5546 ;;; Interactive entry points for new message buffers.
5547 ;;;
5548
5549 ;;;###autoload
5550 (defun message-mail-other-window (&optional to subject)
5551   "Like `message-mail' command, but display mail buffer in another window."
5552   (interactive)
5553   (unless (message-mail-user-agent)
5554     (let ((pop-up-windows t)
5555           (special-display-buffer-names nil)
5556           (special-display-regexps nil)
5557           (same-window-buffer-names nil)
5558           (same-window-regexps nil))
5559       (message-pop-to-buffer (message-buffer-name "mail" to))))
5560   (let ((message-this-is-mail t))
5561     (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
5562                    nil nil 'switch-to-buffer-other-window)))
5563
5564 ;;;###autoload
5565 (defun message-mail-other-frame (&optional to subject)
5566   "Like `message-mail' command, but display mail buffer in another frame."
5567   (interactive)
5568   (unless (message-mail-user-agent)
5569     (let ((pop-up-frames t)
5570           (special-display-buffer-names nil)
5571           (special-display-regexps nil)
5572           (same-window-buffer-names nil)
5573           (same-window-regexps nil))
5574       (message-pop-to-buffer (message-buffer-name "mail" to))))
5575   (let ((message-this-is-mail t))
5576     (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
5577                    nil nil 'switch-to-buffer-other-frame)))
5578
5579 ;;;###autoload
5580 (defun message-news-other-window (&optional newsgroups subject)
5581   "Start editing a news article to be sent."
5582   (interactive)
5583   (let ((pop-up-windows t)
5584         (special-display-buffer-names nil)
5585         (special-display-regexps nil)
5586         (same-window-buffer-names nil)
5587         (same-window-regexps nil))
5588     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
5589   (let ((message-this-is-news t))
5590     (message-setup `((Newsgroups . ,(or newsgroups ""))
5591                      (Subject . ,(or subject ""))))))
5592
5593 ;;;###autoload
5594 (defun message-news-other-frame (&optional newsgroups subject)
5595   "Start editing a news article to be sent."
5596   (interactive)
5597   (let ((pop-up-frames t)
5598         (special-display-buffer-names nil)
5599         (special-display-regexps nil)
5600         (same-window-buffer-names nil)
5601         (same-window-regexps nil))
5602     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
5603   (let ((message-this-is-news t))
5604     (message-setup `((Newsgroups . ,(or newsgroups ""))
5605                      (Subject . ,(or subject ""))))))
5606
5607 ;;; underline.el
5608
5609 ;; This code should be moved to underline.el (from which it is stolen).
5610
5611 ;;;###autoload
5612 (defun bold-region (start end)
5613   "Bold all nonblank characters in the region.
5614 Works by overstriking characters.
5615 Called from program, takes two arguments START and END
5616 which specify the range to operate on."
5617   (interactive "r")
5618   (save-excursion
5619     (let ((end1 (make-marker)))
5620       (move-marker end1 (max start end))
5621       (goto-char (min start end))
5622       (while (< (point) end1)
5623         (or (looking-at "[_\^@- ]")
5624             (insert (char-after) "\b"))
5625         (forward-char 1)))))
5626
5627 ;;;###autoload
5628 (defun unbold-region (start end)
5629   "Remove all boldness (overstruck characters) in the region.
5630 Called from program, takes two arguments START and END
5631 which specify the range to operate on."
5632   (interactive "r")
5633   (save-excursion
5634     (let ((end1 (make-marker)))
5635       (move-marker end1 (max start end))
5636       (goto-char (min start end))
5637       (while (re-search-forward "\b" end1 t)
5638         (if (eq (char-after) (char-after (- (point) 2)))
5639             (delete-char -2))))))
5640
5641 (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
5642
5643 ;; Support for toolbar
5644 (eval-when-compile
5645   (defvar tool-bar-map)
5646   (defvar tool-bar-mode))
5647
5648 (defun message-tool-bar-map ()
5649   (or message-tool-bar-map
5650       (setq message-tool-bar-map
5651             (and (fboundp 'tool-bar-add-item-from-menu)
5652                  tool-bar-mode
5653                  (let ((tool-bar-map (copy-keymap tool-bar-map))
5654                        (load-path (mm-image-load-path)))
5655                    ;; Zap some items which aren't so relevant and take
5656                    ;; up space.
5657                    (dolist (key '(print-buffer kill-buffer save-buffer
5658                                                write-file dired open-file))
5659                      (define-key tool-bar-map (vector key) nil))
5660                    (tool-bar-add-item-from-menu
5661                     'message-send-and-exit "mail_send" message-mode-map)
5662                    (tool-bar-add-item-from-menu
5663                     'message-kill-buffer "close" message-mode-map)
5664                    (tool-bar-add-item-from-menu
5665                     'message-dont-send "cancel" message-mode-map)
5666                    (tool-bar-add-item-from-menu
5667                     'mml-attach-file "attach" message-mode-map)
5668                    (tool-bar-add-item-from-menu
5669                     'ispell-message "spell" message-mode-map)
5670                    tool-bar-map)))))
5671
5672 ;;; Group name completion.
5673
5674 (defvar message-newgroups-header-regexp
5675   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
5676   "Regexp that match headers that lists groups.")
5677
5678 (defun message-tab ()
5679   "Expand group names in Newsgroups and Followup-To headers.
5680 Do a `tab-to-tab-stop' if not in those headers."
5681   (interactive)
5682   (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
5683         (mail-abbrev-in-expansion-header-p))
5684       (message-expand-group)
5685     (tab-to-tab-stop)))
5686
5687 (defun message-expand-group ()
5688   "Expand the group name under point."
5689   (let* ((b (save-excursion
5690               (save-restriction
5691                 (narrow-to-region
5692                  (save-excursion
5693                    (beginning-of-line)
5694                    (skip-chars-forward "^:")
5695                    (1+ (point)))
5696                  (point))
5697                 (skip-chars-backward "^, \t\n") (point))))
5698          (completion-ignore-case t)
5699          (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
5700                                             (point))))
5701          (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
5702          (completions (all-completions string hashtb))
5703          comp)
5704     (delete-region b (point))
5705     (cond
5706      ((= (length completions) 1)
5707       (if (string= (car completions) string)
5708           (progn
5709             (insert string)
5710             (message "Only matching group"))
5711         (insert (car completions))))
5712      ((and (setq comp (try-completion string hashtb))
5713            (not (string= comp string)))
5714       (insert comp))
5715      (t
5716       (insert string)
5717       (if (not comp)
5718           (message "No matching groups")
5719         (save-selected-window
5720           (pop-to-buffer "*Completions*")
5721           (buffer-disable-undo)
5722           (let ((buffer-read-only nil))
5723             (erase-buffer)
5724             (let ((standard-output (current-buffer)))
5725               (display-completion-list (sort completions 'string<)))
5726             (goto-char (point-min))
5727             (delete-region (point) (progn (forward-line 3) (point))))))))))
5728
5729 ;;; Help stuff.
5730
5731 (defun message-talkative-question (ask question show &rest text)
5732   "Call FUNCTION with argument QUESTION; optionally display TEXT... args.
5733 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer.
5734 The following arguments may contain lists of values."
5735   (if (and show
5736            (setq text (message-flatten-list text)))
5737       (save-window-excursion
5738         (save-excursion
5739           (with-output-to-temp-buffer " *MESSAGE information message*"
5740             (set-buffer " *MESSAGE information message*")
5741             (fundamental-mode)          ; for Emacs 20.4+
5742             (mapcar 'princ text)
5743             (goto-char (point-min))))
5744         (funcall ask question))
5745     (funcall ask question)))
5746
5747 (defun message-flatten-list (list)
5748   "Return a new, flat list that contains all elements of LIST.
5749
5750 \(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
5751 => (1 2 3 4 5 6 7)"
5752   (cond ((consp list)
5753          (apply 'append (mapcar 'message-flatten-list list)))
5754         (list
5755          (list list))))
5756
5757 (defun message-generate-new-buffer-clone-locals (name &optional varstr)
5758   "Create and return a buffer with name based on NAME using `generate-new-buffer.'
5759 Then clone the local variables and values from the old buffer to the
5760 new one, cloning only the locals having a substring matching the
5761 regexp varstr."
5762   (let ((oldbuf (current-buffer)))
5763     (save-excursion
5764       (set-buffer (generate-new-buffer name))
5765       (message-clone-locals oldbuf varstr)
5766       (current-buffer))))
5767
5768 (defun message-clone-locals (buffer &optional varstr)
5769   "Clone the local variables from BUFFER to the current buffer."
5770   (let ((locals (save-excursion
5771                   (set-buffer buffer)
5772                   (buffer-local-variables)))
5773         (regexp
5774          "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
5775     (mapcar
5776      (lambda (local)
5777        (when (and (consp local)
5778                   (car local)
5779                   (string-match regexp (symbol-name (car local)))
5780                   (or (null varstr)
5781                       (string-match varstr (symbol-name (car local)))))
5782          (ignore-errors
5783            (set (make-local-variable (car local))
5784                 (cdr local)))))
5785      locals)))
5786
5787
5788 ;;; @ for MIME Edit mode
5789 ;;;
5790
5791 (defun message-maybe-encode ()
5792   (when message-mime-mode
5793     ;; Inherit the buffer local variable `mime-edit-pgp-processing'.
5794     (let ((pgp-processing (with-current-buffer message-edit-buffer
5795                             mime-edit-pgp-processing)))
5796       (setq mime-edit-pgp-processing pgp-processing))
5797     (run-hooks 'mime-edit-translate-hook)
5798     (if (catch 'mime-edit-error
5799           (save-excursion
5800             (mime-edit-pgp-enclose-buffer)
5801             (mime-edit-translate-body)))
5802         (error "Translation error!"))
5803     (run-hooks 'mime-edit-exit-hook)))
5804
5805 (defun message-mime-insert-article (&optional full-headers)
5806   (interactive "P")
5807   (let ((message-cite-function 'mime-edit-inserted-message-filter)
5808         (message-reply-buffer
5809          (message-get-parameter-with-eval 'original-buffer))
5810         (start (point)))
5811     (message-yank-original nil)
5812     (save-excursion
5813       (narrow-to-region (goto-char start)
5814                         (if (search-forward "\n\n" nil t)
5815                             (1- (point))
5816                           (point-max)))
5817       (goto-char (point-min))
5818       (let ((message-included-forward-headers
5819              (if full-headers "" message-included-forward-headers)))
5820         (message-remove-header message-included-forward-headers t nil t))
5821       (widen))))
5822
5823 (set-alist 'mime-edit-message-inserter-alist
5824            'message-mode (function message-mime-insert-article))
5825
5826 ;;; Miscellaneous functions
5827
5828 ;; stolen (and renamed) from nnheader.el
5829 (static-if (fboundp 'subst-char-in-string)
5830     (defsubst message-replace-chars-in-string (string from to)
5831       (subst-char-in-string from to string))
5832   (defun message-replace-chars-in-string (string from to)
5833     "Replace characters in STRING from FROM to TO."
5834     (let ((string (substring string 0)) ;Copy string.
5835           (len (length string))
5836           (idx 0))
5837       ;; Replace all occurrences of FROM with TO.
5838       (while (< idx len)
5839         (when (= (aref string idx) from)
5840           (aset string idx to))
5841         (setq idx (1+ idx)))
5842       string)))
5843
5844 ;;;
5845 ;;; MIME functions
5846 ;;;
5847
5848 (defvar message-inhibit-body-encoding t)
5849
5850 (defun message-encode-message-body ()
5851   (unless message-inhibit-body-encoding
5852     (let ((mail-parse-charset (or mail-parse-charset
5853                                   message-default-charset))
5854           (case-fold-search t)
5855           lines content-type-p)
5856       (message-goto-body)
5857       (save-restriction
5858         (narrow-to-region (point) (point-max))
5859         (let ((new (mml-generate-mime)))
5860           (when new
5861             (delete-region (point-min) (point-max))
5862             (insert new)
5863             (goto-char (point-min))
5864             (if (eq (aref new 0) ?\n)
5865                 (delete-char 1)
5866               (search-forward "\n\n")
5867               (setq lines (buffer-substring (point-min) (1- (point))))
5868               (delete-region (point-min) (point))))))
5869       (save-restriction
5870         (message-narrow-to-headers-or-head)
5871         (message-remove-header "Mime-Version")
5872         (goto-char (point-max))
5873         (insert "MIME-Version: 1.0\n")
5874         (when lines
5875           (insert lines))
5876         (setq content-type-p
5877               (or mml-boundary
5878                   (re-search-backward "^Content-Type:" nil t))))
5879       (save-restriction
5880         (message-narrow-to-headers-or-head)
5881         (message-remove-first-header "Content-Type")
5882         (message-remove-first-header "Content-Transfer-Encoding"))
5883       ;; We always make sure that the message has a Content-Type header.
5884       ;; This is because some broken MTAs and MUAs get awfully confused
5885       ;; when confronted with a message with a MIME-Version header and
5886       ;; without a Content-Type header.  For instance, Solaris'
5887       ;; /usr/bin/mail.
5888       (unless content-type-p
5889         (goto-char (point-min))
5890         (re-search-forward "^MIME-Version:")
5891         (forward-line 1)
5892         (insert "Content-Type: text/plain; charset=us-ascii\n")))))
5893
5894 (defun message-read-from-minibuffer (prompt)
5895   "Read from the minibuffer while providing abbrev expansion."
5896   (if (fboundp 'mail-abbrevs-setup)
5897       (let ((mail-abbrev-mode-regexp "")
5898             (minibuffer-setup-hook 'mail-abbrevs-setup)
5899             (minibuffer-local-map message-minibuffer-local-map))
5900         (read-from-minibuffer prompt))
5901     (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
5902           (minibuffer-local-map message-minibuffer-local-map))
5903       (read-string prompt))))
5904
5905 (defun message-use-alternative-email-as-from ()
5906   (require 'mail-utils)
5907   (let* ((fields '("To" "Cc"))
5908          (emails
5909           (split-string
5910            (mail-strip-quoted-names
5911             (mapconcat 'message-fetch-reply-field fields ","))
5912            "[ \f\t\n\r\v,]+"))
5913          email)
5914     (while emails
5915       (if (string-match message-alternative-emails (car emails))
5916           (setq email (car emails)
5917                 emails nil))
5918       (pop emails))
5919     (unless (or (not email) (equal email user-mail-address))
5920       (goto-char (point-max))
5921       (insert "From: " email "\n"))))
5922
5923 (defun message-options-get (symbol)
5924   (cdr (assq symbol message-options)))
5925
5926 (defun message-options-set (symbol value)
5927   (let ((the-cons (assq symbol message-options)))
5928     (if the-cons
5929         (if value
5930             (setcdr the-cons value)
5931           (setq message-options (delq the-cons message-options)))
5932       (and value
5933            (push (cons symbol value) message-options))))
5934   value)
5935
5936 (defun message-options-set-recipient ()
5937   (save-restriction
5938     (message-narrow-to-headers-or-head)
5939     (message-options-set 'message-sender
5940                          (mail-strip-quoted-names
5941                           (message-fetch-field "from")))
5942     (message-options-set 'message-recipients
5943                          (mail-strip-quoted-names
5944                           (let ((to (message-fetch-field "to"))
5945                                 (cc (message-fetch-field "cc"))
5946                                 (bcc (message-fetch-field "bcc")))
5947                             (concat
5948                              (or to "")
5949                              (if (and to cc) ", ")
5950                              (or cc "")
5951                              (if (and (or to cc) bcc) ", ")
5952                              (or bcc "")))))))
5953
5954 (when (featurep 'xemacs)
5955   (require 'messagexmas)
5956   (message-xmas-redefine))
5957
5958 (defun message-save-drafts ()
5959   "Postponing the message."
5960   (interactive)
5961   (message "Saving %s..." buffer-file-name)
5962   (let ((reply-headers message-reply-headers)
5963         (msg (buffer-substring-no-properties (point-min) (point-max)))
5964         (message-invisibles (message-find-invisible-regions)))
5965     (with-temp-file buffer-file-name
5966       (insert msg)
5967       ;; Inherit the invisible property of texts to make MIME-Edit
5968       ;; find the MIME part boundaries.
5969       (dolist (region message-invisibles)
5970         (put-text-property (car region) (cdr region) 'invisible t))
5971       (setq message-reply-headers reply-headers)
5972       (message-generate-headers '((optional . In-Reply-To)))
5973       (mime-edit-translate-buffer))
5974     (set-buffer-modified-p nil))
5975   (message "Saving %s...done" buffer-file-name))
5976
5977 (provide 'message)
5978
5979 (run-hooks 'message-load-hook)
5980
5981 ;; Local Variables:
5982 ;; coding: iso-8859-1
5983 ;; End:
5984
5985 ;;; message.el ends here