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

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