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       (point-min)))
2144
2145 (defun message-goto-eoh ()
2146   "Move point to the end of the headers."
2147   (interactive)
2148   (message-goto-body)
2149   (forward-line -1))
2150
2151 (defun message-goto-signature ()
2152   "Move point to the beginning of the message signature.
2153 If there is no signature in the article, go to the end and
2154 return nil."
2155   (interactive)
2156   (goto-char (point-min))
2157   (if (re-search-forward message-signature-separator nil t)
2158       (forward-line 1)
2159     (goto-char (point-max))
2160     nil))
2161
2162 \f
2163
2164 (defun message-insert-to (&optional force)
2165   "Insert a To header that points to the author of the article being replied to.
2166 If the original author requested not to be sent mail, the function signals
2167 an error.
2168 With the prefix argument FORCE, insert the header anyway."
2169   (interactive "P")
2170   (let ((co (message-fetch-reply-field "mail-copies-to")))
2171     (when (and (null force)
2172                co
2173                (or (equal (downcase co) "never")
2174                    (equal (downcase co) "nobody")))
2175       (error "The user has requested not to have copies sent via mail")))
2176   (when (and (message-position-on-field "To")
2177              (mail-fetch-field "to")
2178              (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
2179     (insert ", "))
2180   (insert (or (message-fetch-reply-field "mail-reply-to")
2181               (message-fetch-reply-field "reply-to")
2182               (message-fetch-reply-field "from") "")))
2183
2184 (defun message-widen-reply ()
2185   "Widen the reply to include maximum recipients."
2186   (interactive)
2187   (let ((follow-to
2188          (and message-reply-buffer
2189               (buffer-name message-reply-buffer)
2190               (save-excursion
2191                 (set-buffer message-reply-buffer)
2192                 (message-get-reply-headers t)))))
2193     (save-excursion
2194       (save-restriction
2195         (message-narrow-to-headers)
2196         (dolist (elem follow-to)
2197           (message-remove-header (symbol-name (car elem)))
2198           (goto-char (point-min))
2199           (insert (symbol-name (car elem)) ": "
2200                   (cdr elem) "\n"))))))
2201
2202 (defun message-insert-newsgroups ()
2203   "Insert the Newsgroups header from the article being replied to."
2204   (interactive)
2205   (when (and (message-position-on-field "Newsgroups")
2206              (mail-fetch-field "newsgroups")
2207              (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
2208     (insert ","))
2209   (insert (or (message-fetch-reply-field "newsgroups") "")))
2210
2211 \f
2212
2213 ;;; Various commands
2214
2215 (defun message-delete-not-region (beg end)
2216   "Delete everything in the body of the current message outside of the region."
2217   (interactive "r")
2218   (let (citeprefix)
2219     (save-excursion
2220       (goto-char beg)
2221       ;; snarf citation prefix, if appropriate
2222       (unless (eq (point) (progn (beginning-of-line) (point)))
2223         (when (looking-at message-cite-prefix-regexp)
2224           (setq citeprefix (match-string 0))))
2225       (goto-char end)
2226       (delete-region (point) (if (not (message-goto-signature))
2227                                  (point)
2228                                (forward-line -2)
2229                                (point)))
2230       (insert "\n")
2231       (goto-char beg)
2232       (delete-region beg (progn (message-goto-body)
2233                                 (forward-line 2)
2234                                 (point)))
2235       (when citeprefix
2236         (insert citeprefix))))
2237   (when (message-goto-signature)
2238     (forward-line -2)))
2239
2240 (defun message-kill-to-signature ()
2241   "Deletes all text up to the signature."
2242   (interactive)
2243   (let ((point (point)))
2244     (message-goto-signature)
2245     (unless (eobp)
2246       (forward-line -2))
2247     (kill-region point (point))
2248     (unless (bolp)
2249       (insert "\n"))))
2250
2251 (defun message-newline-and-reformat (&optional arg not-break)
2252   "Insert four newlines, and then reformat if inside quoted text.
2253 Prefix arg means justify as well."
2254   (interactive (list (if current-prefix-arg 'full)))
2255   (let (quoted point beg end leading-space bolp)
2256     (setq point (point))
2257     (beginning-of-line)
2258     (setq beg (point))
2259     (setq bolp (= beg point))
2260     ;; Find first line of the paragraph.
2261     (if not-break
2262         (while (and (not (eobp))
2263                     (not (looking-at message-cite-prefix-regexp))
2264                 (looking-at paragraph-start))
2265           (forward-line 1)))
2266     ;; Find the prefix
2267     (when (looking-at message-cite-prefix-regexp)
2268       (setq quoted (match-string 0))
2269       (goto-char (match-end 0))
2270       (looking-at "[ \t]*")
2271       (setq leading-space (match-string 0)))
2272     (if (and quoted
2273              (not not-break)
2274              (not bolp)
2275              (< (- point beg) (length quoted)))
2276         ;; break inside the cite prefix.
2277         (setq quoted nil
2278               end nil))
2279     (if quoted
2280         (progn
2281           (forward-line 1)
2282           (while (and (not (eobp))
2283                       (not (looking-at paragraph-separate))
2284                       (looking-at message-cite-prefix-regexp)
2285                       (equal quoted (match-string 0)))
2286             (goto-char (match-end 0))
2287             (looking-at "[ \t]*")
2288             (if (> (length leading-space) (length (match-string 0)))
2289                 (setq leading-space (match-string 0)))
2290             (forward-line 1))
2291           (setq end (point))
2292           (goto-char beg)
2293           (while (and (if (bobp) nil (forward-line -1) t)
2294                       (not (looking-at paragraph-start))
2295                       (looking-at message-cite-prefix-regexp)
2296                       (equal quoted (match-string 0)))
2297             (setq beg (point))
2298             (goto-char (match-end 0))
2299             (looking-at "[ \t]*")
2300             (if (> (length leading-space) (length (match-string 0)))
2301                 (setq leading-space (match-string 0)))))
2302       (while (and (not (eobp))
2303                   (not (looking-at paragraph-separate))
2304                   (not (looking-at message-cite-prefix-regexp)))
2305         (forward-line 1))
2306       (setq end (point))
2307       (goto-char beg)
2308       (while (and (if (bobp) nil (forward-line -1) t)
2309                   (not (looking-at paragraph-start))
2310                   (not (looking-at message-cite-prefix-regexp)))
2311         (setq beg (point))))
2312     (goto-char point)
2313     (save-restriction
2314       (narrow-to-region beg end)
2315       (if not-break
2316           (setq point nil)
2317         (if bolp
2318             (insert "\n")
2319           (insert "\n\n"))
2320         (setq point (point))
2321         (insert "\n\n")
2322         (delete-region (point) (re-search-forward "[ \t]*"))
2323         (when (and quoted (not bolp))
2324           (insert quoted leading-space)))
2325       (if quoted
2326           (let* ((adaptive-fill-regexp
2327                  (regexp-quote (concat quoted leading-space)))
2328                  (adaptive-fill-first-line-regexp
2329                   adaptive-fill-regexp ))
2330             (fill-paragraph arg))
2331         (fill-paragraph arg))
2332       (if point (goto-char point)))))
2333
2334 (defun message-fill-paragraph (&optional arg)
2335   "Like `fill-paragraph'."
2336   (interactive (list (if current-prefix-arg 'full)))
2337   (message-newline-and-reformat arg t)
2338   t)
2339
2340 (defun message-insert-signature (&optional force)
2341   "Insert a signature.  See documentation for variable `message-signature'."
2342   (interactive (list 0))
2343   (let* ((signature
2344           (cond
2345            ((and (null message-signature)
2346                  (eq force 0))
2347             (save-excursion
2348               (goto-char (point-max))
2349               (not (re-search-backward message-signature-separator nil t))))
2350            ((and (null message-signature)
2351                  force)
2352             t)
2353            ((message-functionp message-signature)
2354             (funcall message-signature))
2355            ((listp message-signature)
2356             (eval message-signature))
2357            (t message-signature)))
2358          (signature
2359           (cond ((stringp signature)
2360                  signature)
2361                 ((and (eq t signature)
2362                       message-signature-file
2363                       (file-exists-p message-signature-file))
2364                  signature))))
2365     (when signature
2366       (goto-char (point-max))
2367       ;; Insert the signature.
2368       (unless (bolp)
2369         (insert "\n"))
2370       (insert "\n-- \n")
2371       (if (eq signature t)
2372           (insert-file-contents message-signature-file)
2373         (insert signature))
2374       (goto-char (point-max))
2375       (or (bolp) (insert "\n")))))
2376
2377 (defun message-elide-region (b e)
2378   "Elide the text in the region.
2379 An ellipsis (from `message-elide-ellipsis') will be inserted where the
2380 text was killed."
2381   (interactive "r")
2382   (kill-region b e)
2383   (insert message-elide-ellipsis))
2384
2385 (defvar message-caesar-translation-table nil)
2386
2387 (defun message-caesar-region (b e &optional n)
2388   "Caesar rotate region B to E by N, default 13, for decrypting netnews."
2389   (interactive
2390    (list
2391     (min (point) (or (mark t) (point)))
2392     (max (point) (or (mark t) (point)))
2393     (when current-prefix-arg
2394       (prefix-numeric-value current-prefix-arg))))
2395
2396   (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
2397   (unless (or (zerop n)                 ; no action needed for a rot of 0
2398               (= b e))                  ; no region to rotate
2399     ;; We build the table, if necessary.
2400     (when (or (not message-caesar-translation-table)
2401               (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
2402       (setq message-caesar-translation-table
2403             (message-make-caesar-translation-table n)))
2404     (translate-region b e message-caesar-translation-table)))
2405
2406 (defun message-make-caesar-translation-table (n)
2407   "Create a rot table with offset N."
2408   (let ((i -1)
2409         (table (make-string 256 0)))
2410     (while (< (incf i) 256)
2411       (aset table i i))
2412     (concat
2413      (substring table 0 ?A)
2414      (substring table (+ ?A n) (+ ?A n (- 26 n)))
2415      (substring table ?A (+ ?A n))
2416      (substring table (+ ?A 26) ?a)
2417      (substring table (+ ?a n) (+ ?a n (- 26 n)))
2418      (substring table ?a (+ ?a n))
2419      (substring table (+ ?a 26) 255))))
2420
2421 (defun message-caesar-buffer-body (&optional rotnum)
2422   "Caesar rotate all letters in the current buffer by 13 places.
2423 Used to encode/decode possibly offensive messages (commonly in rec.humor).
2424 With prefix arg, specifies the number of places to rotate each letter forward.
2425 Mail and USENET news headers are not rotated."
2426   (interactive (if current-prefix-arg
2427                    (list (prefix-numeric-value current-prefix-arg))
2428                  (list nil)))
2429   (save-excursion
2430     (save-restriction
2431       (when (message-goto-body)
2432         (narrow-to-region (point) (point-max)))
2433       (message-caesar-region (point-min) (point-max) rotnum))))
2434
2435 (defun message-pipe-buffer-body (program)
2436   "Pipe the message body in the current buffer through PROGRAM."
2437   (save-excursion
2438     (save-restriction
2439       (when (message-goto-body)
2440         (narrow-to-region (point) (point-max)))
2441       (shell-command-on-region
2442        (point-min) (point-max) program nil t))))
2443
2444 (defun message-rename-buffer (&optional enter-string)
2445   "Rename the *message* buffer to \"*message* RECIPIENT\".
2446 If the function is run with a prefix, it will ask for a new buffer
2447 name, rather than giving an automatic name."
2448   (interactive "Pbuffer name: ")
2449   (save-excursion
2450     (save-restriction
2451       (goto-char (point-min))
2452       (narrow-to-region (point)
2453                         (search-forward mail-header-separator nil 'end))
2454       (let* ((mail-to (or
2455                        (if (message-news-p) (message-fetch-field "Newsgroups")
2456                          (message-fetch-field "To"))
2457                        ""))
2458              (mail-trimmed-to
2459               (if (string-match "," mail-to)
2460                   (concat (substring mail-to 0 (match-beginning 0)) ", ...")
2461                 mail-to))
2462              (name-default (concat "*message* " mail-trimmed-to))
2463              (name (if enter-string
2464                        (read-string "New buffer name: " name-default)
2465                      name-default)))
2466         (rename-buffer name t)))))
2467
2468 (defun message-fill-yanked-message (&optional justifyp)
2469   "Fill the paragraphs of a message yanked into this one.
2470 Numeric argument means justify as well."
2471   (interactive "P")
2472   (save-excursion
2473     (goto-char (point-min))
2474     (search-forward (concat "\n" mail-header-separator "\n") nil t)
2475     (let ((fill-prefix message-yank-prefix))
2476       (fill-individual-paragraphs (point) (point-max) justifyp))))
2477
2478 (defun message-indent-citation ()
2479   "Modify text just inserted from a message to be cited.
2480 The inserted text should be the region.
2481 When this function returns, the region is again around the modified text.
2482
2483 Normally, indent each nonblank line `message-indentation-spaces' spaces.
2484 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
2485   (let ((start (point)))
2486     ;; Remove unwanted headers.
2487     (when message-ignored-cited-headers
2488       (let (all-removed)
2489         (save-restriction
2490           (narrow-to-region
2491            (goto-char start)
2492            (if (search-forward "\n\n" nil t)
2493                (1- (point))
2494              (point)))
2495           (message-remove-header message-ignored-cited-headers t)
2496           (when (= (point-min) (point-max))
2497             (setq all-removed t))
2498           (goto-char (point-max)))
2499         (if all-removed
2500             (goto-char start)
2501           (forward-line 1))))
2502     ;; Delete blank lines at the start of the buffer.
2503     (while (and (point-min)
2504                 (eolp)
2505                 (not (eobp)))
2506       (message-delete-line))
2507     ;; Delete blank lines at the end of the buffer.
2508     (goto-char (point-max))
2509     (unless (bolp)
2510       (insert "\n"))
2511     (while (and (zerop (forward-line -1))
2512                 (looking-at "$"))
2513       (message-delete-line))
2514     ;; Do the indentation.
2515     (if (null message-yank-prefix)
2516         (indent-rigidly start (mark t) message-indentation-spaces)
2517       (save-excursion
2518         (goto-char start)
2519         (while (< (point) (mark t))
2520           (if (looking-at message-cite-prefix-regexp)
2521               (insert message-yank-cited-prefix)
2522             (insert message-yank-prefix))
2523           (forward-line 1))))
2524     (goto-char start)))
2525
2526 (defun message-list-references (refs-list &rest refs-strs)
2527   "Add `Message-ID's which appear in REFS-STRS but not in REFS-LIST,
2528 to REFS-LIST."
2529   (let (refs ref id saved-id)
2530     (when (and refs-list
2531                (integerp message-list-references-add-position))
2532       (let ((pos message-list-references-add-position))
2533         (while (and refs-list
2534                     (> pos 0))
2535           (push (pop refs-list) saved-id)
2536           (setq pos (1- pos)))))
2537     (while refs-strs
2538       (when (setq refs (pop refs-strs))
2539         (setq refs (std11-parse-msg-ids (std11-lexical-analyze refs)))
2540         (while refs
2541           (when (eq (car (setq ref (pop refs))) 'msg-id)
2542             (setq id (concat "<" (mapconcat 'cdr (cdr ref) "") ">"))
2543             (or (member id refs-list)
2544                 (member id saved-id)
2545                 (push id refs-list))))))
2546     (while saved-id
2547       (push (pop saved-id) refs-list))
2548     refs-list))
2549
2550 (defvar gnus-article-copy)
2551 (defun message-yank-original (&optional arg)
2552   "Insert the message being replied to, if any.
2553 Puts point before the text and mark after.
2554 Normally indents each nonblank line ARG spaces (default 3).  However,
2555 if `message-yank-prefix' is non-nil, insert that prefix on each line.
2556
2557 This function uses `message-cite-function' to do the actual citing.
2558
2559 Just \\[universal-argument] as argument means don't indent, insert no
2560 prefix, and don't delete any headers.
2561
2562 In addition, if `message-yank-add-new-references' is non-nil and this
2563 command is called interactively, new IDs from the yanked article will
2564 be added to \"References\" field.
2565 \(See also `message-yank-add-new-references'.)"
2566   (interactive "P")
2567   (let ((modified (buffer-modified-p))
2568         (buffer (message-eval-parameter message-reply-buffer))
2569         start end refs)
2570     (when (and buffer
2571                message-cite-function)
2572       (delete-windows-on buffer t)
2573       (insert-buffer buffer) ; mark will be set at the end of article.
2574       (setq start (point)
2575             end (mark t))
2576
2577       ;; Add new IDs to References field.
2578       (when (and message-yank-add-new-references (interactive-p))
2579         (save-excursion
2580           (save-restriction
2581             (message-narrow-to-headers)
2582             (setq refs (message-list-references
2583                         nil
2584                         (message-fetch-field "References")))
2585             (widen)
2586             (narrow-to-region start end)
2587             (std11-narrow-to-header)
2588             (when (setq refs (message-list-references
2589                               refs
2590                               (unless (eq message-yank-add-new-references
2591                                           'message-id-only)
2592                                 (or (message-fetch-field "References")
2593                                     (message-fetch-field "In-Reply-To")))
2594                               (message-fetch-field "Message-ID")))
2595               (widen)
2596               (message-narrow-to-headers)
2597               (goto-char (point-min))
2598               (let ((case-fold-search t))
2599                 (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t)
2600                     (replace-match "")
2601                   (goto-char (point-max))))
2602               (mail-header-format
2603                (list (or (assq 'References message-header-format-alist)
2604                          '(References . message-fill-references)))
2605                (list (cons 'References
2606                            (mapconcat 'identity (nreverse refs) " "))))
2607               (backward-delete-char 1)))))
2608
2609       (unless arg
2610         (funcall message-cite-function))
2611       (message-exchange-point-and-mark)
2612       (unless (bolp)
2613         (insert ?\n))
2614       (unless modified
2615         (setq message-checksum (message-checksum))))))
2616
2617 (defun message-yank-buffer (buffer)
2618   "Insert BUFFER into the current buffer and quote it."
2619   (interactive "bYank buffer: ")
2620   (let ((message-reply-buffer buffer))
2621     (save-window-excursion
2622       (message-yank-original))))
2623
2624 (defun message-buffers ()
2625   "Return a list of active message buffers."
2626   (let (buffers)
2627     (save-excursion
2628       (dolist (buffer (buffer-list t))
2629         (set-buffer buffer)
2630         (when (and (eq major-mode 'message-mode)
2631                    (null message-sent-message-via))
2632           (push (buffer-name buffer) buffers))))
2633     (nreverse buffers)))
2634
2635 (defun message-cite-original-without-signature ()
2636   "Cite function in the standard Message manner."
2637   (let ((start (point))
2638         (end (mark t))
2639         (functions
2640          (when message-indent-citation-function
2641            (if (listp message-indent-citation-function)
2642                message-indent-citation-function
2643              (list message-indent-citation-function))))
2644         (message-reply-headers (or message-reply-headers
2645                                    (make-mail-header))))
2646     (mail-header-set-from message-reply-headers
2647                           (save-restriction
2648                             (narrow-to-region
2649                              (point)
2650                              (if (search-forward "\n\n" nil t)
2651                                  (1- (point))
2652                                (point-max)))
2653                             (or (message-fetch-field "from")
2654                                 "unknown sender")))
2655     ;; Allow undoing.
2656     (undo-boundary)
2657     (goto-char end)
2658     (when (re-search-backward message-signature-separator start t)
2659       ;; Also peel off any blank lines before the signature.
2660       (forward-line -1)
2661       (while (looking-at "^[ \t]*$")
2662         (forward-line -1))
2663       (forward-line 1)
2664       (delete-region (point) end)
2665       (unless (search-backward "\n\n" start t)
2666         ;; Insert a blank line if it is peeled off.
2667         (insert "\n")))
2668     (goto-char start)
2669     (while functions
2670       (funcall (pop functions)))
2671     (when message-citation-line-function
2672       (unless (bolp)
2673         (insert "\n"))
2674       (funcall message-citation-line-function))))
2675
2676 (eval-when-compile (defvar mail-citation-hook))         ;Compiler directive
2677 (defun message-cite-original ()
2678   "Cite function in the standard Message manner."
2679   (if (and (boundp 'mail-citation-hook)
2680            mail-citation-hook)
2681       (run-hooks 'mail-citation-hook)
2682     (let ((start (point))
2683           (end (mark t))
2684           (functions
2685            (when message-indent-citation-function
2686              (if (listp message-indent-citation-function)
2687                  message-indent-citation-function
2688                (list message-indent-citation-function))))
2689           (message-reply-headers (or message-reply-headers
2690                                      (make-mail-header))))
2691       (mail-header-set-from message-reply-headers
2692                             (save-restriction
2693                               (narrow-to-region
2694                                (point)
2695                                (if (search-forward "\n\n" nil t)
2696                                    (1- (point))
2697                                  (point-max)))
2698                               (or (message-fetch-field "from")
2699                                   "unknown sender")))
2700       (goto-char start)
2701       (while functions
2702         (funcall (pop functions)))
2703       (when message-citation-line-function
2704         (unless (bolp)
2705           (insert "\n"))
2706         (funcall message-citation-line-function)))))
2707
2708 (defun message-insert-citation-line ()
2709   "Insert a simple citation line."
2710   (when message-reply-headers
2711     (insert (mail-header-from message-reply-headers) " writes:\n\n")))
2712
2713 (defun message-position-on-field (header &rest afters)
2714   (let ((case-fold-search t))
2715     (save-restriction
2716       (narrow-to-region
2717        (goto-char (point-min))
2718        (progn
2719          (re-search-forward
2720           (concat "^" (regexp-quote mail-header-separator) "$"))
2721          (match-beginning 0)))
2722       (goto-char (point-min))
2723       (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
2724           (progn
2725             (re-search-forward "^[^ \t]" nil 'move)
2726             (beginning-of-line)
2727             (skip-chars-backward "\n")
2728             t)
2729         (while (and afters
2730                     (not (re-search-forward
2731                           (concat "^" (regexp-quote (car afters)) ":")
2732                           nil t)))
2733           (pop afters))
2734         (when afters
2735           (re-search-forward "^[^ \t]" nil 'move)
2736           (beginning-of-line))
2737         (insert header ": \n")
2738         (forward-char -1)
2739         nil))))
2740
2741 (defun message-remove-signature ()
2742   "Remove the signature from the text between point and mark.
2743 The text will also be indented the normal way."
2744   (save-excursion
2745     (let ((start (point))
2746           mark)
2747       (if (not (re-search-forward message-signature-separator (mark t) t))
2748           ;; No signature here, so we just indent the cited text.
2749           (message-indent-citation)
2750         ;; Find the last non-empty line.
2751         (forward-line -1)
2752         (while (looking-at "[ \t]*$")
2753           (forward-line -1))
2754         (forward-line 1)
2755         (setq mark (set-marker (make-marker) (point)))
2756         (goto-char start)
2757         (message-indent-citation)
2758         ;; Enable undoing the deletion.
2759         (undo-boundary)
2760         (delete-region mark (mark t))
2761         (set-marker mark nil)))))
2762
2763 \f
2764
2765 ;;;
2766 ;;; Sending messages
2767 ;;;
2768
2769 ;; Avoid byte-compile warning.
2770 (defvar message-encoding-buffer nil)
2771 (defvar message-edit-buffer nil)
2772 (defvar message-mime-mode nil)
2773
2774 (defun message-send-and-exit (&optional arg)
2775   "Send message like `message-send', then, if no errors, exit from mail buffer."
2776   (interactive "P")
2777   (let ((buf (current-buffer))
2778         (actions message-exit-actions)
2779         (frame (selected-frame))
2780         (org-frame message-original-frame))
2781     (when (and (message-send arg)
2782                (buffer-name buf))
2783       (if message-kill-buffer-on-exit
2784           (kill-buffer buf)
2785         (bury-buffer buf)
2786         (when (eq buf (current-buffer))
2787           (message-bury buf)))
2788       (message-do-actions actions)
2789       (message-delete-frame frame org-frame)
2790       t)))
2791
2792 (defun message-dont-send ()
2793   "Don't send the message you have been editing."
2794   (interactive)
2795   (message-save-drafts)
2796   (let ((actions message-postpone-actions)
2797         (frame (selected-frame))
2798         (org-frame message-original-frame))
2799     (message-bury (current-buffer))
2800     (message-do-actions actions)
2801     (message-delete-frame frame org-frame)))
2802
2803 (defun message-kill-buffer ()
2804   "Kill the current buffer."
2805   (interactive)
2806   (when (or (not (buffer-modified-p))
2807             (eq t message-kill-buffer-query-function)
2808             (funcall message-kill-buffer-query-function
2809                      "The buffer modified; kill anyway? "))
2810     (let ((actions message-kill-actions)
2811           (frame (selected-frame))
2812           (org-frame message-original-frame))
2813       (setq buffer-file-name nil)
2814       (kill-buffer (current-buffer))
2815       (message-do-actions actions)
2816       (message-delete-frame frame org-frame)))
2817   (message ""))
2818
2819 (defun message-mimic-kill-buffer ()
2820   "Kill the current buffer with query."
2821   (interactive)
2822   (unless (eq 'message-mode major-mode)
2823     (error "%s must be invoked from a message buffer." this-command))
2824   (let ((command this-command)
2825         (bufname (read-buffer (format "Kill buffer: (default %s) "
2826                                       (buffer-name)))))
2827     (if (or (not bufname)
2828             (string-equal bufname "")
2829             (string-equal bufname (buffer-name)))
2830         (message-kill-buffer)
2831       (message "%s must be invoked only for the current buffer." command))))
2832
2833 (defun message-delete-frame (frame org-frame)
2834   "Delete frame for editing message."
2835   (when (and (or (static-if (featurep 'xemacs)
2836                      (device-on-window-system-p)
2837                    window-system)
2838                  (>= emacs-major-version 20))
2839              (or (and (eq message-delete-frame-on-exit t)
2840                       (select-frame frame)
2841                       (or (eq frame org-frame)
2842                           (prog1
2843                               (y-or-n-p "Delete this frame?")
2844                             (message ""))))
2845                  (and (eq message-delete-frame-on-exit 'ask)
2846                       (select-frame frame)
2847                       (prog1
2848                           (y-or-n-p "Delete this frame?")
2849                         (message "")))))
2850     (delete-frame frame)))
2851
2852 (defun message-bury (buffer)
2853   "Bury this mail BUFFER."
2854   (let ((newbuf (other-buffer buffer)))
2855     (bury-buffer buffer)
2856     (if (and (fboundp 'frame-parameters)
2857              (cdr (assq 'dedicated (frame-parameters)))
2858              (not (null (delq (selected-frame) (visible-frame-list)))))
2859         (delete-frame (selected-frame))
2860       (switch-to-buffer newbuf))))
2861
2862 (defun message-send (&optional arg)
2863   "Send the message in the current buffer.
2864 If `message-interactive' is non-nil, wait for success indication or
2865 error messages, and inform user.
2866 Otherwise any failure is reported in a message back to the user from
2867 the mailer.
2868 The usage of ARG is defined by the instance that called Message.
2869 It should typically alter the sending method in some way or other."
2870   (interactive "P")
2871   ;; Disabled test.
2872   (when (or (buffer-modified-p)
2873             (message-check-element 'unchanged)
2874             (y-or-n-p "No changes in the buffer; really send? "))
2875     ;; Make it possible to undo the coming changes.
2876     (undo-boundary)
2877     (let ((inhibit-read-only t))
2878       (put-text-property (point-min) (point-max) 'read-only nil))
2879     (run-hooks 'message-send-hook)
2880     (message-fix-before-sending)
2881     (message message-sending-message)
2882     (let ((message-encoding-buffer
2883            (message-generate-new-buffer-clone-locals " message encoding"))
2884           (message-edit-buffer (current-buffer))
2885           (message-mime-mode mime-edit-mode-flag)
2886           (alist message-send-method-alist)
2887           (success t)
2888           elem sent
2889           (message-options message-options))
2890       (message-options-set-recipient)
2891       (save-excursion
2892         (set-buffer message-encoding-buffer)
2893         (erase-buffer)
2894         ;; Avoid copying text props.
2895         (let (message-invisibles)
2896           (insert
2897            (with-current-buffer message-edit-buffer
2898              (setq message-invisibles (message-find-invisible-regions))
2899              (buffer-substring-no-properties (point-min) (point-max))))
2900           ;; Inherit the invisible property of texts to make MIME-Edit
2901           ;; find the MIME part boundaries.
2902           (dolist (region message-invisibles)
2903             (put-text-property (car region) (cdr region) 'invisible t)))
2904         (funcall message-encode-function)
2905         (while (and success
2906                     (setq elem (pop alist)))
2907           (when (funcall (cadr elem))
2908             (when (and (or (not (memq (car elem)
2909                                       message-sent-message-via))
2910                            (if (or (message-gnksa-enable-p 'multiple-copies)
2911                                    (not (eq (car elem) 'news)))
2912                                (y-or-n-p
2913                                 (format
2914                                  "Already sent message via %s; resend? "
2915                                  (car elem)))
2916                              (error "Denied posting -- multiple copies.")))
2917                        (setq success (funcall (caddr elem) arg)))
2918               (setq sent t)))))
2919       (unless (or sent (not success))
2920         (error "No methods specified to send by"))
2921       (prog1
2922           (when (and success sent)
2923             (message-do-fcc)
2924             (save-excursion
2925               (run-hooks 'message-sent-hook))
2926             (message "Sending...done")
2927             ;; Mark the buffer as unmodified and delete auto-save.
2928             (set-buffer-modified-p nil)
2929             (delete-auto-save-file-if-necessary t)
2930             (message-disassociate-draft)
2931             ;; Delete other mail buffers and stuff.
2932             (message-do-send-housekeeping)
2933             (message-do-actions message-send-actions)
2934             ;; Return success.
2935             t)
2936         (kill-buffer message-encoding-buffer)))))
2937
2938 (defun message-send-via-mail (arg)
2939   "Send the current message via mail."
2940   (message-send-mail arg))
2941
2942 (defun message-send-via-news (arg)
2943   "Send the current message via news."
2944   (message-send-news arg))
2945
2946 (defmacro message-check (type &rest forms)
2947   "Eval FORMS if TYPE is to be checked."
2948   `(or (message-check-element ,type)
2949        (save-excursion
2950          ,@forms)))
2951
2952 (put 'message-check 'lisp-indent-function 1)
2953 (put 'message-check 'edebug-form-spec '(form body))
2954
2955 ;; This function will be used by MIME-Edit when inserting invisible parts.
2956 (defun message-invisible-region (start end)
2957   (if (featurep 'xemacs)
2958       (if (save-excursion
2959             (goto-char start)
2960             (eq (following-char) ?\n))
2961           (setq start (1+ start)))
2962     (if (save-excursion
2963           (goto-char (1- end))
2964           (eq (following-char) ?\n))
2965         (setq end (1- end))))
2966   (put-text-property start end 'invisible t)
2967   (if (eq 'message-mode major-mode)
2968       (put-text-property start end 'message-invisible t)))
2969
2970 (eval-after-load "invisible"
2971   '(defalias 'invisible-region 'message-invisible-region))
2972
2973 (defun message-find-invisible-regions ()
2974   "Find invisible texts with the property `message-invisible' and
2975 return a list of points."
2976   (let (from
2977         (to (point-min))
2978         regions)
2979     (while (setq from (text-property-any to (point-max)
2980                                          'message-invisible t))
2981       (setq to (or (text-property-not-all from (point-max)
2982                                           'message-invisible t)
2983                    (point-max)))
2984       (push (cons from to) regions))
2985     regions))
2986
2987 (defun message-fix-before-sending ()
2988   "Do various things to make the message nice before sending it."
2989   ;; Make sure there's a newline at the end of the message.
2990   (widen)
2991   (goto-char (point-max))
2992   (unless (bolp)
2993     (insert "\n"))
2994   ;; Expose all invisible text with the property `message-invisible'.
2995   ;; We should believe that the things might be created by MIME-Edit.
2996   (let ((message-invisibles (message-find-invisible-regions)))
2997     (dolist (region message-invisibles)
2998       (put-text-property (car region) (cdr region) 'invisible nil))
2999     ;; Expose all invisible text.
3000     (message-check 'invisible-text
3001       (when (text-property-any (point-min) (point-max) 'invisible t)
3002         (put-text-property (point-min) (point-max) 'invisible nil)
3003         (unless (yes-or-no-p
3004                  "Invisible text found and made visible; continue posting? ")
3005           (error "Invisible text found and made visible"))))
3006     ;; Hide again all text with the property `message-invisible'.
3007     ;; It is needed to make MIME-Edit find the MIME part boundaries.
3008     (dolist (region message-invisibles)
3009       (put-text-property (car region) (cdr region) 'invisible t))))
3010
3011 (defun message-add-action (action &rest types)
3012   "Add ACTION to be performed when doing an exit of type TYPES."
3013   (let (var)
3014     (while types
3015       (set (setq var (intern (format "message-%s-actions" (pop types))))
3016            (nconc (symbol-value var) (list action))))))
3017
3018 (defun message-do-actions (actions)
3019   "Perform all actions in ACTIONS."
3020   ;; Now perform actions on successful sending.
3021   (while actions
3022     (ignore-errors
3023       (cond
3024        ;; A simple function.
3025        ((message-functionp (car actions))
3026         (funcall (car actions)))
3027        ;; Something to be evaled.
3028        (t
3029         (eval (car actions)))))
3030     (pop actions)))
3031
3032 (defsubst message-maybe-split-and-send-mail ()
3033   "Split a message if necessary, and send it via mail.
3034 Returns nil if sending succeeded, returns any string if sending failed.
3035 This sub function is for exclusive use of `message-send-mail'."
3036   (let ((mime-edit-split-ignored-field-regexp
3037          mime-edit-split-ignored-field-regexp)
3038         (case-fold-search t)
3039         failure)
3040     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
3041       (setq mime-edit-split-ignored-field-regexp
3042             (concat (substring mime-edit-split-ignored-field-regexp
3043                                0 (match-beginning 0))
3044                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
3045                     "_so_don't_rape_it!"
3046                     (substring mime-edit-split-ignored-field-regexp
3047                                (match-end 0)))))
3048     (setq failure
3049           (or
3050            (catch 'message-sending-mail-failure
3051              (mime-edit-maybe-split-and-send
3052               (function
3053                (lambda ()
3054                  (interactive)
3055                  (save-restriction
3056                    (std11-narrow-to-header mail-header-separator)
3057                    (goto-char (point-min))
3058                    (when (re-search-forward "^Message-ID:" nil t)
3059                      (delete-region (match-end 0) (std11-field-end))
3060                      (insert " " (message-make-message-id))))
3061                  (condition-case err
3062                      (funcall message-send-mail-function)
3063                    (error
3064                     (throw 'message-sending-mail-failure err))))))
3065              nil)
3066            (condition-case err
3067                (progn
3068                  (funcall message-send-mail-function)
3069                  nil)
3070              (error err))))
3071     (when failure
3072       (if (eq 'error (car failure))
3073           (cadr failure)
3074         (prin1-to-string failure)))))
3075
3076 (defun message-send-mail-partially ()
3077   "Send mail as message/partial."
3078   ;; replace the header delimiter with a blank line
3079   (goto-char (point-min))
3080   (re-search-forward
3081    (concat "^" (regexp-quote mail-header-separator) "\n"))
3082   (replace-match "\n")
3083   (run-hooks 'message-send-mail-hook)
3084   (let ((p (goto-char (point-min)))
3085         (tembuf (message-generate-new-buffer-clone-locals " message temp"))
3086         (curbuf (current-buffer))
3087         (id (message-make-message-id)) (n 1)
3088         plist total  header required-mail-headers)
3089     (while (not (eobp))
3090       (if (< (point-max) (+ p message-send-mail-partially-limit))
3091           (goto-char (point-max))
3092         (goto-char (+ p message-send-mail-partially-limit))
3093         (beginning-of-line)
3094         (if (<= (point) p) (forward-line 1))) ;; In case of bad message.
3095       (push p plist)
3096       (setq p (point)))
3097     (setq total (length plist))
3098     (push (point-max) plist)
3099     (setq plist (nreverse plist))
3100     (unwind-protect
3101         (save-excursion
3102           (setq p (pop plist))
3103           (while plist
3104             (set-buffer curbuf)
3105             (copy-to-buffer tembuf p (car plist))
3106             (set-buffer tembuf)
3107             (goto-char (point-min))
3108             (if header
3109                 (progn
3110                   (goto-char (point-min))
3111                   (narrow-to-region (point) (point))
3112                   (insert header))
3113               (message-goto-eoh)
3114               (setq header (buffer-substring (point-min) (point)))
3115               (goto-char (point-min))
3116               (narrow-to-region (point) (point))
3117               (insert header)
3118               (message-remove-header "Mime-Version")
3119               (message-remove-header "Content-Type")
3120               (message-remove-header "Content-Transfer-Encoding")
3121               (message-remove-header "Message-ID")
3122               (message-remove-header "Lines")
3123               (goto-char (point-max))
3124               (insert "Mime-Version: 1.0\n")
3125               (setq header (buffer-substring (point-min) (point-max))))
3126             (goto-char (point-max))
3127             (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n"
3128                             id n total))
3129             (let ((mail-header-separator ""))
3130               (when (memq 'Message-ID message-required-mail-headers)
3131                 (insert "Message-ID: " (message-make-message-id) "\n"))
3132               (when (memq 'Lines message-required-mail-headers)
3133                 (let ((mail-header-separator ""))
3134                   (insert "Lines: " (message-make-lines) "\n")))
3135               (message-goto-subject)
3136               (end-of-line)
3137               (insert (format " (%d/%d)" n total))
3138               (goto-char (point-max))
3139               (insert "\n")
3140               (widen)
3141               (mm-with-unibyte-current-buffer
3142                 (funcall message-send-mail-function)))
3143             (setq n (+ n 1))
3144             (setq p (pop plist))
3145             (erase-buffer)))
3146       (kill-buffer tembuf))))
3147
3148 (defun message-send-mail (&optional arg)
3149   (require 'mail-utils)
3150   (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
3151          (case-fold-search nil)
3152          (news (message-news-p))
3153          (message-this-is-mail t)
3154          failure)
3155     (save-restriction
3156       (message-narrow-to-headers)
3157       ;; Insert some headers.
3158       (let ((message-deletable-headers
3159              (if news nil message-deletable-headers)))
3160         (message-generate-headers message-required-mail-headers))
3161       ;; Let the user do all of the above.
3162       (run-hooks 'message-header-hook))
3163     (if (not (message-check-mail-syntax))
3164         (progn
3165           (message "")
3166           nil)
3167       (unwind-protect
3168           (save-excursion
3169             (set-buffer tembuf)
3170             (erase-buffer)
3171             (insert-buffer message-encoding-buffer)
3172             ;; Remove some headers.
3173             (save-restriction
3174               (message-narrow-to-headers)
3175 ;; We Semi-gnus people have no use for it.
3176 ;;            ;; We (re)generate the Lines header.
3177 ;;            (when (memq 'Lines message-required-mail-headers)
3178 ;;              (message-generate-headers '(Lines)))
3179               ;; Remove some headers.
3180               (message-remove-header message-ignored-mail-headers t))
3181             (goto-char (point-max))
3182             ;; require one newline at the end.
3183             (or (= (preceding-char) ?\n)
3184                 (insert ?\n))
3185             (when
3186                 (save-restriction
3187                   (message-narrow-to-headers)
3188                   (and news
3189                        (or (message-fetch-field "cc")
3190                            (message-fetch-field "to"))
3191                        (let ((ct (mime-read-Content-Type)))
3192                          (or (not ct)
3193                              (and (eq 'text (cdr (assq 'type ct)))
3194                                   (eq 'plain (cdr (assq 'subtype ct))))))))
3195               (message-insert-courtesy-copy))
3196             (setq failure (message-maybe-split-and-send-mail)))
3197         (kill-buffer tembuf))
3198       (set-buffer message-edit-buffer)
3199       (if failure
3200           (progn
3201             (message "Couldn't send message via mail: %s" failure)
3202             nil)
3203         (push 'mail message-sent-message-via)))))
3204
3205 (defun message-send-mail-with-sendmail ()
3206   "Send off the prepared buffer with sendmail."
3207   (let ((errbuf (if message-interactive
3208                     (message-generate-new-buffer-clone-locals
3209                      " sendmail errors")
3210                   0))
3211         resend-to-addresses delimline)
3212     (let ((case-fold-search t))
3213       (save-restriction
3214         (message-narrow-to-headers)
3215         (setq resend-to-addresses (message-fetch-field "resent-to")))
3216       ;; Change header-delimiter to be what sendmail expects.
3217       (goto-char (point-min))
3218       (re-search-forward
3219        (concat "^" (regexp-quote mail-header-separator) "\n"))
3220       (replace-match "\n")
3221       (backward-char 1)
3222       (setq delimline (point-marker))
3223       (run-hooks 'message-send-mail-hook)
3224       ;; Insert an extra newline if we need it to work around
3225       ;; Sun's bug that swallows newlines.
3226       (goto-char (1+ delimline))
3227       (when (eval message-mailer-swallows-blank-line)
3228         (newline))
3229       (when message-interactive
3230         (save-excursion
3231           (set-buffer errbuf)
3232           (erase-buffer))))
3233     (let ((default-directory "/"))
3234       (as-binary-process
3235        (apply 'call-process-region
3236               (append (list (point-min) (point-max)
3237                             (if (boundp 'sendmail-program)
3238                                 sendmail-program
3239                               "/usr/lib/sendmail")
3240                             nil errbuf nil "-oi")
3241                       ;; Always specify who from,
3242                       ;; since some systems have broken sendmails.
3243                       ;; But some systems are more broken with -f, so
3244                       ;; we'll let users override this.
3245                       (if (null message-sendmail-f-is-evil)
3246                           (list "-f" (message-make-address)))
3247                       ;; These mean "report errors by mail"
3248                       ;; and "deliver in background".
3249                       (if (null message-interactive) '("-oem" "-odb"))
3250                       ;; Get the addresses from the message
3251                       ;; unless this is a resend.
3252                       ;; We must not do that for a resend
3253                       ;; because we would find the original addresses.
3254                       ;; For a resend, include the specific addresses.
3255                       (if resend-to-addresses
3256                           (list resend-to-addresses)
3257                         '("-t"))))))
3258     (when message-interactive
3259       (save-excursion
3260         (set-buffer errbuf)
3261         (goto-char (point-min))
3262         (while (re-search-forward "\n\n* *" nil t)
3263           (replace-match "; "))
3264         (if (not (zerop (buffer-size)))
3265             (error "Sending...failed to %s"
3266                    (buffer-substring (point-min) (point-max)))))
3267       (when (bufferp errbuf)
3268         (kill-buffer errbuf)))))
3269
3270 (defun message-send-mail-with-qmail ()
3271   "Pass the prepared message buffer to qmail-inject.
3272 Refer to the documentation for the variable `message-send-mail-function'
3273 to find out how to use this."
3274   ;; replace the header delimiter with a blank line
3275   (goto-char (point-min))
3276   (re-search-forward
3277    (concat "^" (regexp-quote mail-header-separator) "\n"))
3278   (replace-match "\n")
3279   (backward-char 1)
3280   (run-hooks 'message-send-mail-hook)
3281   ;; send the message
3282   (case
3283       (as-binary-process
3284        (apply
3285         'call-process-region 1 (point-max) message-qmail-inject-program
3286         nil nil nil
3287         ;; qmail-inject's default behaviour is to look for addresses on the
3288         ;; command line; if there're none, it scans the headers.
3289         ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
3290         ;;
3291         ;; in general, ALL of qmail-inject's defaults are perfect for simply
3292         ;; reading a formatted (i. e., at least a To: or Resent-To header)
3293         ;; message from stdin.
3294         ;;
3295         ;; qmail also has the advantage of not having been raped by
3296         ;; various vendors, so we don't have to allow for that, either --
3297         ;; compare this with message-send-mail-with-sendmail and weep
3298         ;; for sendmail's lost innocence.
3299         ;;
3300         ;; all this is way cool coz it lets us keep the arguments entirely
3301         ;; free for -inject-arguments -- a big win for the user and for us
3302         ;; since we don't have to play that double-guessing game and the user
3303         ;; gets full control (no gestapo'ish -f's, for instance).  --sj
3304         message-qmail-inject-args))
3305     ;; qmail-inject doesn't say anything on it's stdout/stderr,
3306     ;; we have to look at the retval instead
3307     (0 nil)
3308     (100 (error "qmail-inject reported permanent failure"))
3309     (111 (error "qmail-inject reported transient failure"))
3310     ;; should never happen
3311     (t   (error "qmail-inject reported unknown failure"))))
3312
3313 (defun message-send-mail-with-mh ()
3314   "Send the prepared message buffer with mh."
3315   (let ((mh-previous-window-config nil)
3316         (name (mh-new-draft-name)))
3317     (setq buffer-file-name name)
3318     ;; MH wants to generate these headers itself.
3319     (when message-mh-deletable-headers
3320       (let ((headers message-mh-deletable-headers))
3321         (while headers
3322           (goto-char (point-min))
3323           (and (re-search-forward
3324                 (concat "^" (symbol-name (car headers)) ": *") nil t)
3325                (message-delete-line))
3326           (pop headers))))
3327     (run-hooks 'message-send-mail-hook)
3328     ;; Pass it on to mh.
3329     (mh-send-letter)))
3330
3331 (defun message-send-mail-with-smtp ()
3332   "Send off the prepared buffer with SMTP."
3333   (require 'smtp) ; XXX
3334   (let ((case-fold-search t)
3335         recipients)
3336     (save-restriction
3337       (message-narrow-to-headers)
3338       (setq recipients
3339             ;; XXX: Should be replaced by better one.
3340             (smtp-deduce-address-list (current-buffer)
3341                                       (point-min) (point-max)))
3342       ;; Remove BCC lines.
3343       (message-remove-header "bcc"))
3344     ;; replace the header delimiter with a blank line.
3345     (goto-char (point-min))
3346     (re-search-forward
3347      (concat "^" (regexp-quote mail-header-separator) "\n"))
3348     (replace-match "\n")
3349     (backward-char 1)
3350     (run-hooks 'message-send-mail-hook)
3351     (if recipients
3352         (static-if (fboundp 'smtp-send-buffer)
3353             (smtp-send-buffer user-mail-address recipients
3354                               (current-buffer))
3355           (let ((result (smtp-via-smtp user-mail-address recipients
3356                                        (current-buffer))))
3357             (unless (eq result t)
3358               (error "Sending failed; %s" result))))
3359       (error "Sending failed; no recipients"))))
3360
3361 (defsubst message-maybe-split-and-send-news (method)
3362   "Split a message if necessary, and send it via news.
3363 Returns nil if sending succeeded, returns t if sending failed.
3364 This sub function is for exclusive use of `message-send-news'."
3365   (let ((mime-edit-split-ignored-field-regexp
3366          mime-edit-split-ignored-field-regexp)
3367         (case-fold-search t))
3368     (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
3369       (setq mime-edit-split-ignored-field-regexp
3370             (concat (substring mime-edit-split-ignored-field-regexp
3371                                0 (match-beginning 0))
3372                     "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
3373                     "_so_don't_rape_it!"
3374                     (substring mime-edit-split-ignored-field-regexp
3375                                (match-end 0)))))
3376     (or
3377      (catch 'message-sending-news-failure
3378        (mime-edit-maybe-split-and-send
3379         (function
3380          (lambda ()
3381            (interactive)
3382            (save-restriction
3383              (std11-narrow-to-header mail-header-separator)
3384              (goto-char (point-min))
3385              (when (re-search-forward "^Message-ID:" nil t)
3386                (delete-region (match-end 0) (std11-field-end))
3387                (insert " " (message-make-message-id))))
3388            (unless (funcall message-send-news-function method)
3389              (throw 'message-sending-news-failure t)))))
3390        nil)
3391      (not (funcall message-send-news-function method)))))
3392
3393 (defun message-send-news (&optional arg)
3394   (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
3395          (case-fold-search nil)
3396          (method (if (message-functionp message-post-method)
3397                      (funcall message-post-method arg)
3398                    message-post-method))
3399          (group-name-charset (gnus-group-name-charset method ""))
3400          (message-syntax-checks
3401           (if arg
3402               (cons '(existing-newsgroups . disabled)
3403                     message-syntax-checks)
3404             message-syntax-checks))
3405          (message-this-is-news t)
3406          result)
3407     (save-restriction
3408       (message-narrow-to-headers)
3409       ;; Insert some headers.
3410       (message-generate-headers message-required-news-headers)
3411       ;; Let the user do all of the above.
3412       (run-hooks 'message-header-hook))
3413     (when group-name-charset
3414       (setq message-syntax-checks
3415             (cons '(valid-newsgroups . disabled)
3416                   message-syntax-checks)))
3417     (message-cleanup-headers)
3418     (if (not (message-check-news-syntax))
3419         nil
3420       (unwind-protect
3421           (save-excursion
3422             (set-buffer tembuf)
3423             (buffer-disable-undo)
3424             (erase-buffer)
3425             (insert-buffer message-encoding-buffer)
3426             ;; Remove some headers.
3427             (save-restriction
3428               (message-narrow-to-headers)
3429 ;; We Semi-gnus people have no use for it.
3430 ;;            ;; We (re)generate the Lines header.
3431 ;;            (when (memq 'Lines message-required-mail-headers)
3432 ;;              (message-generate-headers '(Lines)))
3433               ;; Remove some headers.
3434               (message-remove-header message-ignored-news-headers t))
3435             (goto-char (point-max))
3436             ;; require one newline at the end.
3437             (or (= (preceding-char) ?\n)
3438                 (insert ?\n))
3439             (setq result (message-maybe-split-and-send-news method)))
3440         (kill-buffer tembuf))
3441       (set-buffer message-edit-buffer)
3442       (if result
3443           (progn
3444             (message "Couldn't send message via news: %s"
3445                      (nnheader-get-report (car method)))
3446             nil)
3447         (push 'news message-sent-message-via)))))
3448
3449 ;; 1997-09-29 by MORIOKA Tomohiko
3450 (defun message-send-news-with-gnus (method)
3451   (let ((case-fold-search t))
3452     ;; Remove the delimiter.
3453     (goto-char (point-min))
3454     (re-search-forward
3455      (concat "^" (regexp-quote mail-header-separator) "\n"))
3456     (replace-match "\n")
3457     (backward-char 1)
3458     (run-hooks 'message-send-news-hook)
3459     (gnus-open-server method)
3460     (message "Sending news with %s..." (gnus-server-string method))
3461     (gnus-request-post method)
3462     ))
3463
3464 ;;;
3465 ;;; Header generation & syntax checking.
3466 ;;;
3467
3468 (defun message-check-element (type)
3469   "Return non-nil if this TYPE is not to be checked."
3470   (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
3471       t
3472     (let ((able (assq type message-syntax-checks)))
3473       (and (consp able)
3474            (eq (cdr able) 'disabled)))))
3475
3476 (defun message-check-news-syntax ()
3477   "Check the syntax of the message."
3478   (save-excursion
3479     (save-restriction
3480       (widen)
3481       (and
3482        ;; We narrow to the headers and check them first.
3483        (save-excursion
3484          (save-restriction
3485            (message-narrow-to-headers)
3486            (message-check-news-header-syntax)))
3487        ;; Check the body.
3488        (save-excursion
3489          (set-buffer message-edit-buffer)
3490          (message-check-news-body-syntax))))))
3491
3492 (defun message-check-news-header-syntax ()
3493   (and
3494    ;; Check Newsgroups header.
3495    (message-check 'newsgroups
3496      (let ((group (message-fetch-field "newsgroups")))
3497        (or
3498         (and group
3499              (not (string-match "\\`[ \t]*\\'" group)))
3500         (ignore
3501          (message
3502           "The newsgroups field is empty or missing.  Posting is denied.")))))
3503    ;; Check the Subject header.
3504    (message-check 'subject
3505      (let* ((case-fold-search t)
3506             (subject (message-fetch-field "subject")))
3507        (or
3508         (and subject
3509              (not (string-match "\\`[ \t]*\\'" subject)))
3510         (ignore
3511          (message
3512           "The subject field is empty or missing.  Posting is denied.")))))
3513    ;; Check for commands in Subject.
3514    (message-check 'subject-cmsg
3515      (if (string-match "^cmsg " (message-fetch-field "subject"))
3516          (y-or-n-p
3517           "The control code \"cmsg\" is in the subject.  Really post? ")
3518        t))
3519    ;; Check for multiple identical headers.
3520    (message-check 'multiple-headers
3521      (let (found)
3522        (while (and (not found)
3523                    (re-search-forward "^[^ \t:]+: " nil t))
3524          (save-excursion
3525            (or (re-search-forward
3526                 (concat "^"
3527                         (regexp-quote
3528                          (setq found
3529                                (buffer-substring
3530                                 (match-beginning 0) (- (match-end 0) 2))))
3531                         ":")
3532                 nil t)
3533                (setq found nil))))
3534        (if found
3535            (y-or-n-p (format "Multiple %s headers.  Really post? " found))
3536          t)))
3537    ;; Check for Version and Sendsys.
3538    (message-check 'sendsys
3539      (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
3540          (y-or-n-p
3541           (format "The article contains a %s command.  Really post? "
3542                   (buffer-substring (match-beginning 0)
3543                                     (1- (match-end 0)))))
3544        t))
3545    ;; See whether we can shorten Followup-To.
3546    (message-check 'shorten-followup-to
3547      (let ((newsgroups (message-fetch-field "newsgroups"))
3548            (followup-to (message-fetch-field "followup-to"))
3549            to)
3550        (when (and newsgroups
3551                   (string-match "," newsgroups)
3552                   (not followup-to)
3553                   (not
3554                    (zerop
3555                     (length
3556                      (setq to (completing-read
3557                                "Followups to: (default all groups) "
3558                                (mapcar (lambda (g) (list g))
3559                                        (cons "poster"
3560                                              (message-tokenize-header
3561                                               newsgroups)))))))))
3562          (goto-char (point-min))
3563          (insert "Followup-To: " to "\n"))
3564        t))
3565    ;; Check "Shoot me".
3566    (message-check 'shoot
3567      (if (re-search-forward
3568           "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
3569          (y-or-n-p "You appear to have a misconfigured system.  Really post? ")
3570        t))
3571    ;; Check for Approved.
3572    (message-check 'approved
3573      (if (re-search-forward "^Approved:" nil t)
3574          (y-or-n-p "The article contains an Approved header.  Really post? ")
3575        t))
3576    ;; Check the Message-ID header.
3577    (message-check 'message-id
3578      (let* ((case-fold-search t)
3579             (message-id (message-fetch-field "message-id" t)))
3580        (or (not message-id)
3581            ;; Is there an @ in the ID?
3582            (and (string-match "@" message-id)
3583                 ;; Is there a dot in the ID?
3584                 (string-match "@[^.]*\\." message-id)
3585                 ;; Does the ID end with a dot?
3586                 (not (string-match "\\.>" message-id)))
3587            (y-or-n-p
3588             (format "The Message-ID looks strange: \"%s\".  Really post? "
3589                     message-id)))))
3590    ;; Check the Newsgroups & Followup-To headers.
3591    (message-check 'existing-newsgroups
3592      (let* ((case-fold-search t)
3593             (newsgroups (message-fetch-field "newsgroups"))
3594             (followup-to (message-fetch-field "followup-to"))
3595             (groups (message-tokenize-header
3596                      (if followup-to
3597                          (concat newsgroups "," followup-to)
3598                        newsgroups)))
3599             (hashtb (and (boundp 'gnus-active-hashtb)
3600                          gnus-active-hashtb))
3601             errors)
3602        (while groups
3603          (when (and (not (boundp (intern (car groups) hashtb)))
3604                     (not (equal (car groups) "poster")))
3605            (push (car groups) errors))
3606          (pop groups))
3607        (cond
3608         ;; Gnus is not running.
3609         ((or (not hashtb)
3610              (not (boundp 'gnus-read-active-file)))
3611          t)
3612         ;; We don't have all the group names.
3613         ((and (or (not gnus-read-active-file)
3614                   (eq gnus-read-active-file 'some))
3615               errors)
3616          (y-or-n-p
3617           (format
3618            "Really post to %s possibly unknown group%s: %s? "
3619            (if (= (length errors) 1) "this" "these")
3620            (if (= (length errors) 1) "" "s")
3621            (mapconcat 'identity errors ", "))))
3622         ;; There were no errors.
3623         ((not errors)
3624          t)
3625         ;; There are unknown groups.
3626         (t
3627          (y-or-n-p
3628           (format
3629            "Really post to %s unknown group%s: %s? "
3630            (if (= (length errors) 1) "this" "these")
3631            (if (= (length errors) 1) "" "s")
3632            (mapconcat 'identity errors ", ")))))))
3633      ;; Check the Newsgroups & Followup-To headers for syntax errors.
3634      (message-check 'valid-newsgroups
3635        (let ((case-fold-search t)
3636              (headers '("Newsgroups" "Followup-To"))
3637              header error)
3638          (while (and headers (not error))
3639            (when (setq header (mail-fetch-field (car headers)))
3640              (if (or
3641                   (not
3642                    (string-match
3643                     "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
3644                     header))
3645                   (memq
3646                    nil (mapcar
3647                         (lambda (g)
3648                           (not (string-match "\\.\\'\\|\\.\\." g)))
3649                         (message-tokenize-header header ","))))
3650                  (setq error t)))
3651            (unless error
3652              (pop headers)))
3653          (if (not error)
3654              t
3655            (y-or-n-p
3656             (format "The %s header looks odd: \"%s\".  Really post? "
3657                     (car headers) header)))))
3658      (message-check 'repeated-newsgroups
3659        (let ((case-fold-search t)
3660              (headers '("Newsgroups" "Followup-To"))
3661              header error groups group)
3662          (while (and headers
3663                      (not error))
3664            (when (setq header (mail-fetch-field (pop headers)))
3665              (setq groups (message-tokenize-header header ","))
3666              (while (setq group (pop groups))
3667                (when (member group groups)
3668                  (setq error group
3669                        groups nil)))))
3670          (if (not error)
3671              t
3672            (y-or-n-p
3673             (format "Group %s is repeated in headers.  Really post? " error)))))
3674      ;; Check the From header.
3675      (message-check 'from
3676        (let* ((case-fold-search t)
3677               (from (message-fetch-field "from"))
3678               ad)
3679          (cond
3680           ((not from)
3681            (message "There is no From line.  Posting is denied.")
3682            nil)
3683           ((or (not (string-match
3684                      "@[^\\.]*\\."
3685                      (setq ad (nth 1 (mail-extract-address-components
3686                                       from))))) ;larsi@ifi
3687                (string-match "\\.\\." ad) ;larsi@ifi..uio
3688                (string-match "@\\." ad) ;larsi@.ifi.uio
3689                (string-match "\\.$" ad) ;larsi@ifi.uio.
3690                (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
3691                (string-match "(.*).*(.*)" from)) ;(lars) (lars)
3692            (message
3693             "Denied posting -- the From looks strange: \"%s\"." from)
3694            nil)
3695           (t t))))
3696      ;; Check the Reply-To header.
3697      (message-check 'reply-to
3698        (let* ((case-fold-search t)
3699               (reply-to (message-fetch-field "reply-to"))
3700               ad)
3701          (cond
3702           ((not reply-to)
3703            t)
3704           ((string-match "," reply-to)
3705            (y-or-n-p
3706             (format "Multiple Reply-To addresses: \"%s\". Really post? "
3707                     reply-to)))
3708           ((or (not (string-match
3709                      "@[^\\.]*\\."
3710                      (setq ad (nth 1 (mail-extract-address-components
3711                                       reply-to))))) ;larsi@ifi
3712                (string-match "\\.\\." ad) ;larsi@ifi..uio
3713                (string-match "@\\." ad) ;larsi@.ifi.uio
3714                (string-match "\\.$" ad) ;larsi@ifi.uio.
3715                (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
3716                (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars)
3717            (y-or-n-p
3718             (format
3719              "The Reply-To looks strange: \"%s\". Really post? "
3720              reply-to)))
3721           (t t))))))
3722
3723 (defun message-check-news-body-syntax ()
3724   (and
3725    ;; Check for long lines.
3726    (message-check 'long-lines
3727      (goto-char (point-min))
3728      (re-search-forward
3729       (concat "^" (regexp-quote mail-header-separator) "$"))
3730      (forward-line 1)
3731      (while (and
3732              (or (looking-at
3733                   mime-edit-tag-regexp)
3734                  (let ((p (point)))
3735                    (end-of-line)
3736                    (< (- (point) p) 80)))
3737              (zerop (forward-line 1))))
3738      (or (bolp)
3739          (eobp)
3740          (y-or-n-p
3741           "You have lines longer than 79 characters.  Really post? ")))
3742    ;; Check whether the article is empty.
3743    (message-check 'empty
3744      (goto-char (point-min))
3745      (re-search-forward
3746       (concat "^" (regexp-quote mail-header-separator) "$"))
3747      (forward-line 1)
3748      (let ((b (point)))
3749        (goto-char (point-max))
3750        (re-search-backward message-signature-separator nil t)
3751        (beginning-of-line)
3752        (or (re-search-backward "[^ \n\t]" b t)
3753            (if (message-gnksa-enable-p 'empty-article)
3754                (y-or-n-p "Empty article.  Really post? ")
3755              (message "Denied posting -- Empty article.")
3756              nil))))
3757    ;; Check for control characters.
3758    (message-check 'control-chars
3759      (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
3760          (y-or-n-p
3761           "The article contains control characters.  Really post? ")
3762        t))
3763    ;; Check 8bit characters.
3764    (message-check '8bit
3765      (message-check-8bit))
3766    ;; Check excessive size.
3767    (message-check 'size
3768      (if (> (buffer-size) 60000)
3769          (y-or-n-p
3770           (format "The article is %d octets long.  Really post? "
3771                   (buffer-size)))
3772        t))
3773    ;; Check whether any new text has been added.
3774    (message-check 'new-text
3775      (or
3776       (not message-checksum)
3777       (not (eq (message-checksum) message-checksum))
3778       (if (message-gnksa-enable-p 'quoted-text-only)
3779           (y-or-n-p
3780            "It looks like no new text has been added.  Really post? ")
3781         (message "Denied posting -- no new text has been added.")
3782         nil)))
3783    ;; Check the length of the signature.
3784    (message-check 'signature
3785      (goto-char (point-max))
3786      (if (> (count-lines (point) (point-max)) 5)
3787          (y-or-n-p
3788           (format
3789            "Your .sig is %d lines; it should be max 4.  Really post? "
3790            (1- (count-lines (point) (point-max)))))
3791        t))
3792    ;; Ensure that text follows last quoted portion.
3793    (message-check 'quoting-style
3794      (goto-char (point-max))
3795      (let ((no-problem t))
3796        (when (search-backward-regexp "^>[^\n]*\n" nil t)
3797          (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t)))
3798        (if no-problem
3799            t
3800          (if (message-gnksa-enable-p 'quoted-text-only)
3801              (y-or-n-p "Your text should follow quoted text.  Really post? ")
3802            ;; Ensure that
3803            (goto-char (point-min))
3804            (re-search-forward
3805             (concat "^" (regexp-quote mail-header-separator) "$"))
3806            (if (search-forward-regexp "^[ \t]*[^>\n]" nil t)
3807                (y-or-n-p "Your text should follow quoted text.  Really post? ")
3808              (message "Denied posting -- only quoted text.")
3809              nil)))))))
3810
3811 (defun message-check-mail-syntax ()
3812   "Check the syntax of the message."
3813   (save-excursion
3814     (save-restriction
3815       (widen)
3816       (and
3817        ;; We narrow to the headers and check them first.
3818        (save-excursion
3819          (save-restriction
3820            (message-narrow-to-headers)
3821            (message-check-mail-header-syntax)))
3822        ;; Check the body.
3823        (save-excursion
3824          (set-buffer message-edit-buffer)
3825          (message-check-mail-body-syntax))))))
3826
3827 (defun message-check-mail-header-syntax ()
3828   t)
3829
3830 (defun message-check-mail-body-syntax ()
3831   (and
3832    ;; Check 8bit characters.
3833    (message-check '8bit
3834      (message-check-8bit)
3835      )))
3836
3837 (defun message-check-8bit ()
3838   "Check the article contains 8bit characters."
3839   (save-excursion
3840     (set-buffer message-encoding-buffer)
3841     (message-narrow-to-headers)
3842     (let* ((case-fold-search t)
3843            (field-value (message-fetch-field "content-transfer-encoding")))
3844       (if (and field-value
3845                (member (downcase field-value) message-8bit-encoding-list))
3846           t
3847         (widen)
3848         (set-buffer (get-buffer-create " message syntax"))
3849         (erase-buffer)
3850         (goto-char (point-min))
3851         (set-buffer-multibyte nil)
3852         (insert-buffer message-encoding-buffer)
3853         (goto-char (point-min))
3854         (if (re-search-forward "[^\x00-\x7f]" nil t)
3855             (y-or-n-p
3856              "The article contains 8bit characters.  Really post? ")
3857           t)))))
3858
3859 (defun message-checksum ()
3860   "Return a \"checksum\" for the current buffer."
3861   (let ((sum 0))
3862     (save-excursion
3863       (goto-char (point-min))
3864       (re-search-forward
3865        (concat "^" (regexp-quote mail-header-separator) "$"))
3866       (while (not (eobp))
3867         (when (not (looking-at "[ \t\n]"))
3868           (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
3869                             (char-after))))
3870         (forward-char 1)))
3871     sum))
3872
3873 (defun message-do-fcc ()
3874   "Process Fcc headers in the current buffer."
3875   (let ((case-fold-search t)
3876         (coding-system-for-write 'raw-text)
3877         (output-coding-system 'raw-text)
3878         list file)
3879     (save-excursion
3880       (save-restriction
3881         (message-narrow-to-headers)
3882         (setq file (message-fetch-field "fcc" t)))
3883       (when file
3884         (set-buffer (get-buffer-create " *message temp*"))
3885         (erase-buffer)
3886         (insert-buffer-substring message-encoding-buffer)
3887         (save-restriction
3888           (message-narrow-to-headers)
3889           (while (setq file (message-fetch-field "fcc"))
3890             (push file list)
3891             (message-remove-header "fcc" nil t)))
3892         (goto-char (point-min))
3893         (when (re-search-forward
3894                (concat "^" (regexp-quote mail-header-separator) "$")
3895                nil t)
3896           (replace-match "" t t))
3897         ;; Process FCC operations.
3898         (while list
3899           (setq file (pop list))
3900           (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
3901               ;; Pipe the article to the program in question.
3902               (call-process-region (point-min) (point-max) shell-file-name
3903                                    nil nil nil shell-command-switch
3904                                    (match-string 1 file))
3905             ;; Save the article.
3906             (setq file (expand-file-name file))
3907             (unless (file-exists-p (file-name-directory file))
3908               (make-directory (file-name-directory file) t))
3909             (if (and message-fcc-handler-function
3910                      (not (eq message-fcc-handler-function 'rmail-output)))
3911                 (funcall message-fcc-handler-function file)
3912               (if (and (file-readable-p file) (mail-file-babyl-p file))
3913                   (rmail-output file 1 nil t)
3914                 (let ((mail-use-rfc822 t))
3915                   (rmail-output file 1 t t))))))
3916         (kill-buffer (current-buffer))))))
3917
3918 (defun message-output (filename)
3919   "Append this article to Unix/babyl mail file FILENAME."
3920   (if (and (file-readable-p filename)
3921            (mail-file-babyl-p filename))
3922       (gnus-output-to-rmail filename t)
3923     (gnus-output-to-mail filename t)))
3924
3925 (defun message-cleanup-headers ()
3926   "Do various automatic cleanups of the headers."
3927   ;; Remove empty lines in the header.
3928   (save-restriction
3929     (message-narrow-to-headers)
3930     ;; Remove blank lines.
3931     (while (re-search-forward "^[ \t]*\n" nil t)
3932       (replace-match "" t t))
3933
3934     ;; Correct Newsgroups and Followup-To headers:  Change sequence of
3935     ;; spaces to comma and eliminate spaces around commas.  Eliminate
3936     ;; embedded line breaks.
3937     (goto-char (point-min))
3938     (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
3939       (save-restriction
3940         (narrow-to-region
3941          (point)
3942          (if (re-search-forward "^[^ \t]" nil t)
3943              (match-beginning 0)
3944            (forward-line 1)
3945            (point)))
3946         (goto-char (point-min))
3947         (while (re-search-forward "\n[ \t]+" nil t)
3948           (replace-match " " t t))      ;No line breaks (too confusing)
3949         (goto-char (point-min))
3950         (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
3951           (replace-match "," t t))
3952         (goto-char (point-min))
3953         ;; Remove trailing commas.
3954         (when (re-search-forward ",+$" nil t)
3955           (replace-match "" t t))))))
3956
3957 (defun message-make-date (&optional now)
3958   "Make a valid data header.
3959 If NOW, use that time instead."
3960   (let* ((now (or now (current-time)))
3961          (zone (nth 8 (decode-time now)))
3962          (sign "+"))
3963     (when (< zone 0)
3964       (setq sign "-")
3965       (setq zone (- zone)))
3966     (concat
3967      (format-time-string "%a, %d" now)
3968      ;; The month name of the %b spec is locale-specific.  Pfff.
3969      (format " %s "
3970              (capitalize (car (rassoc (nth 4 (decode-time now))
3971                                       parse-time-months))))
3972      (format-time-string "%Y %H:%M:%S " now)
3973      ;; We do all of this because XEmacs doesn't have the %z spec.
3974      (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
3975
3976 (defun message-make-followup-subject (subject)
3977   "Make a followup Subject."
3978   (cond
3979    ((and (eq message-use-subject-re 'guess)
3980          (string-match message-subject-encoded-re-regexp subject))
3981     subject)
3982    (message-use-subject-re
3983     (concat "Re: " (message-strip-subject-re subject)))
3984    (t subject)))
3985
3986 (defun message-make-message-id ()
3987   "Make a unique Message-ID."
3988   (concat "<" (message-unique-id)
3989           (let ((psubject (save-excursion (message-fetch-field "subject")))
3990                 (psupersedes
3991                  (save-excursion (message-fetch-field "supersedes"))))
3992             (if (or
3993                  (and message-reply-headers
3994                       (mail-header-references message-reply-headers)
3995                       (mail-header-subject message-reply-headers)
3996                       psubject
3997                       (not (string=
3998                             (message-strip-subject-re
3999                              (mail-header-subject message-reply-headers))
4000                             (message-strip-subject-re psubject))))
4001                  (and psupersedes
4002                       (string-match "_-_@" psupersedes)))
4003                 "_-_" ""))
4004           "@" (message-make-fqdn) ">"))
4005
4006 (defvar message-unique-id-char nil)
4007
4008 ;; If you ever change this function, make sure the new version
4009 ;; cannot generate IDs that the old version could.
4010 ;; You might for example insert a "." somewhere (not next to another dot
4011 ;; or string boundary), or modify the "fsf" string.
4012 (defun message-unique-id ()
4013   ;; Don't use microseconds from (current-time), they may be unsupported.
4014   ;; Instead we use this randomly inited counter.
4015   (setq message-unique-id-char
4016         (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
4017            ;; (current-time) returns 16-bit ints,
4018            ;; and 2^16*25 just fits into 4 digits i base 36.
4019            (* 25 25)))
4020   (let ((tm (current-time)))
4021     (concat
4022      (if (memq system-type '(ms-dos emx vax-vms))
4023          (let ((user (downcase (user-login-name))))
4024            (while (string-match "[^a-z0-9_]" user)
4025              (aset user (match-beginning 0) ?_))
4026            user)
4027        (message-number-base36 (user-uid) -1))
4028      (message-number-base36 (+ (car   tm)
4029                                (lsh (% message-unique-id-char 25) 16)) 4)
4030      (message-number-base36 (+ (nth 1 tm)
4031                                (lsh (/ message-unique-id-char 25) 16)) 4)
4032      ;; Append the newsreader name, because while the generated
4033      ;; ID is unique to this newsreader, other newsreaders might
4034      ;; otherwise generate the same ID via another algorithm.
4035      ".fsf")))
4036
4037 (defun message-number-base36 (num len)
4038   (if (if (< len 0)
4039           (<= num 0)
4040         (= len 0))
4041       ""
4042     (concat (message-number-base36 (/ num 36) (1- len))
4043             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
4044                                   (% num 36))))))
4045
4046 (defun message-make-organization ()
4047   "Make an Organization header."
4048   (let* ((organization
4049           (when message-user-organization
4050             (if (message-functionp message-user-organization)
4051                 (funcall message-user-organization)
4052               message-user-organization))))
4053     (save-excursion
4054       (message-set-work-buffer)
4055       (cond ((stringp organization)
4056              (insert organization))
4057             ((and (eq t organization)
4058                   message-user-organization-file
4059                   (file-exists-p message-user-organization-file))
4060              (insert-file-contents message-user-organization-file)))
4061       (goto-char (point-min))
4062       (while (re-search-forward "[\t\n]+" nil t)
4063         (replace-match "" t t))
4064       (unless (zerop (buffer-size))
4065         (buffer-string)))))
4066
4067 (defun message-make-lines ()
4068   "Count the number of lines and return numeric string."
4069   (save-excursion
4070     (save-restriction
4071       (widen)
4072       (message-goto-body)
4073       (int-to-string (count-lines (point) (point-max))))))
4074
4075 (defun message-make-in-reply-to ()
4076   "Return the In-Reply-To header for this message."
4077   (when message-reply-headers
4078     (let ((from (mail-header-from message-reply-headers))
4079           (date (mail-header-date message-reply-headers))
4080           (msg-id (mail-header-message-id message-reply-headers)))
4081       (when msg-id
4082         (concat msg-id
4083                 (when from
4084                   (let ((pair (std11-extract-address-components from)))
4085                     (concat "\n ("
4086                             (or (car pair) (cadr pair))
4087                             "'s message of \""
4088                             (if (or (not date) (string= date ""))
4089                                 "(unknown date)" date)
4090                             "\")"))))))))
4091
4092 (defun message-make-distribution ()
4093   "Make a Distribution header."
4094   (let ((orig-distribution (message-fetch-reply-field "distribution")))
4095     (cond ((message-functionp message-distribution-function)
4096            (funcall message-distribution-function))
4097           (t orig-distribution))))
4098
4099 (defun message-make-expires ()
4100   "Return an Expires header based on `message-expires'."
4101   (let ((current (current-time))
4102         (future (* 1.0 message-expires 60 60 24)))
4103     ;; Add the future to current.
4104     (setcar current (+ (car current) (round (/ future (expt 2 16)))))
4105     (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
4106     (message-make-date current)))
4107
4108 (defun message-make-path ()
4109   "Return uucp path."
4110   (let ((login-name (user-login-name)))
4111     (cond ((null message-user-path)
4112            (concat (system-name) "!" login-name))
4113           ((stringp message-user-path)
4114            ;; Support GENERICPATH.  Suggested by vixie@decwrl.dec.com.
4115            (concat message-user-path "!" login-name))
4116           (t login-name))))
4117
4118 (defun message-make-from ()
4119   "Make a From header."
4120   (let* ((style message-from-style)
4121          (login (message-make-address))
4122          (fullname
4123           (or (and (boundp 'user-full-name)
4124                    user-full-name)
4125               (user-full-name))))
4126     (when (string= fullname "&")
4127       (setq fullname (user-login-name)))
4128     (save-excursion
4129       (message-set-work-buffer)
4130       (cond
4131        ((or (null style)
4132             (equal fullname ""))
4133         (insert login))
4134        ((or (eq style 'angles)
4135             (and (not (eq style 'parens))
4136                  ;; Use angles if no quoting is needed, or if parens would
4137                  ;; need quoting too.
4138                  (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
4139                      (let ((tmp (concat fullname nil)))
4140                        (while (string-match "([^()]*)" tmp)
4141                          (aset tmp (match-beginning 0) ?-)
4142                          (aset tmp (1- (match-end 0)) ?-))
4143                        (string-match "[\\()]" tmp)))))
4144         (insert fullname)
4145         (goto-char (point-min))
4146         ;; Look for a character that cannot appear unquoted
4147         ;; according to RFC 822.
4148         (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
4149           ;; Quote fullname, escaping specials.
4150           (goto-char (point-min))
4151           (insert "\"")
4152           (while (re-search-forward "[\"\\]" nil 1)
4153             (replace-match "\\\\\\&" t))
4154           (insert "\""))
4155         (insert " <" login ">"))
4156        (t                               ; 'parens or default
4157         (insert login " (")
4158         (let ((fullname-start (point)))
4159           (insert fullname)
4160           (goto-char fullname-start)
4161           ;; RFC 822 says \ and nonmatching parentheses
4162           ;; must be escaped in comments.
4163           ;; Escape every instance of ()\ ...
4164           (while (re-search-forward "[()\\]" nil 1)
4165             (replace-match "\\\\\\&" t))
4166           ;; ... then undo escaping of matching parentheses,
4167           ;; including matching nested parentheses.
4168           (goto-char fullname-start)
4169           (while (re-search-forward
4170                   "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
4171                   nil 1)
4172             (replace-match "\\1(\\3)" t)
4173             (goto-char fullname-start)))
4174         (insert ")")))
4175       (buffer-string))))
4176
4177 (defun message-make-sender ()
4178   "Return the \"real\" user address.
4179 This function tries to ignore all user modifications, and
4180 give as trustworthy answer as possible."
4181   (concat (user-login-name) "@" (system-name)))
4182
4183 (defun message-make-address ()
4184   "Make the address of the user."
4185   (or (message-user-mail-address)
4186       (concat (user-login-name) "@" (message-make-domain))))
4187
4188 (defun message-user-mail-address ()
4189   "Return the pertinent part of `user-mail-address'."
4190   (when user-mail-address
4191     (if (string-match " " user-mail-address)
4192         (nth 1 (std11-extract-address-components user-mail-address))
4193       user-mail-address)))
4194
4195 (defun message-make-fqdn ()
4196   "Return user's fully qualified domain name."
4197   (let ((system-name (system-name))
4198         (user-mail (message-user-mail-address)))
4199     (cond
4200      ((string-match "[^.]\\.[^.]" system-name)
4201       ;; `system-name' returned the right result.
4202       system-name)
4203      ;; Try `mail-host-address'.
4204      ((and (boundp 'mail-host-address)
4205            (stringp mail-host-address)
4206            (string-match "\\." mail-host-address))
4207       mail-host-address)
4208      ;; We try `user-mail-address' as a backup.
4209      ((and user-mail
4210            (string-match "\\." user-mail)
4211            (string-match "@\\(.*\\)\\'" user-mail))
4212       (match-string 1 user-mail))
4213      ;; Default to this bogus thing.
4214      (t
4215       (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me")))))
4216
4217 (defun message-make-host-name ()
4218   "Return the name of the host."
4219   (let ((fqdn (message-make-fqdn)))
4220     (string-match "^[^.]+\\." fqdn)
4221     (substring fqdn 0 (1- (match-end 0)))))
4222
4223 (defun message-make-domain ()
4224   "Return the domain name."
4225   (or mail-host-address
4226       (message-make-fqdn)))
4227
4228 ;; Dummy to avoid byte-compile warning.
4229 (defvar mule-version)
4230 (defvar emacs-beta-version)
4231 (defvar xemacs-codename)
4232 (defvar gnus-inviolable-extended-version)
4233
4234 (defun message-make-user-agent ()
4235   "Return user-agent info if the value `message-user-agent' is non-nil. If the
4236 \"User-Agent\" field has already exist, it's value will be added in the return
4237 string."
4238   (when message-user-agent
4239     (save-excursion
4240       (goto-char (point-min))
4241       (let ((case-fold-search t)
4242             user-agent start p end)
4243         (if (re-search-forward "^User-Agent:[\t ]*" nil t)
4244             (progn
4245               (setq start (match-beginning 0)
4246                     p (match-end 0)
4247                     end (std11-field-end)
4248                     user-agent (buffer-substring-no-properties p end))
4249               (delete-region start (1+ end))
4250               (concat message-user-agent " " user-agent))
4251           message-user-agent)))))
4252
4253 (defun message-generate-headers (headers)
4254   "Prepare article HEADERS.
4255 Headers already prepared in the buffer are not modified."
4256   (save-restriction
4257     (message-narrow-to-headers)
4258     (let* ((Date (message-make-date))
4259            (Message-ID (message-make-message-id))
4260            (Organization (message-make-organization))
4261            (From (message-make-from))
4262            (Path (message-make-path))
4263            (Subject nil)
4264            (Newsgroups nil)
4265            (In-Reply-To (message-make-in-reply-to))
4266            (To nil)
4267            (Distribution (message-make-distribution))
4268            (Lines (message-make-lines))
4269            (User-Agent (message-make-user-agent))
4270            (Expires (message-make-expires))
4271            (case-fold-search t)
4272            header value elem)
4273       ;; First we remove any old generated headers.
4274       (let ((headers message-deletable-headers))
4275         (unless (buffer-modified-p)
4276           (setq headers (delq 'Message-ID (copy-sequence headers))))
4277         (while headers
4278           (goto-char (point-min))
4279           (and (re-search-forward
4280                 (concat "^" (symbol-name (car headers)) ": *") nil t)
4281                (get-text-property (1+ (match-beginning 0)) 'message-deletable)
4282                (message-delete-line))
4283           (pop headers)))
4284       ;; Go through all the required headers and see if they are in the
4285       ;; articles already.  If they are not, or are empty, they are
4286       ;; inserted automatically - except for Subject, Newsgroups and
4287       ;; Distribution.
4288       (while headers
4289         (goto-char (point-min))
4290         (setq elem (pop headers))
4291         (if (consp elem)
4292             (if (eq (car elem) 'optional)
4293                 (setq header (cdr elem))
4294               (setq header (car elem)))
4295           (setq header elem))
4296         (when (or (not (re-search-forward
4297                         (concat "^"
4298                                 (regexp-quote
4299                                  (downcase
4300                                   (if (stringp header)
4301                                       header
4302                                     (symbol-name header))))
4303                                 ":")
4304                         nil t))
4305                   (progn
4306                     ;; The header was found.  We insert a space after the
4307                     ;; colon, if there is none.
4308                     (if (/= (char-after) ? ) (insert " ") (forward-char 1))
4309                     ;; Find out whether the header is empty...
4310                     (looking-at "[ \t]*\n[^ \t]")))
4311           ;; So we find out what value we should insert.
4312           (setq value
4313                 (cond
4314                  ((and (consp elem) (eq (car elem) 'optional))
4315                   ;; This is an optional header.  If the cdr of this
4316                   ;; is something that is nil, then we do not insert
4317                   ;; this header.
4318                   (setq header (cdr elem))
4319                   (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
4320                       (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
4321                  ((consp elem)
4322                   ;; The element is a cons.  Either the cdr is a
4323                   ;; string to be inserted verbatim, or it is a
4324                   ;; function, and we insert the value returned from
4325                   ;; this function.
4326                   (or (and (stringp (cdr elem)) (cdr elem))
4327                       (and (fboundp (cdr elem)) (funcall (cdr elem)))))
4328                  ((and (boundp header) (symbol-value header))
4329                   ;; The element is a symbol.  We insert the value
4330                   ;; of this symbol, if any.
4331                   (symbol-value header))
4332                  ((not (message-check-element header))
4333                   ;; We couldn't generate a value for this header,
4334                   ;; so we just ask the user.
4335                   (read-from-minibuffer
4336                    (format "Empty header for %s; enter value: " header)))))
4337           ;; Finally insert the header.
4338           (when (and value
4339                      (not (equal value "")))
4340             (save-excursion
4341               (if (bolp)
4342                   (progn
4343                     ;; This header didn't exist, so we insert it.
4344                     (goto-char (point-max))
4345                     (insert (if (stringp header) header (symbol-name header))
4346                             ": " value)
4347                     (unless (bolp)
4348                       (insert "\n"))
4349                     (forward-line -1))
4350                 ;; The value of this header was empty, so we clear
4351                 ;; totally and insert the new value.
4352                 (delete-region (point) (gnus-point-at-eol))
4353                 (insert value)
4354                 (when (bolp)
4355                   (delete-char -1)))
4356               ;; Add the deletable property to the headers that require it.
4357               (and (memq header message-deletable-headers)
4358                    (progn (beginning-of-line) (looking-at "[^:]+: "))
4359                    (add-text-properties
4360                     (point) (match-end 0)
4361                     '(message-deletable t face italic) (current-buffer)))))))
4362       ;; Insert new Sender if the From is strange.
4363       (let ((from (message-fetch-field "from"))
4364             (sender (message-fetch-field "sender"))
4365             (secure-sender (message-make-sender)))
4366         (when (and from
4367                    (not (message-check-element 'sender))
4368                    (not (string=
4369                          (downcase
4370                           (cadr (std11-extract-address-components from)))
4371                          (downcase secure-sender)))
4372                    (or (null sender)
4373                        (not
4374                         (string=
4375                          (downcase
4376                           (cadr (std11-extract-address-components sender)))
4377                          (downcase secure-sender)))))
4378           (goto-char (point-min))
4379           ;; Rename any old Sender headers to Original-Sender.
4380           (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
4381             (beginning-of-line)
4382             (insert "Original-")
4383             (beginning-of-line))
4384           (when (or (message-news-p)
4385                     (string-match "@.+\\.." secure-sender))
4386             (insert "Sender: " secure-sender "\n")))))))
4387
4388 (defun message-insert-courtesy-copy ()
4389   "Insert a courtesy message in mail copies of combined messages."
4390   (let (newsgroups)
4391     (save-excursion
4392       (save-restriction
4393         (message-narrow-to-headers)
4394         (when (setq newsgroups (message-fetch-field "newsgroups"))
4395           (goto-char (point-max))
4396           (insert "Posted-To: " newsgroups "\n")))
4397       (forward-line 1)
4398       (when message-courtesy-message
4399         (cond
4400          ((string-match "%s" message-courtesy-message)
4401           (insert (format message-courtesy-message newsgroups)))
4402          (t
4403           (insert message-courtesy-message)))))))
4404
4405 ;;;
4406 ;;; Setting up a message buffer
4407 ;;;
4408
4409 (defun message-fill-address (header value)
4410   (save-restriction
4411     (narrow-to-region (point) (point))
4412     (insert (capitalize (symbol-name header))
4413             ": "
4414             (if (consp value) (car value) value)
4415             "\n")
4416     (narrow-to-region (point-min) (1- (point-max)))
4417     (let (quoted last)
4418       (goto-char (point-min))
4419       (while (not (eobp))
4420         (skip-chars-forward "^,\"" (point-max))
4421         (if (or (eq (char-after) ?,)
4422                 (eobp))
4423             (when (not quoted)
4424               (if (and (> (current-column) 78)
4425                        last)
4426                   (save-excursion
4427                     (goto-char last)
4428                     (looking-at "[ \t]*")
4429                     (replace-match "\n " t t)))
4430               (setq last (1+ (point))))
4431           (setq quoted (not quoted)))
4432         (unless (eobp)
4433           (forward-char 1))))
4434     (goto-char (point-max))
4435     (widen)
4436     (forward-line 1)))
4437
4438 (defun message-fill-references (header value)
4439   (insert (capitalize (symbol-name header))
4440           ": "
4441           (std11-fill-msg-id-list-string
4442           (if (consp value) (car value) value))
4443           "\n"))
4444
4445 (defun message-fill-header (header value)
4446   (let ((begin (point))
4447         (fill-column 78)
4448         (fill-prefix " "))
4449     (insert (capitalize (symbol-name header))
4450             ": "
4451             (if (consp value) (car value) value)
4452             "\n")
4453     (save-restriction
4454       (narrow-to-region begin (point))
4455       (fill-region-as-paragraph begin (point))
4456       ;; Tapdance around looong Message-IDs.
4457       (forward-line -1)
4458       (when (looking-at "[ \t]*$")
4459         (message-delete-line))
4460       (goto-char begin)
4461       (re-search-forward ":" nil t)
4462       (when (looking-at "\n[ \t]+")
4463         (replace-match " " t t))
4464       (goto-char (point-max)))))
4465
4466 (defun message-shorten-1 (list cut surplus)
4467   "Cut SURPLUS elements out of LIST, beginning with CUTth one."
4468   (setcdr (nthcdr (- cut 2) list)
4469           (nthcdr (+ (- cut 2) surplus 1) list)))
4470
4471 (defun message-shorten-references (header references)
4472   "Trim REFERENCES to be less than 31 Message-ID long, and fold them.
4473 If folding is disallowed, also check that the REFERENCES are less
4474 than 988 characters long, and if they are not, trim them until they are."
4475   (let ((maxcount 31)
4476         (count 0)
4477         (cut 6)
4478         refs)
4479     (with-temp-buffer
4480       (insert references)
4481       (goto-char (point-min))
4482       ;; Cons a list of valid references.
4483       (while (re-search-forward "<[^>]+>" nil t)
4484         (push (match-string 0) refs))
4485       (setq refs (nreverse refs)
4486             count (length refs)))
4487
4488     ;; If the list has more than MAXCOUNT elements, trim it by
4489     ;; removing the CUTth element and the required number of
4490     ;; elements that follow.
4491     (when (> count maxcount)
4492       (let ((surplus (- count maxcount)))
4493         (message-shorten-1 refs cut surplus)
4494         (decf count surplus)))
4495
4496     ;; If folding is disallowed, make sure the total length (including
4497     ;; the spaces between) will be less than MAXSIZE characters.
4498     ;;
4499     ;; Only disallow folding for News messages. At this point the headers
4500     ;; have not been generated, thus we use message-this-is-news directly.
4501     (when (and message-this-is-news message-cater-to-broken-inn)
4502       (let ((maxsize 988)
4503             (totalsize (+ (apply #'+ (mapcar #'length refs))
4504                           (1- count)))
4505             (surplus 0)
4506             (ptr (nthcdr (1- cut) refs)))
4507         ;; Decide how many elements to cut off...
4508         (while (> totalsize maxsize)
4509           (decf totalsize (1+ (length (car ptr))))
4510           (incf surplus)
4511           (setq ptr (cdr ptr)))
4512         ;; ...and do it.
4513         (when (> surplus 0)
4514           (message-shorten-1 refs cut surplus))))
4515
4516     ;; Finally, collect the references back into a string and insert
4517     ;; it into the buffer.
4518     (let ((refstring (mapconcat #'identity refs " ")))
4519       (if (and message-this-is-news message-cater-to-broken-inn)
4520           (insert (capitalize (symbol-name header)) ": "
4521                   refstring "\n")
4522         (message-fill-header header refstring)))))
4523
4524 (defun message-position-point ()
4525   "Move point to where the user probably wants to find it."
4526   (message-narrow-to-headers)
4527   (cond
4528    ((re-search-forward "^[^:]+:[ \t]*$" nil t)
4529     (search-backward ":" )
4530     (widen)
4531     (forward-char 1)
4532     (if (eq (char-after) ? )
4533         (forward-char 1)
4534       (insert " ")))
4535    (t
4536     (goto-char (point-max))
4537     (widen)
4538     (forward-line 1)
4539     (unless (looking-at "$")
4540       (forward-line 2)))
4541    (sit-for 0)))
4542
4543 (defun message-buffer-name (type &optional to group)
4544   "Return a new (unique) buffer name based on TYPE and TO."
4545   (cond
4546    ;; Generate a new buffer name The Message Way.
4547    ((eq message-generate-new-buffers 'unique)
4548     (generate-new-buffer-name
4549      (concat "*" type
4550              (if to
4551                  (concat " to "
4552                          (or (car (std11-extract-address-components to))
4553                              to) "")
4554                "")
4555              (if (and group (not (string= group ""))) (concat " on " group) "")
4556              "*")))
4557    ;; Check whether `message-generate-new-buffers' is a function,
4558    ;; and if so, call it.
4559    ((message-functionp message-generate-new-buffers)
4560     (funcall message-generate-new-buffers type to group))
4561    ((eq message-generate-new-buffers 'unsent)
4562     (generate-new-buffer-name
4563      (concat "*unsent " type
4564              (if to
4565                  (concat " to "
4566                          (or (car (mail-extract-address-components to))
4567                              to) "")
4568                "")
4569              (if (and group (not (string= group ""))) (concat " on " group) "")
4570              "*")))
4571    ;; Use standard name.
4572    (t
4573     (format "*%s message*" type))))
4574
4575 (defmacro message-pop-to-buffer-1 (buffer)
4576   `(if pop-up-frames
4577        (let (special-display-buffer-names
4578              special-display-regexps
4579              same-window-buffer-names
4580              same-window-regexps)
4581          (pop-to-buffer ,buffer))
4582      (pop-to-buffer ,buffer)))
4583
4584 (defun message-pop-to-buffer (name)
4585   "Pop to buffer NAME, and warn if it already exists and is modified."
4586   (let ((buffer (get-buffer name))
4587         (pop-up-frames (and (or (static-if (featurep 'xemacs)
4588                                     (device-on-window-system-p)
4589                                   window-system)
4590                                 (>= emacs-major-version 20))
4591                             message-use-multi-frames)))
4592     (if (and buffer
4593              (buffer-name buffer))
4594         (progn
4595           (message-pop-to-buffer-1 buffer)
4596           (when (and (buffer-modified-p)
4597                      (not (y-or-n-p
4598                            "Message already being composed; erase? ")))
4599             (error "Message being composed")))
4600       (message-pop-to-buffer-1 name))
4601     (erase-buffer)
4602     (message-mode)
4603     (when pop-up-frames
4604       (set (make-local-variable 'message-original-frame) (selected-frame)))))
4605
4606 (defun message-do-send-housekeeping ()
4607   "Kill old message buffers."
4608   ;; We might have sent this buffer already.  Delete it from the
4609   ;; list of buffers.
4610   (setq message-buffer-list (delq (current-buffer) message-buffer-list))
4611   (while (and message-max-buffers
4612               message-buffer-list
4613               (>= (length message-buffer-list) message-max-buffers))
4614     ;; Kill the oldest buffer -- unless it has been changed.
4615     (let ((buffer (pop message-buffer-list)))
4616       (when (and (buffer-name buffer)
4617                  (not (buffer-modified-p buffer)))
4618         (kill-buffer buffer))))
4619   ;; Rename the buffer.
4620   (if message-send-rename-function
4621       (funcall message-send-rename-function)
4622     ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
4623     (when (string-match
4624            "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
4625            (buffer-name))
4626       (let ((name (match-string 2 (buffer-name)))
4627             to group)
4628         (if (not (or (null name)
4629                      (string-equal name "mail")
4630                      (string-equal name "news")))
4631             (setq name (concat "*sent " name "*"))
4632           (setq to (message-fetch-field "to"))
4633           (setq group (message-fetch-field "newsgroups"))
4634           (setq name
4635                 (cond
4636                  (to (concat "*sent mail to "
4637                              (or (car (mail-extract-address-components to))
4638                                  to) "*"))
4639                  ((and group (not (string= group "")))
4640                   (concat "*sent news on " group "*"))
4641                  (t "*sent mail*"))))
4642         (unless (string-equal name (buffer-name))
4643           (rename-buffer name t)))))
4644   ;; Push the current buffer onto the list.
4645   (when message-max-buffers
4646     (setq message-buffer-list
4647           (nconc message-buffer-list (list (current-buffer))))))
4648
4649 (defun message-mail-user-agent ()
4650   (let ((mua (cond
4651               ((not message-mail-user-agent) nil)
4652               ((eq message-mail-user-agent t) mail-user-agent)
4653               (t message-mail-user-agent))))
4654     (if (memq mua '(message-user-agent gnus-user-agent))
4655         nil
4656       mua)))
4657
4658 (defun message-setup (headers &optional replybuffer actions switch-function)
4659   (let ((mua (message-mail-user-agent))
4660         subject to field yank-action)
4661     (if (not (and message-this-is-mail mua))
4662         (message-setup-1 headers replybuffer actions)
4663       (if replybuffer
4664           (setq yank-action (list 'insert-buffer replybuffer)))
4665       (setq headers (copy-sequence headers))
4666       (setq field (assq 'Subject headers))
4667       (when field
4668         (setq subject (cdr field))
4669         (setq headers (delq field headers)))
4670       (setq field (assq 'To headers))
4671       (when field
4672         (setq to (cdr field))
4673         (setq headers (delq field headers)))
4674       (let ((mail-user-agent mua))
4675         (compose-mail to subject
4676                       (mapcar (lambda (item)
4677                                 (cons
4678                                  (format "%s" (car item))
4679                                  (cdr item)))
4680                               headers)
4681                       nil switch-function yank-action actions)))))
4682
4683 ;;;(defvar mc-modes-alist)
4684 (defun message-setup-1 (headers &optional replybuffer actions)
4685 ;;;   (when (and (boundp 'mc-modes-alist)
4686 ;;;          (not (assq 'message-mode mc-modes-alist)))
4687 ;;;     (push '(message-mode (encrypt . mc-encrypt-message)
4688 ;;;                      (sign . mc-sign-message))
4689 ;;;       mc-modes-alist))
4690   (when actions
4691     (setq message-send-actions actions))
4692   (setq message-reply-buffer
4693         (or (message-get-parameter 'reply-buffer)
4694             replybuffer))
4695   (goto-char (point-min))
4696   ;; Insert all the headers.
4697   (mail-header-format
4698    (let ((h headers)
4699          (alist message-header-format-alist))
4700      (while h
4701        (unless (assq (caar h) message-header-format-alist)
4702          (push (list (caar h)) alist))
4703        (pop h))
4704      alist)
4705    headers)
4706   (delete-region (point) (progn (forward-line -1) (point)))
4707   (when message-default-headers
4708     (insert message-default-headers)
4709     (or (bolp) (insert ?\n)))
4710   (put-text-property
4711    (point)
4712    (progn
4713      (insert mail-header-separator "\n")
4714      (1- (point)))
4715    'read-only nil)
4716   (forward-line -1)
4717   (when (message-news-p)
4718     (when message-default-news-headers
4719       (insert message-default-news-headers)
4720       (or (bolp) (insert ?\n)))
4721     (when message-generate-headers-first
4722       (message-generate-headers
4723        (delq 'Lines
4724              (delq 'Subject
4725                    (copy-sequence message-required-news-headers))))))
4726   (when (message-mail-p)
4727     (when message-default-mail-headers
4728       (insert message-default-mail-headers)
4729       (or (bolp) (insert ?\n)))
4730     (when message-generate-headers-first
4731       (message-generate-headers
4732        (delq 'Lines
4733              (delq 'Subject
4734                    (copy-sequence message-required-mail-headers))))))
4735   (run-hooks 'message-signature-setup-hook)
4736   (message-insert-signature)
4737   (save-restriction
4738     (message-narrow-to-headers)
4739     (if message-alternative-emails
4740         (message-use-alternative-email-as-from))
4741     (run-hooks 'message-header-setup-hook))
4742   (set-buffer-modified-p nil)
4743   (setq buffer-undo-list nil)
4744   (run-hooks 'message-setup-hook)
4745   (message-position-point)
4746   (undo-boundary))
4747
4748 (defun message-set-auto-save-file-name ()
4749   "Associate the message buffer with a file in the drafts directory."
4750   (when message-auto-save-directory
4751     (unless (file-directory-p
4752              (directory-file-name message-auto-save-directory))
4753       (gnus-make-directory message-auto-save-directory))
4754     (if (gnus-alive-p)
4755         (setq message-draft-article
4756               (nndraft-request-associate-buffer "drafts"))
4757       (setq buffer-file-name (expand-file-name
4758                               (if (eq system-type 'windows-nt)
4759                                   "message"
4760                                 "*message*")
4761                               message-auto-save-directory))
4762       (setq buffer-auto-save-file-name (make-auto-save-file-name)))
4763     (clear-visited-file-modtime)
4764     (static-if (boundp 'MULE)
4765         (set-file-coding-system message-draft-coding-system)
4766       (setq buffer-file-coding-system message-draft-coding-system))))
4767
4768 (defun message-disassociate-draft ()
4769   "Disassociate the message buffer from the drafts directory."
4770   (when message-draft-article
4771     (nndraft-request-expire-articles
4772      (list message-draft-article) "drafts" nil t)))
4773
4774 (defun message-insert-headers ()
4775   "Generate the headers for the article."
4776   (interactive)
4777   (save-excursion
4778     (save-restriction
4779       (message-narrow-to-headers)
4780       (when (message-news-p)
4781         (message-generate-headers
4782          (delq 'Lines
4783                (delq 'Subject
4784                      (copy-sequence message-required-news-headers)))))
4785       (when (message-mail-p)
4786         (message-generate-headers
4787          (delq 'Lines
4788                (delq 'Subject
4789                      (copy-sequence message-required-mail-headers))))))))
4790
4791 \f
4792
4793 ;;;
4794 ;;; Commands for interfacing with message
4795 ;;;
4796
4797 ;;;###autoload
4798 (defun message-mail (&optional to subject
4799                                other-headers continue switch-function
4800                                yank-action send-actions)
4801   "Start editing a mail message to be sent.
4802 OTHER-HEADERS is an alist of header/value pairs."
4803   (interactive)
4804   (let ((message-this-is-mail t) replybuffer)
4805     (unless (message-mail-user-agent)
4806       (message-pop-to-buffer (message-buffer-name "mail" to)))
4807     ;; FIXME: message-mail should do something if YANK-ACTION is not
4808     ;; insert-buffer.
4809     (and (consp yank-action) (eq (car yank-action) 'insert-buffer)
4810          (setq replybuffer (nth 1 yank-action)))
4811     (message-setup
4812      (nconc
4813       `((To . ,(or to "")) (Subject . ,(or subject "")))
4814       (when other-headers other-headers))
4815      replybuffer send-actions)
4816     ;; FIXME: Should return nil if failure.
4817     t))
4818
4819 ;;;###autoload
4820 (defun message-news (&optional newsgroups subject)
4821   "Start editing a news article to be sent."
4822   (interactive)
4823   (let ((message-this-is-news t))
4824     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
4825     (message-setup `((Newsgroups . ,(or newsgroups ""))
4826                      (Subject . ,(or subject ""))))))
4827
4828 (defun message-get-reply-headers (wide &optional to-address)
4829   (let (follow-to mct never-mct from to cc reply-to mrt mft)
4830     ;; Find all relevant headers we need.
4831     (setq from (message-fetch-field "from")
4832           to (message-fetch-field "to")
4833           cc (message-fetch-field "cc")
4834           mct (when message-use-mail-copies-to
4835                 (message-fetch-field "mail-copies-to"))
4836           reply-to (message-fetch-field "reply-to")
4837           mrt (when message-use-mail-reply-to
4838                 (message-fetch-field "mail-reply-to"))
4839           mft (when (and (not (or to-address mrt reply-to))
4840                          (or message-use-followup-to
4841                              message-use-mail-followup-to))
4842                 (message-fetch-field "mail-followup-to")))
4843
4844     ;; Handle special values of Mail-Copies-To.
4845     (when mct
4846       (cond
4847        ((and (or (equal (downcase mct) "never")
4848                  (equal (downcase mct) "nobody")))
4849         (when (or (not (eq message-use-mail-copies-to 'ask))
4850                   (message-y-or-n-p
4851                    (concat "Obey Mail-Copies-To: never? ") t "\
4852 You should normally obey the Mail-Copies-To: header.
4853
4854         `Mail-Copies-To: " mct "'
4855 directs you not to send your response to the author."))
4856           (setq never-mct t))
4857         (setq mct nil))
4858        ((and (or (equal (downcase mct) "always")
4859                  (equal (downcase mct) "poster")))
4860         (if (or (not (eq message-use-mail-copies-to 'ask))
4861                 (message-y-or-n-p
4862                  (concat "Obey Mail-Copies-To: always? ") t "\
4863 You should normally obey the Mail-Copies-To: header.
4864
4865         `Mail-Copies-To: " mct "'
4866 sends a copy of your response to the author."))
4867             (setq mct (or mrt reply-to from))
4868           (setq mct nil)))
4869        ((and (eq message-use-mail-copies-to 'ask)
4870              (not (message-y-or-n-p
4871                    (concat "Obey Mail-Copies-To: " mct " ? ") t "\
4872 You should normally obey the Mail-Copies-To: header.
4873
4874         `Mail-Copies-To: " mct "'
4875 sends a copy of your response to " (if (string-match "," mct)
4876                                        "the specified addresses"
4877                                      "that address") ".")))
4878         (setq mct nil))))
4879
4880     ;; Handle Mail-Followup-To.
4881     (when (and mft
4882                (eq (or message-use-followup-to
4883                        message-use-mail-followup-to) 'ask)
4884                (not (message-y-or-n-p
4885                      (concat "Obey Mail-Followup-To: " mft "? ") t "\
4886 You should normally obey the Mail-Followup-To: header.
4887
4888         `Mail-Followup-To: " mft "'
4889 directs your response to " (if (string-match "," mft)
4890                                "the specified addresses"
4891                              "that address only") ".
4892
4893 A typical situation where Mail-Followup-To is used is when the author thinks
4894 that further discussion should take place only in "
4895                              (if (string-match "," mft)
4896                                  "the specified mailing lists"
4897                                "that mailing list") ".")))
4898       (setq mft nil))
4899
4900     (if (and (not mft)
4901              (or (not wide)
4902                  to-address))
4903         (progn
4904           (setq follow-to (list (cons 'To
4905                                       (or to-address mrt reply-to mft from))))
4906           (when (and wide mct
4907                      (not (member (cons 'To mct) follow-to)))
4908             (push (cons 'Cc mct) follow-to)))
4909       (let (ccalist)
4910         (save-excursion
4911           (message-set-work-buffer)
4912           (if (and mft
4913                    message-use-followup-to
4914                    wide
4915                    (or (not (eq message-use-followup-to 'ask))
4916                        (message-y-or-n-p "Obey Mail-Followup-To? " t "\
4917 You should normally obey the Mail-Followup-To: header.  In this
4918 article, it has the value of
4919
4920 " mft "
4921
4922 which directs your response to " (if (string-match "," mft)
4923                                      "the specified addresses"
4924                                    "that address only") ".
4925
4926 If a message is posted to several mailing lists, Mail-Followup-To is
4927 often used to direct the following discussion to one list only,
4928 because discussions that are spread over several lists tend to be
4929 fragmented and very difficult to follow.
4930
4931 Also, some source/announcement lists are not intended for discussion;
4932 responses here are directed to other addresses.")))
4933               (insert mft)
4934             (unless never-mct
4935               (insert (or mrt reply-to from "")))
4936             (insert (if to (concat (if (bolp) "" ", ") to) ""))
4937             (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
4938             (insert (if cc (concat (if (bolp) "" ", ") cc) "")))
4939           (goto-char (point-min))
4940           (while (re-search-forward "[ \t]+" nil t)
4941             (replace-match " " t t))
4942           ;; Remove addresses that match `rmail-dont-reply-to-names'.
4943           (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
4944             (insert (prog1 (rmail-dont-reply-to (buffer-string))
4945                       (erase-buffer))))
4946           (goto-char (point-min))
4947           ;; Perhaps "Mail-Copies-To: never" removed the only address?
4948           (when (eobp)
4949             (insert (or mrt reply-to from "")))
4950           (setq ccalist
4951                 (mapcar
4952                  (lambda (addr)
4953                    (cons (mail-strip-quoted-names addr) addr))
4954                  (message-tokenize-header (buffer-string))))
4955           (let ((s ccalist))
4956             (while s
4957               (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
4958         (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
4959         (when ccalist
4960           (let ((ccs (cons 'Cc (mapconcat
4961                                 (lambda (addr) (cdr addr)) ccalist ", "))))
4962             (when (string-match "^ +" (cdr ccs))
4963               (setcdr ccs (substring (cdr ccs) (match-end 0))))
4964             (push ccs follow-to)))
4965         ;; Allow the user to be asked whether or not to reply to all
4966         ;; recipients in a wide reply.
4967         (if (and ccalist wide message-wide-reply-confirm-recipients
4968                  (not (y-or-n-p "Reply to all recipients?")))
4969             (setq follow-to (delq (assoc 'Cc follow-to) follow-to)))))
4970     follow-to))
4971
4972 ;;;###autoload
4973 (defun message-reply (&optional to-address wide)
4974   "Start editing a reply to the article in the current buffer."
4975   (interactive)
4976   (require 'gnus-sum)                   ; for gnus-list-identifiers
4977   (let ((cur (current-buffer))
4978         from subject date
4979         references message-id follow-to
4980         (inhibit-point-motion-hooks t)
4981         (message-this-is-mail t)
4982         gnus-warning in-reply-to)
4983     (save-restriction
4984       (message-narrow-to-head-1)
4985       ;; Allow customizations to have their say.
4986       (if (not wide)
4987           ;; This is a regular reply.
4988           (when (message-functionp message-reply-to-function)
4989             (save-excursion
4990               (setq follow-to (funcall message-reply-to-function))))
4991         ;; This is a followup.
4992         (when (message-functionp message-wide-reply-to-function)
4993           (save-excursion
4994             (setq follow-to
4995                   (funcall message-wide-reply-to-function)))))
4996       (setq message-id (message-fetch-field "message-id" t)
4997             references (message-fetch-field "references")
4998             date (message-fetch-field "date")
4999             from (message-fetch-field "from")
5000             subject (or (message-fetch-field "subject") "none"))
5001       (when gnus-list-identifiers
5002         (setq subject (message-strip-list-identifiers subject)))
5003       (setq subject (message-make-followup-subject subject))
5004
5005       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
5006                  (string-match "<[^>]+>" gnus-warning))
5007         (setq message-id (match-string 0 gnus-warning)))
5008
5009       (unless follow-to
5010         (setq follow-to (message-get-reply-headers wide to-address)))
5011
5012       ;; Get the references from "In-Reply-To" field if there were
5013       ;; no references and "In-Reply-To" field looks promising.
5014       (unless references
5015         (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
5016                    (string-match "<[^>]+>" in-reply-to))
5017           (setq references (match-string 0 in-reply-to)))))
5018
5019     (unless (message-mail-user-agent)
5020       (message-pop-to-buffer
5021        (message-buffer-name
5022         (if wide "wide reply" "reply") from
5023         (if wide to-address nil))))
5024
5025     (setq message-reply-headers
5026           (make-full-mail-header-from-decoded-header
5027            0 subject from date message-id references 0 0 ""))
5028
5029     (message-setup
5030      `((Subject . ,subject)
5031        ,@follow-to
5032        ,@(if (or references message-id)
5033              `((References . ,(concat (or references "") (and references " ")
5034                                       (or message-id ""))))
5035            nil))
5036      cur)))
5037
5038 ;;;###autoload
5039 (defun message-wide-reply (&optional to-address)
5040   "Make a \"wide\" reply to the message in the current buffer."
5041   (interactive)
5042   (message-reply to-address t))
5043
5044 ;;;###autoload
5045 (defun message-followup (&optional to-newsgroups)
5046   "Follow up to the message in the current buffer.
5047 If TO-NEWSGROUPS, use that as the new Newsgroups line."
5048   (interactive)
5049   (require 'gnus-sum)                   ; for gnus-list-identifiers
5050   (let ((cur (current-buffer))
5051         from subject date reply-to mrt mct mft
5052         references message-id follow-to
5053         (inhibit-point-motion-hooks t)
5054         (message-this-is-news t)
5055         followup-to distribution newsgroups gnus-warning posted-to)
5056     (save-restriction
5057       (message-narrow-to-head)
5058       (when (message-functionp message-followup-to-function)
5059         (setq follow-to
5060               (funcall message-followup-to-function)))
5061       (setq from (message-fetch-field "from")
5062             date (message-fetch-field "date")
5063             subject (or (message-fetch-field "subject") "none")
5064             references (message-fetch-field "references")
5065             message-id (message-fetch-field "message-id" t)
5066             followup-to (message-fetch-field "followup-to")
5067             newsgroups (message-fetch-field "newsgroups")
5068             posted-to (message-fetch-field "posted-to")
5069             reply-to (message-fetch-field "reply-to")
5070             mrt (when message-use-mail-reply-to
5071                   (message-fetch-field "mail-reply-to"))
5072             distribution (message-fetch-field "distribution")
5073             mct (when message-use-mail-copies-to
5074                   (message-fetch-field "mail-copies-to"))
5075             mft (when (or message-use-followup-to
5076                           message-use-mail-followup-to)
5077                   (message-fetch-field "mail-followup-to")))
5078       (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
5079                  (string-match "<[^>]+>" gnus-warning))
5080         (setq message-id (match-string 0 gnus-warning)))
5081       ;; Remove bogus distribution.
5082       (when (and (stringp distribution)
5083                  (let ((case-fold-search t))
5084                    (string-match "world" distribution)))
5085         (setq distribution nil))
5086       (if gnus-list-identifiers
5087           (setq subject (message-strip-list-identifiers subject)))
5088       (setq subject (message-make-followup-subject subject))
5089       (widen))
5090
5091     ;; Handle special values of Mail-Copies-To.
5092     (when mct
5093       (cond
5094        ((and (or (equal (downcase mct) "never")
5095                  (equal (downcase mct) "nobody")))
5096         (setq mct nil))
5097        ((and (or (equal (downcase mct) "always")
5098                  (equal (downcase mct) "poster")))
5099         (if (or (not (eq message-use-mail-copies-to 'ask))
5100                 (message-y-or-n-p
5101                  (concat "Obey Mail-Copies-To: always? ") t "\
5102 You should normally obey the Mail-Copies-To: header.
5103
5104         `Mail-Copies-To: " mct "'
5105 sends a copy of your response to the author."))
5106             (setq mct (or mrt reply-to from))
5107           (setq mct nil)))
5108        ((and (eq message-use-mail-copies-to 'ask)
5109              (not
5110               (message-y-or-n-p
5111                (concat "Obey Mail-Copies-To: " mct " ? ") t "\
5112 You should normally obey the Mail-Copies-To: header.
5113
5114         `Mail-Copies-To: " mct "'
5115 sends a copy of your response to " (if (string-match "," mct)
5116                                        "the specified addresses"
5117                                      "that address") ".")))
5118         (setq mct nil))))
5119
5120     (unless follow-to
5121       (cond
5122        (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups))))
5123        ;; Handle Followup-To.
5124        (followup-to
5125         (cond
5126          ((equal (downcase followup-to) "poster")
5127           (if (or (and followup-to (eq message-use-followup-to 'use))
5128                   (message-y-or-n-p "Obey Followup-To: poster? " t "\
5129 You should normally obey the Followup-To: header.
5130
5131         `Followup-To: poster'
5132 sends your response via e-mail instead of news.
5133
5134 A typical situation where `Followup-To: poster' is used is when the author
5135 does not read the newsgroup, so he wouldn't see any replies sent to it."))
5136               (setq message-this-is-news nil
5137                     distribution nil
5138                     follow-to (list (cons 'To (or mrt reply-to from ""))))
5139             (setq follow-to (list (cons 'Newsgroups newsgroups)))))
5140          (t
5141           (if (or (equal followup-to newsgroups)
5142                   (not (and followup-to (eq message-use-followup-to 'ask)))
5143                   (message-y-or-n-p
5144                    (concat "Obey Followup-To: " followup-to "? ") t "\
5145 You should normally obey the Followup-To: header.
5146
5147         `Followup-To: " followup-to "'
5148 directs your response to " (if (string-match "," followup-to)
5149                                "the specified newsgroups"
5150                              "that newsgroup only") ".
5151
5152 If a message is posted to several newsgroups, Followup-To is often
5153 used to direct the following discussion to one newsgroup only,
5154 because discussions that are spread over several newsgroup tend to
5155 be fragmented and very difficult to follow.
5156
5157 Also, some source/announcement newsgroups are not intended for discussion;
5158 responses here are directed to other newsgroups."))
5159               (setq follow-to (list (cons 'Newsgroups followup-to)))
5160             (setq follow-to (list (cons 'Newsgroups newsgroups)))))))
5161        ;; Handle Mail-Followup-To, followup via e-mail.
5162        ((and mft
5163              (or (not (eq (or message-use-followup-to
5164                               message-use-mail-followup-to) 'ask))
5165                  (message-y-or-n-p
5166                   (concat "Obey Mail-Followup-To: " mft "? ") t "\
5167 You should normally obey the Mail-Followup-To: header.
5168
5169         `Mail-Followup-To: " mft "'
5170 directs your response to " (if (string-match "," mft)
5171                                "the specified addresses"
5172                              "that address only") " instead of news.
5173
5174 A typical situation where Mail-Followup-To is used is when the author thinks
5175 that further discussion should take place only in "
5176                              (if (string-match "," mft)
5177                                  "the specified mailing lists"
5178                                "that mailing list") ".")))
5179         (setq message-this-is-news nil
5180               distribution nil
5181               follow-to (list (cons 'To mft))))
5182        (posted-to (setq follow-to (list (cons 'Newsgroups posted-to))))
5183        (t
5184         (setq follow-to (list (cons 'Newsgroups newsgroups))))))
5185
5186     (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
5187
5188     (message-setup
5189      `((Subject . ,subject)
5190        ,@follow-to
5191        ,@(and mct (list (cons 'Cc mct)))
5192        ,@(and distribution (list (cons 'Distribution distribution)))
5193        ,@(if (or references message-id)
5194              `((References . ,(concat (or references "") (and references " ")
5195                                       (or message-id ""))))))
5196      cur)
5197
5198     (setq message-reply-headers
5199           (make-full-mail-header-from-decoded-header
5200            0 subject from date message-id references 0 0 ""))))
5201
5202 ;;;###autoload
5203 (defun message-cancel-news (&optional arg)
5204   "Cancel an article you posted.
5205 If ARG, allow editing of the cancellation message."
5206   (interactive "P")
5207   (unless (message-news-p)
5208     (error "This is not a news article; canceling is impossible"))
5209   (let (from newsgroups message-id distribution buf sender)
5210     (save-excursion
5211       ;; Get header info from original article.
5212       (save-restriction
5213         (message-narrow-to-head-1)
5214         (setq from (message-fetch-field "from")
5215               sender (message-fetch-field "sender")
5216               newsgroups (message-fetch-field "newsgroups")
5217               message-id (message-fetch-field "message-id" t)
5218               distribution (message-fetch-field "distribution")))
5219       ;; Make sure that this article was written by the user.
5220       (unless (or (message-gnksa-enable-p 'cancel-messages)
5221                   (and sender
5222                        (string-equal
5223                         (downcase sender)
5224                         (downcase (message-make-sender))))
5225                   (string-equal
5226                    (downcase (cadr (std11-extract-address-components from)))
5227                    (downcase (cadr (std11-extract-address-components
5228                                     (message-make-from))))))
5229         (error "This article is not yours"))
5230       (when (yes-or-no-p "Do you really want to cancel this article? ")
5231         ;; Make control message.
5232         (if arg
5233             (message-news)
5234           (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
5235         (erase-buffer)
5236         (insert "Newsgroups: " newsgroups "\n"
5237                 "From: " from "\n"
5238                 "Subject: cmsg cancel " message-id "\n"
5239                 "Control: cancel " message-id "\n"
5240                 (if distribution
5241                     (concat "Distribution: " distribution "\n")
5242                   "")
5243                 mail-header-separator "\n"
5244                 message-cancel-message)
5245         (run-hooks 'message-cancel-hook)
5246         (unless arg
5247           (message "Canceling your article...")
5248           (if (let ((message-syntax-checks
5249                      'dont-check-for-anything-just-trust-me)
5250                     (message-encoding-buffer (current-buffer))
5251                     (message-edit-buffer (current-buffer)))
5252                 (message-send-news))
5253               (message "Canceling your article...done"))
5254           (kill-buffer buf))))))
5255
5256 (defun message-supersede-setup-for-mime-edit ()
5257   (set (make-local-variable 'message-setup-hook) nil)
5258   (mime-edit-again))
5259
5260 ;;;###autoload
5261 (defun message-supersede ()
5262   "Start composing a message to supersede the current message.
5263 This is done simply by taking the old article and adding a Supersedes
5264 header line with the old Message-ID."
5265   (interactive)
5266   (let ((cur (current-buffer))
5267         (sender (message-fetch-field "sender"))
5268         (from (message-fetch-field "from")))
5269     ;; Check whether the user owns the article that is to be superseded.
5270     (unless (or (message-gnksa-enable-p 'cancel-messages)
5271                 (and sender
5272                      (string-equal
5273                       (downcase sender)
5274                       (downcase (message-make-sender))))
5275                 (string-equal
5276                  (downcase (cadr (std11-extract-address-components from)))
5277                  (downcase (cadr (std11-extract-address-components
5278                                   (message-make-from))))))
5279       (error "This article is not yours"))
5280     ;; Get a normal message buffer.
5281     (message-pop-to-buffer (message-buffer-name "supersede"))
5282     (insert-buffer-substring cur)
5283     (message-narrow-to-head-1)
5284     ;; Remove unwanted headers.
5285     (when message-ignored-supersedes-headers
5286       (message-remove-header message-ignored-supersedes-headers t))
5287     (goto-char (point-min))
5288     (if (not (re-search-forward "^Message-ID: " nil t))
5289         (error "No Message-ID in this article")
5290       (replace-match "Supersedes: " t t))
5291     (goto-char (point-max))
5292     (insert mail-header-separator)
5293     (widen)
5294     (when message-supersede-setup-function
5295       (funcall message-supersede-setup-function))
5296     (run-hooks 'message-supersede-setup-hook)
5297     (goto-char (point-min))
5298     (search-forward (concat "\n" mail-header-separator "\n") nil t)))
5299
5300 ;;;###autoload
5301 (defun message-recover ()
5302   "Reread contents of current buffer from its last auto-save file."
5303   (interactive)
5304   (let ((file-name (make-auto-save-file-name)))
5305     (cond ((save-window-excursion
5306              (if (not (eq system-type 'vax-vms))
5307                  (with-output-to-temp-buffer "*Directory*"
5308                    (with-current-buffer standard-output
5309                      (fundamental-mode)) ; for Emacs 20.4+
5310                    (buffer-disable-undo standard-output)
5311                    (let ((default-directory "/"))
5312                      (call-process
5313                       "ls" nil standard-output nil "-l" file-name))))
5314              (yes-or-no-p (format "Recover auto save file %s? " file-name)))
5315            (let ((buffer-read-only nil))
5316              (erase-buffer)
5317              (insert-file-contents file-name nil)))
5318           (t (error "message-recover cancelled")))))
5319
5320 ;;; Washing Subject:
5321
5322 (defun message-wash-subject (subject)
5323   "Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT.
5324 Previous forwarders, replyers, etc. may add it."
5325   (with-temp-buffer
5326     (insert-string subject)
5327     (goto-char (point-min))
5328     ;; strip Re/Fwd stuff off the beginning
5329     (while (re-search-forward
5330             "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
5331       (replace-match ""))
5332
5333     ;; and gnus-style forwards [foo@bar.com] subject
5334     (goto-char (point-min))
5335     (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
5336       (replace-match ""))
5337
5338     ;; and off the end
5339     (goto-char (point-max))
5340     (while (re-search-backward "([Ff][Ww][Dd])" nil t)
5341       (replace-match ""))
5342
5343     ;; and finally, any whitespace that was left-over
5344     (goto-char (point-min))
5345     (while (re-search-forward "^[ \t]+" nil t)
5346       (replace-match ""))
5347     (goto-char (point-max))
5348     (while (re-search-backward "[ \t]+$" nil t)
5349       (replace-match ""))
5350
5351     (buffer-string)))
5352
5353 ;;; Forwarding messages.
5354
5355 (defvar message-forward-decoded-p nil
5356   "Non-nil means the original message is decoded.")
5357
5358 (defun message-forward-subject-author-subject (subject)
5359   "Generate a SUBJECT for a forwarded message.
5360 The form is: [Source] Subject, where if the original message was mail,
5361 Source is the sender, and if the original message was news, Source is
5362 the list of newsgroups is was posted to."
5363   (concat "["
5364           (if (message-news-p)
5365               (or (message-fetch-field "newsgroups")
5366                   "(nowhere)")
5367             (let ((from (message-fetch-field "from")))
5368               (if from
5369                   (nnheader-decode-from from)
5370                 "(nobody)")))
5371           "] " subject))
5372
5373 (defun message-forward-subject-fwd (subject)
5374   "Generate a SUBJECT for a forwarded message.
5375 The form is: Fwd: Subject, where Subject is the original subject of
5376 the message."
5377   (concat "Fwd: " subject))
5378
5379 (defun message-make-forward-subject ()
5380   "Return a Subject header suitable for the message in the current buffer."
5381   (save-excursion
5382     (save-restriction
5383       (message-narrow-to-head-1)
5384       (let ((funcs message-make-forward-subject-function)
5385             (subject (message-fetch-field "Subject")))
5386         (setq subject
5387               (if subject
5388                   (if message-forward-decoded-p
5389                       subject
5390                     (nnheader-decode-subject subject))
5391                 ""))
5392         (if message-wash-forwarded-subjects
5393             (setq subject (message-wash-subject subject)))
5394         ;; Make sure funcs is a list.
5395         (and funcs
5396              (not (listp funcs))
5397              (setq funcs (list funcs)))
5398         ;; Apply funcs in order, passing subject generated by previous
5399         ;; func to the next one.
5400         (while funcs
5401           (when (message-functionp (car funcs))
5402             (setq subject (funcall (car funcs) subject)))
5403           (setq funcs (cdr funcs)))
5404         subject))))
5405
5406 ;;;###autoload
5407 (defun message-forward (&optional news)
5408   "Forward the current message via mail.
5409 Optional NEWS will use news to forward instead of mail."
5410   (interactive "P")
5411   (let ((cur (current-buffer))
5412         (subject (message-make-forward-subject))
5413         art-beg)
5414     (if news
5415         (message-news nil subject)
5416       (message-mail nil subject))
5417     ;; Put point where we want it before inserting the forwarded
5418     ;; message.
5419     (if message-forward-before-signature
5420         (message-goto-body)
5421       (goto-char (point-max)))
5422     ;; Make sure we're at the start of the line.
5423     (unless (bolp)
5424       (insert "\n"))
5425     ;; Narrow to the area we are to insert.
5426     (narrow-to-region (point) (point))
5427     ;; Insert the separators and the forwarded buffer.
5428     (insert message-forward-start-separator)
5429     (setq art-beg (point))
5430     (insert-buffer-substring cur)
5431     (goto-char (point-max))
5432     (insert message-forward-end-separator)
5433     (set-text-properties (point-min) (point-max) nil)
5434     ;; Remove all unwanted headers.
5435     (goto-char art-beg)
5436     (narrow-to-region (point) (if (search-forward "\n\n" nil t)
5437                                   (1- (point))
5438                                 (point)))
5439     (goto-char (point-min))
5440     (message-remove-header message-included-forward-headers t nil t)
5441     (widen)
5442     (message-position-point)))
5443
5444 ;;;###autoload
5445 (defun message-resend (address)
5446   "Resend the current article to ADDRESS."
5447   (interactive
5448    (list (message-read-from-minibuffer "Resend message to: ")))
5449   (message "Resending message to %s..." address)
5450   (save-excursion
5451     (let ((cur (current-buffer))
5452           beg)
5453       ;; We first set up a normal mail buffer.
5454       (unless (message-mail-user-agent)
5455         (set-buffer (get-buffer-create " *message resend*"))
5456         (erase-buffer)
5457         (let ((message-this-is-mail t)
5458               ;; avoid to turn-on-mime-edit
5459               message-setup-hook)
5460           (message-setup `((To . ,address)))))
5461       ;; Insert our usual headers.
5462       (message-generate-headers '(From Date To))
5463       (message-narrow-to-headers)
5464       ;; Rename them all to "Resent-*".
5465       (while (re-search-forward "^[A-Za-z]" nil t)
5466         (forward-char -1)
5467         (insert "Resent-"))
5468       (widen)
5469       (forward-line)
5470       (delete-region (point) (point-max))
5471       (setq beg (point))
5472       ;; Insert the message to be resent.
5473       (insert-buffer-substring cur)
5474       (goto-char (point-min))
5475       (search-forward "\n\n")
5476       (forward-char -1)
5477       (save-restriction
5478         (narrow-to-region beg (point))
5479         (message-remove-header message-ignored-resent-headers t)
5480         (goto-char (point-max)))
5481       (insert mail-header-separator)
5482       ;; Rename all old ("Also-")Resent headers.
5483       (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
5484         (beginning-of-line)
5485         (insert "Also-"))
5486       ;; Quote any "From " lines at the beginning.
5487       (goto-char beg)
5488       (when (looking-at "From ")
5489         (replace-match "X-From-Line: "))
5490       ;; Send it.
5491       (let ((message-encoding-buffer (current-buffer))
5492             (message-edit-buffer (current-buffer)))
5493         (let (message-required-mail-headers)
5494           (message-send-mail)))
5495       (kill-buffer (current-buffer)))
5496     (message "Resending message to %s...done" address)))
5497
5498 (defun message-bounce-setup-for-mime-edit ()
5499   (set (make-local-variable 'message-setup-hook) nil)
5500   (mime-edit-again))
5501
5502 ;;;###autoload
5503 (defun message-bounce ()
5504   "Re-mail the current message.
5505 This only makes sense if the current message is a bounce message that
5506 contains some mail you have written which has been bounced back to
5507 you."
5508   (interactive)
5509   (let ((cur (current-buffer))
5510         boundary)
5511     (message-pop-to-buffer (message-buffer-name "bounce"))
5512     (insert-buffer-substring cur)
5513     (undo-boundary)
5514     (message-narrow-to-head)
5515     (if (and (message-fetch-field "MIME-Version")
5516              (setq boundary (message-fetch-field "Content-Type")))
5517         (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
5518             (setq boundary (concat (match-string 1 boundary) " *\n"
5519                                    "Content-Type: message/rfc822"))
5520           (setq boundary nil)))
5521     (widen)
5522     (goto-char (point-min))
5523     (search-forward "\n\n" nil t)
5524     (or (and boundary
5525              (re-search-forward boundary nil t)
5526              (forward-line 2))
5527         (and (re-search-forward message-unsent-separator nil t)
5528              (forward-line 1))
5529         (re-search-forward "^Return-Path:.*\n" nil t))
5530     ;; We remove everything before the bounced mail.
5531     (delete-region
5532      (point-min)
5533      (if (re-search-forward "^[^ \n\t]+:" nil t)
5534          (match-beginning 0)
5535        (point)))
5536     (save-restriction
5537       (message-narrow-to-head-1)
5538       (message-remove-header message-ignored-bounced-headers t)
5539       (goto-char (point-max))
5540       (insert mail-header-separator))
5541     (when message-bounce-setup-function
5542       (funcall message-bounce-setup-function))
5543     (run-hooks 'message-bounce-setup-hook)
5544     (message-position-point)))
5545
5546 ;;;
5547 ;;; Interactive entry points for new message buffers.
5548 ;;;
5549
5550 ;;;###autoload
5551 (defun message-mail-other-window (&optional to subject)
5552   "Like `message-mail' command, but display mail buffer in another window."
5553   (interactive)
5554   (unless (message-mail-user-agent)
5555     (let ((pop-up-windows t)
5556           (special-display-buffer-names nil)
5557           (special-display-regexps nil)
5558           (same-window-buffer-names nil)
5559           (same-window-regexps nil))
5560       (message-pop-to-buffer (message-buffer-name "mail" to))))
5561   (let ((message-this-is-mail t))
5562     (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
5563                    nil nil 'switch-to-buffer-other-window)))
5564
5565 ;;;###autoload
5566 (defun message-mail-other-frame (&optional to subject)
5567   "Like `message-mail' command, but display mail buffer in another frame."
5568   (interactive)
5569   (unless (message-mail-user-agent)
5570     (let ((pop-up-frames t)
5571           (special-display-buffer-names nil)
5572           (special-display-regexps nil)
5573           (same-window-buffer-names nil)
5574           (same-window-regexps nil))
5575       (message-pop-to-buffer (message-buffer-name "mail" to))))
5576   (let ((message-this-is-mail t))
5577     (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
5578                    nil nil 'switch-to-buffer-other-frame)))
5579
5580 ;;;###autoload
5581 (defun message-news-other-window (&optional newsgroups subject)
5582   "Start editing a news article to be sent."
5583   (interactive)
5584   (let ((pop-up-windows t)
5585         (special-display-buffer-names nil)
5586         (special-display-regexps nil)
5587         (same-window-buffer-names nil)
5588         (same-window-regexps nil))
5589     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
5590   (let ((message-this-is-news t))
5591     (message-setup `((Newsgroups . ,(or newsgroups ""))
5592                      (Subject . ,(or subject ""))))))
5593
5594 ;;;###autoload
5595 (defun message-news-other-frame (&optional newsgroups subject)
5596   "Start editing a news article to be sent."
5597   (interactive)
5598   (let ((pop-up-frames t)
5599         (special-display-buffer-names nil)
5600         (special-display-regexps nil)
5601         (same-window-buffer-names nil)
5602         (same-window-regexps nil))
5603     (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
5604   (let ((message-this-is-news t))
5605     (message-setup `((Newsgroups . ,(or newsgroups ""))
5606                      (Subject . ,(or subject ""))))))
5607
5608 ;;; underline.el
5609
5610 ;; This code should be moved to underline.el (from which it is stolen).
5611
5612 ;;;###autoload
5613 (defun bold-region (start end)
5614   "Bold all nonblank characters in the region.
5615 Works by overstriking characters.
5616 Called from program, takes two arguments START and END
5617 which specify the range to operate on."
5618   (interactive "r")
5619   (save-excursion
5620     (let ((end1 (make-marker)))
5621       (move-marker end1 (max start end))
5622       (goto-char (min start end))
5623       (while (< (point) end1)
5624         (or (looking-at "[_\^@- ]")
5625             (insert (char-after) "\b"))
5626         (forward-char 1)))))
5627
5628 ;;;###autoload
5629 (defun unbold-region (start end)
5630   "Remove all boldness (overstruck characters) in the region.
5631 Called from program, takes two arguments START and END
5632 which specify the range to operate on."
5633   (interactive "r")
5634   (save-excursion
5635     (let ((end1 (make-marker)))
5636       (move-marker end1 (max start end))
5637       (goto-char (min start end))
5638       (while (re-search-forward "\b" end1 t)
5639         (if (eq (char-after) (char-after (- (point) 2)))
5640             (delete-char -2))))))
5641
5642 (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
5643
5644 ;; Support for toolbar
5645 (eval-when-compile
5646   (defvar tool-bar-map)
5647   (defvar tool-bar-mode))
5648
5649 (defun message-tool-bar-map ()
5650   (or message-tool-bar-map
5651       (setq message-tool-bar-map
5652             (and (fboundp 'tool-bar-add-item-from-menu)
5653                  tool-bar-mode
5654                  (let ((tool-bar-map (copy-keymap tool-bar-map))
5655                        (load-path (mm-image-load-path)))
5656                    ;; Zap some items which aren't so relevant and take
5657                    ;; up space.
5658                    (dolist (key '(print-buffer kill-buffer save-buffer
5659                                                write-file dired open-file))
5660                      (define-key tool-bar-map (vector key) nil))
5661                    (tool-bar-add-item-from-menu
5662                     'message-send-and-exit "mail_send" message-mode-map)
5663                    (tool-bar-add-item-from-menu
5664                     'message-kill-buffer "close" message-mode-map)
5665                    (tool-bar-add-item-from-menu
5666                     'message-dont-send "cancel" message-mode-map)
5667                    (tool-bar-add-item-from-menu
5668                     'mml-attach-file "attach" message-mode-map)
5669                    (tool-bar-add-item-from-menu
5670                     'ispell-message "spell" message-mode-map)
5671                    tool-bar-map)))))
5672
5673 ;;; Group name completion.
5674
5675 (defvar message-newgroups-header-regexp
5676   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
5677   "Regexp that match headers that lists groups.")
5678
5679 (defun message-tab ()
5680   "Expand group names in Newsgroups and Followup-To headers.
5681 Do a `tab-to-tab-stop' if not in those headers."
5682   (interactive)
5683   (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
5684         (mail-abbrev-in-expansion-header-p))
5685       (message-expand-group)
5686     (tab-to-tab-stop)))
5687
5688 (defun message-expand-group ()
5689   "Expand the group name under point."
5690   (let* ((b (save-excursion
5691               (save-restriction
5692                 (narrow-to-region
5693                  (save-excursion
5694                    (beginning-of-line)
5695                    (skip-chars-forward "^:")
5696                    (1+ (point)))
5697                  (point))
5698                 (skip-chars-backward "^, \t\n") (point))))
5699          (completion-ignore-case t)
5700          (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
5701                                             (point))))
5702          (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
5703          (completions (all-completions string hashtb))
5704          comp)
5705     (delete-region b (point))
5706     (cond
5707      ((= (length completions) 1)
5708       (if (string= (car completions) string)
5709           (progn
5710             (insert string)
5711             (message "Only matching group"))
5712         (insert (car completions))))
5713      ((and (setq comp (try-completion string hashtb))
5714            (not (string= comp string)))
5715       (insert comp))
5716      (t
5717       (insert string)
5718       (if (not comp)
5719           (message "No matching groups")
5720         (save-selected-window
5721           (pop-to-buffer "*Completions*")
5722           (buffer-disable-undo)
5723           (let ((buffer-read-only nil))
5724             (erase-buffer)
5725             (let ((standard-output (current-buffer)))
5726               (display-completion-list (sort completions 'string<)))
5727             (goto-char (point-min))
5728             (delete-region (point) (progn (forward-line 3) (point))))))))))
5729
5730 ;;; Help stuff.
5731
5732 (defun message-talkative-question (ask question show &rest text)
5733   "Call FUNCTION with argument QUESTION; optionally display TEXT... args.
5734 If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer.
5735 The following arguments may contain lists of values."
5736   (if (and show
5737            (setq text (message-flatten-list text)))
5738       (save-window-excursion
5739         (save-excursion
5740           (with-output-to-temp-buffer " *MESSAGE information message*"
5741             (set-buffer " *MESSAGE information message*")
5742             (fundamental-mode)          ; for Emacs 20.4+
5743             (mapcar 'princ text)
5744             (goto-char (point-min))))
5745         (funcall ask question))
5746     (funcall ask question)))
5747
5748 (defun message-flatten-list (list)
5749   "Return a new, flat list that contains all elements of LIST.
5750
5751 \(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
5752 => (1 2 3 4 5 6 7)"
5753   (cond ((consp list)
5754          (apply 'append (mapcar 'message-flatten-list list)))
5755         (list
5756          (list list))))
5757
5758 (defun message-generate-new-buffer-clone-locals (name &optional varstr)
5759   "Create and return a buffer with name based on NAME using `generate-new-buffer.'
5760 Then clone the local variables and values from the old buffer to the
5761 new one, cloning only the locals having a substring matching the
5762 regexp varstr."
5763   (let ((oldbuf (current-buffer)))
5764     (save-excursion
5765       (set-buffer (generate-new-buffer name))
5766       (message-clone-locals oldbuf varstr)
5767       (current-buffer))))
5768
5769 (defun message-clone-locals (buffer &optional varstr)
5770   "Clone the local variables from BUFFER to the current buffer."
5771   (let ((locals (save-excursion
5772                   (set-buffer buffer)
5773                   (buffer-local-variables)))
5774         (regexp
5775          "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
5776     (mapcar
5777      (lambda (local)
5778        (when (and (consp local)
5779                   (car local)
5780                   (string-match regexp (symbol-name (car local)))
5781                   (or (null varstr)
5782                       (string-match varstr (symbol-name (car local)))))
5783          (ignore-errors
5784            (set (make-local-variable (car local))
5785                 (cdr local)))))
5786      locals)))
5787
5788
5789 ;;; @ for MIME Edit mode
5790 ;;;
5791
5792 (defun message-maybe-encode ()
5793   (when message-mime-mode
5794     ;; Inherit the buffer local variable `mime-edit-pgp-processing'.
5795     (let ((pgp-processing (with-current-buffer message-edit-buffer
5796                             mime-edit-pgp-processing)))
5797       (setq mime-edit-pgp-processing pgp-processing))
5798     (run-hooks 'mime-edit-translate-hook)
5799     (if (catch 'mime-edit-error
5800           (save-excursion
5801             (mime-edit-pgp-enclose-buffer)
5802             (mime-edit-translate-body)))
5803         (error "Translation error!"))
5804     (run-hooks 'mime-edit-exit-hook)))
5805
5806 (defun message-mime-insert-article (&optional full-headers)
5807   (interactive "P")
5808   (let ((message-cite-function 'mime-edit-inserted-message-filter)
5809         (message-reply-buffer
5810          (message-get-parameter-with-eval 'original-buffer))
5811         (start (point)))
5812     (message-yank-original nil)
5813     (save-excursion
5814       (narrow-to-region (goto-char start)
5815                         (if (search-forward "\n\n" nil t)
5816                             (1- (point))
5817                           (point-max)))
5818       (goto-char (point-min))
5819       (let ((message-included-forward-headers
5820              (if full-headers "" message-included-forward-headers)))
5821         (message-remove-header message-included-forward-headers t nil t))
5822       (widen))))
5823
5824 (set-alist 'mime-edit-message-inserter-alist
5825            'message-mode (function message-mime-insert-article))
5826
5827 ;;; Miscellaneous functions
5828
5829 ;; stolen (and renamed) from nnheader.el
5830 (static-if (fboundp 'subst-char-in-string)
5831     (defsubst message-replace-chars-in-string (string from to)
5832       (subst-char-in-string from to string))
5833   (defun message-replace-chars-in-string (string from to)
5834     "Replace characters in STRING from FROM to TO."
5835     (let ((string (substring string 0)) ;Copy string.
5836           (len (length string))
5837           (idx 0))
5838       ;; Replace all occurrences of FROM with TO.
5839       (while (< idx len)
5840         (when (= (aref string idx) from)
5841           (aset string idx to))
5842         (setq idx (1+ idx)))
5843       string)))
5844
5845 ;;;
5846 ;;; MIME functions
5847 ;;;
5848
5849 (defvar message-inhibit-body-encoding t)
5850
5851 (defun message-encode-message-body ()
5852   (unless message-inhibit-body-encoding
5853     (let ((mail-parse-charset (or mail-parse-charset
5854                                   message-default-charset))
5855           (case-fold-search t)
5856           lines content-type-p)
5857       (message-goto-body)
5858       (save-restriction
5859         (narrow-to-region (point) (point-max))
5860         (let ((new (mml-generate-mime)))
5861           (when new
5862             (delete-region (point-min) (point-max))
5863             (insert new)
5864             (goto-char (point-min))
5865             (if (eq (aref new 0) ?\n)
5866                 (delete-char 1)
5867               (search-forward "\n\n")
5868               (setq lines (buffer-substring (point-min) (1- (point))))
5869               (delete-region (point-min) (point))))))
5870       (save-restriction
5871         (message-narrow-to-headers-or-head)
5872         (message-remove-header "Mime-Version")
5873         (goto-char (point-max))
5874         (insert "MIME-Version: 1.0\n")
5875         (when lines
5876           (insert lines))
5877         (setq content-type-p
5878               (or mml-boundary
5879                   (re-search-backward "^Content-Type:" nil t))))
5880       (save-restriction
5881         (message-narrow-to-headers-or-head)
5882         (message-remove-first-header "Content-Type")
5883         (message-remove-first-header "Content-Transfer-Encoding"))
5884       ;; We always make sure that the message has a Content-Type header.
5885       ;; This is because some broken MTAs and MUAs get awfully confused
5886       ;; when confronted with a message with a MIME-Version header and
5887       ;; without a Content-Type header.  For instance, Solaris'
5888       ;; /usr/bin/mail.
5889       (unless content-type-p
5890         (goto-char (point-min))
5891         (re-search-forward "^MIME-Version:")
5892         (forward-line 1)
5893         (insert "Content-Type: text/plain; charset=us-ascii\n")))))
5894
5895 (defun message-read-from-minibuffer (prompt)
5896   "Read from the minibuffer while providing abbrev expansion."
5897   (if (fboundp 'mail-abbrevs-setup)
5898       (let ((mail-abbrev-mode-regexp "")
5899             (minibuffer-setup-hook 'mail-abbrevs-setup)
5900             (minibuffer-local-map message-minibuffer-local-map))
5901         (read-from-minibuffer prompt))
5902     (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
5903           (minibuffer-local-map message-minibuffer-local-map))
5904       (read-string prompt))))
5905
5906 (defun message-use-alternative-email-as-from ()
5907   (require 'mail-utils)
5908   (let* ((fields '("To" "Cc"))
5909          (emails
5910           (split-string
5911            (mail-strip-quoted-names
5912             (mapconcat 'message-fetch-reply-field fields ","))
5913            "[ \f\t\n\r\v,]+"))
5914          email)
5915     (while emails
5916       (if (string-match message-alternative-emails (car emails))
5917           (setq email (car emails)
5918                 emails nil))
5919       (pop emails))
5920     (unless (or (not email) (equal email user-mail-address))
5921       (goto-char (point-max))
5922       (insert "From: " email "\n"))))
5923
5924 (defun message-options-get (symbol)
5925   (cdr (assq symbol message-options)))
5926
5927 (defun message-options-set (symbol value)
5928   (let ((the-cons (assq symbol message-options)))
5929     (if the-cons
5930         (if value
5931             (setcdr the-cons value)
5932           (setq message-options (delq the-cons message-options)))
5933       (and value
5934            (push (cons symbol value) message-options))))
5935   value)
5936
5937 (defun message-options-set-recipient ()
5938   (save-restriction
5939     (message-narrow-to-headers-or-head)
5940     (message-options-set 'message-sender
5941                          (mail-strip-quoted-names
5942                           (message-fetch-field "from")))
5943     (message-options-set 'message-recipients
5944                          (mail-strip-quoted-names
5945                           (let ((to (message-fetch-field "to"))
5946                                 (cc (message-fetch-field "cc"))
5947                                 (bcc (message-fetch-field "bcc")))
5948                             (concat
5949                              (or to "")
5950                              (if (and to cc) ", ")
5951                              (or cc "")
5952                              (if (and (or to cc) bcc) ", ")
5953                              (or bcc "")))))))
5954
5955 (when (featurep 'xemacs)
5956   (require 'messagexmas)
5957   (message-xmas-redefine))
5958
5959 (defun message-save-drafts ()
5960   "Postponing the message."
5961   (interactive)
5962   (message "Saving %s..." buffer-file-name)
5963   (let ((reply-headers message-reply-headers)
5964         (msg (buffer-substring-no-properties (point-min) (point-max)))
5965         (message-invisibles (message-find-invisible-regions)))
5966     (with-temp-file buffer-file-name
5967       (insert msg)
5968       ;; Inherit the invisible property of texts to make MIME-Edit
5969       ;; find the MIME part boundaries.
5970       (dolist (region message-invisibles)
5971         (put-text-property (car region) (cdr region) 'invisible t))
5972       (setq message-reply-headers reply-headers)
5973       (message-generate-headers '((optional . In-Reply-To)))
5974       (mime-edit-translate-buffer))
5975     (set-buffer-modified-p nil))
5976   (message "Saving %s...done" buffer-file-name))
5977
5978 (provide 'message)
5979
5980 (run-hooks 'message-load-hook)
5981
5982 ;; Local Variables:
5983 ;; coding: iso-8859-1
5984 ;; End:
5985
5986 ;;; message.el ends here