1;;; message.el --- composing mail and news messages 2 3;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; Keywords: mail, news 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; This mode provides mail-sending facilities from within Emacs. It 29;; consists mainly of large chunks of code from the sendmail.el, 30;; gnus-msg.el and rnewspost.el files. 31 32;;; Code: 33 34(eval-when-compile 35 (require 'cl) 36 (defvar gnus-message-group-art) 37 (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary 38(require 'canlock) 39(require 'mailheader) 40(require 'gmm-utils) 41(require 'nnheader) 42;; This is apparently necessary even though things are autoloaded. 43;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better 44;; require mailabbrev here. 45(if (featurep 'xemacs) 46 (require 'mail-abbrevs) 47 (require 'mailabbrev)) 48(require 'mail-parse) 49(require 'mml) 50(require 'rfc822) 51(eval-and-compile 52 (autoload 'gnus-find-method-for-group "gnus") 53 (autoload 'nnvirtual-find-group-art "nnvirtual") 54 (autoload 'gnus-group-decoded-name "gnus-group")) 55 56(defgroup message '((user-mail-address custom-variable) 57 (user-full-name custom-variable)) 58 "Mail and news message composing." 59 :link '(custom-manual "(message)Top") 60 :group 'mail 61 :group 'news) 62 63(put 'user-mail-address 'custom-type 'string) 64(put 'user-full-name 'custom-type 'string) 65 66(defgroup message-various nil 67 "Various Message Variables." 68 :link '(custom-manual "(message)Various Message Variables") 69 :group 'message) 70 71(defgroup message-buffers nil 72 "Message Buffers." 73 :link '(custom-manual "(message)Message Buffers") 74 :group 'message) 75 76(defgroup message-sending nil 77 "Message Sending." 78 :link '(custom-manual "(message)Sending Variables") 79 :group 'message) 80 81(defgroup message-interface nil 82 "Message Interface." 83 :link '(custom-manual "(message)Interface") 84 :group 'message) 85 86(defgroup message-forwarding nil 87 "Message Forwarding." 88 :link '(custom-manual "(message)Forwarding") 89 :group 'message-interface) 90 91(defgroup message-insertion nil 92 "Message Insertion." 93 :link '(custom-manual "(message)Insertion") 94 :group 'message) 95 96(defgroup message-headers nil 97 "Message Headers." 98 :link '(custom-manual "(message)Message Headers") 99 :group 'message) 100 101(defgroup message-news nil 102 "Composing News Messages." 103 :group 'message) 104 105(defgroup message-mail nil 106 "Composing Mail Messages." 107 :group 'message) 108 109(defgroup message-faces nil 110 "Faces used for message composing." 111 :group 'message 112 :group 'faces) 113 114(defcustom message-directory "~/Mail/" 115 "*Directory from which all other mail file variables are derived." 116 :group 'message-various 117 :type 'directory) 118 119(defcustom message-max-buffers 10 120 "*How many buffers to keep before starting to kill them off." 121 :group 'message-buffers 122 :type 'integer) 123 124(defcustom message-send-rename-function nil 125 "Function called to rename the buffer after sending it." 126 :group 'message-buffers 127 :type '(choice function (const nil))) 128 129(defcustom message-fcc-handler-function 'message-output 130 "*A function called to save outgoing articles. 131This function will be called with the name of the file to store the 132article in. The default function is `message-output' which saves in Unix 133mailbox format." 134 :type '(radio (function-item message-output) 135 (function :tag "Other")) 136 :group 'message-sending) 137 138(defcustom message-fcc-externalize-attachments nil 139 "If non-nil, attachments are included as external parts in Fcc copies." 140 :version "22.1" 141 :type 'boolean 142 :group 'message-sending) 143 144(defcustom message-courtesy-message 145 "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" 146 "*This is inserted at the start of a mailed copy of a posted message. 147If the string contains the format spec \"%s\", the Newsgroups 148the article has been posted to will be inserted there. 149If this variable is nil, no such courtesy message will be added." 150 :group 'message-sending 151 :type '(radio string (const nil))) 152 153(defcustom message-ignored-bounced-headers 154 "^\\(Received\\|Return-Path\\|Delivered-To\\):" 155 "*Regexp that matches headers to be removed in resent bounced mail." 156 :group 'message-interface 157 :type 'regexp) 158 159;;;###autoload 160(defcustom message-from-style 'default 161 "*Specifies how \"From\" headers look. 162 163If nil, they contain just the return address like: 164 king@grassland.com 165If `parens', they look like: 166 king@grassland.com (Elvis Parsley) 167If `angles', they look like: 168 Elvis Parsley <king@grassland.com> 169 170Otherwise, most addresses look like `angles', but they look like 171`parens' if `angles' would need quoting and `parens' would not." 172 :type '(choice (const :tag "simple" nil) 173 (const parens) 174 (const angles) 175 (const default)) 176 :group 'message-headers) 177 178(defcustom message-insert-canlock t 179 "Whether to insert a Cancel-Lock header in news postings." 180 :version "22.1" 181 :group 'message-headers 182 :type 'boolean) 183 184(defcustom message-syntax-checks 185 (if message-insert-canlock '((sender . disabled)) nil) 186 ;; Guess this one shouldn't be easy to customize... 187 "*Controls what syntax checks should not be performed on outgoing posts. 188To disable checking of long signatures, for instance, add 189 `(signature . disabled)' to this list. 190 191Don't touch this variable unless you really know what you're doing. 192 193Checks include `approved', `continuation-headers', `control-chars', 194`empty', `existing-newsgroups', `from', `illegible-text', 195`invisible-text', `long-header-lines', `long-lines', `message-id', 196`multiple-headers', `new-text', `newsgroups', `quoting-style', 197`repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot', 198`shorten-followup-to', `signature', `size', `subject', `subject-cmsg' 199and `valid-newsgroups'." 200 :group 'message-news 201 :type '(repeat sexp)) ; Fixme: improve this 202 203(defcustom message-required-headers '((optional . References) 204 From) 205 "*Headers to be generated or prompted for when sending a message. 206Also see `message-required-news-headers' and 207`message-required-mail-headers'." 208 :version "22.1" 209 :group 'message-news 210 :group 'message-headers 211 :link '(custom-manual "(message)Message Headers") 212 :type '(repeat sexp)) 213 214(defcustom message-draft-headers '(References From) 215 "*Headers to be generated when saving a draft message." 216 :version "22.1" 217 :group 'message-news 218 :group 'message-headers 219 :link '(custom-manual "(message)Message Headers") 220 :type '(repeat sexp)) 221 222(defcustom message-required-news-headers 223 '(From Newsgroups Subject Date Message-ID 224 (optional . Organization) 225 (optional . User-Agent)) 226 "*Headers to be generated or prompted for when posting an article. 227RFC977 and RFC1036 require From, Date, Newsgroups, Subject, 228Message-ID. Organization, Lines, In-Reply-To, Expires, and 229User-Agent are optional. If you don't want message to insert some 230header, remove it from this list." 231 :group 'message-news 232 :group 'message-headers 233 :link '(custom-manual "(message)Message Headers") 234 :type '(repeat sexp)) 235 236(defcustom message-required-mail-headers 237 '(From Subject Date (optional . In-Reply-To) Message-ID 238 (optional . User-Agent)) 239 "*Headers to be generated or prompted for when mailing a message. 240It is recommended that From, Date, To, Subject and Message-ID be 241included. Organization and User-Agent are optional." 242 :group 'message-mail 243 :group 'message-headers 244 :link '(custom-manual "(message)Message Headers") 245 :type '(repeat sexp)) 246 247(defcustom message-deletable-headers '(Message-ID Date Lines) 248 "Headers to be deleted if they already exist and were generated by message previously." 249 :group 'message-headers 250 :link '(custom-manual "(message)Message Headers") 251 :type 'sexp) 252 253(defcustom message-ignored-news-headers 254 "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" 255 "*Regexp of headers to be removed unconditionally before posting." 256 :group 'message-news 257 :group 'message-headers 258 :link '(custom-manual "(message)Message Headers") 259 :type '(repeat :value-to-internal (lambda (widget value) 260 (custom-split-regexp-maybe value)) 261 :match (lambda (widget value) 262 (or (stringp value) 263 (widget-editable-list-match widget value))) 264 regexp)) 265 266(defcustom message-ignored-mail-headers 267 "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" 268 "*Regexp of headers to be removed unconditionally before mailing." 269 :group 'message-mail 270 :group 'message-headers 271 :link '(custom-manual "(message)Mail Headers") 272 :type 'regexp) 273 274(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:" 275 "*Header lines matching this regexp will be deleted before posting. 276It's best to delete old Path and Date headers before posting to avoid 277any confusion." 278 :group 'message-interface 279 :link '(custom-manual "(message)Superseding") 280 :type '(repeat :value-to-internal (lambda (widget value) 281 (custom-split-regexp-maybe value)) 282 :match (lambda (widget value) 283 (or (stringp value) 284 (widget-editable-list-match widget value))) 285 regexp)) 286 287(defcustom message-subject-re-regexp 288 "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*" 289 "*Regexp matching \"Re: \" in the subject line." 290 :group 'message-various 291 :link '(custom-manual "(message)Message Headers") 292 :type 'regexp) 293 294;;; Start of variables adopted from `message-utils.el'. 295 296(defcustom message-subject-trailing-was-query 'ask 297 "*What to do with trailing \"(was: <old subject>)\" in subject lines. 298If nil, leave the subject unchanged. If it is the symbol `ask', query 299the user what do do. In this case, the subject is matched against 300`message-subject-trailing-was-ask-regexp'. If 301`message-subject-trailing-was-query' is t, always strip the trailing 302old subject. In this case, `message-subject-trailing-was-regexp' is 303used." 304 :version "22.1" 305 :type '(choice (const :tag "never" nil) 306 (const :tag "always strip" t) 307 (const ask)) 308 :link '(custom-manual "(message)Message Headers") 309 :group 'message-various) 310 311(defcustom message-subject-trailing-was-ask-regexp 312 "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)" 313 "*Regexp matching \"(was: <old subject>)\" in the subject line. 314 315The function `message-strip-subject-trailing-was' uses this regexp if 316`message-subject-trailing-was-query' is set to the symbol `ask'. If 317the variable is t instead of `ask', use 318`message-subject-trailing-was-regexp' instead. 319 320It is okay to create some false positives here, as the user is asked." 321 :version "22.1" 322 :group 'message-various 323 :link '(custom-manual "(message)Message Headers") 324 :type 'regexp) 325 326(defcustom message-subject-trailing-was-regexp 327 "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" 328 "*Regexp matching \"(was: <old subject>)\" in the subject line. 329 330If `message-subject-trailing-was-query' is set to t, the subject is 331matched against `message-subject-trailing-was-regexp' in 332`message-strip-subject-trailing-was'. You should use a regexp creating very 333few false positives here." 334 :version "22.1" 335 :group 'message-various 336 :link '(custom-manual "(message)Message Headers") 337 :type 'regexp) 338 339;;; marking inserted text 340 341(defcustom message-mark-insert-begin 342 "--8<---------------cut here---------------start------------->8---\n" 343 "How to mark the beginning of some inserted text." 344 :version "22.1" 345 :type 'string 346 :link '(custom-manual "(message)Insertion Variables") 347 :group 'message-various) 348 349(defcustom message-mark-insert-end 350 "--8<---------------cut here---------------end--------------->8---\n" 351 "How to mark the end of some inserted text." 352 :version "22.1" 353 :type 'string 354 :link '(custom-manual "(message)Insertion Variables") 355 :group 'message-various) 356 357(defcustom message-archive-header "X-No-Archive: Yes\n" 358 "Header to insert when you don't want your article to be archived. 359Archives \(such as groups.google.com\) respect this header." 360 :version "22.1" 361 :type 'string 362 :link '(custom-manual "(message)Header Commands") 363 :group 'message-various) 364 365(defcustom message-archive-note 366 "X-No-Archive: Yes - save http://groups.google.com/" 367 "Note to insert why you wouldn't want this posting archived. 368If nil, don't insert any text in the body." 369 :version "22.1" 370 :type '(radio string (const nil)) 371 :link '(custom-manual "(message)Header Commands") 372 :group 'message-various) 373 374;;; Crossposts and Followups 375;; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de> 376;; new suggestions by R. Weikusat <rw at another.de> 377 378(defvar message-cross-post-old-target nil 379 "Old target for cross-posts or follow-ups.") 380(make-variable-buffer-local 'message-cross-post-old-target) 381 382(defcustom message-cross-post-default t 383 "When non-nil `message-cross-post-followup-to' will perform a crosspost. 384If nil, `message-cross-post-followup-to' will only do a followup. Note that 385you can explicitly override this setting by calling 386`message-cross-post-followup-to' with a prefix." 387 :version "22.1" 388 :type 'boolean 389 :group 'message-various) 390 391(defcustom message-cross-post-note "Crosspost & Followup-To: " 392 "Note to insert before signature to notify of cross-post and follow-up." 393 :version "22.1" 394 :type 'string 395 :group 'message-various) 396 397(defcustom message-followup-to-note "Followup-To: " 398 "Note to insert before signature to notify of follow-up only." 399 :version "22.1" 400 :type 'string 401 :group 'message-various) 402 403(defcustom message-cross-post-note-function 'message-cross-post-insert-note 404 "Function to use to insert note about Crosspost or Followup-To. 405The function will be called with four arguments. The function should not only 406insert a note, but also ensure old notes are deleted. See the documentation 407for `message-cross-post-insert-note'." 408 :version "22.1" 409 :type 'function 410 :group 'message-various) 411 412;;; End of variables adopted from `message-utils.el'. 413 414;;;###autoload 415(defcustom message-signature-separator "^-- *$" 416 "Regexp matching the signature separator." 417 :type 'regexp 418 :link '(custom-manual "(message)Various Message Variables") 419 :group 'message-various) 420 421(defcustom message-elide-ellipsis "\n[...]\n\n" 422 "*The string which is inserted for elided text." 423 :type 'string 424 :link '(custom-manual "(message)Various Commands") 425 :group 'message-various) 426 427(defcustom message-interactive t 428 "Non-nil means when sending a message wait for and display errors. 429nil means let mailer mail back a message to report errors." 430 :group 'message-sending 431 :group 'message-mail 432 :link '(custom-manual "(message)Sending Variables") 433 :type 'boolean) 434 435(defcustom message-generate-new-buffers 'unique 436 "*Say whether to create a new message buffer to compose a message. 437Valid values include: 438 439nil 440 Generate the buffer name in the Message way (e.g., *mail*, *news*, 441 *mail to whom*, *news on group*, etc.) and continue editing in the 442 existing buffer of that name. If there is no such buffer, it will 443 be newly created. 444 445`unique' or t 446 Create the new buffer with the name generated in the Message way. 447 448`unsent' 449 Similar to `unique' but the buffer name begins with \"*unsent \". 450 451`standard' 452 Similar to nil but the buffer name is simpler like *mail message*. 453 454function 455 If this is a function, call that function with three parameters: 456 The type, the To address and the group name (any of these may be nil). 457 The function should return the new buffer name." 458 :group 'message-buffers 459 :link '(custom-manual "(message)Message Buffers") 460 :type '(choice (const nil) 461 (sexp :tag "unique" :format "unique\n" :value unique 462 :match (lambda (widget value) (memq value '(unique t)))) 463 (const unsent) 464 (const standard) 465 (function :format "\n %{%t%}: %v"))) 466 467(defcustom message-kill-buffer-on-exit nil 468 "*Non-nil means that the message buffer will be killed after sending a message." 469 :group 'message-buffers 470 :link '(custom-manual "(message)Message Buffers") 471 :type 'boolean) 472 473(eval-when-compile 474 (defvar gnus-local-organization)) 475(defcustom message-user-organization 476 (or (and (boundp 'gnus-local-organization) 477 (stringp gnus-local-organization) 478 gnus-local-organization) 479 (getenv "ORGANIZATION") 480 t) 481 "*String to be used as an Organization header. 482If t, use `message-user-organization-file'." 483 :group 'message-headers 484 :type '(choice string 485 (const :tag "consult file" t))) 486 487;;;###autoload 488(defcustom message-user-organization-file "/usr/lib/news/organization" 489 "*Local news organization file." 490 :type 'file 491 :link '(custom-manual "(message)News Headers") 492 :group 'message-headers) 493 494(defcustom message-make-forward-subject-function 495 #'message-forward-subject-name-subject 496 "*List of functions called to generate subject headers for forwarded messages. 497The subject generated by the previous function is passed into each 498successive function. 499 500The provided functions are: 501 502* `message-forward-subject-author-subject' Source of article (author or 503 newsgroup), in brackets followed by the subject 504* `message-forward-subject-name-subject' Source of article (name of author 505 or newsgroup), in brackets followed by the subject 506* `message-forward-subject-fwd' Subject of article with 'Fwd:' prepended 507 to it." 508 :group 'message-forwarding 509 :link '(custom-manual "(message)Forwarding") 510 :type '(radio (function-item message-forward-subject-author-subject) 511 (function-item message-forward-subject-fwd) 512 (function-item message-forward-subject-name-subject) 513 (repeat :tag "List of functions" function))) 514 515(defcustom message-forward-as-mime t 516 "*Non-nil means forward messages as an inline/rfc822 MIME section. 517Otherwise, directly inline the old message in the forwarded message." 518 :version "21.1" 519 :group 'message-forwarding 520 :link '(custom-manual "(message)Forwarding") 521 :type 'boolean) 522 523(defcustom message-forward-show-mml 'best 524 "*Non-nil means show forwarded messages as MML (decoded from MIME). 525Otherwise, forwarded messages are unchanged. 526Can also be the symbol `best' to indicate that MML should be 527used, except when it is a bad idea to use MML. One example where 528it is a bad idea is when forwarding a signed or encrypted 529message, because converting MIME to MML would invalidate the 530digital signature." 531 :version "21.1" 532 :group 'message-forwarding 533 :type '(choice (const :tag "use MML" t) 534 (const :tag "don't use MML " nil) 535 (const :tag "use MML when appropriate" best))) 536 537(defcustom message-forward-before-signature t 538 "*Non-nil means put forwarded message before signature, else after." 539 :group 'message-forwarding 540 :type 'boolean) 541 542(defcustom message-wash-forwarded-subjects nil 543 "*Non-nil means try to remove as much cruft as possible from the subject. 544Done before generating the new subject of a forward." 545 :group 'message-forwarding 546 :link '(custom-manual "(message)Forwarding") 547 :type 'boolean) 548 549(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From " 550 "*All headers that match this regexp will be deleted when resending a message." 551 :group 'message-interface 552 :link '(custom-manual "(message)Resending") 553 :type '(repeat :value-to-internal (lambda (widget value) 554 (custom-split-regexp-maybe value)) 555 :match (lambda (widget value) 556 (or (stringp value) 557 (widget-editable-list-match widget value))) 558 regexp)) 559 560(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" 561 "*All headers that match this regexp will be deleted when forwarding a message." 562 :version "21.1" 563 :group 'message-forwarding 564 :type '(repeat :value-to-internal (lambda (widget value) 565 (custom-split-regexp-maybe value)) 566 :match (lambda (widget value) 567 (or (stringp value) 568 (widget-editable-list-match widget value))) 569 regexp)) 570 571(defcustom message-ignored-cited-headers "." 572 "*Delete these headers from the messages you yank." 573 :group 'message-insertion 574 :link '(custom-manual "(message)Insertion Variables") 575 :type 'regexp) 576 577(defcustom message-cite-prefix-regexp 578 (if (string-match "[[:digit:]]" "1") ;; support POSIX? 579 "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+" 580 ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. 581 (let ((old-table (syntax-table)) 582 non-word-constituents) 583 (set-syntax-table text-mode-syntax-table) 584 (setq non-word-constituents 585 (concat 586 (if (string-match "\\w" "-") "" "-") 587 (if (string-match "\\w" "_") "" "_") 588 (if (string-match "\\w" ".") "" "."))) 589 (set-syntax-table old-table) 590 (if (equal non-word-constituents "") 591 "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+" 592 (concat "\\([ \t]*\\(\\w\\|[" 593 non-word-constituents 594 "]\\)+>+\\|[ \t]*[]>|}+]\\)+")))) 595 "*Regexp matching the longest possible citation prefix on a line." 596 :version "22.1" 597 :group 'message-insertion 598 :link '(custom-manual "(message)Insertion Variables") 599 :type 'regexp) 600 601(defcustom message-cancel-message "I am canceling my own article.\n" 602 "Message to be inserted in the cancel message." 603 :group 'message-interface 604 :link '(custom-manual "(message)Canceling News") 605 :type 'string) 606 607;; Useful to set in site-init.el 608;;;###autoload 609(defcustom message-send-mail-function 'message-send-mail-with-sendmail 610 "Function to call to send the current buffer as mail. 611The headers should be delimited by a line whose contents match the 612variable `mail-header-separator'. 613 614Valid values include `message-send-mail-with-sendmail' (the default), 615`message-send-mail-with-mh', `message-send-mail-with-qmail', 616`message-smtpmail-send-it', `smtpmail-send-it' and `feedmail-send-it'. 617 618See also `send-mail-function'." 619 :type '(radio (function-item message-send-mail-with-sendmail) 620 (function-item message-send-mail-with-mh) 621 (function-item message-send-mail-with-qmail) 622 (function-item message-smtpmail-send-it) 623 (function-item smtpmail-send-it) 624 (function-item feedmail-send-it) 625 (function :tag "Other")) 626 :group 'message-sending 627 :link '(custom-manual "(message)Mail Variables") 628 :group 'message-mail) 629 630(defcustom message-send-news-function 'message-send-news 631 "Function to call to send the current buffer as news. 632The headers should be delimited by a line whose contents match the 633variable `mail-header-separator'." 634 :group 'message-sending 635 :group 'message-news 636 :link '(custom-manual "(message)News Variables") 637 :type 'function) 638 639(defcustom message-reply-to-function nil 640 "If non-nil, function that should return a list of headers. 641This function should pick out addresses from the To, Cc, and From headers 642and respond with new To and Cc headers." 643 :group 'message-interface 644 :link '(custom-manual "(message)Reply") 645 :type '(choice function (const nil))) 646 647(defcustom message-wide-reply-to-function nil 648 "If non-nil, function that should return a list of headers. 649This function should pick out addresses from the To, Cc, and From headers 650and respond with new To and Cc headers." 651 :group 'message-interface 652 :link '(custom-manual "(message)Wide Reply") 653 :type '(choice function (const nil))) 654 655(defcustom message-followup-to-function nil 656 "If non-nil, function that should return a list of headers. 657This function should pick out addresses from the To, Cc, and From headers 658and respond with new To and Cc headers." 659 :group 'message-interface 660 :link '(custom-manual "(message)Followup") 661 :type '(choice function (const nil))) 662 663(defcustom message-use-followup-to 'ask 664 "*Specifies what to do with Followup-To header. 665If nil, always ignore the header. If it is t, use its value, but 666query before using the \"poster\" value. If it is the symbol `ask', 667always query the user whether to use the value. If it is the symbol 668`use', always use the value." 669 :group 'message-interface 670 :link '(custom-manual "(message)Followup") 671 :type '(choice (const :tag "ignore" nil) 672 (const :tag "use & query" t) 673 (const use) 674 (const ask))) 675 676(defcustom message-use-mail-followup-to 'use 677 "*Specifies what to do with Mail-Followup-To header. 678If nil, always ignore the header. If it is the symbol `ask', always 679query the user whether to use the value. If it is the symbol `use', 680always use the value." 681 :version "22.1" 682 :group 'message-interface 683 :link '(custom-manual "(message)Mailing Lists") 684 :type '(choice (const :tag "ignore" nil) 685 (const use) 686 (const ask))) 687 688(defcustom message-subscribed-address-functions nil 689 "*Specifies functions for determining list subscription. 690If nil, do not attempt to determine list subscription with functions. 691If non-nil, this variable contains a list of functions which return 692regular expressions to match lists. These functions can be used in 693conjunction with `message-subscribed-regexps' and 694`message-subscribed-addresses'." 695 :version "22.1" 696 :group 'message-interface 697 :link '(custom-manual "(message)Mailing Lists") 698 :type '(repeat sexp)) 699 700(defcustom message-subscribed-address-file nil 701 "*A file containing addresses the user is subscribed to. 702If nil, do not look at any files to determine list subscriptions. If 703non-nil, each line of this file should be a mailing list address." 704 :version "22.1" 705 :group 'message-interface 706 :link '(custom-manual "(message)Mailing Lists") 707 :type '(radio file (const nil))) 708 709(defcustom message-subscribed-addresses nil 710 "*Specifies a list of addresses the user is subscribed to. 711If nil, do not use any predefined list subscriptions. This list of 712addresses can be used in conjunction with 713`message-subscribed-address-functions' and `message-subscribed-regexps'." 714 :version "22.1" 715 :group 'message-interface 716 :link '(custom-manual "(message)Mailing Lists") 717 :type '(repeat string)) 718 719(defcustom message-subscribed-regexps nil 720 "*Specifies a list of addresses the user is subscribed to. 721If nil, do not use any predefined list subscriptions. This list of 722regular expressions can be used in conjunction with 723`message-subscribed-address-functions' and `message-subscribed-addresses'." 724 :version "22.1" 725 :group 'message-interface 726 :link '(custom-manual "(message)Mailing Lists") 727 :type '(repeat regexp)) 728 729(defcustom message-allow-no-recipients 'ask 730 "Specifies what to do when there are no recipients other than Gcc/Fcc. 731If it is the symbol `always', the posting is allowed. If it is the 732symbol `never', the posting is not allowed. If it is the symbol 733`ask', you are prompted." 734 :version "22.1" 735 :group 'message-interface 736 :link '(custom-manual "(message)Message Headers") 737 :type '(choice (const always) 738 (const never) 739 (const ask))) 740 741(defcustom message-sendmail-f-is-evil nil 742 "*Non-nil means don't add \"-f username\" to the sendmail command line. 743Doing so would be even more evil than leaving it out." 744 :group 'message-sending 745 :link '(custom-manual "(message)Mail Variables") 746 :type 'boolean) 747 748(defcustom message-sendmail-envelope-from nil 749 "*Envelope-from when sending mail with sendmail. 750If this is nil, use `user-mail-address'. If it is the symbol 751`header', use the From: header of the message." 752 :version "22.1" 753 :type '(choice (string :tag "From name") 754 (const :tag "Use From: header from message" header) 755 (const :tag "Use `user-mail-address'" nil)) 756 :link '(custom-manual "(message)Mail Variables") 757 :group 'message-sending) 758 759;; qmail-related stuff 760(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" 761 "Location of the qmail-inject program." 762 :group 'message-sending 763 :link '(custom-manual "(message)Mail Variables") 764 :type 'file) 765 766(defcustom message-qmail-inject-args nil 767 "Arguments passed to qmail-inject programs. 768This should be a list of strings, one string for each argument. It 769may also be a function. 770 771For e.g., if you wish to set the envelope sender address so that bounces 772go to the right place or to deal with listserv's usage of that address, you 773might set this variable to '(\"-f\" \"you@some.where\")." 774 :group 'message-sending 775 :link '(custom-manual "(message)Mail Variables") 776 :type '(choice (function) 777 (repeat string))) 778 779(defvar message-cater-to-broken-inn t 780 "Non-nil means Gnus should not fold the `References' header. 781Folding `References' makes ancient versions of INN create incorrect 782NOV lines.") 783 784(eval-when-compile 785 (defvar gnus-post-method) 786 (defvar gnus-select-method)) 787(defcustom message-post-method 788 (cond ((and (boundp 'gnus-post-method) 789 (listp gnus-post-method) 790 gnus-post-method) 791 gnus-post-method) 792 ((boundp 'gnus-select-method) 793 gnus-select-method) 794 (t '(nnspool ""))) 795 "*Method used to post news. 796Note that when posting from inside Gnus, for instance, this 797variable isn't used." 798 :group 'message-news 799 :group 'message-sending 800 ;; This should be the `gnus-select-method' widget, but that might 801 ;; create a dependence to `gnus.el'. 802 :type 'sexp) 803 804;; FIXME: This should be a temporary workaround until someone implements a 805;; proper solution. If a crash happens while replying, the auto-save file 806;; will *not* have a `References:' header if `message-generate-headers-first' 807;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138 808(defcustom message-generate-headers-first '(references) 809 "Which headers should be generated before starting to compose a message. 810If t, generate all required headers. This can also be a list of headers to 811generate. The variables `message-required-news-headers' and 812`message-required-mail-headers' specify which headers to generate. 813 814Note that the variable `message-deletable-headers' specifies headers which 815are to be deleted and then re-generated before sending, so this variable 816will not have a visible effect for those headers." 817 :group 'message-headers 818 :link '(custom-manual "(message)Message Headers") 819 :type '(choice (const :tag "None" nil) 820 (const :tag "References" '(references)) 821 (const :tag "All" t) 822 (repeat (sexp :tag "Header")))) 823 824(defcustom message-setup-hook nil 825 "Normal hook, run each time a new outgoing message is initialized. 826The function `message-setup' runs this hook." 827 :group 'message-various 828 :link '(custom-manual "(message)Various Message Variables") 829 :type 'hook) 830 831(defcustom message-cancel-hook nil 832 "Hook run when cancelling articles." 833 :group 'message-various 834 :link '(custom-manual "(message)Various Message Variables") 835 :type 'hook) 836 837(defcustom message-signature-setup-hook nil 838 "Normal hook, run each time a new outgoing message is initialized. 839It is run after the headers have been inserted and before 840the signature is inserted." 841 :group 'message-various 842 :link '(custom-manual "(message)Various Message Variables") 843 :type 'hook) 844 845(defcustom message-mode-hook nil 846 "Hook run in message mode buffers." 847 :group 'message-various 848 :type 'hook) 849 850(defcustom message-header-hook nil 851 "Hook run in a message mode buffer narrowed to the headers." 852 :group 'message-various 853 :type 'hook) 854 855(defcustom message-header-setup-hook nil 856 "Hook called narrowed to the headers when setting up a message buffer." 857 :group 'message-various 858 :link '(custom-manual "(message)Various Message Variables") 859 :type 'hook) 860 861(defcustom message-minibuffer-local-map 862 (let ((map (make-sparse-keymap 'message-minibuffer-local-map))) 863 (set-keymap-parent map minibuffer-local-map) 864 map) 865 "Keymap for `message-read-from-minibuffer'." 866 :version "22.1" 867 :group 'message-various) 868 869;;;###autoload 870(defcustom message-citation-line-function 'message-insert-citation-line 871 "*Function called to insert the \"Whomever writes:\" line. 872 873Note that Gnus provides a feature where the reader can click on 874`writes:' to hide the cited text. If you change this line too much, 875people who read your message will have to change their Gnus 876configuration. See the variable `gnus-cite-attribution-suffix'." 877 :type 'function 878 :link '(custom-manual "(message)Insertion Variables") 879 :group 'message-insertion) 880 881;;;###autoload 882(defcustom message-yank-prefix "> " 883 "*Prefix inserted on the lines of yanked messages. 884Fix `message-cite-prefix-regexp' if it is set to an abnormal value. 885See also `message-yank-cited-prefix'." 886 :type 'string 887 :link '(custom-manual "(message)Insertion Variables") 888 :group 'message-insertion) 889 890(defcustom message-yank-cited-prefix ">" 891 "*Prefix inserted on cited or empty lines of yanked messages. 892Fix `message-cite-prefix-regexp' if it is set to an abnormal value. 893See also `message-yank-prefix'." 894 :version "22.1" 895 :type 'string 896 :link '(custom-manual "(message)Insertion Variables") 897 :group 'message-insertion) 898 899(defcustom message-indentation-spaces 3 900 "*Number of spaces to insert at the beginning of each cited line. 901Used by `message-yank-original' via `message-yank-cite'." 902 :group 'message-insertion 903 :link '(custom-manual "(message)Insertion Variables") 904 :type 'integer) 905 906;;;###autoload 907(defcustom message-cite-function 'message-cite-original 908 "*Function for citing an original message. 909Predefined functions include `message-cite-original' and 910`message-cite-original-without-signature'. 911Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil." 912 :type '(radio (function-item message-cite-original) 913 (function-item message-cite-original-without-signature) 914 (function-item sc-cite-original) 915 (function :tag "Other")) 916 :link '(custom-manual "(message)Insertion Variables") 917 :group 'message-insertion) 918 919;;;###autoload 920(defcustom message-indent-citation-function 'message-indent-citation 921 "*Function for modifying a citation just inserted in the mail buffer. 922This can also be a list of functions. Each function can find the 923citation between (point) and (mark t). And each function should leave 924point and mark around the citation text as modified." 925 :type 'function 926 :link '(custom-manual "(message)Insertion Variables") 927 :group 'message-insertion) 928 929;;;###autoload 930(defcustom message-signature t 931 "*String to be inserted at the end of the message buffer. 932If t, the `message-signature-file' file will be inserted instead. 933If a function, the result from the function will be used instead. 934If a form, the result from the form will be used instead." 935 :type 'sexp 936 :link '(custom-manual "(message)Insertion Variables") 937 :group 'message-insertion) 938 939;;;###autoload 940(defcustom message-signature-file "~/.signature" 941 "*Name of file containing the text inserted at end of message buffer. 942Ignored if the named file doesn't exist. 943If nil, don't insert a signature." 944 :type '(choice file (const :tags "None" nil)) 945 :link '(custom-manual "(message)Insertion Variables") 946 :group 'message-insertion) 947 948;;;###autoload 949(defcustom message-signature-insert-empty-line t 950 "*If non-nil, insert an empty line before the signature separator." 951 :version "22.1" 952 :type 'boolean 953 :link '(custom-manual "(message)Insertion Variables") 954 :group 'message-insertion) 955 956(defcustom message-distribution-function nil 957 "*Function called to return a Distribution header." 958 :group 'message-news 959 :group 'message-headers 960 :link '(custom-manual "(message)News Headers") 961 :type '(choice function (const nil))) 962 963(defcustom message-expires 14 964 "Number of days before your article expires." 965 :group 'message-news 966 :group 'message-headers 967 :link '(custom-manual "(message)News Headers") 968 :type 'integer) 969 970(defcustom message-user-path nil 971 "If nil, use the NNTP server name in the Path header. 972If stringp, use this; if non-nil, use no host name (user name only)." 973 :group 'message-news 974 :group 'message-headers 975 :link '(custom-manual "(message)News Headers") 976 :type '(choice (const :tag "nntp" nil) 977 (string :tag "name") 978 (sexp :tag "none" :format "%t" t))) 979 980(defvar message-reply-buffer nil) 981(defvar message-reply-headers nil 982 "The headers of the current replied article. 983It is a vector of the following headers: 984\[number subject from date id references chars lines xref extra].") 985(defvar message-newsreader nil) 986(defvar message-mailer nil) 987(defvar message-sent-message-via nil) 988(defvar message-checksum nil) 989(defvar message-send-actions nil 990 "A list of actions to be performed upon successful sending of a message.") 991(defvar message-exit-actions nil 992 "A list of actions to be performed upon exiting after sending a message.") 993(defvar message-kill-actions nil 994 "A list of actions to be performed before killing a message buffer.") 995(defvar message-postpone-actions nil 996 "A list of actions to be performed after postponing a message.") 997 998(define-widget 'message-header-lines 'text 999 "All header lines must be LFD terminated." 1000 :format "%{%t%}:%n%v" 1001 :valid-regexp "^\\'" 1002 :error "All header lines must be newline terminated") 1003 1004(defcustom message-default-headers "" 1005 "*A string containing header lines to be inserted in outgoing messages. 1006It is inserted before you edit the message, so you can edit or delete 1007these lines." 1008 :group 'message-headers 1009 :link '(custom-manual "(message)Message Headers") 1010 :type 'message-header-lines) 1011 1012(defcustom message-default-mail-headers "" 1013 "*A string of header lines to be inserted in outgoing mails." 1014 :group 'message-headers 1015 :group 'message-mail 1016 :link '(custom-manual "(message)Mail Headers") 1017 :type 'message-header-lines) 1018 1019(defcustom message-default-news-headers "" 1020 "*A string of header lines to be inserted in outgoing news articles." 1021 :group 'message-headers 1022 :group 'message-news 1023 :link '(custom-manual "(message)News Headers") 1024 :type 'message-header-lines) 1025 1026;; Note: could use /usr/ucb/mail instead of sendmail; 1027;; options -t, and -v if not interactive. 1028(defcustom message-mailer-swallows-blank-line 1029 (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" 1030 system-configuration) 1031 (file-readable-p "/etc/sendmail.cf") 1032 (let ((buffer (get-buffer-create " *temp*"))) 1033 (unwind-protect 1034 (save-excursion 1035 (set-buffer buffer) 1036 (insert-file-contents "/etc/sendmail.cf") 1037 (goto-char (point-min)) 1038 (let ((case-fold-search nil)) 1039 (re-search-forward "^OR\\>" nil t))) 1040 (kill-buffer buffer)))) 1041 ;; According to RFC822, "The field-name must be composed of printable 1042 ;; ASCII characters (i. e., characters that have decimal values between 1043 ;; 33 and 126, except colon)", i. e., any chars except ctl chars, 1044 ;; space, or colon. 1045 '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) 1046 "*Set this non-nil if the system's mailer runs the header and body together. 1047\(This problem exists on Sunos 4 when sendmail is run in remote mode.) 1048The value should be an expression to test whether the problem will 1049actually occur." 1050 :group 'message-sending 1051 :link '(custom-manual "(message)Mail Variables") 1052 :type 'sexp) 1053 1054;;;###autoload 1055(define-mail-user-agent 'message-user-agent 1056 'message-mail 'message-send-and-exit 1057 'message-kill-buffer 'message-send-hook) 1058 1059(defvar message-mh-deletable-headers '(Message-ID Date Lines Sender) 1060 "If non-nil, delete the deletable headers before feeding to mh.") 1061 1062(defvar message-send-method-alist 1063 '((news message-news-p message-send-via-news) 1064 (mail message-mail-p message-send-via-mail)) 1065 "Alist of ways to send outgoing messages. 1066Each element has the form 1067 1068 \(TYPE PREDICATE FUNCTION) 1069 1070where TYPE is a symbol that names the method; PREDICATE is a function 1071called without any parameters to determine whether the message is 1072a message of type TYPE; and FUNCTION is a function to be called if 1073PREDICATE returns non-nil. FUNCTION is called with one parameter -- 1074the prefix.") 1075 1076(defcustom message-mail-alias-type 'abbrev 1077 "*What alias expansion type to use in Message buffers. 1078The default is `abbrev', which uses mailabbrev. nil switches 1079mail aliases off." 1080 :group 'message 1081 :link '(custom-manual "(message)Mail Aliases") 1082 :type '(choice (const :tag "Use Mailabbrev" abbrev) 1083 (const :tag "No expansion" nil))) 1084 1085(defcustom message-auto-save-directory 1086 (file-name-as-directory (nnheader-concat message-directory "drafts")) 1087 "*Directory where Message auto-saves buffers if Gnus isn't running. 1088If nil, Message won't auto-save." 1089 :group 'message-buffers 1090 :link '(custom-manual "(message)Various Message Variables") 1091 :type '(choice directory (const :tag "Don't auto-save" nil))) 1092 1093(defcustom message-default-charset 1094 (and (not (mm-multibyte-p)) 'iso-8859-1) 1095 "Default charset used in non-MULE Emacsen. 1096If nil, you might be asked to input the charset." 1097 :version "21.1" 1098 :group 'message 1099 :link '(custom-manual "(message)Various Message Variables") 1100 :type 'symbol) 1101 1102(defcustom message-dont-reply-to-names 1103 (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) 1104 "*A regexp specifying addresses to prune when doing wide replies. 1105A value of nil means exclude your own user name only." 1106 :version "21.1" 1107 :group 'message 1108 :link '(custom-manual "(message)Wide Reply") 1109 :type '(choice (const :tag "Yourself" nil) 1110 regexp)) 1111 1112(defvar message-shoot-gnksa-feet nil 1113 "*A list of GNKSA feet you are allowed to shoot. 1114Gnus gives you all the opportunity you could possibly want for 1115shooting yourself in the foot. Also, Gnus allows you to shoot the 1116feet of Good Net-Keeping Seal of Approval. The following are foot 1117candidates: 1118`empty-article' Allow you to post an empty article; 1119`quoted-text-only' Allow you to post quoted text only; 1120`multiple-copies' Allow you to post multiple copies; 1121`cancel-messages' Allow you to cancel or supersede messages from 1122 your other email addresses.") 1123 1124(defsubst message-gnksa-enable-p (feature) 1125 (or (not (listp message-shoot-gnksa-feet)) 1126 (memq feature message-shoot-gnksa-feet))) 1127 1128(defcustom message-hidden-headers nil 1129 "Regexp of headers to be hidden when composing new messages. 1130This can also be a list of regexps to match headers. Or a list 1131starting with `not' and followed by regexps." 1132 :version "22.1" 1133 :group 'message 1134 :link '(custom-manual "(message)Message Headers") 1135 :type '(repeat regexp)) 1136 1137;;; Internal variables. 1138;;; Well, not really internal. 1139 1140(defvar message-mode-syntax-table 1141 (let ((table (copy-syntax-table text-mode-syntax-table))) 1142 (modify-syntax-entry ?% ". " table) 1143 (modify-syntax-entry ?> ". " table) 1144 (modify-syntax-entry ?< ". " table) 1145 table) 1146 "Syntax table used while in Message mode.") 1147 1148(defface message-header-to 1149 '((((class color) 1150 (background dark)) 1151 (:foreground "green2" :bold t)) 1152 (((class color) 1153 (background light)) 1154 (:foreground "MidnightBlue" :bold t)) 1155 (t 1156 (:bold t :italic t))) 1157 "Face used for displaying From headers." 1158 :group 'message-faces) 1159;; backward-compatibility alias 1160(put 'message-header-to-face 'face-alias 'message-header-to) 1161 1162(defface message-header-cc 1163 '((((class color) 1164 (background dark)) 1165 (:foreground "green4" :bold t)) 1166 (((class color) 1167 (background light)) 1168 (:foreground "MidnightBlue")) 1169 (t 1170 (:bold t))) 1171 "Face used for displaying Cc headers." 1172 :group 'message-faces) 1173;; backward-compatibility alias 1174(put 'message-header-cc-face 'face-alias 'message-header-cc) 1175 1176(defface message-header-subject 1177 '((((class color) 1178 (background dark)) 1179 (:foreground "green3")) 1180 (((class color) 1181 (background light)) 1182 (:foreground "navy blue" :bold t)) 1183 (t 1184 (:bold t))) 1185 "Face used for displaying subject headers." 1186 :group 'message-faces) 1187;; backward-compatibility alias 1188(put 'message-header-subject-face 'face-alias 'message-header-subject) 1189 1190(defface message-header-newsgroups 1191 '((((class color) 1192 (background dark)) 1193 (:foreground "yellow" :bold t :italic t)) 1194 (((class color) 1195 (background light)) 1196 (:foreground "blue4" :bold t :italic t)) 1197 (t 1198 (:bold t :italic t))) 1199 "Face used for displaying newsgroups headers." 1200 :group 'message-faces) 1201;; backward-compatibility alias 1202(put 'message-header-newsgroups-face 'face-alias 'message-header-newsgroups) 1203 1204(defface message-header-other 1205 '((((class color) 1206 (background dark)) 1207 (:foreground "#b00000")) 1208 (((class color) 1209 (background light)) 1210 (:foreground "steel blue")) 1211 (t 1212 (:bold t :italic t))) 1213 "Face used for displaying newsgroups headers." 1214 :group 'message-faces) 1215;; backward-compatibility alias 1216(put 'message-header-other-face 'face-alias 'message-header-other) 1217 1218(defface message-header-name 1219 '((((class color) 1220 (background dark)) 1221 (:foreground "DarkGreen")) 1222 (((class color) 1223 (background light)) 1224 (:foreground "cornflower blue")) 1225 (t 1226 (:bold t))) 1227 "Face used for displaying header names." 1228 :group 'message-faces) 1229;; backward-compatibility alias 1230(put 'message-header-name-face 'face-alias 'message-header-name) 1231 1232(defface message-header-xheader 1233 '((((class color) 1234 (background dark)) 1235 (:foreground "blue")) 1236 (((class color) 1237 (background light)) 1238 (:foreground "blue")) 1239 (t 1240 (:bold t))) 1241 "Face used for displaying X-Header headers." 1242 :group 'message-faces) 1243;; backward-compatibility alias 1244(put 'message-header-xheader-face 'face-alias 'message-header-xheader) 1245 1246(defface message-separator 1247 '((((class color) 1248 (background dark)) 1249 (:foreground "blue3")) 1250 (((class color) 1251 (background light)) 1252 (:foreground "brown")) 1253 (t 1254 (:bold t))) 1255 "Face used for displaying the separator." 1256 :group 'message-faces) 1257;; backward-compatibility alias 1258(put 'message-separator-face 'face-alias 'message-separator) 1259 1260(defface message-cited-text 1261 '((((class color) 1262 (background dark)) 1263 (:foreground "red")) 1264 (((class color) 1265 (background light)) 1266 (:foreground "red")) 1267 (t 1268 (:bold t))) 1269 "Face used for displaying cited text names." 1270 :group 'message-faces) 1271;; backward-compatibility alias 1272(put 'message-cited-text-face 'face-alias 'message-cited-text) 1273 1274(defface message-mml 1275 '((((class color) 1276 (background dark)) 1277 (:foreground "ForestGreen")) 1278 (((class color) 1279 (background light)) 1280 (:foreground "ForestGreen")) 1281 (t 1282 (:bold t))) 1283 "Face used for displaying MML." 1284 :group 'message-faces) 1285;; backward-compatibility alias 1286(put 'message-mml-face 'face-alias 'message-mml) 1287 1288(defun message-font-lock-make-header-matcher (regexp) 1289 (let ((form 1290 `(lambda (limit) 1291 (let ((start (point))) 1292 (save-restriction 1293 (widen) 1294 (goto-char (point-min)) 1295 (if (re-search-forward 1296 (concat "^" (regexp-quote mail-header-separator) "$") 1297 nil t) 1298 (setq limit (min limit (match-beginning 0)))) 1299 (goto-char start)) 1300 (and (< start limit) 1301 (re-search-forward ,regexp limit t)))))) 1302 (if (featurep 'bytecomp) 1303 (byte-compile form) 1304 form))) 1305 1306(defvar message-font-lock-keywords 1307 (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) 1308 `((,(message-font-lock-make-header-matcher 1309 (concat "^\\([Tt]o:\\)" content)) 1310 (1 'message-header-name) 1311 (2 'message-header-to nil t)) 1312 (,(message-font-lock-make-header-matcher 1313 (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)) 1314 (1 'message-header-name) 1315 (2 'message-header-cc nil t)) 1316 (,(message-font-lock-make-header-matcher 1317 (concat "^\\([Ss]ubject:\\)" content)) 1318 (1 'message-header-name) 1319 (2 'message-header-subject nil t)) 1320 (,(message-font-lock-make-header-matcher 1321 (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)) 1322 (1 'message-header-name) 1323 (2 'message-header-newsgroups nil t)) 1324 (,(message-font-lock-make-header-matcher 1325 (concat "^\\([A-Z][^: \n\t]+:\\)" content)) 1326 (1 'message-header-name) 1327 (2 'message-header-other nil t)) 1328 (,(message-font-lock-make-header-matcher 1329 (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) 1330 (1 'message-header-name) 1331 (2 'message-header-name)) 1332 ,@(if (and mail-header-separator 1333 (not (equal mail-header-separator ""))) 1334 `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") 1335 1 'message-separator)) 1336 nil) 1337 ((lambda (limit) 1338 (re-search-forward (concat "^\\(" 1339 message-cite-prefix-regexp 1340 "\\).*") 1341 limit t)) 1342 (0 'message-cited-text)) 1343 ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>" 1344 (0 'message-mml)))) 1345 "Additional expressions to highlight in Message mode.") 1346 1347 1348;; XEmacs does it like this. For Emacs, we have to set the 1349;; `font-lock-defaults' buffer-local variable. 1350(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) 1351 1352(defvar message-face-alist 1353 '((bold . bold-region) 1354 (underline . underline-region) 1355 (default . (lambda (b e) 1356 (unbold-region b e) 1357 (ununderline-region b e)))) 1358 "Alist of mail and news faces for facemenu. 1359The cdr of each entry is a function for applying the face to a region.") 1360 1361(defcustom message-send-hook nil 1362 "Hook run before sending messages. 1363This hook is run quite early when sending." 1364 :group 'message-various 1365 :options '(ispell-message) 1366 :link '(custom-manual "(message)Various Message Variables") 1367 :type 'hook) 1368 1369(defcustom message-send-mail-hook nil 1370 "Hook run before sending mail messages. 1371This hook is run very late -- just before the message is sent as 1372mail." 1373 :group 'message-various 1374 :link '(custom-manual "(message)Various Message Variables") 1375 :type 'hook) 1376 1377(defcustom message-send-news-hook nil 1378 "Hook run before sending news messages. 1379This hook is run very late -- just before the message is sent as 1380news." 1381 :group 'message-various 1382 :link '(custom-manual "(message)Various Message Variables") 1383 :type 'hook) 1384 1385(defcustom message-sent-hook nil 1386 "Hook run after sending messages." 1387 :group 'message-various 1388 :type 'hook) 1389 1390(defvar message-send-coding-system 'binary 1391 "Coding system to encode outgoing mail.") 1392 1393(defvar message-draft-coding-system 1394 mm-auto-save-coding-system 1395 "*Coding system to compose mail. 1396If you'd like to make it possible to share draft files between XEmacs 1397and Emacs, you may use `iso-2022-7bit' for this value at your own risk. 1398Note that the coding-system `iso-2022-7bit' isn't suitable to all data.") 1399 1400(defcustom message-send-mail-partially-limit 1000000 1401 "The limitation of messages sent as message/partial. 1402The lower bound of message size in characters, beyond which the message 1403should be sent in several parts. If it is nil, the size is unlimited." 1404 :version "21.1" 1405 :group 'message-buffers 1406 :link '(custom-manual "(message)Mail Variables") 1407 :type '(choice (const :tag "unlimited" nil) 1408 (integer 1000000))) 1409 1410(defcustom message-alternative-emails nil 1411 "*Regexp matching alternative email addresses. 1412The first address in the To, Cc or From headers of the original 1413article matching this variable is used as the From field of 1414outgoing messages. 1415 1416This variable has precedence over posting styles and anything that runs 1417off `message-setup-hook'." 1418 :group 'message-headers 1419 :link '(custom-manual "(message)Message Headers") 1420 :type '(choice (const :tag "Always use primary" nil) 1421 regexp)) 1422 1423(defcustom message-hierarchical-addresses nil 1424 "A list of hierarchical mail address definitions. 1425 1426Inside each entry, the first address is the \"top\" address, and 1427subsequent addresses are subaddresses; this is used to indicate that 1428mail sent to the first address will automatically be delivered to the 1429subaddresses. So if the first address appears in the recipient list 1430for a message, the subaddresses will be removed (if present) before 1431the mail is sent. All addresses in this structure should be 1432downcased." 1433 :version "22.1" 1434 :group 'message-headers 1435 :type '(repeat (repeat string))) 1436 1437(defcustom message-mail-user-agent nil 1438 "Like `mail-user-agent'. 1439Except if it is nil, use Gnus native MUA; if it is t, use 1440`mail-user-agent'." 1441 :version "22.1" 1442 :type '(radio (const :tag "Gnus native" 1443 :format "%t\n" 1444 nil) 1445 (const :tag "`mail-user-agent'" 1446 :format "%t\n" 1447 t) 1448 (function-item :tag "Default Emacs mail" 1449 :format "%t\n" 1450 sendmail-user-agent) 1451 (function-item :tag "Emacs interface to MH" 1452 :format "%t\n" 1453 mh-e-user-agent) 1454 (function :tag "Other")) 1455 :version "21.1" 1456 :group 'message) 1457 1458(defcustom message-wide-reply-confirm-recipients nil 1459 "Whether to confirm a wide reply to multiple email recipients. 1460If this variable is nil, don't ask whether to reply to all recipients. 1461If this variable is non-nil, pose the question \"Reply to all 1462recipients?\" before a wide reply to multiple recipients. If the user 1463answers yes, reply to all recipients as usual. If the user answers 1464no, only reply back to the author." 1465 :version "22.1" 1466 :group 'message-headers 1467 :link '(custom-manual "(message)Wide Reply") 1468 :type 'boolean) 1469 1470(defcustom message-user-fqdn nil 1471 "*Domain part of Message-Ids." 1472 :version "22.1" 1473 :group 'message-headers 1474 :link '(custom-manual "(message)News Headers") 1475 :type '(radio (const :format "%v " nil) 1476 (string :format "FQDN: %v"))) 1477 1478(defcustom message-use-idna (and (condition-case nil (require 'idna) 1479 (file-error)) 1480 (mm-coding-system-p 'utf-8) 1481 (executable-find idna-program) 1482 (string= (idna-to-ascii "r�ksm�rg�s") 1483 "xn--rksmrgs-5wao1o") 1484 t) 1485 "Whether to encode non-ASCII in domain names into ASCII according to IDNA. 1486GNU Libidn, and in particular the elisp package \"idna.el\" and 1487the external program \"idn\", must be installed for this 1488functionality to work." 1489 :version "22.1" 1490 :group 'message-headers 1491 :link '(custom-manual "(message)IDNA") 1492 :type '(choice (const :tag "Ask" ask) 1493 (const :tag "Never" nil) 1494 (const :tag "Always" t))) 1495 1496;;; Internal variables. 1497 1498(defvar message-sending-message "Sending...") 1499(defvar message-buffer-list nil) 1500(defvar message-this-is-news nil) 1501(defvar message-this-is-mail nil) 1502(defvar message-draft-article nil) 1503(defvar message-mime-part nil) 1504(defvar message-posting-charset nil) 1505(defvar message-inserted-headers nil) 1506 1507;; Byte-compiler warning 1508(eval-when-compile 1509 (defvar gnus-active-hashtb) 1510 (defvar gnus-read-active-file)) 1511 1512;;; Regexp matching the delimiter of messages in UNIX mail format 1513;;; (UNIX From lines), minus the initial ^. It should be a copy 1514;;; of rmail.el's rmail-unix-mail-delimiter. 1515(defvar message-unix-mail-delimiter 1516 (let ((time-zone-regexp 1517 (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?" 1518 "\\|[-+]?[0-9][0-9][0-9][0-9]" 1519 "\\|" 1520 "\\) *"))) 1521 (concat 1522 "From " 1523 1524 ;; Many things can happen to an RFC 822 mailbox before it is put into 1525 ;; a `From' line. The leading phrase can be stripped, e.g. 1526 ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g. 1527 ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF 1528 ;; can be removed, e.g. 1529 ;; From: joe@y.z (Joe K 1530 ;; User) 1531 ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and 1532 ;; From: Joe User 1533 ;; <joe@y.z> 1534 ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'. 1535 ;; The mailbox can be removed or be replaced by white space, e.g. 1536 ;; From: "Joe User"{space}{tab} 1537 ;; <joe@y.z> 1538 ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996', 1539 ;; where {space} and {tab} represent the Ascii space and tab characters. 1540 ;; We want to match the results of any of these manglings. 1541 ;; The following regexp rejects names whose first characters are 1542 ;; obviously bogus, but after that anything goes. 1543 "\\([^\0-\b\n-\r\^?].*\\)?" 1544 1545 ;; The time the message was sent. 1546 "\\([^\0-\r \^?]+\\) +" ; day of the week 1547 "\\([^\0-\r \^?]+\\) +" ; month 1548 "\\([0-3]?[0-9]\\) +" ; day of month 1549 "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day 1550 1551 ;; Perhaps a time zone, specified by an abbreviation, or by a 1552 ;; numeric offset. 1553 time-zone-regexp 1554 1555 ;; The year. 1556 " \\([0-9][0-9]+\\) *" 1557 1558 ;; On some systems the time zone can appear after the year, too. 1559 time-zone-regexp 1560 1561 ;; Old uucp cruft. 1562 "\\(remote from .*\\)?" 1563 1564 "\n")) 1565 "Regexp matching the delimiter of messages in UNIX mail format.") 1566 1567(defvar message-unsent-separator 1568 (concat "^ *---+ +Unsent message follows +---+ *$\\|" 1569 "^ *---+ +Returned message +---+ *$\\|" 1570 "^Start of returned message$\\|" 1571 "^ *---+ +Original message +---+ *$\\|" 1572 "^ *--+ +begin message +--+ *$\\|" 1573 "^ *---+ +Original message follows +---+ *$\\|" 1574 "^ *---+ +Undelivered message follows +---+ *$\\|" 1575 "^|? *---+ +Message text follows: +---+ *|?$") 1576 "A regexp that matches the separator before the text of a failed message.") 1577 1578(defvar message-header-format-alist 1579 `((Newsgroups) 1580 (To . message-fill-address) 1581 (Cc . message-fill-address) 1582 (Subject) 1583 (In-Reply-To) 1584 (Fcc) 1585 (Bcc) 1586 (Date) 1587 (Organization) 1588 (Distribution) 1589 (Lines) 1590 (Expires) 1591 (Message-ID) 1592 (References . message-shorten-references) 1593 (User-Agent)) 1594 "Alist used for formatting headers.") 1595 1596(defvar message-options nil 1597 "Some saved answers when sending message.") 1598 1599(defvar message-send-mail-real-function nil 1600 "Internal send mail function.") 1601 1602(defvar message-bogus-system-names "^localhost\\.\\|\\.local$" 1603 "The regexp of bogus system names.") 1604 1605(defcustom message-valid-fqdn-regexp 1606 (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain. 1607 ;; valid TLDs: 1608 "\\([a-z][a-z]\\|" ;; two letter country TDLs 1609 "aero\\|arpa\\|bitnet\\|biz\\|bofh\\|" 1610 "cat\\|com\\|coop\\|edu\\|gov\\|" 1611 "info\\|int\\|jobs\\|" 1612 "mil\\|mobi\\|museum\\|name\\|net\\|" 1613 "org\\|pro\\|travel\\|uucp\\)") 1614 ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains 1615 ;; http://en.wikipedia.org/wiki/GTLD 1616 ;; `in the process of being approved': .asia .post .tel .sex 1617 ;; "dead" nato bitnet uucp 1618 "Regular expression that matches a valid FQDN." 1619 ;; see also: gnus-button-valid-fqdn-regexp 1620 :version "22.1" 1621 :group 'message-headers 1622 :type 'regexp) 1623 1624(eval-and-compile 1625 (autoload 'idna-to-ascii "idna") 1626 (autoload 'message-setup-toolbar "messagexmas") 1627 (autoload 'mh-new-draft-name "mh-comp") 1628 (autoload 'mh-send-letter "mh-comp") 1629 (autoload 'gnus-point-at-eol "gnus-util") 1630 (autoload 'gnus-point-at-bol "gnus-util") 1631 (autoload 'gnus-output-to-rmail "gnus-util") 1632 (autoload 'gnus-output-to-mail "gnus-util") 1633 (autoload 'nndraft-request-associate-buffer "nndraft") 1634 (autoload 'nndraft-request-expire-articles "nndraft") 1635 (autoload 'gnus-open-server "gnus-int") 1636 (autoload 'gnus-request-post "gnus-int") 1637 (autoload 'gnus-alive-p "gnus-util") 1638 (autoload 'gnus-server-string "gnus") 1639 (autoload 'gnus-group-name-charset "gnus-group") 1640 (autoload 'gnus-group-name-decode "gnus-group") 1641 (autoload 'gnus-groups-from-server "gnus") 1642 (autoload 'rmail-output "rmailout") 1643 (autoload 'gnus-delay-article "gnus-delay") 1644 (autoload 'gnus-make-local-hook "gnus-util") 1645 (autoload 'gnus-extract-address-components "gnus-util") 1646 (autoload 'gnus-select-frame-set-input-focus "gnus-util")) 1647 1648 1649 1650;;; 1651;;; Utility functions. 1652;;; 1653 1654(defmacro message-y-or-n-p (question show &rest text) 1655 "Ask QUESTION, displaying remaining args in a temporary buffer if SHOW." 1656 `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) 1657 1658(defmacro message-delete-line (&optional n) 1659 "Delete the current line (and the next N lines)." 1660 `(delete-region (progn (beginning-of-line) (point)) 1661 (progn (forward-line ,(or n 1)) (point)))) 1662 1663(defun message-mark-active-p () 1664 "Non-nil means the mark and region are currently active in this buffer." 1665 mark-active) 1666 1667(defun message-unquote-tokens (elems) 1668 "Remove double quotes (\") from strings in list ELEMS." 1669 (mapcar (lambda (item) 1670 (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) 1671 (setq item (concat (match-string 1 item) 1672 (match-string 2 item)))) 1673 item) 1674 elems)) 1675 1676(defun message-tokenize-header (header &optional separator) 1677 "Split HEADER into a list of header elements. 1678SEPARATOR is a string of characters to be used as separators. \",\" 1679is used by default." 1680 (if (not header) 1681 nil 1682 (let ((regexp (format "[%s]+" (or separator ","))) 1683 (first t) 1684 beg quoted elems paren) 1685 (with-temp-buffer 1686 (mm-enable-multibyte) 1687 (setq beg (point-min)) 1688 (insert header) 1689 (goto-char (point-min)) 1690 (while (not (eobp)) 1691 (if first 1692 (setq first nil) 1693 (forward-char 1)) 1694 (cond ((and (> (point) beg) 1695 (or (eobp) 1696 (and (looking-at regexp) 1697 (not quoted) 1698 (not paren)))) 1699 (push (buffer-substring beg (point)) elems) 1700 (setq beg (match-end 0))) 1701 ((eq (char-after) ?\") 1702 (setq quoted (not quoted))) 1703 ((and (eq (char-after) ?\() 1704 (not quoted)) 1705 (setq paren t)) 1706 ((and (eq (char-after) ?\)) 1707 (not quoted)) 1708 (setq paren nil)))) 1709 (nreverse elems))))) 1710 1711(defun message-mail-file-mbox-p (file) 1712 "Say whether FILE looks like a Unix mbox file." 1713 (when (and (file-exists-p file) 1714 (file-readable-p file) 1715 (file-regular-p file)) 1716 (with-temp-buffer 1717 (nnheader-insert-file-contents file) 1718 (goto-char (point-min)) 1719 (looking-at message-unix-mail-delimiter)))) 1720 1721(defun message-fetch-field (header &optional not-all) 1722 "The same as `mail-fetch-field', only remove all newlines. 1723The buffer is expected to be narrowed to just the header of the message; 1724see `message-narrow-to-headers-or-head'." 1725 (let* ((inhibit-point-motion-hooks t) 1726 (case-fold-search t) 1727 (value (mail-fetch-field header nil (not not-all)))) 1728 (when value 1729 (while (string-match "\n[\t ]+" value) 1730 (setq value (replace-match " " t t value))) 1731 (set-text-properties 0 (length value) nil value) 1732 value))) 1733 1734(defun message-field-value (header &optional not-all) 1735 "The same as `message-fetch-field', only narrow to the headers first." 1736 (save-excursion 1737 (save-restriction 1738 (message-narrow-to-headers-or-head) 1739 (message-fetch-field header not-all)))) 1740 1741(defun message-narrow-to-field () 1742 "Narrow the buffer to the header on the current line." 1743 (beginning-of-line) 1744 (narrow-to-region 1745 (point) 1746 (progn 1747 (forward-line 1) 1748 (if (re-search-forward "^[^ \n\t]" nil t) 1749 (progn 1750 (beginning-of-line) 1751 (point)) 1752 (point-max)))) 1753 (goto-char (point-min))) 1754 1755(defun message-add-header (&rest headers) 1756 "Add the HEADERS to the message header, skipping those already present." 1757 (while headers 1758 (let (hclean) 1759 (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers)) 1760 (error "Invalid header `%s'" (car headers))) 1761 (setq hclean (match-string 1 (car headers))) 1762 (save-restriction 1763 (message-narrow-to-headers) 1764 (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) 1765 (goto-char (point-max)) 1766 (if (string-match "\n$" (car headers)) 1767 (insert (car headers)) 1768 (insert (car headers) ?\n))))) 1769 (setq headers (cdr headers)))) 1770 1771(defmacro message-with-reply-buffer (&rest forms) 1772 "Evaluate FORMS in the reply buffer, if it exists." 1773 `(when (and message-reply-buffer 1774 (buffer-name message-reply-buffer)) 1775 (save-excursion 1776 (set-buffer message-reply-buffer) 1777 ,@forms))) 1778 1779(put 'message-with-reply-buffer 'lisp-indent-function 0) 1780(put 'message-with-reply-buffer 'edebug-form-spec '(body)) 1781 1782(defun message-fetch-reply-field (header) 1783 "Fetch field HEADER from the message we're replying to." 1784 (message-with-reply-buffer 1785 (save-restriction 1786 (mail-narrow-to-head) 1787 (message-fetch-field header)))) 1788 1789(defun message-strip-list-identifiers (subject) 1790 "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT." 1791 (require 'gnus-sum) ; for gnus-list-identifiers 1792 (let ((regexp (if (stringp gnus-list-identifiers) 1793 gnus-list-identifiers 1794 (mapconcat 'identity gnus-list-identifiers " *\\|")))) 1795 (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp 1796 " *\\)\\)+\\(Re: +\\)?\\)") subject) 1797 (concat (substring subject 0 (match-beginning 1)) 1798 (or (match-string 3 subject) 1799 (match-string 5 subject)) 1800 (substring subject 1801 (match-end 1))) 1802 subject))) 1803 1804(defun message-strip-subject-re (subject) 1805 "Remove \"Re:\" from subject lines in string SUBJECT." 1806 (if (string-match message-subject-re-regexp subject) 1807 (substring subject (match-end 0)) 1808 subject)) 1809 1810(defcustom message-replacement-char "." 1811 "Replacement character used instead of unprintable or not decodable chars." 1812 :group 'message-various 1813 :version "22.1" ;; Gnus 5.10.9 1814 :type '(choice string 1815 (const ".") 1816 (const "?"))) 1817 1818;; FIXME: We also should call `message-strip-subject-encoded-words' 1819;; when forwarding. Probably in `message-make-forward-subject' and 1820;; `message-forward-make-body'. 1821 1822(defun message-strip-subject-encoded-words (subject) 1823 "Fix non-decodable words in SUBJECT." 1824 ;; Cf. `gnus-simplify-subject-fully'. 1825 (let* ((case-fold-search t) 1826 (replacement-chars (format "[%s%s%s]" 1827 message-replacement-char 1828 message-replacement-char 1829 message-replacement-char)) 1830 (enc-word-re "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?\\([^?]+\\)\\(\\?=\\)") 1831 cs-string 1832 (have-marker 1833 (with-temp-buffer 1834 (insert subject) 1835 (goto-char (point-min)) 1836 (when (re-search-forward enc-word-re nil t) 1837 (setq cs-string (match-string 1))))) 1838 cs-coding q-or-b word-beg word-end) 1839 (if (or (not have-marker) ;; No encoded word found... 1840 ;; ... or double encoding was correct: 1841 (and (stringp cs-string) 1842 (setq cs-string (downcase cs-string)) 1843 (mm-coding-system-p (intern cs-string)) 1844 (not (prog1 1845 (y-or-n-p 1846 (format "\ 1847Decoded Subject \"%s\" 1848contains a valid encoded word. Decode again? " 1849 subject)) 1850 (setq cs-coding (intern cs-string)))))) 1851 subject 1852 (with-temp-buffer 1853 (insert subject) 1854 (goto-char (point-min)) 1855 (while (re-search-forward enc-word-re nil t) 1856 (setq cs-string (downcase (match-string 1)) 1857 q-or-b (match-string 2) 1858 word-beg (match-beginning 0) 1859 word-end (match-end 0)) 1860 (setq cs-coding 1861 (if (mm-coding-system-p (intern cs-string)) 1862 (setq cs-coding (intern cs-string)) 1863 nil)) 1864 ;; No double encoded subject? => bogus charset. 1865 (unless cs-coding 1866 (setq cs-coding 1867 (mm-read-coding-system 1868 (format "\ 1869Decoded Subject \"%s\" 1870contains an encoded word. The charset `%s' is unknown or invalid. 1871Hit RET to replace non-decodable characters with \"%s\" or enter replacement 1872charset: " 1873 subject cs-string message-replacement-char))) 1874 (if cs-coding 1875 (replace-match (concat "=?" (symbol-name cs-coding) 1876 "?\\2?\\3\\4\\5")) 1877 (save-excursion 1878 (goto-char word-beg) 1879 (re-search-forward "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?" word-end t) 1880 (replace-match "") 1881 ;; QP or base64 1882 (if (string-match "\\`Q\\'" q-or-b) 1883 ;; QP 1884 (progn 1885 (message "Replacing non-decodable characters with \"%s\"." 1886 message-replacement-char) 1887 (while (re-search-forward "\\(=[A-F0-9][A-F0-9]\\)+" 1888 word-end t) 1889 (replace-match message-replacement-char))) 1890 ;; base64 1891 (message "Replacing non-decodable characters with \"%s\"." 1892 replacement-chars) 1893 (re-search-forward "[^?]+" word-end t) 1894 (replace-match replacement-chars)) 1895 (re-search-forward "\\?=") 1896 (replace-match ""))))) 1897 (rfc2047-decode-region (point-min) (point-max)) 1898 (buffer-string))))) 1899 1900;;; Start of functions adopted from `message-utils.el'. 1901 1902(defun message-strip-subject-trailing-was (subject) 1903 "Remove trailing \"(was: <old subject>)\" from SUBJECT lines. 1904Leading \"Re: \" is not stripped by this function. Use the function 1905`message-strip-subject-re' for this." 1906 (let* ((query message-subject-trailing-was-query) 1907 (new) (found)) 1908 (setq found 1909 (string-match 1910 (if (eq query 'ask) 1911 message-subject-trailing-was-ask-regexp 1912 message-subject-trailing-was-regexp) 1913 subject)) 1914 (if found 1915 (setq new (substring subject 0 (match-beginning 0)))) 1916 (if (or (not found) (eq query nil)) 1917 subject 1918 (if (eq query 'ask) 1919 (if (message-y-or-n-p 1920 "Strip `(was: <old subject>)' in subject? " t 1921 (concat 1922 "Strip `(was: <old subject>)' in subject " 1923 "and use the new one instead?\n\n" 1924 "Current subject is: \"" 1925 subject "\"\n\n" 1926 "New subject would be: \"" 1927 new "\"\n\n" 1928 "See the variable `message-subject-trailing-was-query' " 1929 "to get rid of this query." 1930 )) 1931 new subject) 1932 new)))) 1933 1934;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/ 1935 1936(defun message-change-subject (new-subject) 1937 "Ask for NEW-SUBJECT header, append (was: <Old Subject>)." 1938 ;; <URL:http://www.landfield.com/usefor/drafts/draft-ietf-usefor-useage--1.02.unpaged> 1939 (interactive 1940 (list 1941 (read-from-minibuffer "New subject: "))) 1942 (cond ((and (not (or (null new-subject) ; new subject not empty 1943 (zerop (string-width new-subject)) 1944 (string-match "^[ \t]*$" new-subject)))) 1945 (save-excursion 1946 (let ((old-subject 1947 (save-restriction 1948 (message-narrow-to-headers) 1949 (message-fetch-field "Subject")))) 1950 (cond ((not old-subject) 1951 (error "No current subject")) 1952 ((not (string-match 1953 (concat "^[ \t]*" 1954 (regexp-quote new-subject) 1955 " \t]*$") 1956 old-subject)) ; yes, it really is a new subject 1957 ;; delete eventual Re: prefix 1958 (setq old-subject 1959 (message-strip-subject-re old-subject)) 1960 (message-goto-subject) 1961 (message-delete-line) 1962 (insert (concat "Subject: " 1963 new-subject 1964 " (was: " 1965 old-subject ")\n"))))))))) 1966 1967(defun message-mark-inserted-region (beg end) 1968 "Mark some region in the current article with enclosing tags. 1969See `message-mark-insert-begin' and `message-mark-insert-end'." 1970 (interactive "r") 1971 (save-excursion 1972 ;; add to the end of the region first, otherwise end would be invalid 1973 (goto-char end) 1974 (insert message-mark-insert-end) 1975 (goto-char beg) 1976 (insert message-mark-insert-begin))) 1977 1978(defun message-mark-insert-file (file) 1979 "Insert FILE at point, marking it with enclosing tags. 1980See `message-mark-insert-begin' and `message-mark-insert-end'." 1981 (interactive "fFile to insert: ") 1982 ;; reverse insertion to get correct result. 1983 (let ((p (point))) 1984 (insert message-mark-insert-end) 1985 (goto-char p) 1986 (insert-file-contents file) 1987 (goto-char p) 1988 (insert message-mark-insert-begin))) 1989 1990(defun message-add-archive-header () 1991 "Insert \"X-No-Archive: Yes\" in the header and a note in the body. 1992The note can be customized using `message-archive-note'. When called with a 1993prefix argument, ask for a text to insert. If you don't want the note in the 1994body, set `message-archive-note' to nil." 1995 (interactive) 1996 (if current-prefix-arg 1997 (setq message-archive-note 1998 (read-from-minibuffer "Reason for No-Archive: " 1999 (cons message-archive-note 0)))) 2000 (save-excursion 2001 (if (message-goto-signature) 2002 (re-search-backward message-signature-separator)) 2003 (when message-archive-note 2004 (insert message-archive-note) 2005 (newline)) 2006 (message-add-header message-archive-header) 2007 (message-sort-headers))) 2008 2009(defun message-cross-post-followup-to-header (target-group) 2010 "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP. 2011With prefix-argument just set Follow-Up, don't cross-post." 2012 (interactive 2013 (list ; Completion based on Gnus 2014 (completing-read "Followup To: " 2015 (if (boundp 'gnus-newsrc-alist) 2016 gnus-newsrc-alist) 2017 nil nil '("poster" . 0) 2018 (if (boundp 'gnus-group-history) 2019 'gnus-group-history)))) 2020 (message-remove-header "Follow[Uu]p-[Tt]o" t) 2021 (message-goto-newsgroups) 2022 (beginning-of-line) 2023 ;; if we already did a crosspost before, kill old target 2024 (if (and message-cross-post-old-target 2025 (re-search-forward 2026 (regexp-quote (concat "," message-cross-post-old-target)) 2027 nil t)) 2028 (replace-match "")) 2029 ;; unless (followup is to poster or user explicitly asked not 2030 ;; to cross-post, or target-group is already in Newsgroups) 2031 ;; add target-group to Newsgroups line. 2032 (cond ((and (or 2033 ;; def: cross-post, req:no 2034 (and message-cross-post-default (not current-prefix-arg)) 2035 ;; def: no-cross-post, req:yes 2036 (and (not message-cross-post-default) current-prefix-arg)) 2037 (not (string-match "poster" target-group)) 2038 (not (string-match (regexp-quote target-group) 2039 (message-fetch-field "Newsgroups")))) 2040 (end-of-line) 2041 (insert (concat "," target-group)))) 2042 (end-of-line) ; ensure Followup: comes after Newsgroups: 2043 ;; unless new followup would be identical to Newsgroups line 2044 ;; make a new Followup-To line 2045 (if (not (string-match (concat "^[ \t]*" 2046 target-group 2047 "[ \t]*$") 2048 (message-fetch-field "Newsgroups"))) 2049 (insert (concat "\nFollowup-To: " target-group))) 2050 (setq message-cross-post-old-target target-group)) 2051 2052(defun message-cross-post-insert-note (target-group cross-post in-old 2053 old-groups) 2054 "Insert a in message body note about a set Followup or Crosspost. 2055If there have been previous notes, delete them. TARGET-GROUP specifies the 2056group to Followup-To. When CROSS-POST is t, insert note about 2057crossposting. IN-OLD specifies whether TARGET-GROUP is a member of 2058OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have 2059been made to before the user asked for a Crosspost." 2060 ;; start scanning body for previous uses 2061 (message-goto-signature) 2062 (let ((head (re-search-backward 2063 (concat "^" mail-header-separator) 2064 nil t))) ; just search in body 2065 (message-goto-signature) 2066 (while (re-search-backward 2067 (concat "^" (regexp-quote message-cross-post-note) ".*") 2068 head t) 2069 (message-delete-line)) 2070 (message-goto-signature) 2071 (while (re-search-backward 2072 (concat "^" (regexp-quote message-followup-to-note) ".*") 2073 head t) 2074 (message-delete-line)) 2075 ;; insert new note 2076 (if (message-goto-signature) 2077 (re-search-backward message-signature-separator)) 2078 (if (or in-old 2079 (not cross-post) 2080 (string-match "^[ \t]*poster[ \t]*$" target-group)) 2081 (insert (concat message-followup-to-note target-group "\n")) 2082 (insert (concat message-cross-post-note target-group "\n"))))) 2083 2084(defun message-cross-post-followup-to (target-group) 2085 "Crossposts message and set Followup-To to TARGET-GROUP. 2086With prefix-argument just set Follow-Up, don't cross-post." 2087 (interactive 2088 (list ; Completion based on Gnus 2089 (completing-read "Followup To: " 2090 (if (boundp 'gnus-newsrc-alist) 2091 gnus-newsrc-alist) 2092 nil nil '("poster" . 0) 2093 (if (boundp 'gnus-group-history) 2094 'gnus-group-history)))) 2095 (cond ((not (or (null target-group) ; new subject not empty 2096 (zerop (string-width target-group)) 2097 (string-match "^[ \t]*$" target-group))) 2098 (save-excursion 2099 (let* ((old-groups (message-fetch-field "Newsgroups")) 2100 (in-old (string-match 2101 (regexp-quote target-group) 2102 (or old-groups "")))) 2103 ;; check whether target exactly matches old Newsgroups 2104 (cond ((not old-groups) 2105 (error "No current newsgroup")) 2106 ((or (not in-old) 2107 (not (string-match 2108 (concat "^[ \t]*" 2109 (regexp-quote target-group) 2110 "[ \t]*$") 2111 old-groups))) 2112 ;; yes, Newsgroups line must change 2113 (message-cross-post-followup-to-header target-group) 2114 ;; insert note whether we do cross-post or followup-to 2115 (funcall message-cross-post-note-function 2116 target-group 2117 (if (or (and message-cross-post-default 2118 (not current-prefix-arg)) 2119 (and (not message-cross-post-default) 2120 current-prefix-arg)) t) 2121 in-old old-groups)))))))) 2122 2123;;; Reduce To: to Cc: or Bcc: header 2124 2125(defun message-reduce-to-to-cc () 2126 "Replace contents of To: header with contents of Cc: or Bcc: header." 2127 (interactive) 2128 (let ((cc-content 2129 (save-restriction (message-narrow-to-headers) 2130 (message-fetch-field "cc"))) 2131 (bcc nil)) 2132 (if (and (not cc-content) 2133 (setq cc-content 2134 (save-restriction 2135 (message-narrow-to-headers) 2136 (message-fetch-field "bcc")))) 2137 (setq bcc t)) 2138 (cond (cc-content 2139 (save-excursion 2140 (message-goto-to) 2141 (message-delete-line) 2142 (insert (concat "To: " cc-content "\n")) 2143 (save-restriction 2144 (message-narrow-to-headers) 2145 (message-remove-header (if bcc 2146 "bcc" 2147 "cc")))))))) 2148 2149;;; End of functions adopted from `message-utils.el'. 2150 2151(defun message-remove-header (header &optional is-regexp first reverse) 2152 "Remove HEADER in the narrowed buffer. 2153If IS-REGEXP, HEADER is a regular expression. 2154If FIRST, only remove the first instance of the header. 2155Return the number of headers removed." 2156 (goto-char (point-min)) 2157 (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":"))) 2158 (number 0) 2159 (case-fold-search t) 2160 last) 2161 (while (and (not (eobp)) 2162 (not last)) 2163 (if (if reverse 2164 (not (looking-at regexp)) 2165 (looking-at regexp)) 2166 (progn 2167 (incf number) 2168 (when first 2169 (setq last t)) 2170 (delete-region 2171 (point) 2172 ;; There might be a continuation header, so we have to search 2173 ;; until we find a new non-continuation line. 2174 (progn 2175 (forward-line 1) 2176 (if (re-search-forward "^[^ \t]" nil t) 2177 (goto-char (match-beginning 0)) 2178 (point-max))))) 2179 (forward-line 1) 2180 (if (re-search-forward "^[^ \t]" nil t) 2181 (goto-char (match-beginning 0)) 2182 (goto-char (point-max))))) 2183 number)) 2184 2185(defun message-remove-first-header (header) 2186 "Remove the first instance of HEADER if there is more than one." 2187 (let ((count 0) 2188 (regexp (concat "^" (regexp-quote header) ":"))) 2189 (save-excursion 2190 (goto-char (point-min)) 2191 (while (re-search-forward regexp nil t) 2192 (incf count))) 2193 (while (> count 1) 2194 (message-remove-header header nil t) 2195 (decf count)))) 2196 2197(defun message-narrow-to-headers () 2198 "Narrow the buffer to the head of the message." 2199 (widen) 2200 (narrow-to-region 2201 (goto-char (point-min)) 2202 (if (re-search-forward 2203 (concat "^" (regexp-quote mail-header-separator) "\n") nil t) 2204 (match-beginning 0) 2205 (point-max))) 2206 (goto-char (point-min))) 2207 2208(defun message-narrow-to-head-1 () 2209 "Like `message-narrow-to-head'. Don't widen." 2210 (narrow-to-region 2211 (goto-char (point-min)) 2212 (if (search-forward "\n\n" nil 1) 2213 (1- (point)) 2214 (point-max))) 2215 (goto-char (point-min))) 2216 2217(defun message-narrow-to-head () 2218 "Narrow the buffer to the head of the message. 2219Point is left at the beginning of the narrowed-to region." 2220 (widen) 2221 (message-narrow-to-head-1)) 2222 2223(defun message-narrow-to-headers-or-head () 2224 "Narrow the buffer to the head of the message." 2225 (widen) 2226 (narrow-to-region 2227 (goto-char (point-min)) 2228 (if (re-search-forward (concat "\\(\n\\)\n\\|^\\(" 2229 (regexp-quote mail-header-separator) 2230 "\n\\)") 2231 nil t) 2232 (or (match-end 1) (match-beginning 2)) 2233 (point-max))) 2234 (goto-char (point-min))) 2235 2236(defun message-news-p () 2237 "Say whether the current buffer contains a news message." 2238 (and (not message-this-is-mail) 2239 (or message-this-is-news 2240 (save-excursion 2241 (save-restriction 2242 (message-narrow-to-headers) 2243 (and (message-fetch-field "newsgroups") 2244 (not (message-fetch-field "posted-to")))))))) 2245 2246(defun message-mail-p () 2247 "Say whether the current buffer contains a mail message." 2248 (and (not message-this-is-news) 2249 (or message-this-is-mail 2250 (save-excursion 2251 (save-restriction 2252 (message-narrow-to-headers) 2253 (or (message-fetch-field "to") 2254 (message-fetch-field "cc") 2255 (message-fetch-field "bcc"))))))) 2256 2257(defun message-subscribed-p () 2258 "Say whether we need to insert a MFT header." 2259 (or message-subscribed-regexps 2260 message-subscribed-addresses 2261 message-subscribed-address-file 2262 message-subscribed-address-functions)) 2263 2264(defun message-next-header () 2265 "Go to the beginning of the next header." 2266 (beginning-of-line) 2267 (or (eobp) (forward-char 1)) 2268 (not (if (re-search-forward "^[^ \t]" nil t) 2269 (beginning-of-line) 2270 (goto-char (point-max))))) 2271 2272(defun message-sort-headers-1 () 2273 "Sort the buffer as headers using `message-rank' text props." 2274 (goto-char (point-min)) 2275 (require 'sort) 2276 (sort-subr 2277 nil 'message-next-header 2278 (lambda () 2279 (message-next-header) 2280 (unless (bobp) 2281 (forward-char -1))) 2282 (lambda () 2283 (or (get-text-property (point) 'message-rank) 2284 10000)))) 2285 2286(defun message-sort-headers () 2287 "Sort the headers of the current message according to `message-header-format-alist'." 2288 (interactive) 2289 (save-excursion 2290 (save-restriction 2291 (let ((max (1+ (length message-header-format-alist))) 2292 rank) 2293 (message-narrow-to-headers) 2294 (while (re-search-forward "^[^ \n]+:" nil t) 2295 (put-text-property 2296 (match-beginning 0) (1+ (match-beginning 0)) 2297 'message-rank 2298 (if (setq rank (length (memq (assq (intern (buffer-substring 2299 (match-beginning 0) 2300 (1- (match-end 0)))) 2301 message-header-format-alist) 2302 message-header-format-alist))) 2303 (- max rank) 2304 (1+ max))))) 2305 (message-sort-headers-1)))) 2306 2307(defun message-info (&optional arg) 2308 "Display the Message manual. 2309 2310Prefixed with one \\[universal-argument], display the Emacs MIME manual. 2311Prefixed with two \\[universal-argument]'s, display the PGG manual." 2312 (interactive "p") 2313 (cond ((eq arg 16) (Info-goto-node "(pgg)Top")) 2314 ((eq arg 4) (Info-goto-node "(emacs-mime)Top")) 2315 (t (Info-goto-node "(message)Top")))) 2316 2317 2318 2319;;; 2320;;; Message mode 2321;;; 2322 2323;;; Set up keymap. 2324 2325(defvar message-mode-map nil) 2326 2327(unless message-mode-map 2328 (setq message-mode-map (make-keymap)) 2329 (set-keymap-parent message-mode-map text-mode-map) 2330 (define-key message-mode-map "\C-c?" 'describe-mode) 2331 2332 (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) 2333 (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from) 2334 (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc) 2335 (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) 2336 (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) 2337 (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject) 2338 (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) 2339 (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) 2340 (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) 2341 (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) 2342 (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to) 2343 (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords) 2344 (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) 2345 (define-key message-mode-map "\C-c\C-f\C-i" 2346 'message-insert-or-toggle-importance) 2347 (define-key message-mode-map "\C-c\C-f\C-a" 2348 'message-generate-unsubscribed-mail-followup-to) 2349 2350 ;; modify headers (and insert notes in body) 2351 (define-key message-mode-map "\C-c\C-fs" 'message-change-subject) 2352 ;; 2353 (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to) 2354 ;; prefix+message-cross-post-followup-to = same w/o cross-post 2355 (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc) 2356 (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header) 2357 ;; mark inserted text 2358 (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region) 2359 (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file) 2360 2361 (define-key message-mode-map "\C-c\C-b" 'message-goto-body) 2362 (define-key message-mode-map "\C-c\C-i" 'message-goto-signature) 2363 2364 (define-key message-mode-map "\C-c\C-t" 'message-insert-to) 2365 (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply) 2366 (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) 2367 (define-key message-mode-map "\C-c\C-l" 'message-to-list-only) 2368 2369 (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance) 2370 (define-key message-mode-map "\C-c\M-n" 2371 'message-insert-disposition-notification-to) 2372 2373 (define-key message-mode-map "\C-c\C-y" 'message-yank-original) 2374 (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) 2375 (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) 2376 (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) 2377 (define-key message-mode-map "\C-c\M-h" 'message-insert-headers) 2378 (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body) 2379 (define-key message-mode-map "\C-c\C-o" 'message-sort-headers) 2380 (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer) 2381 2382 (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit) 2383 (define-key message-mode-map "\C-c\C-s" 'message-send) 2384 (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) 2385 (define-key message-mode-map "\C-c\C-d" 'message-dont-send) 2386 (define-key message-mode-map "\C-c\n" 'gnus-delay-article) 2387 2388 (define-key message-mode-map "\C-c\C-e" 'message-elide-region) 2389 (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) 2390 (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) 2391 (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) 2392 ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph) 2393 (define-key message-mode-map [remap split-line] 'message-split-line) 2394 2395 (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) 2396 2397 (define-key message-mode-map "\C-a" 'message-beginning-of-line) 2398 (define-key message-mode-map "\t" 'message-tab) 2399 (define-key message-mode-map "\M-;" 'comment-region)) 2400 2401(easy-menu-define 2402 message-mode-menu message-mode-map "Message Menu." 2403 `("Message" 2404 ["Yank Original" message-yank-original message-reply-buffer] 2405 ["Fill Yanked Message" message-fill-yanked-message t] 2406 ["Insert Signature" message-insert-signature t] 2407 ["Caesar (rot13) Message" message-caesar-buffer-body t] 2408 ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)] 2409 ["Elide Region" message-elide-region 2410 :active (message-mark-active-p) 2411 ,@(if (featurep 'xemacs) nil 2412 '(:help "Replace text in region with an ellipsis"))] 2413 ["Delete Outside Region" message-delete-not-region 2414 :active (message-mark-active-p) 2415 ,@(if (featurep 'xemacs) nil 2416 '(:help "Delete all quoted text outside region"))] 2417 ["Kill To Signature" message-kill-to-signature t] 2418 ["Newline and Reformat" message-newline-and-reformat t] 2419 ["Rename buffer" message-rename-buffer t] 2420 ["Spellcheck" ispell-message 2421 ,@(if (featurep 'xemacs) '(t) 2422 '(:help "Spellcheck this message"))] 2423 "----" 2424 ["Insert Region Marked" message-mark-inserted-region 2425 :active (message-mark-active-p) 2426 ,@(if (featurep 'xemacs) nil 2427 '(:help "Mark region with enclosing tags"))] 2428 ["Insert File Marked..." message-mark-insert-file 2429 ,@(if (featurep 'xemacs) '(t) 2430 '(:help "Insert file at point marked with enclosing tags"))] 2431 "----" 2432 ["Send Message" message-send-and-exit 2433 ,@(if (featurep 'xemacs) '(t) 2434 '(:help "Send this message"))] 2435 ["Postpone Message" message-dont-send 2436 ,@(if (featurep 'xemacs) '(t) 2437 '(:help "File this draft message and exit"))] 2438 ["Send at Specific Time..." gnus-delay-article 2439 ,@(if (featurep 'xemacs) '(t) 2440 '(:help "Ask, then arrange to send message at that time"))] 2441 ["Kill Message" message-kill-buffer 2442 ,@(if (featurep 'xemacs) '(t) 2443 '(:help "Delete this message without sending"))] 2444 "----" 2445 ["Message manual" message-info 2446 ,@(if (featurep 'xemacs) '(t) 2447 '(:help "Display the Message manual"))])) 2448 2449(easy-menu-define 2450 message-mode-field-menu message-mode-map "" 2451 `("Field" 2452 ["To" message-goto-to t] 2453 ["From" message-goto-from t] 2454 ["Subject" message-goto-subject t] 2455 ["Change subject..." message-change-subject t] 2456 ["Cc" message-goto-cc t] 2457 ["Bcc" message-goto-bcc t] 2458 ["Fcc" message-goto-fcc t] 2459 ["Reply-To" message-goto-reply-to t] 2460 ["Flag As Important" message-insert-importance-high 2461 ,@(if (featurep 'xemacs) '(t) 2462 '(:help "Mark this message as important"))] 2463 ["Flag As Unimportant" message-insert-importance-low 2464 ,@(if (featurep 'xemacs) '(t) 2465 '(:help "Mark this message as unimportant"))] 2466 ["Request Receipt" 2467 message-insert-disposition-notification-to 2468 ,@(if (featurep 'xemacs) '(t) 2469 '(:help "Request a receipt notification"))] 2470 "----" 2471 ;; (typical) news stuff 2472 ["Summary" message-goto-summary t] 2473 ["Keywords" message-goto-keywords t] 2474 ["Newsgroups" message-goto-newsgroups t] 2475 ["Fetch Newsgroups" message-insert-newsgroups t] 2476 ["Followup-To" message-goto-followup-to t] 2477 ;; ["Followup-To (with note in body)" message-cross-post-followup-to t] 2478 ["Crosspost / Followup-To..." message-cross-post-followup-to t] 2479 ["Distribution" message-goto-distribution t] 2480 ["X-No-Archive:" message-add-archive-header t ] 2481 "----" 2482 ;; (typical) mailing-lists stuff 2483 ["Fetch To" message-insert-to 2484 ,@(if (featurep 'xemacs) '(t) 2485 '(:help "Insert a To header that points to the author."))] 2486 ["Fetch To and Cc" message-insert-wide-reply 2487 ,@(if (featurep 'xemacs) '(t) 2488 '(:help 2489 "Insert To and Cc headers as if you were doing a wide reply."))] 2490 "----" 2491 ["Send to list only" message-to-list-only t] 2492 ["Mail-Followup-To" message-goto-mail-followup-to t] 2493 ["Unsubscribed list post" message-generate-unsubscribed-mail-followup-to 2494 ,@(if (featurep 'xemacs) '(t) 2495 '(:help "Insert a reasonable `Mail-Followup-To:' header."))] 2496 ["Reduce To: to Cc:" message-reduce-to-to-cc t] 2497 "----" 2498 ["Sort Headers" message-sort-headers t] 2499 ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t] 2500 ["Goto Body" message-goto-body t] 2501 ["Goto Signature" message-goto-signature t])) 2502 2503(defvar message-tool-bar-map nil) 2504 2505(eval-when-compile 2506 (defvar facemenu-add-face-function) 2507 (defvar facemenu-remove-face-function)) 2508 2509;;; Forbidden properties 2510;; 2511;; We use `after-change-functions' to keep special text properties 2512;; that interfer with the normal function of message mode out of the 2513;; buffer. 2514 2515(defcustom message-strip-special-text-properties t 2516 "Strip special properties from the message buffer. 2517 2518Emacs has a number of special text properties which can break message 2519composing in various ways. If this option is set, message will strip 2520these properties from the message composition buffer. However, some 2521packages requires these properties to be present in order to work. 2522If you use one of these packages, turn this option off, and hope the 2523message composition doesn't break too bad." 2524 :version "22.1" 2525 :group 'message-various 2526 :link '(custom-manual "(message)Various Message Variables") 2527 :type 'boolean) 2528 2529(defconst message-forbidden-properties 2530 ;; No reason this should be clutter up customize. We make it a 2531 ;; property list (rather than a list of property symbols), to be 2532 ;; directly useful for `remove-text-properties'. 2533 '(field nil read-only nil invisible nil intangible nil 2534 mouse-face nil modification-hooks nil insert-in-front-hooks nil 2535 insert-behind-hooks nil point-entered nil point-left nil) 2536 ;; Other special properties: 2537 ;; category, face, display: probably doesn't do any harm. 2538 ;; fontified: is used by font-lock. 2539 ;; syntax-table, local-map: I dunno. 2540 ;; We need to add XEmacs names to the list. 2541 "Property list of with properties forbidden in message buffers. 2542The values of the properties are ignored, only the property names are used.") 2543 2544(defun message-tamago-not-in-use-p (pos) 2545 "Return t when tamago version 4 is not in use at the cursor position. 2546Tamago version 4 is a popular input method for writing Japanese text. 2547It uses the properties `intangible', `invisible', `modification-hooks' 2548and `read-only' when translating ascii or kana text to kanji text. 2549These properties are essential to work, so we should never strip them." 2550 (not (and (boundp 'egg-modefull-mode) 2551 (symbol-value 'egg-modefull-mode) 2552 (or (memq (get-text-property pos 'intangible) 2553 '(its-part-1 its-part-2)) 2554 (get-text-property pos 'egg-end) 2555 (get-text-property pos 'egg-lang) 2556 (get-text-property pos 'egg-start))))) 2557 2558(defun message-strip-forbidden-properties (begin end &optional old-length) 2559 "Strip forbidden properties between BEGIN and END, ignoring the third arg. 2560This function is intended to be called from `after-change-functions'. 2561See also `message-forbidden-properties'." 2562 (when (and message-strip-special-text-properties 2563 (message-tamago-not-in-use-p begin)) 2564 (let ((buffer-read-only nil) 2565 (inhibit-read-only t)) 2566 (while (not (= begin end)) 2567 (when (not (get-text-property begin 'message-hidden)) 2568 (remove-text-properties begin (1+ begin) 2569 message-forbidden-properties)) 2570 (incf begin))))) 2571 2572;;;###autoload 2573(define-derived-mode message-mode text-mode "Message" 2574 "Major mode for editing mail and news to be sent. 2575Like Text Mode but with these additional commands:\\<message-mode-map> 2576C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit' 2577C-c C-d Postpone sending the message C-c C-k Kill the message 2578C-c C-f move to a header field (and create it if there isn't): 2579 C-c C-f C-t move to To C-c C-f C-s move to Subject 2580 C-c C-f C-c move to Cc C-c C-f C-b move to Bcc 2581 C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To 2582 C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups 2583 C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution 2584 C-c C-f C-o move to From (\"Originator\") 2585 C-c C-f C-f move to Followup-To 2586 C-c C-f C-m move to Mail-Followup-To 2587 C-c C-f C-i cycle through Importance values 2588 C-c C-f s change subject and append \"(was: <Old Subject>)\" 2589 C-c C-f x crossposting with FollowUp-To header and note in body 2590 C-c C-f t replace To: header with contents of Cc: or Bcc: 2591 C-c C-f a Insert X-No-Archive: header and a note in the body 2592C-c C-t `message-insert-to' (add a To header to a news followup) 2593C-c C-l `message-to-list-only' (removes all but list address in to/cc) 2594C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) 2595C-c C-b `message-goto-body' (move to beginning of message text). 2596C-c C-i `message-goto-signature' (move to the beginning of the signature). 2597C-c C-w `message-insert-signature' (insert `message-signature-file' file). 2598C-c C-y `message-yank-original' (insert current message, if any). 2599C-c C-q `message-fill-yanked-message' (fill what was yanked). 2600C-c C-e `message-elide-region' (elide the text between point and mark). 2601C-c C-v `message-delete-not-region' (remove the text outside the region). 2602C-c C-z `message-kill-to-signature' (kill the text up to the signature). 2603C-c C-r `message-caesar-buffer-body' (rot13 the message body). 2604C-c C-a `mml-attach-file' (attach a file as MIME). 2605C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance). 2606C-c M-n `message-insert-disposition-notification-to' (request receipt). 2607C-c M-m `message-mark-inserted-region' (mark region with enclosing tags). 2608C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags). 2609M-RET `message-newline-and-reformat' (break the line and reformat)." 2610 (setq local-abbrev-table text-mode-abbrev-table) 2611 (set (make-local-variable 'message-reply-buffer) nil) 2612 (set (make-local-variable 'message-inserted-headers) nil) 2613 (set (make-local-variable 'message-send-actions) nil) 2614 (set (make-local-variable 'message-exit-actions) nil) 2615 (set (make-local-variable 'message-kill-actions) nil) 2616 (set (make-local-variable 'message-postpone-actions) nil) 2617 (set (make-local-variable 'message-draft-article) nil) 2618 (setq buffer-offer-save t) 2619 (set (make-local-variable 'facemenu-add-face-function) 2620 (lambda (face end) 2621 (let ((face-fun (cdr (assq face message-face-alist)))) 2622 (if face-fun 2623 (funcall face-fun (point) end) 2624 (error "Face %s not configured for %s mode" face mode-name))) 2625 "")) 2626 (set (make-local-variable 'facemenu-remove-face-function) t) 2627 (set (make-local-variable 'message-reply-headers) nil) 2628 (make-local-variable 'message-newsreader) 2629 (make-local-variable 'message-mailer) 2630 (make-local-variable 'message-post-method) 2631 (set (make-local-variable 'message-sent-message-via) nil) 2632 (set (make-local-variable 'message-checksum) nil) 2633 (set (make-local-variable 'message-mime-part) 0) 2634 (message-setup-fill-variables) 2635 ;; Allow using comment commands to add/remove quoting. 2636 ;; (set (make-local-variable 'comment-start) message-yank-prefix) 2637 (when message-yank-prefix 2638 (set (make-local-variable 'comment-start) message-yank-prefix) 2639 (set (make-local-variable 'comment-start-skip) 2640 (concat "^" (regexp-quote message-yank-prefix) "[ \t]*"))) 2641 (if (featurep 'xemacs) 2642 (message-setup-toolbar) 2643 (set (make-local-variable 'font-lock-defaults) 2644 '(message-font-lock-keywords t)) 2645 (if (boundp 'tool-bar-map) 2646 (set (make-local-variable 'tool-bar-map) (message-make-tool-bar)))) 2647 (easy-menu-add message-mode-menu message-mode-map) 2648 (easy-menu-add message-mode-field-menu message-mode-map) 2649 (gnus-make-local-hook 'after-change-functions) 2650 ;; Mmmm... Forbidden properties... 2651 (add-hook 'after-change-functions 'message-strip-forbidden-properties 2652 nil 'local) 2653 ;; Allow mail alias things. 2654 (when (eq message-mail-alias-type 'abbrev) 2655 (if (fboundp 'mail-abbrevs-setup) 2656 (mail-abbrevs-setup) 2657 (if (fboundp 'mail-aliases-setup) ; warning avoidance 2658 (mail-aliases-setup)))) 2659 (unless buffer-file-name 2660 (message-set-auto-save-file-name)) 2661 (unless (buffer-base-buffer) 2662 ;; Don't enable multibyte on an indirect buffer. Maybe enabling 2663 ;; multibyte is not necessary at all. -- zsh 2664 (mm-enable-multibyte)) 2665 (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation. 2666 (mml-mode)) 2667 2668(defun message-setup-fill-variables () 2669 "Setup message fill variables." 2670 (set (make-local-variable 'fill-paragraph-function) 2671 'message-fill-paragraph) 2672 (make-local-variable 'paragraph-separate) 2673 (make-local-variable 'paragraph-start) 2674 (make-local-variable 'adaptive-fill-regexp) 2675 (unless (boundp 'adaptive-fill-first-line-regexp) 2676 (setq adaptive-fill-first-line-regexp nil)) 2677 (make-local-variable 'adaptive-fill-first-line-regexp) 2678 (let ((quote-prefix-regexp 2679 ;; User should change message-cite-prefix-regexp if 2680 ;; message-yank-prefix is set to an abnormal value. 2681 (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*"))) 2682 (setq paragraph-start 2683 (concat 2684 (regexp-quote mail-header-separator) "$\\|" 2685 "[ \t]*$\\|" ; blank lines 2686 "-- $\\|" ; signature delimiter 2687 "---+$\\|" ; delimiters for forwarded messages 2688 page-delimiter "$\\|" ; spoiler warnings 2689 ".*wrote:$\\|" ; attribution lines 2690 quote-prefix-regexp "$\\|" ; empty lines in quoted text 2691 ; mml tags 2692 "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)")) 2693 (setq paragraph-separate paragraph-start) 2694 (setq adaptive-fill-regexp 2695 (concat quote-prefix-regexp "\\|" adaptive-fill-regexp)) 2696 (setq adaptive-fill-first-line-regexp 2697 (concat quote-prefix-regexp "\\|" 2698 adaptive-fill-first-line-regexp))) 2699 (make-local-variable 'auto-fill-inhibit-regexp) 2700 ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:") 2701 (setq auto-fill-inhibit-regexp nil) 2702 (make-local-variable 'normal-auto-fill-function) 2703 (setq normal-auto-fill-function 'message-do-auto-fill) 2704 ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'. 2705 ;; In that case, ensure that it uses the right function. The real 2706 ;; solution would be not to use `define-derived-mode', and run 2707 ;; `text-mode-hook' ourself at the end of the mode. 2708 ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19. 2709 (when auto-fill-function 2710 (setq auto-fill-function normal-auto-fill-function))) 2711 2712 2713 2714;;; 2715;;; Message mode commands 2716;;; 2717 2718;;; Movement commands 2719 2720(defun message-goto-to () 2721 "Move point to the To header." 2722 (interactive) 2723 (message-position-on-field "To")) 2724 2725(defun message-goto-from () 2726 "Move point to the From header." 2727 (interactive) 2728 (message-position-on-field "From")) 2729 2730(defun message-goto-subject () 2731 "Move point to the Subject header." 2732 (interactive) 2733 (message-position-on-field "Subject")) 2734 2735(defun message-goto-cc () 2736 "Move point to the Cc header." 2737 (interactive) 2738 (message-position-on-field "Cc" "To")) 2739 2740(defun message-goto-bcc () 2741 "Move point to the Bcc header." 2742 (interactive) 2743 (message-position-on-field "Bcc" "Cc" "To")) 2744 2745(defun message-goto-fcc () 2746 "Move point to the Fcc header." 2747 (interactive) 2748 (message-position-on-field "Fcc" "To" "Newsgroups")) 2749 2750(defun message-goto-reply-to () 2751 "Move point to the Reply-To header." 2752 (interactive) 2753 (message-position-on-field "Reply-To" "Subject")) 2754 2755(defun message-goto-newsgroups () 2756 "Move point to the Newsgroups header." 2757 (interactive) 2758 (message-position-on-field "Newsgroups")) 2759 2760(defun message-goto-distribution () 2761 "Move point to the Distribution header." 2762 (interactive) 2763 (message-position-on-field "Distribution")) 2764 2765(defun message-goto-followup-to () 2766 "Move point to the Followup-To header." 2767 (interactive) 2768 (message-position-on-field "Followup-To" "Newsgroups")) 2769 2770(defun message-goto-mail-followup-to () 2771 "Move point to the Mail-Followup-To header." 2772 (interactive) 2773 (message-position-on-field "Mail-Followup-To" "To")) 2774 2775(defun message-goto-keywords () 2776 "Move point to the Keywords header." 2777 (interactive) 2778 (message-position-on-field "Keywords" "Subject")) 2779 2780(defun message-goto-summary () 2781 "Move point to the Summary header." 2782 (interactive) 2783 (message-position-on-field "Summary" "Subject")) 2784 2785(defun message-goto-body (&optional interactivep) 2786 "Move point to the beginning of the message body." 2787 (interactive (list t)) 2788 (when (and interactivep 2789 (looking-at "[ \t]*\n")) 2790 (expand-abbrev)) 2791 (goto-char (point-min)) 2792 (or (search-forward (concat "\n" mail-header-separator "\n") nil t) 2793 (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) 2794 2795(defun message-in-body-p () 2796 "Return t if point is in the message body." 2797 (let ((body (save-excursion (message-goto-body) (point)))) 2798 (>= (point) body))) 2799 2800(defun message-goto-eoh () 2801 "Move point to the end of the headers." 2802 (interactive) 2803 (message-goto-body) 2804 (forward-line -1)) 2805 2806(defun message-goto-signature () 2807 "Move point to the beginning of the message signature. 2808If there is no signature in the article, go to the end and 2809return nil." 2810 (interactive) 2811 (goto-char (point-min)) 2812 (if (re-search-forward message-signature-separator nil t) 2813 (forward-line 1) 2814 (goto-char (point-max)) 2815 nil)) 2816 2817(defun message-generate-unsubscribed-mail-followup-to (&optional include-cc) 2818 "Insert a reasonable MFT header in a post to an unsubscribed list. 2819When making original posts to a mailing list you are not subscribed to, 2820you have to type in a MFT header by hand. The contents, usually, are 2821the addresses of the list and your own address. This function inserts 2822such a header automatically. It fetches the contents of the To: header 2823in the current mail buffer, and appends the current `user-mail-address'. 2824 2825If the optional argument INCLUDE-CC is non-nil, the addresses in the 2826Cc: header are also put into the MFT." 2827 2828 (interactive "P") 2829 (let* (cc tos) 2830 (save-restriction 2831 (message-narrow-to-headers) 2832 (message-remove-header "Mail-Followup-To") 2833 (setq cc (and include-cc (message-fetch-field "Cc"))) 2834 (setq tos (if cc 2835 (concat (message-fetch-field "To") "," cc) 2836 (message-fetch-field "To")))) 2837 (message-goto-mail-followup-to) 2838 (insert (concat tos ", " user-mail-address)))) 2839 2840 2841 2842(defun message-insert-to (&optional force) 2843 "Insert a To header that points to the author of the article being replied to. 2844If the original author requested not to be sent mail, don't insert unless the 2845prefix FORCE is given." 2846 (interactive "P") 2847 (let* ((mct (message-fetch-reply-field "mail-copies-to")) 2848 (dont (and mct (or (equal (downcase mct) "never") 2849 (equal (downcase mct) "nobody")))) 2850 (to (or (message-fetch-reply-field "mail-reply-to") 2851 (message-fetch-reply-field "reply-to") 2852 (message-fetch-reply-field "from")))) 2853 (when (and dont to) 2854 (message 2855 (if force 2856 "Ignoring the user request not to have copies sent via mail" 2857 "Complying with the user request not to have copies sent via mail"))) 2858 (when (and force (not to)) 2859 (error "No mail address in the article")) 2860 (when (and to (or force (not dont))) 2861 (message-carefully-insert-headers (list (cons 'To to)))))) 2862 2863(defun message-insert-wide-reply () 2864 "Insert To and Cc headers as if you were doing a wide reply." 2865 (interactive) 2866 (let ((headers (message-with-reply-buffer 2867 (message-get-reply-headers t)))) 2868 (message-carefully-insert-headers headers))) 2869 2870(defcustom message-header-synonyms 2871 '((To Cc Bcc) 2872 (Original-To)) 2873 "List of lists of header synonyms. 2874E.g., if this list contains a member list with elements `Cc' and `To', 2875then `message-carefully-insert-headers' will not insert a `To' header 2876when the message is already `Cc'ed to the recipient." 2877 :version "22.1" 2878 :group 'message-headers 2879 :link '(custom-manual "(message)Message Headers") 2880 :type '(repeat sexp)) 2881 2882(defun message-carefully-insert-headers (headers) 2883 "Insert the HEADERS, an alist, into the message buffer. 2884Does not insert the headers when they are already present there 2885or in the synonym headers, defined by `message-header-synonyms'." 2886 ;; FIXME: Should compare only the address and not the full name. Comparison 2887 ;; should be done case-folded (and with `string=' rather than 2888 ;; `string-match'). 2889 ;; (mail-strip-quoted-names "Foo Bar <foo@bar>, bla@fasel (Bla Fasel)") 2890 (dolist (header headers) 2891 (let* ((header-name (symbol-name (car header))) 2892 (new-header (cdr header)) 2893 (synonyms (loop for synonym in message-header-synonyms 2894 when (memq (car header) synonym) return synonym)) 2895 (old-header 2896 (loop for synonym in synonyms 2897 for old-header = (mail-fetch-field (symbol-name synonym)) 2898 when (and old-header (string-match new-header old-header)) 2899 return synonym))) 2900 (if old-header 2901 (message "already have `%s' in `%s'" new-header old-header) 2902 (when (and (message-position-on-field header-name) 2903 (setq old-header (mail-fetch-field header-name)) 2904 (not (string-match "\\` *\\'" old-header))) 2905 (insert ", ")) 2906 (insert new-header))))) 2907 2908(defun message-widen-reply () 2909 "Widen the reply to include maximum recipients." 2910 (interactive) 2911 (let ((follow-to 2912 (and message-reply-buffer 2913 (buffer-name message-reply-buffer) 2914 (save-excursion 2915 (set-buffer message-reply-buffer) 2916 (message-get-reply-headers t))))) 2917 (save-excursion 2918 (save-restriction 2919 (message-narrow-to-headers) 2920 (dolist (elem follow-to) 2921 (message-remove-header (symbol-name (car elem))) 2922 (goto-char (point-min)) 2923 (insert (symbol-name (car elem)) ": " 2924 (cdr elem) "\n")))))) 2925 2926(defun message-insert-newsgroups () 2927 "Insert the Newsgroups header from the article being replied to." 2928 (interactive) 2929 (when (and (message-position-on-field "Newsgroups") 2930 (mail-fetch-field "newsgroups") 2931 (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups")))) 2932 (insert ",")) 2933 (insert (or (message-fetch-reply-field "newsgroups") ""))) 2934 2935 2936 2937;;; Various commands 2938 2939(defun message-delete-not-region (beg end) 2940 "Delete everything in the body of the current message outside of the region." 2941 (interactive "r") 2942 (let (citeprefix) 2943 (save-excursion 2944 (goto-char beg) 2945 ;; snarf citation prefix, if appropriate 2946 (unless (eq (point) (progn (beginning-of-line) (point))) 2947 (when (looking-at message-cite-prefix-regexp) 2948 (setq citeprefix (match-string 0)))) 2949 (goto-char end) 2950 (delete-region (point) (if (not (message-goto-signature)) 2951 (point) 2952 (forward-line -2) 2953 (point))) 2954 (insert "\n") 2955 (goto-char beg) 2956 (delete-region beg (progn (message-goto-body) 2957 (forward-line 2) 2958 (point))) 2959 (when citeprefix 2960 (insert citeprefix)))) 2961 (when (message-goto-signature) 2962 (forward-line -2))) 2963 2964(defun message-kill-to-signature () 2965 "Deletes all text up to the signature." 2966 (interactive) 2967 (let ((point (point))) 2968 (message-goto-signature) 2969 (unless (eobp) 2970 (end-of-line -1)) 2971 (kill-region point (point)) 2972 (unless (bolp) 2973 (insert "\n")))) 2974 2975(defun message-newline-and-reformat (&optional arg not-break) 2976 "Insert four newlines, and then reformat if inside quoted text. 2977Prefix arg means justify as well." 2978 (interactive (list (if current-prefix-arg 'full))) 2979 (let (quoted point beg end leading-space bolp) 2980 (setq point (point)) 2981 (beginning-of-line) 2982 (setq beg (point)) 2983 (setq bolp (= beg point)) 2984 ;; Find first line of the paragraph. 2985 (if not-break 2986 (while (and (not (eobp)) 2987 (not (looking-at message-cite-prefix-regexp)) 2988 (looking-at paragraph-start)) 2989 (forward-line 1))) 2990 ;; Find the prefix 2991 (when (looking-at message-cite-prefix-regexp) 2992 (setq quoted (match-string 0)) 2993 (goto-char (match-end 0)) 2994 (looking-at "[ \t]*") 2995 (setq leading-space (match-string 0))) 2996 (if (and quoted 2997 (not not-break) 2998 (not bolp) 2999 (< (- point beg) (length quoted))) 3000 ;; break inside the cite prefix. 3001 (setq quoted nil 3002 end nil)) 3003 (if quoted 3004 (progn 3005 (forward-line 1) 3006 (while (and (not (eobp)) 3007 (not (looking-at paragraph-separate)) 3008 (looking-at message-cite-prefix-regexp) 3009 (equal quoted (match-string 0))) 3010 (goto-char (match-end 0)) 3011 (looking-at "[ \t]*") 3012 (if (> (length leading-space) (length (match-string 0))) 3013 (setq leading-space (match-string 0))) 3014 (forward-line 1)) 3015 (setq end (point)) 3016 (goto-char beg) 3017 (while (and (if (bobp) nil (forward-line -1) t) 3018 (not (looking-at paragraph-start)) 3019 (looking-at message-cite-prefix-regexp) 3020 (equal quoted (match-string 0))) 3021 (setq beg (point)) 3022 (goto-char (match-end 0)) 3023 (looking-at "[ \t]*") 3024 (if (> (length leading-space) (length (match-string 0))) 3025 (setq leading-space (match-string 0))))) 3026 (while (and (not (eobp)) 3027 (not (looking-at paragraph-separate)) 3028 (not (looking-at message-cite-prefix-regexp))) 3029 (forward-line 1)) 3030 (setq end (point)) 3031 (goto-char beg) 3032 (while (and (if (bobp) nil (forward-line -1) t) 3033 (not (looking-at paragraph-start)) 3034 (not (looking-at message-cite-prefix-regexp))) 3035 (setq beg (point)))) 3036 (goto-char point) 3037 (save-restriction 3038 (narrow-to-region beg end) 3039 (if not-break 3040 (setq point nil) 3041 (if bolp 3042 (newline) 3043 (newline) 3044 (newline)) 3045 (setq point (point)) 3046 ;; (newline 2) doesn't mark both newline's as hard, so call 3047 ;; newline twice. -jas 3048 (newline) 3049 (newline) 3050 (delete-region (point) (re-search-forward "[ \t]*")) 3051 (when (and quoted (not bolp)) 3052 (insert quoted leading-space))) 3053 (undo-boundary) 3054 (if quoted 3055 (let* ((adaptive-fill-regexp 3056 (regexp-quote (concat quoted leading-space))) 3057 (adaptive-fill-first-line-regexp 3058 adaptive-fill-regexp )) 3059 (fill-paragraph arg)) 3060 (fill-paragraph arg)) 3061 (if point (goto-char point))))) 3062 3063(defun message-fill-paragraph (&optional arg) 3064 "Like `fill-paragraph'." 3065 (interactive (list (if current-prefix-arg 'full))) 3066 (if (if (boundp 'filladapt-mode) filladapt-mode) 3067 nil 3068 (message-newline-and-reformat arg t) 3069 t)) 3070 3071;; Is it better to use `mail-header-end'? 3072(defun message-point-in-header-p () 3073 "Return t if point is in the header." 3074 (save-excursion 3075 (let ((p (point))) 3076 (goto-char (point-min)) 3077 (not (re-search-forward 3078 (concat "^" (regexp-quote mail-header-separator) "\n") 3079 p t))))) 3080 3081(defun message-do-auto-fill () 3082 "Like `do-auto-fill', but don't fill in message header." 3083 (unless (message-point-in-header-p) 3084 (do-auto-fill))) 3085 3086(defun message-insert-signature (&optional force) 3087 "Insert a signature. See documentation for variable `message-signature'." 3088 (interactive (list 0)) 3089 (let* ((signature 3090 (cond 3091 ((and (null message-signature) 3092 (eq force 0)) 3093 (save-excursion 3094 (goto-char (point-max)) 3095 (not (re-search-backward message-signature-separator nil t)))) 3096 ((and (null message-signature) 3097 force) 3098 t) 3099 ((functionp message-signature) 3100 (funcall message-signature)) 3101 ((listp message-signature) 3102 (eval message-signature)) 3103 (t message-signature))) 3104 (signature 3105 (cond ((stringp signature) 3106 signature) 3107 ((and (eq t signature) 3108 message-signature-file 3109 (file-exists-p message-signature-file)) 3110 signature)))) 3111 (when signature 3112 (goto-char (point-max)) 3113 ;; Insert the signature. 3114 (unless (bolp) 3115 (insert "\n")) 3116 (when message-signature-insert-empty-line 3117 (insert "\n")) 3118 (insert "-- \n") 3119 (if (eq signature t) 3120 (insert-file-contents message-signature-file) 3121 (insert signature)) 3122 (goto-char (point-max)) 3123 (or (bolp) (insert "\n"))))) 3124 3125(defun message-insert-importance-high () 3126 "Insert header to mark message as important." 3127 (interactive) 3128 (save-excursion 3129 (save-restriction 3130 (message-narrow-to-headers) 3131 (message-remove-header "Importance")) 3132 (message-goto-eoh) 3133 (insert "Importance: high\n"))) 3134 3135(defun message-insert-importance-low () 3136 "Insert header to mark message as unimportant." 3137 (interactive) 3138 (save-excursion 3139 (save-restriction 3140 (message-narrow-to-headers) 3141 (message-remove-header "Importance")) 3142 (message-goto-eoh) 3143 (insert "Importance: low\n"))) 3144 3145(defun message-insert-or-toggle-importance () 3146 "Insert a \"Importance: high\" header, or cycle through the header values. 3147The three allowed values according to RFC 1327 are `high', `normal' 3148and `low'." 3149 (interactive) 3150 (save-excursion 3151 (let ((valid '("high" "normal" "low")) 3152 (new "high") 3153 cur) 3154 (save-restriction 3155 (message-narrow-to-headers) 3156 (when (setq cur (message-fetch-field "Importance")) 3157 (message-remove-header "Importance") 3158 (setq new (cond ((string= cur "high") 3159 "low") 3160 ((string= cur "low") 3161 "normal") 3162 (t 3163 "high"))))) 3164 (message-goto-eoh) 3165 (insert (format "Importance: %s\n" new))))) 3166 3167(defun message-insert-disposition-notification-to () 3168 "Request a disposition notification (return receipt) to this message. 3169Note that this should not be used in newsgroups." 3170 (interactive) 3171 (save-excursion 3172 (save-restriction 3173 (message-narrow-to-headers) 3174 (message-remove-header "Disposition-Notification-To")) 3175 (message-goto-eoh) 3176 (insert (format "Disposition-Notification-To: %s\n" 3177 (or (message-field-value "Reply-to") 3178 (message-field-value "From") 3179 (message-make-from)))))) 3180 3181(defun message-elide-region (b e) 3182 "Elide the text in the region. 3183An ellipsis (from `message-elide-ellipsis') will be inserted where the 3184text was killed." 3185 (interactive "r") 3186 (kill-region b e) 3187 (insert message-elide-ellipsis)) 3188 3189(defvar message-caesar-translation-table nil) 3190 3191(defun message-caesar-region (b e &optional n) 3192 "Caesar rotate region B to E by N, default 13, for decrypting netnews." 3193 (interactive 3194 (list 3195 (min (point) (or (mark t) (point))) 3196 (max (point) (or (mark t) (point))) 3197 (when current-prefix-arg 3198 (prefix-numeric-value current-prefix-arg)))) 3199 3200 (setq n (if (numberp n) (mod n 26) 13)) ;canonize N 3201 (unless (or (zerop n) ; no action needed for a rot of 0 3202 (= b e)) ; no region to rotate 3203 ;; We build the table, if necessary. 3204 (when (or (not message-caesar-translation-table) 3205 (/= (aref message-caesar-translation-table ?a) (+ ?a n))) 3206 (setq message-caesar-translation-table 3207 (message-make-caesar-translation-table n))) 3208 (translate-region b e message-caesar-translation-table))) 3209 3210(defun message-make-caesar-translation-table (n) 3211 "Create a rot table with offset N." 3212 (let ((i -1) 3213 (table (make-string 256 0))) 3214 (while (< (incf i) 256) 3215 (aset table i i)) 3216 (concat 3217 (substring table 0 ?A) 3218 (substring table (+ ?A n) (+ ?A n (- 26 n))) 3219 (substring table ?A (+ ?A n)) 3220 (substring table (+ ?A 26) ?a) 3221 (substring table (+ ?a n) (+ ?a n (- 26 n))) 3222 (substring table ?a (+ ?a n)) 3223 (substring table (+ ?a 26) 255)))) 3224 3225(defun message-caesar-buffer-body (&optional rotnum) 3226 "Caesar rotate all letters in the current buffer by 13 places. 3227Used to encode/decode possibly offensive messages (commonly in rec.humor). 3228With prefix arg, specifies the number of places to rotate each letter forward. 3229Mail and USENET news headers are not rotated." 3230 (interactive (if current-prefix-arg 3231 (list (prefix-numeric-value current-prefix-arg)) 3232 (list nil))) 3233 (save-excursion 3234 (save-restriction 3235 (when (message-goto-body) 3236 (narrow-to-region (point) (point-max))) 3237 (message-caesar-region (point-min) (point-max) rotnum)))) 3238 3239(defun message-pipe-buffer-body (program) 3240 "Pipe the message body in the current buffer through PROGRAM." 3241 (save-excursion 3242 (save-restriction 3243 (when (message-goto-body) 3244 (narrow-to-region (point) (point-max))) 3245 (shell-command-on-region 3246 (point-min) (point-max) program nil t)))) 3247 3248(defun message-rename-buffer (&optional enter-string) 3249 "Rename the *message* buffer to \"*message* RECIPIENT\". 3250If the function is run with a prefix, it will ask for a new buffer 3251name, rather than giving an automatic name." 3252 (interactive "Pbuffer name: ") 3253 (save-excursion 3254 (save-restriction 3255 (goto-char (point-min)) 3256 (narrow-to-region (point) 3257 (search-forward mail-header-separator nil 'end)) 3258 (let* ((mail-to (or 3259 (if (message-news-p) (message-fetch-field "Newsgroups") 3260 (message-fetch-field "To")) 3261 "")) 3262 (mail-trimmed-to 3263 (if (string-match "," mail-to) 3264 (concat (substring mail-to 0 (match-beginning 0)) ", ...") 3265 mail-to)) 3266 (name-default (concat "*message* " mail-trimmed-to)) 3267 (name (if enter-string 3268 (read-string "New buffer name: " name-default) 3269 name-default))) 3270 (rename-buffer name t))))) 3271 3272(defun message-fill-yanked-message (&optional justifyp) 3273 "Fill the paragraphs of a message yanked into this one. 3274Numeric argument means justify as well." 3275 (interactive "P") 3276 (save-excursion 3277 (goto-char (point-min)) 3278 (search-forward (concat "\n" mail-header-separator "\n") nil t) 3279 (let ((fill-prefix message-yank-prefix)) 3280 (fill-individual-paragraphs (point) (point-max) justifyp)))) 3281 3282(defun message-indent-citation () 3283 "Modify text just inserted from a message to be cited. 3284The inserted text should be the region. 3285When this function returns, the region is again around the modified text. 3286 3287Normally, indent each nonblank line `message-indentation-spaces' spaces. 3288However, if `message-yank-prefix' is non-nil, insert that prefix on each line." 3289 (let ((start (point))) 3290 ;; Remove unwanted headers. 3291 (when message-ignored-cited-headers 3292 (let (all-removed) 3293 (save-restriction 3294 (narrow-to-region 3295 (goto-char start) 3296 (if (search-forward "\n\n" nil t) 3297 (1- (point)) 3298 (point))) 3299 (message-remove-header message-ignored-cited-headers t) 3300 (when (= (point-min) (point-max)) 3301 (setq all-removed t)) 3302 (goto-char (point-max))) 3303 (if all-removed 3304 (goto-char start) 3305 (forward-line 1)))) 3306 ;; Delete blank lines at the start of the buffer. 3307 (while (and (point-min) 3308 (eolp) 3309 (not (eobp))) 3310 (message-delete-line)) 3311 ;; Delete blank lines at the end of the buffer. 3312 (goto-char (point-max)) 3313 (unless (eolp) 3314 (insert "\n")) 3315 (while (and (zerop (forward-line -1)) 3316 (looking-at "$")) 3317 (message-delete-line)) 3318 ;; Do the indentation. 3319 (if (null message-yank-prefix) 3320 (indent-rigidly start (mark t) message-indentation-spaces) 3321 (save-excursion 3322 (goto-char start) 3323 (while (< (point) (mark t)) 3324 (if (or (looking-at ">") (looking-at "^$")) 3325 (insert message-yank-cited-prefix) 3326 (insert message-yank-prefix)) 3327 (forward-line 1)))) 3328 (goto-char start))) 3329 3330(defun message-yank-original (&optional arg) 3331 "Insert the message being replied to, if any. 3332Puts point before the text and mark after. 3333Normally indents each nonblank line ARG spaces (default 3). However, 3334if `message-yank-prefix' is non-nil, insert that prefix on each line. 3335 3336This function uses `message-cite-function' to do the actual citing. 3337 3338Just \\[universal-argument] as argument means don't indent, insert no 3339prefix, and don't delete any headers." 3340 (interactive "P") 3341 (let ((modified (buffer-modified-p))) 3342 (when (and message-reply-buffer 3343 message-cite-function) 3344 (delete-windows-on message-reply-buffer t) 3345 (push-mark (save-excursion 3346 (insert-buffer-substring message-reply-buffer) 3347 (unless (bolp) 3348 (insert ?\n)) 3349 (point))) 3350 (unless arg 3351 (funcall message-cite-function) 3352 (unless (eq (char-before (mark t)) ?\n) 3353 (let ((pt (point))) 3354 (goto-char (mark t)) 3355 (insert-before-markers ?\n) 3356 (goto-char pt)))) 3357 (unless modified 3358 (setq message-checksum (message-checksum)))))) 3359 3360(defun message-yank-buffer (buffer) 3361 "Insert BUFFER into the current buffer and quote it." 3362 (interactive "bYank buffer: ") 3363 (let ((message-reply-buffer (get-buffer buffer))) 3364 (save-window-excursion 3365 (message-yank-original)))) 3366 3367(defun message-buffers () 3368 "Return a list of active message buffers." 3369 (let (buffers) 3370 (save-excursion 3371 (dolist (buffer (buffer-list t)) 3372 (set-buffer buffer) 3373 (when (and (eq major-mode 'message-mode) 3374 (null message-sent-message-via)) 3375 (push (buffer-name buffer) buffers)))) 3376 (nreverse buffers))) 3377 3378(defun message-cite-original-without-signature () 3379 "Cite function in the standard Message manner." 3380 (let* ((start (point)) 3381 (end (mark t)) 3382 (functions 3383 (when message-indent-citation-function 3384 (if (listp message-indent-citation-function) 3385 message-indent-citation-function 3386 (list message-indent-citation-function)))) 3387 ;; This function may be called by `gnus-summary-yank-message' and 3388 ;; may insert a different article from the original. So, we will 3389 ;; modify the value of `message-reply-headers' with that article. 3390 (message-reply-headers 3391 (save-restriction 3392 (narrow-to-region start end) 3393 (message-narrow-to-head-1) 3394 (vector 0 3395 (or (message-fetch-field "subject") "none") 3396 (or (message-fetch-field "from") "nobody") 3397 (message-fetch-field "date") 3398 (message-fetch-field "message-id" t) 3399 (message-fetch-field "references") 3400 0 0 "")))) 3401 (mml-quote-region start end) 3402 ;; Allow undoing. 3403 (undo-boundary) 3404 (goto-char end) 3405 (when (re-search-backward message-signature-separator start t) 3406 ;; Also peel off any blank lines before the signature. 3407 (forward-line -1) 3408 (while (looking-at "^[ \t]*$") 3409 (forward-line -1)) 3410 (forward-line 1) 3411 (delete-region (point) end) 3412 (unless (search-backward "\n\n" start t) 3413 ;; Insert a blank line if it is peeled off. 3414 (insert "\n"))) 3415 (goto-char start) 3416 (while functions 3417 (funcall (pop functions))) 3418 (when message-citation-line-function 3419 (unless (bolp) 3420 (insert "\n")) 3421 (funcall message-citation-line-function)))) 3422 3423(eval-when-compile (defvar mail-citation-hook)) ;Compiler directive 3424(defun message-cite-original () 3425 "Cite function in the standard Message manner." 3426 (if (and (boundp 'mail-citation-hook) 3427 mail-citation-hook) 3428 (run-hooks 'mail-citation-hook) 3429 (let* ((start (point)) 3430 (end (mark t)) 3431 (functions 3432 (when message-indent-citation-function 3433 (if (listp message-indent-citation-function) 3434 message-indent-citation-function 3435 (list message-indent-citation-function)))) 3436 ;; This function may be called by `gnus-summary-yank-message' and 3437 ;; may insert a different article from the original. So, we will 3438 ;; modify the value of `message-reply-headers' with that article. 3439 (message-reply-headers 3440 (save-restriction 3441 (narrow-to-region start end) 3442 (message-narrow-to-head-1) 3443 (vector 0 3444 (or (message-fetch-field "subject") "none") 3445 (or (message-fetch-field "from") "nobody") 3446 (message-fetch-field "date") 3447 (message-fetch-field "message-id" t) 3448 (message-fetch-field "references") 3449 0 0 "")))) 3450 (mml-quote-region start end) 3451 (goto-char start) 3452 (while functions 3453 (funcall (pop functions))) 3454 (when message-citation-line-function 3455 (unless (bolp) 3456 (insert "\n")) 3457 (funcall message-citation-line-function))))) 3458 3459(defun message-insert-citation-line () 3460 "Insert a simple citation line." 3461 (when message-reply-headers 3462 (insert (mail-header-from message-reply-headers) " writes:") 3463 (newline) 3464 (newline))) 3465 3466(defun message-position-on-field (header &rest afters) 3467 (let ((case-fold-search t)) 3468 (save-restriction 3469 (narrow-to-region 3470 (goto-char (point-min)) 3471 (progn 3472 (re-search-forward 3473 (concat "^" (regexp-quote mail-header-separator) "$")) 3474 (match-beginning 0))) 3475 (goto-char (point-min)) 3476 (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t) 3477 (progn 3478 (re-search-forward "^[^ \t]" nil 'move) 3479 (beginning-of-line) 3480 (skip-chars-backward "\n") 3481 t) 3482 (while (and afters 3483 (not (re-search-forward 3484 (concat "^" (regexp-quote (car afters)) ":") 3485 nil t))) 3486 (pop afters)) 3487 (when afters 3488 (re-search-forward "^[^ \t]" nil 'move) 3489 (beginning-of-line)) 3490 (insert header ": \n") 3491 (forward-char -1) 3492 nil)))) 3493 3494(defun message-remove-signature () 3495 "Remove the signature from the text between point and mark. 3496The text will also be indented the normal way." 3497 (save-excursion 3498 (let ((start (point)) 3499 mark) 3500 (if (not (re-search-forward message-signature-separator (mark t) t)) 3501 ;; No signature here, so we just indent the cited text. 3502 (message-indent-citation) 3503 ;; Find the last non-empty line. 3504 (forward-line -1) 3505 (while (looking-at "[ \t]*$") 3506 (forward-line -1)) 3507 (forward-line 1) 3508 (setq mark (set-marker (make-marker) (point))) 3509 (goto-char start) 3510 (message-indent-citation) 3511 ;; Enable undoing the deletion. 3512 (undo-boundary) 3513 (delete-region mark (mark t)) 3514 (set-marker mark nil))))) 3515 3516 3517 3518;;; 3519;;; Sending messages 3520;;; 3521 3522(defun message-send-and-exit (&optional arg) 3523 "Send message like `message-send', then, if no errors, exit from mail buffer." 3524 (interactive "P") 3525 (let ((buf (current-buffer)) 3526 (actions message-exit-actions)) 3527 (when (and (message-send arg) 3528 (buffer-name buf)) 3529 (if message-kill-buffer-on-exit 3530 (kill-buffer buf) 3531 (bury-buffer buf) 3532 (when (eq buf (current-buffer)) 3533 (message-bury buf))) 3534 (message-do-actions actions) 3535 t))) 3536 3537(defun message-dont-send () 3538 "Don't send the message you have been editing. 3539Instead, just auto-save the buffer and then bury it." 3540 (interactive) 3541 (set-buffer-modified-p t) 3542 (save-buffer) 3543 (let ((actions message-postpone-actions)) 3544 (message-bury (current-buffer)) 3545 (message-do-actions actions))) 3546 3547(defun message-kill-buffer () 3548 "Kill the current buffer." 3549 (interactive) 3550 (when (or (not (buffer-modified-p)) 3551 (yes-or-no-p "Message modified; kill anyway? ")) 3552 (let ((actions message-kill-actions) 3553 (draft-article message-draft-article) 3554 (auto-save-file-name buffer-auto-save-file-name) 3555 (file-name buffer-file-name) 3556 (modified (buffer-modified-p))) 3557 (setq buffer-file-name nil) 3558 (kill-buffer (current-buffer)) 3559 (when (and (or (and auto-save-file-name 3560 (file-exists-p auto-save-file-name)) 3561 (and file-name 3562 (file-exists-p file-name))) 3563 (progn 3564 ;; If the message buffer has lived in a dedicated window, 3565 ;; `kill-buffer' has killed the frame. Thus the 3566 ;; `yes-or-no-p' may show up in a lowered frame. Make sure 3567 ;; that the user can see the question by raising the 3568 ;; current frame: 3569 (raise-frame) 3570 (yes-or-no-p (format "Remove the backup file%s? " 3571 (if modified " too" ""))))) 3572 (ignore-errors 3573 (delete-file auto-save-file-name)) 3574 (let ((message-draft-article draft-article)) 3575 (message-disassociate-draft))) 3576 (message-do-actions actions)))) 3577 3578(defun message-bury (buffer) 3579 "Bury this mail BUFFER." 3580 (let ((newbuf (other-buffer buffer))) 3581 (bury-buffer buffer) 3582 (if (and (window-dedicated-p (selected-window)) 3583 (not (null (delq (selected-frame) (visible-frame-list))))) 3584 (delete-frame (selected-frame)) 3585 (switch-to-buffer newbuf)))) 3586 3587(defun message-send (&optional arg) 3588 "Send the message in the current buffer. 3589If `message-interactive' is non-nil, wait for success indication or 3590error messages, and inform user. 3591Otherwise any failure is reported in a message back to the user from 3592the mailer. 3593The usage of ARG is defined by the instance that called Message. 3594It should typically alter the sending method in some way or other." 3595 (interactive "P") 3596 ;; Make it possible to undo the coming changes. 3597 (undo-boundary) 3598 (let ((inhibit-read-only t)) 3599 (put-text-property (point-min) (point-max) 'read-only nil)) 3600 (message-fix-before-sending) 3601 (run-hooks 'message-send-hook) 3602 (message message-sending-message) 3603 (let ((alist message-send-method-alist) 3604 (success t) 3605 elem sent dont-barf-on-no-method 3606 (message-options message-options)) 3607 (message-options-set-recipient) 3608 (while (and success 3609 (setq elem (pop alist))) 3610 (when (funcall (cadr elem)) 3611 (when (and (or (not (memq (car elem) 3612 message-sent-message-via)) 3613 (message-fetch-field "supersedes") 3614 (if (or (message-gnksa-enable-p 'multiple-copies) 3615 (not (eq (car elem) 'news))) 3616 (y-or-n-p 3617 (format 3618 "Already sent message via %s; resend? " 3619 (car elem))) 3620 (error "Denied posting -- multiple copies"))) 3621 (setq success (funcall (caddr elem) arg))) 3622 (setq sent t)))) 3623 (unless (or sent 3624 (not success) 3625 (let ((fcc (message-fetch-field "Fcc")) 3626 (gcc (message-fetch-field "Gcc"))) 3627 (when (or fcc gcc) 3628 (or (eq message-allow-no-recipients 'always) 3629 (and (not (eq message-allow-no-recipients 'never)) 3630 (setq dont-barf-on-no-method 3631 (gnus-y-or-n-p 3632 (format "No receiver, perform %s anyway? " 3633 (cond ((and fcc gcc) "Fcc and Gcc") 3634 (fcc "Fcc") 3635 (t "Gcc")))))))))) 3636 (error "No methods specified to send by")) 3637 (when (or dont-barf-on-no-method 3638 (and success sent)) 3639 (message-do-fcc) 3640 (save-excursion 3641 (run-hooks 'message-sent-hook)) 3642 (message "Sending...done") 3643 ;; Mark the buffer as unmodified and delete auto-save. 3644 (set-buffer-modified-p nil) 3645 (delete-auto-save-file-if-necessary t) 3646 (message-disassociate-draft) 3647 ;; Delete other mail buffers and stuff. 3648 (message-do-send-housekeeping) 3649 (message-do-actions message-send-actions) 3650 ;; Return success. 3651 t))) 3652 3653(defun message-send-via-mail (arg) 3654 "Send the current message via mail." 3655 (message-send-mail arg)) 3656 3657(defun message-send-via-news (arg) 3658 "Send the current message via news." 3659 (funcall message-send-news-function arg)) 3660 3661(defmacro message-check (type &rest forms) 3662 "Eval FORMS if TYPE is to be checked." 3663 `(or (message-check-element ,type) 3664 (save-excursion 3665 ,@forms))) 3666 3667(put 'message-check 'lisp-indent-function 1) 3668(put 'message-check 'edebug-form-spec '(form body)) 3669 3670(defun message-text-with-property (prop) 3671 "Return a list of all points where the text has PROP." 3672 (let ((points nil) 3673 (point (point-min))) 3674 (save-excursion 3675 (while (< point (point-max)) 3676 (when (get-text-property point prop) 3677 (push point points)) 3678 (incf point))) 3679 (nreverse points))) 3680 3681(defun message-fix-before-sending () 3682 "Do various things to make the message nice before sending it." 3683 ;; Make sure there's a newline at the end of the message. 3684 (goto-char (point-max)) 3685 (unless (bolp) 3686 (insert "\n")) 3687 ;; Make the hidden headers visible. 3688 (let ((points (message-text-with-property 'message-hidden))) 3689 (when points 3690 (goto-char (car points)) 3691 (dolist (point points) 3692 (add-text-properties point (1+ point) 3693 '(invisible nil intangible nil))))) 3694 ;; Make invisible text visible. 3695 ;; It doesn't seem as if this is useful, since the invisible property 3696 ;; is clobbered by an after-change hook anyhow. 3697 (message-check 'invisible-text 3698 (let ((points (message-text-with-property 'invisible))) 3699 (when points 3700 (goto-char (car points)) 3701 (dolist (point points) 3702 (put-text-property point (1+ point) 'invisible nil) 3703 (message-overlay-put (message-make-overlay point (1+ point)) 3704 'face 'highlight)) 3705 (unless (yes-or-no-p 3706 "Invisible text found and made visible; continue sending? ") 3707 (error "Invisible text found and made visible"))))) 3708 (message-check 'illegible-text 3709 (let (found choice) 3710 (message-goto-body) 3711 (skip-chars-forward mm-7bit-chars) 3712 (while (not (eobp)) 3713 (when (let ((char (char-after))) 3714 (or (< (mm-char-int char) 128) 3715 (and (mm-multibyte-p) 3716 (memq (char-charset char) 3717 '(eight-bit-control eight-bit-graphic 3718 control-1)) 3719 (not (get-text-property 3720 (point) 'untranslated-utf-8))))) 3721 (message-overlay-put (message-make-overlay (point) (1+ (point))) 3722 'face 'highlight) 3723 (setq found t)) 3724 (forward-char) 3725 (skip-chars-forward mm-7bit-chars)) 3726 (when found 3727 (setq choice 3728 (gnus-multiple-choice 3729 "Non-printable characters found. Continue sending?" 3730 `((?d "Remove non-printable characters and send") 3731 (?r ,(format 3732 "Replace non-printable characters with \"%s\" and send" 3733 message-replacement-char)) 3734 (?i "Ignore non-printable characters and send") 3735 (?e "Continue editing")))) 3736 (if (eq choice ?e) 3737 (error "Non-printable characters")) 3738 (message-goto-body) 3739 (skip-chars-forward mm-7bit-chars) 3740 (while (not (eobp)) 3741 (when (let ((char (char-after))) 3742 (or (< (mm-char-int char) 128) 3743 (and (mm-multibyte-p) 3744 ;; FIXME: Wrong for Emacs 23 (unicode) and for 3745 ;; things like undecable utf-8. Should at least 3746 ;; use find-coding-systems-region. 3747 (memq (char-charset char) 3748 '(eight-bit-control eight-bit-graphic 3749 control-1)) 3750 (not (get-text-property 3751 (point) 'untranslated-utf-8))))) 3752 (if (eq choice ?i) 3753 (message-kill-all-overlays) 3754 (delete-char 1) 3755 (when (eq choice ?r) 3756 (insert message-replacement-char)))) 3757 (forward-char) 3758 (skip-chars-forward mm-7bit-chars)))))) 3759 3760(defun message-add-action (action &rest types) 3761 "Add ACTION to be performed when doing an exit of type TYPES." 3762 (while types 3763 (add-to-list (intern (format "message-%s-actions" (pop types))) 3764 action))) 3765 3766(defun message-delete-action (action &rest types) 3767 "Delete ACTION from lists of actions performed when doing an exit of type TYPES." 3768 (let (var) 3769 (while types 3770 (set (setq var (intern (format "message-%s-actions" (pop types)))) 3771 (delq action (symbol-value var)))))) 3772 3773(defun message-do-actions (actions) 3774 "Perform all actions in ACTIONS." 3775 ;; Now perform actions on successful sending. 3776 (while actions 3777 (ignore-errors 3778 (cond 3779 ;; A simple function. 3780 ((functionp (car actions)) 3781 (funcall (car actions))) 3782 ;; Something to be evaled. 3783 (t 3784 (eval (car actions))))) 3785 (pop actions))) 3786 3787(defun message-send-mail-partially () 3788 "Send mail as message/partial." 3789 ;; replace the header delimiter with a blank line 3790 (goto-char (point-min)) 3791 (re-search-forward 3792 (concat "^" (regexp-quote mail-header-separator) "\n")) 3793 (replace-match "\n") 3794 (run-hooks 'message-send-mail-hook) 3795 (let ((p (goto-char (point-min))) 3796 (tembuf (message-generate-new-buffer-clone-locals " message temp")) 3797 (curbuf (current-buffer)) 3798 (id (message-make-message-id)) (n 1) 3799 plist total header required-mail-headers) 3800 (while (not (eobp)) 3801 (if (< (point-max) (+ p message-send-mail-partially-limit)) 3802 (goto-char (point-max)) 3803 (goto-char (+ p message-send-mail-partially-limit)) 3804 (beginning-of-line) 3805 (if (<= (point) p) (forward-line 1))) ;; In case of bad message. 3806 (push p plist) 3807 (setq p (point))) 3808 (setq total (length plist)) 3809 (push (point-max) plist) 3810 (setq plist (nreverse plist)) 3811 (unwind-protect 3812 (save-excursion 3813 (setq p (pop plist)) 3814 (while plist 3815 (set-buffer curbuf) 3816 (copy-to-buffer tembuf p (car plist)) 3817 (set-buffer tembuf) 3818 (goto-char (point-min)) 3819 (if header 3820 (progn 3821 (goto-char (point-min)) 3822 (narrow-to-region (point) (point)) 3823 (insert header)) 3824 (message-goto-eoh) 3825 (setq header (buffer-substring (point-min) (point))) 3826 (goto-char (point-min)) 3827 (narrow-to-region (point) (point)) 3828 (insert header) 3829 (message-remove-header "Mime-Version") 3830 (message-remove-header "Content-Type") 3831 (message-remove-header "Content-Transfer-Encoding") 3832 (message-remove-header "Message-ID") 3833 (message-remove-header "Lines") 3834 (goto-char (point-max)) 3835 (insert "Mime-Version: 1.0\n") 3836 (setq header (buffer-string))) 3837 (goto-char (point-max)) 3838 (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n" 3839 id n total)) 3840 (forward-char -1) 3841 (let ((mail-header-separator "")) 3842 (when (memq 'Message-ID message-required-mail-headers) 3843 (insert "Message-ID: " (message-make-message-id) "\n")) 3844 (when (memq 'Lines message-required-mail-headers) 3845 (insert "Lines: " (message-make-lines) "\n")) 3846 (message-goto-subject) 3847 (end-of-line) 3848 (insert (format " (%d/%d)" n total)) 3849 (widen) 3850 (mm-with-unibyte-current-buffer 3851 (funcall (or message-send-mail-real-function 3852 message-send-mail-function)))) 3853 (setq n (+ n 1)) 3854 (setq p (pop plist)) 3855 (erase-buffer))) 3856 (kill-buffer tembuf)))) 3857 3858(defun message-send-mail (&optional arg) 3859 (require 'mail-utils) 3860 (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) 3861 (case-fold-search nil) 3862 (news (message-news-p)) 3863 (mailbuf (current-buffer)) 3864 (message-this-is-mail t) 3865 (message-posting-charset 3866 (if (fboundp 'gnus-setup-posting-charset) 3867 (gnus-setup-posting-charset nil) 3868 message-posting-charset)) 3869 (headers message-required-mail-headers)) 3870 (save-restriction 3871 (message-narrow-to-headers) 3872 ;; Generate the Mail-Followup-To header if the header is not there... 3873 (if (and (message-subscribed-p) 3874 (not (mail-fetch-field "mail-followup-to"))) 3875 (setq headers 3876 (cons 3877 (cons "Mail-Followup-To" (message-make-mail-followup-to)) 3878 message-required-mail-headers)) 3879 ;; otherwise, delete the MFT header if the field is empty 3880 (when (equal "" (mail-fetch-field "mail-followup-to")) 3881 (message-remove-header "^Mail-Followup-To:"))) 3882 ;; Insert some headers. 3883 (let ((message-deletable-headers 3884 (if news nil message-deletable-headers))) 3885 (message-generate-headers headers)) 3886 ;; Check continuation headers. 3887 (message-check 'continuation-headers 3888 (goto-char (point-min)) 3889 (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) 3890 (goto-char (match-beginning 0)) 3891 (if (y-or-n-p "Fix continuation lines? ") 3892 (insert " ") 3893 (forward-line 1) 3894 (unless (y-or-n-p "Send anyway? ") 3895 (error "Failed to send the message"))))) 3896 ;; Let the user do all of the above. 3897 (run-hooks 'message-header-hook)) 3898 (unwind-protect 3899 (save-excursion 3900 (set-buffer tembuf) 3901 (erase-buffer) 3902 ;; Avoid copying text props (except hard newlines). 3903 (insert (with-current-buffer mailbuf 3904 (mml-buffer-substring-no-properties-except-hard-newlines 3905 (point-min) (point-max)))) 3906 ;; Remove some headers. 3907 (message-encode-message-body) 3908 (save-restriction 3909 (message-narrow-to-headers) 3910 ;; We (re)generate the Lines header. 3911 (when (memq 'Lines message-required-mail-headers) 3912 (message-generate-headers '(Lines))) 3913 ;; Remove some headers. 3914 (message-remove-header message-ignored-mail-headers t) 3915 (let ((mail-parse-charset message-default-charset)) 3916 (mail-encode-encoded-word-buffer))) 3917 (goto-char (point-max)) 3918 ;; require one newline at the end. 3919 (or (= (preceding-char) ?\n) 3920 (insert ?\n)) 3921 (message-cleanup-headers) 3922 ;; FIXME: we're inserting the courtesy copy after encoding. 3923 ;; This is wrong if the courtesy copy string contains 3924 ;; non-ASCII characters. -- jh 3925 (when 3926 (save-restriction 3927 (message-narrow-to-headers) 3928 (and news 3929 (or (message-fetch-field "cc") 3930 (message-fetch-field "bcc") 3931 (message-fetch-field "to")) 3932 (let ((content-type (message-fetch-field 3933 "content-type"))) 3934 (and 3935 (or 3936 (not content-type) 3937 (string= "text/plain" 3938 (car 3939 (mail-header-parse-content-type 3940 content-type)))) 3941 (not 3942 (string= "base64" 3943 (message-fetch-field 3944 "content-transfer-encoding"))))))) 3945 (message-insert-courtesy-copy)) 3946 (if (or (not message-send-mail-partially-limit) 3947 (< (buffer-size) message-send-mail-partially-limit) 3948 (not (message-y-or-n-p 3949 "The message size is too large, split? " 3950 t 3951 "\ 3952The message size, " 3953 (/ (buffer-size) 1000) "KB, is too large. 3954 3955Some mail gateways (MTA's) bounce large messages. To avoid the 3956problem, answer `y', and the message will be split into several 3957smaller pieces, the size of each is about " 3958 (/ message-send-mail-partially-limit 1000) 3959 "KB except the last 3960one. 3961 3962However, some mail readers (MUA's) can't read split messages, i.e., 3963mails in message/partially format. Answer `n', and the message will be 3964sent in one piece. 3965 3966The size limit is controlled by `message-send-mail-partially-limit'. 3967If you always want Gnus to send messages in one piece, set 3968`message-send-mail-partially-limit' to nil. 3969"))) 3970 (mm-with-unibyte-current-buffer 3971 (message "Sending via mail...") 3972 (funcall (or message-send-mail-real-function 3973 message-send-mail-function))) 3974 (message-send-mail-partially))) 3975 (kill-buffer tembuf)) 3976 (set-buffer mailbuf) 3977 (push 'mail message-sent-message-via))) 3978 3979(defun message-send-mail-with-sendmail () 3980 "Send off the prepared buffer with sendmail." 3981 (let ((errbuf (if message-interactive 3982 (message-generate-new-buffer-clone-locals 3983 " sendmail errors") 3984 0)) 3985 resend-to-addresses delimline) 3986 (unwind-protect 3987 (progn 3988 (let ((case-fold-search t)) 3989 (save-restriction 3990 (message-narrow-to-headers) 3991 (setq resend-to-addresses (message-fetch-field "resent-to"))) 3992 ;; Change header-delimiter to be what sendmail expects. 3993 (goto-char (point-min)) 3994 (re-search-forward 3995 (concat "^" (regexp-quote mail-header-separator) "\n")) 3996 (replace-match "\n") 3997 (backward-char 1) 3998 (setq delimline (point-marker)) 3999 (run-hooks 'message-send-mail-hook) 4000 ;; Insert an extra newline if we need it to work around 4001 ;; Sun's bug that swallows newlines. 4002 (goto-char (1+ delimline)) 4003 (when (eval message-mailer-swallows-blank-line) 4004 (newline)) 4005 (when message-interactive 4006 (save-excursion 4007 (set-buffer errbuf) 4008 (erase-buffer)))) 4009 (let* ((default-directory "/") 4010 (coding-system-for-write message-send-coding-system) 4011 (cpr (apply 4012 'call-process-region 4013 (append 4014 (list (point-min) (point-max) 4015 (cond ((boundp 'sendmail-program) 4016 sendmail-program) 4017 ((file-exists-p "/usr/sbin/sendmail") 4018 "/usr/sbin/sendmail") 4019 ((file-exists-p "/usr/lib/sendmail") 4020 "/usr/lib/sendmail") 4021 ((file-exists-p "/usr/ucblib/sendmail") 4022 "/usr/ucblib/sendmail") 4023 (t "fakemail")) 4024 nil errbuf nil "-oi") 4025 ;; Always specify who from, 4026 ;; since some systems have broken sendmails. 4027 ;; But some systems are more broken with -f, so 4028 ;; we'll let users override this. 4029 (if (null message-sendmail-f-is-evil) 4030 (list "-f" (message-sendmail-envelope-from))) 4031 ;; These mean "report errors by mail" 4032 ;; and "deliver in background". 4033 (if (null message-interactive) '("-oem" "-odb")) 4034 ;; Get the addresses from the message 4035 ;; unless this is a resend. 4036 ;; We must not do that for a resend 4037 ;; because we would find the original addresses. 4038 ;; For a resend, include the specific addresses. 4039 (if resend-to-addresses 4040 (list resend-to-addresses) 4041 '("-t")))))) 4042 (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) 4043 (error "Sending...failed with exit value %d" cpr))) 4044 (when message-interactive 4045 (save-excursion 4046 (set-buffer errbuf) 4047 (goto-char (point-min)) 4048 (while (re-search-forward "\n\n* *" nil t) 4049 (replace-match "; ")) 4050 (if (not (zerop (buffer-size))) 4051 (error "Sending...failed to %s" 4052 (buffer-string)))))) 4053 (when (bufferp errbuf) 4054 (kill-buffer errbuf))))) 4055 4056(defun message-send-mail-with-qmail () 4057 "Pass the prepared message buffer to qmail-inject. 4058Refer to the documentation for the variable `message-send-mail-function' 4059to find out how to use this." 4060 ;; replace the header delimiter with a blank line 4061 (goto-char (point-min)) 4062 (re-search-forward 4063 (concat "^" (regexp-quote mail-header-separator) "\n")) 4064 (replace-match "\n") 4065 (run-hooks 'message-send-mail-hook) 4066 ;; send the message 4067 (case 4068 (let ((coding-system-for-write message-send-coding-system)) 4069 (apply 4070 'call-process-region (point-min) (point-max) 4071 message-qmail-inject-program nil nil nil 4072 ;; qmail-inject's default behaviour is to look for addresses on the 4073 ;; command line; if there're none, it scans the headers. 4074 ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. 4075 ;; 4076 ;; in general, ALL of qmail-inject's defaults are perfect for simply 4077 ;; reading a formatted (i. e., at least a To: or Resent-To header) 4078 ;; message from stdin. 4079 ;; 4080 ;; qmail also has the advantage of not having been raped by 4081 ;; various vendors, so we don't have to allow for that, either -- 4082 ;; compare this with message-send-mail-with-sendmail and weep 4083 ;; for sendmail's lost innocence. 4084 ;; 4085 ;; all this is way cool coz it lets us keep the arguments entirely 4086 ;; free for -inject-arguments -- a big win for the user and for us 4087 ;; since we don't have to play that double-guessing game and the user 4088 ;; gets full control (no gestapo'ish -f's, for instance). --sj 4089 (if (functionp message-qmail-inject-args) 4090 (funcall message-qmail-inject-args) 4091 message-qmail-inject-args))) 4092 ;; qmail-inject doesn't say anything on it's stdout/stderr, 4093 ;; we have to look at the retval instead 4094 (0 nil) 4095 (100 (error "qmail-inject reported permanent failure")) 4096 (111 (error "qmail-inject reported transient failure")) 4097 ;; should never happen 4098 (t (error "qmail-inject reported unknown failure")))) 4099 4100(defun message-send-mail-with-mh () 4101 "Send the prepared message buffer with mh." 4102 (let ((mh-previous-window-config nil) 4103 (name (mh-new-draft-name))) 4104 (setq buffer-file-name name) 4105 ;; MH wants to generate these headers itself. 4106 (when message-mh-deletable-headers 4107 (let ((headers message-mh-deletable-headers)) 4108 (while headers 4109 (goto-char (point-min)) 4110 (and (re-search-forward 4111 (concat "^" (symbol-name (car headers)) ": *") nil t) 4112 (message-delete-line)) 4113 (pop headers)))) 4114 (run-hooks 'message-send-mail-hook) 4115 ;; Pass it on to mh. 4116 (mh-send-letter))) 4117 4118(defun message-smtpmail-send-it () 4119 "Send the prepared message buffer with `smtpmail-send-it'. 4120This only differs from `smtpmail-send-it' that this command evaluates 4121`message-send-mail-hook' just before sending a message. It is useful 4122if your ISP requires the POP-before-SMTP authentication. See the Gnus 4123manual for details." 4124 (run-hooks 'message-send-mail-hook) 4125 (smtpmail-send-it)) 4126 4127(defun message-canlock-generate () 4128 "Return a string that is non-trivial to guess. 4129Do not use this for anything important, it is cryptographically weak." 4130 (require 'sha1) 4131 (let (sha1-maximum-internal-length) 4132 (sha1 (concat (message-unique-id) 4133 (format "%x%x%x" (random) (random t) (random)) 4134 (prin1-to-string (recent-keys)) 4135 (prin1-to-string (garbage-collect)))))) 4136 4137(defun message-canlock-password () 4138 "The password used by message for cancel locks. 4139This is the value of `canlock-password', if that option is non-nil. 4140Otherwise, generate and save a value for `canlock-password' first." 4141 (unless canlock-password 4142 (customize-save-variable 'canlock-password (message-canlock-generate)) 4143 (setq canlock-password-for-verify canlock-password)) 4144 canlock-password) 4145 4146(defun message-insert-canlock () 4147 (when message-insert-canlock 4148 (message-canlock-password) 4149 (canlock-insert-header))) 4150 4151(defun message-send-news (&optional arg) 4152 (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) 4153 (case-fold-search nil) 4154 (method (if (functionp message-post-method) 4155 (funcall message-post-method arg) 4156 message-post-method)) 4157 (newsgroups-field (save-restriction 4158 (message-narrow-to-headers-or-head) 4159 (message-fetch-field "Newsgroups"))) 4160 (followup-field (save-restriction 4161 (message-narrow-to-headers-or-head) 4162 (message-fetch-field "Followup-To"))) 4163 ;; BUG: We really need to get the charset for each name in the 4164 ;; Newsgroups and Followup-To lines to allow crossposting 4165 ;; between group namess with incompatible character sets. 4166 ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08. 4167 (group-field-charset 4168 (gnus-group-name-charset method newsgroups-field)) 4169 (followup-field-charset 4170 (gnus-group-name-charset method (or followup-field ""))) 4171 (rfc2047-header-encoding-alist 4172 (append (when group-field-charset 4173 (list (cons "Newsgroups" group-field-charset))) 4174 (when followup-field-charset 4175 (list (cons "Followup-To" followup-field-charset))) 4176 rfc2047-header-encoding-alist)) 4177 (messbuf (current-buffer)) 4178 (message-syntax-checks 4179 (if (and arg 4180 (listp message-syntax-checks)) 4181 (cons '(existing-newsgroups . disabled) 4182 message-syntax-checks) 4183 message-syntax-checks)) 4184 (message-this-is-news t) 4185 (message-posting-charset 4186 (gnus-setup-posting-charset newsgroups-field)) 4187 result) 4188 (if (not (message-check-news-body-syntax)) 4189 nil 4190 (save-restriction 4191 (message-narrow-to-headers) 4192 ;; Insert some headers. 4193 (message-generate-headers message-required-news-headers) 4194 (message-insert-canlock) 4195 ;; Let the user do all of the above. 4196 (run-hooks 'message-header-hook)) 4197 ;; Note: This check will be disabled by the ".*" default value for 4198 ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07. 4199 (when (and group-field-charset 4200 (listp message-syntax-checks)) 4201 (setq message-syntax-checks 4202 (cons '(valid-newsgroups . disabled) 4203 message-syntax-checks))) 4204 (message-cleanup-headers) 4205 (if (not (let ((message-post-method method)) 4206 (message-check-news-syntax))) 4207 nil 4208 (unwind-protect 4209 (save-excursion 4210 (set-buffer tembuf) 4211 (buffer-disable-undo) 4212 (erase-buffer) 4213 ;; Avoid copying text props (except hard newlines). 4214 (insert 4215 (with-current-buffer messbuf 4216 (mml-buffer-substring-no-properties-except-hard-newlines 4217 (point-min) (point-max)))) 4218 (message-encode-message-body) 4219 ;; Remove some headers. 4220 (save-restriction 4221 (message-narrow-to-headers) 4222 ;; We (re)generate the Lines header. 4223 (when (memq 'Lines message-required-mail-headers) 4224 (message-generate-headers '(Lines))) 4225 ;; Remove some headers. 4226 (message-remove-header message-ignored-news-headers t) 4227 (let ((mail-parse-charset message-default-charset)) 4228 (mail-encode-encoded-word-buffer))) 4229 (goto-char (point-max)) 4230 ;; require one newline at the end. 4231 (or (= (preceding-char) ?\n) 4232 (insert ?\n)) 4233 (let ((case-fold-search t)) 4234 ;; Remove the delimiter. 4235 (goto-char (point-min)) 4236 (re-search-forward 4237 (concat "^" (regexp-quote mail-header-separator) "\n")) 4238 (replace-match "\n") 4239 (backward-char 1)) 4240 (run-hooks 'message-send-news-hook) 4241 (gnus-open-server method) 4242 (message "Sending news via %s..." (gnus-server-string method)) 4243 (setq result (let ((mail-header-separator "")) 4244 (gnus-request-post method)))) 4245 (kill-buffer tembuf)) 4246 (set-buffer messbuf) 4247 (if result 4248 (push 'news message-sent-message-via) 4249 (message "Couldn't send message via news: %s" 4250 (nnheader-get-report (car method))) 4251 nil))))) 4252 4253;;; 4254;;; Header generation & syntax checking. 4255;;; 4256 4257(defun message-check-element (type) 4258 "Return non-nil if this TYPE is not to be checked." 4259 (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me) 4260 t 4261 (let ((able (assq type message-syntax-checks))) 4262 (and (consp able) 4263 (eq (cdr able) 'disabled))))) 4264 4265(defun message-check-news-syntax () 4266 "Check the syntax of the message." 4267 (save-excursion 4268 (save-restriction 4269 (widen) 4270 ;; We narrow to the headers and check them first. 4271 (save-excursion 4272 (save-restriction 4273 (message-narrow-to-headers) 4274 (message-check-news-header-syntax)))))) 4275 4276(defun message-check-news-header-syntax () 4277 (and 4278 ;; Check Newsgroups header. 4279 (message-check 'newsgroups 4280 (let ((group (message-fetch-field "newsgroups"))) 4281 (or 4282 (and group 4283 (not (string-match "\\`[ \t]*\\'" group))) 4284 (ignore 4285 (message 4286 "The newsgroups field is empty or missing. Posting is denied."))))) 4287 ;; Check the Subject header. 4288 (message-check 'subject 4289 (let* ((case-fold-search t) 4290 (subject (message-fetch-field "subject"))) 4291 (or 4292 (and subject 4293 (not (string-match "\\`[ \t]*\\'" subject))) 4294 (ignore 4295 (message 4296 "The subject field is empty or missing. Posting is denied."))))) 4297 ;; Check for commands in Subject. 4298 (message-check 'subject-cmsg 4299 (if (string-match "^cmsg " (message-fetch-field "subject")) 4300 (y-or-n-p 4301 "The control code \"cmsg\" is in the subject. Really post? ") 4302 t)) 4303 ;; Check long header lines. 4304 (message-check 'long-header-lines 4305 (let ((start (point)) 4306 (header nil) 4307 (length 0) 4308 found) 4309 (while (and (not found) 4310 (re-search-forward "^\\([^ \t:]+\\): " nil t)) 4311 (if (> (- (point) (match-beginning 0)) 998) 4312 (setq found t 4313 length (- (point) (match-beginning 0))) 4314 (setq header (match-string-no-properties 1))) 4315 (setq start (match-beginning 0)) 4316 (forward-line 1)) 4317 (if found 4318 (y-or-n-p (format "Your %s header is too long (%d). Really post? " 4319 header length)) 4320 t))) 4321 ;; Check for multiple identical headers. 4322 (message-check 'multiple-headers 4323 (let (found) 4324 (while (and (not found) 4325 (re-search-forward "^[^ \t:]+: " nil t)) 4326 (save-excursion 4327 (or (re-search-forward 4328 (concat "^" 4329 (regexp-quote 4330 (setq found 4331 (buffer-substring 4332 (match-beginning 0) (- (match-end 0) 2)))) 4333 ":") 4334 nil t) 4335 (setq found nil)))) 4336 (if found 4337 (y-or-n-p (format "Multiple %s headers. Really post? " found)) 4338 t))) 4339 ;; Check for Version and Sendsys. 4340 (message-check 'sendsys 4341 (if (re-search-forward "^Sendsys:\\|^Version:" nil t) 4342 (y-or-n-p 4343 (format "The article contains a %s command. Really post? " 4344 (buffer-substring (match-beginning 0) 4345 (1- (match-end 0))))) 4346 t)) 4347 ;; See whether we can shorten Followup-To. 4348 (message-check 'shorten-followup-to 4349 (let ((newsgroups (message-fetch-field "newsgroups")) 4350 (followup-to (message-fetch-field "followup-to")) 4351 to) 4352 (when (and newsgroups 4353 (string-match "," newsgroups) 4354 (not followup-to) 4355 (not 4356 (zerop 4357 (length 4358 (setq to (completing-read 4359 "Followups to (default no Followup-To header): " 4360 (mapcar #'list 4361 (cons "poster" 4362 (message-tokenize-header 4363 newsgroups))))))))) 4364 (goto-char (point-min)) 4365 (insert "Followup-To: " to "\n")) 4366 t)) 4367 ;; Check "Shoot me". 4368 (message-check 'shoot 4369 (if (re-search-forward 4370 "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t) 4371 (y-or-n-p "You appear to have a misconfigured system. Really post? ") 4372 t)) 4373 ;; Check for Approved. 4374 (message-check 'approved 4375 (if (re-search-forward "^Approved:" nil t) 4376 (y-or-n-p "The article contains an Approved header. Really post? ") 4377 t)) 4378 ;; Check the Message-ID header. 4379 (message-check 'message-id 4380 (let* ((case-fold-search t) 4381 (message-id (message-fetch-field "message-id" t))) 4382 (or (not message-id) 4383 ;; Is there an @ in the ID? 4384 (and (string-match "@" message-id) 4385 ;; Is there a dot in the ID? 4386 (string-match "@[^.]*\\." message-id) 4387 ;; Does the ID end with a dot? 4388 (not (string-match "\\.>" message-id))) 4389 (y-or-n-p 4390 (format "The Message-ID looks strange: \"%s\". Really post? " 4391 message-id))))) 4392 ;; Check the Newsgroups & Followup-To headers. 4393 (message-check 'existing-newsgroups 4394 (let* ((case-fold-search t) 4395 (newsgroups (message-fetch-field "newsgroups")) 4396 (followup-to (message-fetch-field "followup-to")) 4397 (groups (message-tokenize-header 4398 (if followup-to 4399 (concat newsgroups "," followup-to) 4400 newsgroups))) 4401 (post-method (if (functionp message-post-method) 4402 (funcall message-post-method) 4403 message-post-method)) 4404 ;; KLUDGE to handle nnvirtual groups. Doing this right 4405 ;; would probably involve a new nnoo function. 4406 ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17. 4407 (method (if (and (consp post-method) 4408 (eq (car post-method) 'nnvirtual) 4409 gnus-message-group-art) 4410 (let ((group (car (nnvirtual-find-group-art 4411 (car gnus-message-group-art) 4412 (cdr gnus-message-group-art))))) 4413 (gnus-find-method-for-group group)) 4414 post-method)) 4415 (known-groups 4416 (mapcar (lambda (n) 4417 (gnus-group-name-decode 4418 (gnus-group-real-name n) 4419 (gnus-group-name-charset method n))) 4420 (gnus-groups-from-server method))) 4421 errors) 4422 (while groups 4423 (when (and (not (equal (car groups) "poster")) 4424 (not (member (car groups) known-groups)) 4425 (not (member (car groups) errors))) 4426 (push (car groups) errors)) 4427 (pop groups)) 4428 (cond 4429 ;; Gnus is not running. 4430 ((or (not (and (boundp 'gnus-active-hashtb) 4431 gnus-active-hashtb)) 4432 (not (boundp 'gnus-read-active-file))) 4433 t) 4434 ;; We don't have all the group names. 4435 ((and (or (not gnus-read-active-file) 4436 (eq gnus-read-active-file 'some)) 4437 errors) 4438 (y-or-n-p 4439 (format 4440 "Really use %s possibly unknown group%s: %s? " 4441 (if (= (length errors) 1) "this" "these") 4442 (if (= (length errors) 1) "" "s") 4443 (mapconcat 'identity errors ", ")))) 4444 ;; There were no errors. 4445 ((not errors) 4446 t) 4447 ;; There are unknown groups. 4448 (t 4449 (y-or-n-p 4450 (format 4451 "Really post to %s unknown group%s: %s? " 4452 (if (= (length errors) 1) "this" "these") 4453 (if (= (length errors) 1) "" "s") 4454 (mapconcat 'identity errors ", "))))))) 4455 ;; Check continuation headers. 4456 (message-check 'continuation-headers 4457 (goto-char (point-min)) 4458 (let ((do-posting t)) 4459 (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) 4460 (goto-char (match-beginning 0)) 4461 (if (y-or-n-p "Fix continuation lines? ") 4462 (insert " ") 4463 (forward-line 1) 4464 (unless (y-or-n-p "Send anyway? ") 4465 (setq do-posting nil)))) 4466 do-posting)) 4467 ;; Check the Newsgroups & Followup-To headers for syntax errors. 4468 (message-check 'valid-newsgroups 4469 (let ((case-fold-search t) 4470 (headers '("Newsgroups" "Followup-To")) 4471 header error) 4472 (while (and headers (not error)) 4473 (when (setq header (mail-fetch-field (car headers))) 4474 (if (or 4475 (not 4476 (string-match 4477 "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'" 4478 header)) 4479 (memq 4480 nil (mapcar 4481 (lambda (g) 4482 (not (string-match "\\.\\'\\|\\.\\." g))) 4483 (message-tokenize-header header ",")))) 4484 (setq error t))) 4485 (unless error 4486 (pop headers))) 4487 (if (not error) 4488 t 4489 (y-or-n-p 4490 (format "The %s header looks odd: \"%s\". Really post? " 4491 (car headers) header))))) 4492 (message-check 'repeated-newsgroups 4493 (let ((case-fold-search t) 4494 (headers '("Newsgroups" "Followup-To")) 4495 header error groups group) 4496 (while (and headers 4497 (not error)) 4498 (when (setq header (mail-fetch-field (pop headers))) 4499 (setq groups (message-tokenize-header header ",")) 4500 (while (setq group (pop groups)) 4501 (when (member group groups) 4502 (setq error group 4503 groups nil))))) 4504 (if (not error) 4505 t 4506 (y-or-n-p 4507 (format "Group %s is repeated in headers. Really post? " error))))) 4508 ;; Check the From header. 4509 (message-check 'from 4510 (let* ((case-fold-search t) 4511 (from (message-fetch-field "from")) 4512 ad) 4513 (cond 4514 ((not from) 4515 (message "There is no From line. Posting is denied.") 4516 nil) 4517 ((or (not (string-match 4518 "@[^\\.]*\\." 4519 (setq ad (nth 1 (mail-extract-address-components 4520 from))))) ;larsi@ifi 4521 (string-match "\\.\\." ad) ;larsi@ifi..uio 4522 (string-match "@\\." ad) ;larsi@.ifi.uio 4523 (string-match "\\.$" ad) ;larsi@ifi.uio. 4524 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio 4525 (string-match "(.*).*(.*)" from)) ;(lars) (lars) 4526 (message 4527 "Denied posting -- the From looks strange: \"%s\"." from) 4528 nil) 4529 ((let ((addresses (rfc822-addresses from))) 4530 (while (and addresses 4531 (not (eq (string-to-char (car addresses)) ?\())) 4532 (setq addresses (cdr addresses))) 4533 addresses) 4534 (message 4535 "Denied posting -- bad From address: \"%s\"." from) 4536 nil) 4537 (t t)))) 4538 ;; Check the Reply-To header. 4539 (message-check 'reply-to 4540 (let* ((case-fold-search t) 4541 (reply-to (message-fetch-field "reply-to")) 4542 ad) 4543 (cond 4544 ((not reply-to) 4545 t) 4546 ((string-match "," reply-to) 4547 (y-or-n-p 4548 (format "Multiple Reply-To addresses: \"%s\". Really post? " 4549 reply-to))) 4550 ((or (not (string-match 4551 "@[^\\.]*\\." 4552 (setq ad (nth 1 (mail-extract-address-components 4553 reply-to))))) ;larsi@ifi 4554 (string-match "\\.\\." ad) ;larsi@ifi..uio 4555 (string-match "@\\." ad) ;larsi@.ifi.uio 4556 (string-match "\\.$" ad) ;larsi@ifi.uio. 4557 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio 4558 (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars) 4559 (y-or-n-p 4560 (format 4561 "The Reply-To looks strange: \"%s\". Really post? " 4562 reply-to))) 4563 (t t)))))) 4564 4565(defun message-check-news-body-syntax () 4566 (and 4567 ;; Check for long lines. 4568 (message-check 'long-lines 4569 (goto-char (point-min)) 4570 (re-search-forward 4571 (concat "^" (regexp-quote mail-header-separator) "$")) 4572 (forward-line 1) 4573 (while (and 4574 (or (looking-at 4575 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)") 4576 (let ((p (point))) 4577 (end-of-line) 4578 (< (- (point) p) 80))) 4579 (zerop (forward-line 1)))) 4580 (or (bolp) 4581 (eobp) 4582 (y-or-n-p 4583 "You have lines longer than 79 characters. Really post? "))) 4584 ;; Check whether the article is empty. 4585 (message-check 'empty 4586 (goto-char (point-min)) 4587 (re-search-forward 4588 (concat "^" (regexp-quote mail-header-separator) "$")) 4589 (forward-line 1) 4590 (let ((b (point))) 4591 (goto-char (point-max)) 4592 (re-search-backward message-signature-separator nil t) 4593 (beginning-of-line) 4594 (or (re-search-backward "[^ \n\t]" b t) 4595 (if (message-gnksa-enable-p 'empty-article) 4596 (y-or-n-p "Empty article. Really post? ") 4597 (message "Denied posting -- Empty article.") 4598 nil)))) 4599 ;; Check for control characters. 4600 (message-check 'control-chars 4601 (if (re-search-forward 4602 (mm-string-as-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") 4603 nil t) 4604 (y-or-n-p 4605 "The article contains control characters. Really post? ") 4606 t)) 4607 ;; Check excessive size. 4608 (message-check 'size 4609 (if (> (buffer-size) 60000) 4610 (y-or-n-p 4611 (format "The article is %d octets long. Really post? " 4612 (buffer-size))) 4613 t)) 4614 ;; Check whether any new text has been added. 4615 (message-check 'new-text 4616 (or 4617 (not message-checksum) 4618 (not (eq (message-checksum) message-checksum)) 4619 (if (message-gnksa-enable-p 'quoted-text-only) 4620 (y-or-n-p 4621 "It looks like no new text has been added. Really post? ") 4622 (message "Denied posting -- no new text has been added.") 4623 nil))) 4624 ;; Check the length of the signature. 4625 (message-check 'signature 4626 (goto-char (point-max)) 4627 (if (> (count-lines (point) (point-max)) 5) 4628 (y-or-n-p 4629 (format 4630 "Your .sig is %d lines; it should be max 4. Really post? " 4631 (1- (count-lines (point) (point-max))))) 4632 t)) 4633 ;; Ensure that text follows last quoted portion. 4634 (message-check 'quoting-style 4635 (goto-char (point-max)) 4636 (let ((no-problem t)) 4637 (when (search-backward-regexp "^>[^\n]*\n" nil t) 4638 (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t))) 4639 (if no-problem 4640 t 4641 (if (message-gnksa-enable-p 'quoted-text-only) 4642 (y-or-n-p "Your text should follow quoted text. Really post? ") 4643 ;; Ensure that 4644 (goto-char (point-min)) 4645 (re-search-forward 4646 (concat "^" (regexp-quote mail-header-separator) "$")) 4647 (if (search-forward-regexp "^[ \t]*[^>\n]" nil t) 4648 (y-or-n-p "Your text should follow quoted text. Really post? ") 4649 (message "Denied posting -- only quoted text.") 4650 nil))))))) 4651 4652(defun message-checksum () 4653 "Return a \"checksum\" for the current buffer." 4654 (let ((sum 0)) 4655 (save-excursion 4656 (goto-char (point-min)) 4657 (re-search-forward 4658 (concat "^" (regexp-quote mail-header-separator) "$")) 4659 (while (not (eobp)) 4660 (when (not (looking-at "[ \t\n]")) 4661 (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) 4662 (char-after)))) 4663 (forward-char 1))) 4664 sum)) 4665 4666(defun message-do-fcc () 4667 "Process Fcc headers in the current buffer." 4668 (let ((case-fold-search t) 4669 (buf (current-buffer)) 4670 list file 4671 (mml-externalize-attachments message-fcc-externalize-attachments)) 4672 (save-excursion 4673 (save-restriction 4674 (message-narrow-to-headers) 4675 (setq file (message-fetch-field "fcc" t))) 4676 (when file 4677 (set-buffer (get-buffer-create " *message temp*")) 4678 (erase-buffer) 4679 (insert-buffer-substring buf) 4680 (message-encode-message-body) 4681 (save-restriction 4682 (message-narrow-to-headers) 4683 (while (setq file (message-fetch-field "fcc" t)) 4684 (push file list) 4685 (message-remove-header "fcc" nil t)) 4686 (let ((mail-parse-charset message-default-charset) 4687 (rfc2047-header-encoding-alist 4688 (cons '("Newsgroups" . default) 4689 rfc2047-header-encoding-alist))) 4690 (mail-encode-encoded-word-buffer))) 4691 (goto-char (point-min)) 4692 (when (re-search-forward 4693 (concat "^" (regexp-quote mail-header-separator) "$") 4694 nil t) 4695 (replace-match "" t t )) 4696 ;; Process FCC operations. 4697 (while list 4698 (setq file (pop list)) 4699 (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) 4700 ;; Pipe the article to the program in question. 4701 (call-process-region (point-min) (point-max) shell-file-name 4702 nil nil nil shell-command-switch 4703 (match-string 1 file)) 4704 ;; Save the article. 4705 (setq file (expand-file-name file)) 4706 (unless (file-exists-p (file-name-directory file)) 4707 (make-directory (file-name-directory file) t)) 4708 (if (and message-fcc-handler-function 4709 (not (eq message-fcc-handler-function 'rmail-output))) 4710 (funcall message-fcc-handler-function file) 4711 (if (and (file-readable-p file) (mail-file-babyl-p file)) 4712 (rmail-output file 1 nil t) 4713 (let ((mail-use-rfc822 t)) 4714 (rmail-output file 1 t t)))))) 4715 (kill-buffer (current-buffer)))))) 4716 4717(defun message-output (filename) 4718 "Append this article to Unix/babyl mail file FILENAME." 4719 (if (and (file-readable-p filename) 4720 (mail-file-babyl-p filename)) 4721 (gnus-output-to-rmail filename t) 4722 (gnus-output-to-mail filename t))) 4723 4724(defun message-cleanup-headers () 4725 "Do various automatic cleanups of the headers." 4726 ;; Remove empty lines in the header. 4727 (save-restriction 4728 (message-narrow-to-headers) 4729 ;; Remove blank lines. 4730 (while (re-search-forward "^[ \t]*\n" nil t) 4731 (replace-match "" t t)) 4732 4733 ;; Correct Newsgroups and Followup-To headers: Change sequence of 4734 ;; spaces to comma and eliminate spaces around commas. Eliminate 4735 ;; embedded line breaks. 4736 (goto-char (point-min)) 4737 (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t) 4738 (save-restriction 4739 (narrow-to-region 4740 (point) 4741 (if (re-search-forward "^[^ \t]" nil t) 4742 (match-beginning 0) 4743 (forward-line 1) 4744 (point))) 4745 (goto-char (point-min)) 4746 (while (re-search-forward "\n[ \t]+" nil t) 4747 (replace-match " " t t)) ;No line breaks (too confusing) 4748 (goto-char (point-min)) 4749 (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) 4750 (replace-match "," t t)) 4751 (goto-char (point-min)) 4752 ;; Remove trailing commas. 4753 (when (re-search-forward ",+$" nil t) 4754 (replace-match "" t t)))))) 4755 4756(eval-when-compile (require 'parse-time)) 4757(defun message-make-date (&optional now) 4758 "Make a valid data header. 4759If NOW, use that time instead." 4760 (require 'parse-time) 4761 (let* ((now (or now (current-time))) 4762 (zone (nth 8 (decode-time now))) 4763 (sign "+")) 4764 (when (< zone 0) 4765 (setq sign "-") 4766 (setq zone (- zone))) 4767 (concat 4768 ;; The day name of the %a spec is locale-specific. Pfff. 4769 (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now)) 4770 parse-time-weekdays)))) 4771 (format-time-string "%d" now) 4772 ;; The month name of the %b spec is locale-specific. Pfff. 4773 (format " %s " 4774 (capitalize (car (rassoc (nth 4 (decode-time now)) 4775 parse-time-months)))) 4776 (format-time-string "%Y %H:%M:%S " now) 4777 ;; We do all of this because XEmacs doesn't have the %z spec. 4778 (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60))))) 4779 4780(defun message-make-message-id () 4781 "Make a unique Message-ID." 4782 (concat "<" (message-unique-id) 4783 (let ((psubject (save-excursion (message-fetch-field "subject"))) 4784 (psupersedes 4785 (save-excursion (message-fetch-field "supersedes")))) 4786 (if (or 4787 (and message-reply-headers 4788 (mail-header-references message-reply-headers) 4789 (mail-header-subject message-reply-headers) 4790 psubject 4791 (not (string= 4792 (message-strip-subject-re 4793 (mail-header-subject message-reply-headers)) 4794 (message-strip-subject-re psubject)))) 4795 (and psupersedes 4796 (string-match "_-_@" psupersedes))) 4797 "_-_" "")) 4798 "@" (message-make-fqdn) ">")) 4799 4800(defvar message-unique-id-char nil) 4801 4802;; If you ever change this function, make sure the new version 4803;; cannot generate IDs that the old version could. 4804;; You might for example insert a "." somewhere (not next to another dot 4805;; or string boundary), or modify the "fsf" string. 4806(defun message-unique-id () 4807 ;; Don't use microseconds from (current-time), they may be unsupported. 4808 ;; Instead we use this randomly inited counter. 4809 (setq message-unique-id-char 4810 (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20))))) 4811 ;; (current-time) returns 16-bit ints, 4812 ;; and 2^16*25 just fits into 4 digits i base 36. 4813 (* 25 25))) 4814 (let ((tm (current-time))) 4815 (concat 4816 (if (or (memq system-type '(ms-dos emx vax-vms)) 4817 ;; message-number-base36 doesn't handle bigints. 4818 (floatp (user-uid))) 4819 (let ((user (downcase (user-login-name)))) 4820 (while (string-match "[^a-z0-9_]" user) 4821 (aset user (match-beginning 0) ?_)) 4822 user) 4823 (message-number-base36 (user-uid) -1)) 4824 (message-number-base36 (+ (car tm) 4825 (lsh (% message-unique-id-char 25) 16)) 4) 4826 (message-number-base36 (+ (nth 1 tm) 4827 (lsh (/ message-unique-id-char 25) 16)) 4) 4828 ;; Append a given name, because while the generated ID is unique 4829 ;; to this newsreader, other newsreaders might otherwise generate 4830 ;; the same ID via another algorithm. 4831 ".fsf"))) 4832 4833(defun message-number-base36 (num len) 4834 (if (if (< len 0) 4835 (<= num 0) 4836 (= len 0)) 4837 "" 4838 (concat (message-number-base36 (/ num 36) (1- len)) 4839 (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" 4840 (% num 36)))))) 4841 4842(defun message-make-organization () 4843 "Make an Organization header." 4844 (let* ((organization 4845 (when message-user-organization 4846 (if (functionp message-user-organization) 4847 (funcall message-user-organization) 4848 message-user-organization)))) 4849 (with-temp-buffer 4850 (mm-enable-multibyte) 4851 (cond ((stringp organization) 4852 (insert organization)) 4853 ((and (eq t organization) 4854 message-user-organization-file 4855 (file-exists-p message-user-organization-file)) 4856 (insert-file-contents message-user-organization-file))) 4857 (goto-char (point-min)) 4858 (while (re-search-forward "[\t\n]+" nil t) 4859 (replace-match "" t t)) 4860 (unless (zerop (buffer-size)) 4861 (buffer-string))))) 4862 4863(defun message-make-lines () 4864 "Count the number of lines and return numeric string." 4865 (save-excursion 4866 (save-restriction 4867 (widen) 4868 (message-goto-body) 4869 (int-to-string (count-lines (point) (point-max)))))) 4870 4871(defun message-make-references () 4872 "Return the References header for this message." 4873 (when message-reply-headers 4874 (let ((message-id (mail-header-message-id message-reply-headers)) 4875 (references (mail-header-references message-reply-headers)) 4876 new-references) 4877 (if (or references message-id) 4878 (concat (or references "") (and references " ") 4879 (or message-id "")) 4880 nil)))) 4881 4882(defun message-make-in-reply-to () 4883 "Return the In-Reply-To header for this message." 4884 (when message-reply-headers 4885 (let ((from (mail-header-from message-reply-headers)) 4886 (date (mail-header-date message-reply-headers)) 4887 (msg-id (mail-header-message-id message-reply-headers))) 4888 (when from 4889 (let ((name (mail-extract-address-components from))) 4890 (concat 4891 msg-id (if msg-id " (") 4892 (if (car name) 4893 (if (string-match "[^\000-\177]" (car name)) 4894 ;; Quote a string containing non-ASCII characters. 4895 ;; It will make the RFC2047 encoder cause an error 4896 ;; if there are special characters. 4897 (let ((default-enable-multibyte-characters t)) 4898 (with-temp-buffer 4899 (insert (car name)) 4900 (goto-char (point-min)) 4901 (while (search-forward "\"" nil t) 4902 (when (prog2 4903 (backward-char) 4904 (zerop (% (skip-chars-backward "\\\\") 2)) 4905 (goto-char (match-beginning 0))) 4906 (insert "\\")) 4907 (forward-char)) 4908 ;; Those quotes will be removed by the RFC2047 encoder. 4909 (concat "\"" (buffer-string) "\""))) 4910 (car name)) 4911 (nth 1 name)) 4912 "'s message of \"" 4913 (if (or (not date) (string= date "")) 4914 "(unknown date)" date) 4915 "\"" (if msg-id ")"))))))) 4916 4917(defun message-make-distribution () 4918 "Make a Distribution header." 4919 (let ((orig-distribution (message-fetch-reply-field "distribution"))) 4920 (cond ((functionp message-distribution-function) 4921 (funcall message-distribution-function)) 4922 (t orig-distribution)))) 4923 4924(defun message-make-expires () 4925 "Return an Expires header based on `message-expires'." 4926 (let ((current (current-time)) 4927 (future (* 1.0 message-expires 60 60 24))) 4928 ;; Add the future to current. 4929 (setcar current (+ (car current) (round (/ future (expt 2 16))))) 4930 (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16)))) 4931 (message-make-date current))) 4932 4933(defun message-make-path () 4934 "Return uucp path." 4935 (let ((login-name (user-login-name))) 4936 (cond ((null message-user-path) 4937 (concat (system-name) "!" login-name)) 4938 ((stringp message-user-path) 4939 ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. 4940 (concat message-user-path "!" login-name)) 4941 (t login-name)))) 4942 4943(defun message-make-from () 4944 "Make a From header." 4945 (let* ((style message-from-style) 4946 (login (message-make-address)) 4947 (fullname 4948 (or (and (boundp 'user-full-name) 4949 user-full-name) 4950 (user-full-name)))) 4951 (when (string= fullname "&") 4952 (setq fullname (user-login-name))) 4953 (with-temp-buffer 4954 (mm-enable-multibyte) 4955 (cond 4956 ((or (null style) 4957 (equal fullname "")) 4958 (insert login)) 4959 ((or (eq style 'angles) 4960 (and (not (eq style 'parens)) 4961 ;; Use angles if no quoting is needed, or if parens would 4962 ;; need quoting too. 4963 (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname)) 4964 (let ((tmp (concat fullname nil))) 4965 (while (string-match "([^()]*)" tmp) 4966 (aset tmp (match-beginning 0) ?-) 4967 (aset tmp (1- (match-end 0)) ?-)) 4968 (string-match "[\\()]" tmp))))) 4969 (insert fullname) 4970 (goto-char (point-min)) 4971 ;; Look for a character that cannot appear unquoted 4972 ;; according to RFC 822. 4973 (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) 4974 ;; Quote fullname, escaping specials. 4975 (goto-char (point-min)) 4976 (insert "\"") 4977 (while (re-search-forward "[\"\\]" nil 1) 4978 (replace-match "\\\\\\&" t)) 4979 (insert "\"")) 4980 (insert " <" login ">")) 4981 (t ; 'parens or default 4982 (insert login " (") 4983 (let ((fullname-start (point))) 4984 (insert fullname) 4985 (goto-char fullname-start) 4986 ;; RFC 822 says \ and nonmatching parentheses 4987 ;; must be escaped in comments. 4988 ;; Escape every instance of ()\ ... 4989 (while (re-search-forward "[()\\]" nil 1) 4990 (replace-match "\\\\\\&" t)) 4991 ;; ... then undo escaping of matching parentheses, 4992 ;; including matching nested parentheses. 4993 (goto-char fullname-start) 4994 (while (re-search-forward 4995 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" 4996 nil 1) 4997 (replace-match "\\1(\\3)" t) 4998 (goto-char fullname-start))) 4999 (insert ")"))) 5000 (buffer-string)))) 5001 5002(defun message-make-sender () 5003 "Return the \"real\" user address. 5004This function tries to ignore all user modifications, and 5005give as trustworthy answer as possible." 5006 (concat (user-login-name) "@" (system-name))) 5007 5008(defun message-make-address () 5009 "Make the address of the user." 5010 (or (message-user-mail-address) 5011 (concat (user-login-name) "@" (message-make-domain)))) 5012 5013(defun message-user-mail-address () 5014 "Return the pertinent part of `user-mail-address'." 5015 (when (and user-mail-address 5016 (string-match "@.*\\." user-mail-address)) 5017 (if (string-match " " user-mail-address) 5018 (nth 1 (mail-extract-address-components user-mail-address)) 5019 user-mail-address))) 5020 5021(defun message-sendmail-envelope-from () 5022 "Return the envelope from." 5023 (cond ((eq message-sendmail-envelope-from 'header) 5024 (nth 1 (mail-extract-address-components 5025 (message-fetch-field "from")))) 5026 ((stringp message-sendmail-envelope-from) 5027 message-sendmail-envelope-from) 5028 (t 5029 (message-make-address)))) 5030 5031(defun message-make-fqdn () 5032 "Return user's fully qualified domain name." 5033 (let* ((system-name (system-name)) 5034 (user-mail (message-user-mail-address)) 5035 (user-domain 5036 (if (and user-mail 5037 (string-match "@\\(.*\\)\\'" user-mail)) 5038 (match-string 1 user-mail))) 5039 (case-fold-search t)) 5040 (cond 5041 ((and message-user-fqdn 5042 (stringp message-user-fqdn) 5043 (string-match message-valid-fqdn-regexp message-user-fqdn) 5044 (not (string-match message-bogus-system-names message-user-fqdn))) 5045 ;; `message-user-fqdn' seems to be valid 5046 message-user-fqdn) 5047 ((and (string-match message-valid-fqdn-regexp system-name) 5048 (not (string-match message-bogus-system-names system-name))) 5049 ;; `system-name' returned the right result. 5050 system-name) 5051 ;; Try `mail-host-address'. 5052 ((and (boundp 'mail-host-address) 5053 (stringp mail-host-address) 5054 (string-match message-valid-fqdn-regexp mail-host-address) 5055 (not (string-match message-bogus-system-names mail-host-address))) 5056 mail-host-address) 5057 ;; We try `user-mail-address' as a backup. 5058 ((and user-domain 5059 (stringp user-domain) 5060 (string-match message-valid-fqdn-regexp user-domain) 5061 (not (string-match message-bogus-system-names user-domain))) 5062 user-domain) 5063 ;; Default to this bogus thing. 5064 (t 5065 (concat system-name 5066 ".i-did-not-set--mail-host-address--so-tickle-me"))))) 5067 5068(defun message-make-host-name () 5069 "Return the name of the host." 5070 (let ((fqdn (message-make-fqdn))) 5071 (string-match "^[^.]+\\." fqdn) 5072 (substring fqdn 0 (1- (match-end 0))))) 5073 5074(defun message-make-domain () 5075 "Return the domain name." 5076 (or mail-host-address 5077 (message-make-fqdn))) 5078 5079(defun message-to-list-only () 5080 "Send a message to the list only. 5081Remove all addresses but the list address from To and Cc headers." 5082 (interactive) 5083 (let ((listaddr (message-make-mail-followup-to t))) 5084 (when listaddr 5085 (save-excursion 5086 (message-remove-header "to") 5087 (message-remove-header "cc") 5088 (message-position-on-field "To" "X-Draft-From") 5089 (insert listaddr))))) 5090 5091(defun message-make-mail-followup-to (&optional only-show-subscribed) 5092 "Return the Mail-Followup-To header. 5093If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the 5094subscribed address (and not the additional To and Cc header contents)." 5095 (let* ((case-fold-search t) 5096 (to (message-fetch-field "To")) 5097 (cc (message-fetch-field "cc")) 5098 (msg-recipients (concat to (and to cc ", ") cc)) 5099 (recipients 5100 (mapcar 'mail-strip-quoted-names 5101 (message-tokenize-header msg-recipients))) 5102 (file-regexps 5103 (if message-subscribed-address-file 5104 (let (begin end item re) 5105 (save-excursion 5106 (with-temp-buffer 5107 (insert-file-contents message-subscribed-address-file) 5108 (while (not (eobp)) 5109 (setq begin (point)) 5110 (forward-line 1) 5111 (setq end (point)) 5112 (if (bolp) (setq end (1- end))) 5113 (setq item (regexp-quote (buffer-substring begin end))) 5114 (if re (setq re (concat re "\\|" item)) 5115 (setq re (concat "\\`\\(" item)))) 5116 (and re (list (concat re "\\)\\'")))))))) 5117 (mft-regexps (apply 'append message-subscribed-regexps 5118 (mapcar 'regexp-quote 5119 message-subscribed-addresses) 5120 file-regexps 5121 (mapcar 'funcall 5122 message-subscribed-address-functions)))) 5123 (save-match-data 5124 (let ((subscribed-lists nil) 5125 (list 5126 (loop for recipient in recipients 5127 when (loop for regexp in mft-regexps 5128 when (string-match regexp recipient) return t) 5129 return recipient))) 5130 (when list 5131 (if only-show-subscribed 5132 list 5133 msg-recipients)))))) 5134 5135(defun message-idna-to-ascii-rhs-1 (header) 5136 "Interactively potentially IDNA encode domain names in HEADER." 5137 (let ((field (message-fetch-field header)) 5138 rhs ace address) 5139 (when field 5140 (dolist (rhs 5141 (mm-delete-duplicates 5142 (mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) "")) 5143 (mapcar 'downcase 5144 (mapcar 5145 'car (mail-header-parse-addresses field)))))) 5146 (setq ace (downcase (idna-to-ascii rhs))) 5147 (when (and (not (equal rhs ace)) 5148 (or (not (eq message-use-idna 'ask)) 5149 (y-or-n-p (format "Replace %s with %s in %s:? " 5150 rhs ace header)))) 5151 (goto-char (point-min)) 5152 (while (re-search-forward (concat "^" header ":") nil t) 5153 (message-narrow-to-field) 5154 (while (search-forward (concat "@" rhs) nil t) 5155 (replace-match (concat "@" ace) t t)) 5156 (goto-char (point-max)) 5157 (widen))))))) 5158 5159(defun message-idna-to-ascii-rhs () 5160 "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers. 5161See `message-idna-encode'." 5162 (interactive) 5163 (when message-use-idna 5164 (save-excursion 5165 (save-restriction 5166 (message-narrow-to-head) 5167 (message-idna-to-ascii-rhs-1 "From") 5168 (message-idna-to-ascii-rhs-1 "To") 5169 (message-idna-to-ascii-rhs-1 "Reply-To") 5170 (message-idna-to-ascii-rhs-1 "Mail-Reply-To") 5171 (message-idna-to-ascii-rhs-1 "Mail-Followup-To") 5172 (message-idna-to-ascii-rhs-1 "Cc"))))) 5173 5174(defun message-generate-headers (headers) 5175 "Prepare article HEADERS. 5176Headers already prepared in the buffer are not modified." 5177 (setq headers (append headers message-required-headers)) 5178 (save-restriction 5179 (message-narrow-to-headers) 5180 (let* ((Date (message-make-date)) 5181 (Message-ID (message-make-message-id)) 5182 (Organization (message-make-organization)) 5183 (From (message-make-from)) 5184 (Path (message-make-path)) 5185 (Subject nil) 5186 (Newsgroups nil) 5187 (In-Reply-To (message-make-in-reply-to)) 5188 (References (message-make-references)) 5189 (To nil) 5190 (Distribution (message-make-distribution)) 5191 (Lines (message-make-lines)) 5192 (User-Agent message-newsreader) 5193 (Expires (message-make-expires)) 5194 (case-fold-search t) 5195 (optionalp nil) 5196 header value elem header-string) 5197 ;; First we remove any old generated headers. 5198 (let ((headers message-deletable-headers)) 5199 (unless (buffer-modified-p) 5200 (setq headers (delq 'Message-ID (copy-sequence headers)))) 5201 (while headers 5202 (goto-char (point-min)) 5203 (and (re-search-forward 5204 (concat "^" (symbol-name (car headers)) ": *") nil t) 5205 (get-text-property (1+ (match-beginning 0)) 'message-deletable) 5206 (message-delete-line)) 5207 (pop headers))) 5208 ;; Go through all the required headers and see if they are in the 5209 ;; articles already. If they are not, or are empty, they are 5210 ;; inserted automatically - except for Subject, Newsgroups and 5211 ;; Distribution. 5212 (while headers 5213 (goto-char (point-min)) 5214 (setq elem (pop headers)) 5215 (if (consp elem) 5216 (if (eq (car elem) 'optional) 5217 (setq header (cdr elem) 5218 optionalp t) 5219 (setq header (car elem))) 5220 (setq header elem)) 5221 (setq header-string (if (stringp header) 5222 header 5223 (symbol-name header))) 5224 (when (or (not (re-search-forward 5225 (concat "^" 5226 (regexp-quote (downcase header-string)) 5227 ":") 5228 nil t)) 5229 (progn 5230 ;; The header was found. We insert a space after the 5231 ;; colon, if there is none. 5232 (if (/= (char-after) ? ) (insert " ") (forward-char 1)) 5233 ;; Find out whether the header is empty. 5234 (looking-at "[ \t]*\n[^ \t]"))) 5235 ;; So we find out what value we should insert. 5236 (setq value 5237 (cond 5238 ((and (consp elem) 5239 (eq (car elem) 'optional) 5240 (not (member header-string message-inserted-headers))) 5241 ;; This is an optional header. If the cdr of this 5242 ;; is something that is nil, then we do not insert 5243 ;; this header. 5244 (setq header (cdr elem)) 5245 (or (and (functionp (cdr elem)) 5246 (funcall (cdr elem))) 5247 (and (boundp (cdr elem)) 5248 (symbol-value (cdr elem))))) 5249 ((consp elem) 5250 ;; The element is a cons. Either the cdr is a 5251 ;; string to be inserted verbatim, or it is a 5252 ;; function, and we insert the value returned from 5253 ;; this function. 5254 (or (and (stringp (cdr elem)) 5255 (cdr elem)) 5256 (and (functionp (cdr elem)) 5257 (funcall (cdr elem))))) 5258 ((and (boundp header) 5259 (symbol-value header)) 5260 ;; The element is a symbol. We insert the value 5261 ;; of this symbol, if any. 5262 (symbol-value header)) 5263 ((not (message-check-element 5264 (intern (downcase (symbol-name header))))) 5265 ;; We couldn't generate a value for this header, 5266 ;; so we just ask the user. 5267 (read-from-minibuffer 5268 (format "Empty header for %s; enter value: " header))))) 5269 ;; Finally insert the header. 5270 (when (and value 5271 (not (equal value ""))) 5272 (save-excursion 5273 (if (bolp) 5274 (progn 5275 ;; This header didn't exist, so we insert it. 5276 (goto-char (point-max)) 5277 (let ((formatter 5278 (cdr (assq header message-header-format-alist)))) 5279 (if formatter 5280 (funcall formatter header value) 5281 (insert header-string ": " value)) 5282 ;; We check whether the value was ended by a 5283 ;; newline. If now, we insert one. 5284 (unless (bolp) 5285 (insert "\n")) 5286 (forward-line -1))) 5287 ;; The value of this header was empty, so we clear 5288 ;; totally and insert the new value. 5289 (delete-region (point) (gnus-point-at-eol)) 5290 ;; If the header is optional, and the header was 5291 ;; empty, we con't insert it anyway. 5292 (unless optionalp 5293 (push header-string message-inserted-headers) 5294 (insert value))) 5295 ;; Add the deletable property to the headers that require it. 5296 (and (memq header message-deletable-headers) 5297 (progn (beginning-of-line) (looking-at "[^:]+: ")) 5298 (add-text-properties 5299 (point) (match-end 0) 5300 '(message-deletable t face italic) (current-buffer))))))) 5301 ;; Insert new Sender if the From is strange. 5302 (let ((from (message-fetch-field "from")) 5303 (sender (message-fetch-field "sender")) 5304 (secure-sender (message-make-sender))) 5305 (when (and from 5306 (not (message-check-element 'sender)) 5307 (not (string= 5308 (downcase 5309 (cadr (mail-extract-address-components from))) 5310 (downcase secure-sender))) 5311 (or (null sender) 5312 (not 5313 (string= 5314 (downcase 5315 (cadr (mail-extract-address-components sender))) 5316 (downcase secure-sender))))) 5317 (goto-char (point-min)) 5318 ;; Rename any old Sender headers to Original-Sender. 5319 (when (re-search-forward "^\\(Original-\\)*Sender:" nil t) 5320 (beginning-of-line) 5321 (insert "Original-") 5322 (beginning-of-line)) 5323 (when (or (message-news-p) 5324 (string-match "@.+\\.." secure-sender)) 5325 (insert "Sender: " secure-sender "\n")))) 5326 ;; Check for IDNA 5327 (message-idna-to-ascii-rhs)))) 5328 5329(defun message-insert-courtesy-copy () 5330 "Insert a courtesy message in mail copies of combined messages." 5331 (let (newsgroups) 5332 (save-excursion 5333 (save-restriction 5334 (message-narrow-to-headers) 5335 (when (setq newsgroups (message-fetch-field "newsgroups")) 5336 (goto-char (point-max)) 5337 (insert "Posted-To: " newsgroups "\n"))) 5338 (forward-line 1) 5339 (when message-courtesy-message 5340 (cond 5341 ((string-match "%s" message-courtesy-message) 5342 (insert (format message-courtesy-message newsgroups))) 5343 (t 5344 (insert message-courtesy-message))))))) 5345 5346;;; 5347;;; Setting up a message buffer 5348;;; 5349 5350(defun message-fill-address (header value) 5351 (save-restriction 5352 (narrow-to-region (point) (point)) 5353 (insert (capitalize (symbol-name header)) 5354 ": " 5355 (if (consp value) (car value) value) 5356 "\n") 5357 (narrow-to-region (point-min) (1- (point-max))) 5358 (let (quoted last) 5359 (goto-char (point-min)) 5360 (while (not (eobp)) 5361 (skip-chars-forward "^,\"" (point-max)) 5362 (if (or (eq (char-after) ?,) 5363 (eobp)) 5364 (when (not quoted) 5365 (if (and (> (current-column) 78) 5366 last) 5367 (progn 5368 (save-excursion 5369 (goto-char last) 5370 (insert "\n\t")) 5371 (setq last (1+ (point)))) 5372 (setq last (1+ (point))))) 5373 (setq quoted (not quoted))) 5374 (unless (eobp) 5375 (forward-char 1)))) 5376 (goto-char (point-max)) 5377 (widen) 5378 (forward-line 1))) 5379 5380(defun message-split-line () 5381 "Split current line, moving portion beyond point vertically down. 5382If the current line has `message-yank-prefix', insert it on the new line." 5383 (interactive "*") 5384 (condition-case nil 5385 (split-line message-yank-prefix) ;; Emacs 22.1+ supports arg. 5386 (error 5387 (split-line)))) 5388 5389(defun message-fill-header (header value) 5390 (let ((begin (point)) 5391 (fill-column 78) 5392 (fill-prefix "\t")) 5393 (insert (capitalize (symbol-name header)) 5394 ": " 5395 (if (consp value) (car value) value) 5396 "\n") 5397 (save-restriction 5398 (narrow-to-region begin (point)) 5399 (fill-region-as-paragraph begin (point)) 5400 ;; Tapdance around looong Message-IDs. 5401 (forward-line -1) 5402 (when (looking-at "[ \t]*$") 5403 (message-delete-line)) 5404 (goto-char begin) 5405 (re-search-forward ":" nil t) 5406 (when (looking-at "\n[ \t]+") 5407 (replace-match " " t t)) 5408 (goto-char (point-max))))) 5409 5410(defun message-shorten-1 (list cut surplus) 5411 "Cut SURPLUS elements out of LIST, beginning with CUTth one." 5412 (setcdr (nthcdr (- cut 2) list) 5413 (nthcdr (+ (- cut 2) surplus 1) list))) 5414 5415(defun message-shorten-references (header references) 5416 "Trim REFERENCES to be 21 Message-ID long or less, and fold them. 5417If folding is disallowed, also check that the REFERENCES are less 5418than 988 characters long, and if they are not, trim them until they are." 5419 (let ((maxcount 21) 5420 (count 0) 5421 (cut 2) 5422 refs) 5423 (with-temp-buffer 5424 (insert references) 5425 (goto-char (point-min)) 5426 ;; Cons a list of valid references. 5427 (while (re-search-forward "<[^>]+>" nil t) 5428 (push (match-string 0) refs)) 5429 (setq refs (nreverse refs) 5430 count (length refs))) 5431 5432 ;; If the list has more than MAXCOUNT elements, trim it by 5433 ;; removing the CUTth element and the required number of 5434 ;; elements that follow. 5435 (when (> count maxcount) 5436 (let ((surplus (- count maxcount))) 5437 (message-shorten-1 refs cut surplus) 5438 (decf count surplus))) 5439 5440 ;; If folding is disallowed, make sure the total length (including 5441 ;; the spaces between) will be less than MAXSIZE characters. 5442 ;; 5443 ;; Only disallow folding for News messages. At this point the headers 5444 ;; have not been generated, thus we use message-this-is-news directly. 5445 (when (and message-this-is-news message-cater-to-broken-inn) 5446 (let ((maxsize 988) 5447 (totalsize (+ (apply #'+ (mapcar #'length refs)) 5448 (1- count))) 5449 (surplus 0) 5450 (ptr (nthcdr (1- cut) refs))) 5451 ;; Decide how many elements to cut off... 5452 (while (> totalsize maxsize) 5453 (decf totalsize (1+ (length (car ptr)))) 5454 (incf surplus) 5455 (setq ptr (cdr ptr))) 5456 ;; ...and do it. 5457 (when (> surplus 0) 5458 (message-shorten-1 refs cut surplus)))) 5459 5460 ;; Finally, collect the references back into a string and insert 5461 ;; it into the buffer. 5462 (let ((refstring (mapconcat #'identity refs " "))) 5463 (if (and message-this-is-news message-cater-to-broken-inn) 5464 (insert (capitalize (symbol-name header)) ": " 5465 refstring "\n") 5466 (message-fill-header header refstring))))) 5467 5468(defun message-position-point () 5469 "Move point to where the user probably wants to find it." 5470 (message-narrow-to-headers) 5471 (cond 5472 ((re-search-forward "^[^:]+:[ \t]*$" nil t) 5473 (search-backward ":" ) 5474 (widen) 5475 (forward-char 1) 5476 (if (eq (char-after) ? ) 5477 (forward-char 1) 5478 (insert " "))) 5479 (t 5480 (goto-char (point-max)) 5481 (widen) 5482 (forward-line 1) 5483 (unless (looking-at "$") 5484 (forward-line 2))) 5485 (sit-for 0))) 5486 5487(defcustom message-beginning-of-line t 5488 "Whether \\<message-mode-map>\\[message-beginning-of-line]\ 5489 goes to beginning of header values." 5490 :version "22.1" 5491 :group 'message-buffers 5492 :link '(custom-manual "(message)Movement") 5493 :type 'boolean) 5494 5495(defun message-beginning-of-line (&optional n) 5496 "Move point to beginning of header value or to beginning of line. 5497The prefix argument N is passed directly to `beginning-of-line'. 5498 5499This command is identical to `beginning-of-line' if point is 5500outside the message header or if the option `message-beginning-of-line' 5501is nil. 5502 5503If point is in the message header and on a (non-continued) header 5504line, move point to the beginning of the header value or the beginning of line, 5505whichever is closer. If point is already at beginning of line, move point to 5506beginning of header value. Therefore, repeated calls will toggle point 5507between beginning of field and beginning of line." 5508 (interactive "p") 5509 (let ((zrs 'zmacs-region-stays)) 5510 (when (and (interactive-p) (boundp zrs)) 5511 (set zrs t))) 5512 (if (and message-beginning-of-line 5513 (message-point-in-header-p)) 5514 (let* ((here (point)) 5515 (bol (progn (beginning-of-line n) (point))) 5516 (eol (gnus-point-at-eol)) 5517 (eoh (re-search-forward ": *" eol t))) 5518 (goto-char 5519 (if (and eoh (or (< eoh here) (= bol here))) 5520 eoh bol))) 5521 (beginning-of-line n))) 5522 5523(defun message-buffer-name (type &optional to group) 5524 "Return a new (unique) buffer name based on TYPE and TO." 5525 (cond 5526 ;; Generate a new buffer name The Message Way. 5527 ((memq message-generate-new-buffers '(unique t)) 5528 (generate-new-buffer-name 5529 (concat "*" type 5530 (if to 5531 (concat " to " 5532 (or (car (mail-extract-address-components to)) 5533 to) "") 5534 "") 5535 (if (and group (not (string= group ""))) (concat " on " group) "") 5536 "*"))) 5537 ;; Check whether `message-generate-new-buffers' is a function, 5538 ;; and if so, call it. 5539 ((functionp message-generate-new-buffers) 5540 (funcall message-generate-new-buffers type to group)) 5541 ((eq message-generate-new-buffers 'unsent) 5542 (generate-new-buffer-name 5543 (concat "*unsent " type 5544 (if to 5545 (concat " to " 5546 (or (car (mail-extract-address-components to)) 5547 to) "") 5548 "") 5549 (if (and group (not (string= group ""))) (concat " on " group) "") 5550 "*"))) 5551 ;; Search for the existing message buffer with the specified name. 5552 (t 5553 (let* ((new (if (eq message-generate-new-buffers 'standard) 5554 (generate-new-buffer-name (concat "*" type " message*")) 5555 (let ((message-generate-new-buffers 'unique)) 5556 (message-buffer-name type to group)))) 5557 (regexp (concat "\\`" 5558 (regexp-quote 5559 (if (string-match "<[0-9]+>\\'" new) 5560 (substring new 0 (match-beginning 0)) 5561 new)) 5562 "\\(?:<\\([0-9]+\\)>\\)?\\'")) 5563 (case-fold-search nil)) 5564 (or (cdar 5565 (last 5566 (sort 5567 (delq nil 5568 (mapcar 5569 (lambda (b) 5570 (when (and (string-match regexp (setq b (buffer-name b))) 5571 (eq (with-current-buffer b major-mode) 5572 'message-mode)) 5573 (cons (string-to-number (or (match-string 1 b) "1")) 5574 b))) 5575 (buffer-list))) 5576 'car-less-than-car))) 5577 new))))) 5578 5579(defun message-pop-to-buffer (name &optional switch-function) 5580 "Pop to buffer NAME, and warn if it already exists and is modified." 5581 (let ((buffer (get-buffer name))) 5582 (if (and buffer 5583 (buffer-name buffer)) 5584 (let ((window (get-buffer-window buffer 0))) 5585 (if window 5586 ;; Raise the frame already displaying the message buffer. 5587 (progn 5588 (gnus-select-frame-set-input-focus (window-frame window)) 5589 (select-window window)) 5590 (funcall (or switch-function 'pop-to-buffer) buffer) 5591 (set-buffer buffer)) 5592 (when (and (buffer-modified-p) 5593 (not (prog1 5594 (y-or-n-p 5595 "Message already being composed; erase? ") 5596 (message nil)))) 5597 (error "Message being composed"))) 5598 (funcall (or switch-function 'pop-to-buffer) name) 5599 (set-buffer name)) 5600 (erase-buffer) 5601 (message-mode))) 5602 5603(defun message-do-send-housekeeping () 5604 "Kill old message buffers." 5605 ;; We might have sent this buffer already. Delete it from the 5606 ;; list of buffers. 5607 (setq message-buffer-list (delq (current-buffer) message-buffer-list)) 5608 (while (and message-max-buffers 5609 message-buffer-list 5610 (>= (length message-buffer-list) message-max-buffers)) 5611 ;; Kill the oldest buffer -- unless it has been changed. 5612 (let ((buffer (pop message-buffer-list))) 5613 (when (and (buffer-name buffer) 5614 (not (buffer-modified-p buffer))) 5615 (kill-buffer buffer)))) 5616 ;; Rename the buffer. 5617 (if message-send-rename-function 5618 (funcall message-send-rename-function) 5619 ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus. 5620 (when (string-match 5621 "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to " 5622 (buffer-name)) 5623 (let ((name (match-string 2 (buffer-name))) 5624 to group) 5625 (if (not (or (null name) 5626 (string-equal name "mail") 5627 (string-equal name "posting"))) 5628 (setq name (concat "*sent " name "*")) 5629 (message-narrow-to-headers) 5630 (setq to (message-fetch-field "to")) 5631 (setq group (message-fetch-field "newsgroups")) 5632 (widen) 5633 (setq name 5634 (cond 5635 (to (concat "*sent mail to " 5636 (or (car (mail-extract-address-components to)) 5637 to) "*")) 5638 ((and group (not (string= group ""))) 5639 (concat "*sent posting on " group "*")) 5640 (t "*sent mail*")))) 5641 (unless (string-equal name (buffer-name)) 5642 (rename-buffer name t))))) 5643 ;; Push the current buffer onto the list. 5644 (when message-max-buffers 5645 (setq message-buffer-list 5646 (nconc message-buffer-list (list (current-buffer)))))) 5647 5648(defun message-mail-user-agent () 5649 (let ((mua (cond 5650 ((not message-mail-user-agent) nil) 5651 ((eq message-mail-user-agent t) mail-user-agent) 5652 (t message-mail-user-agent)))) 5653 (if (memq mua '(message-user-agent gnus-user-agent)) 5654 nil 5655 mua))) 5656 5657(defun message-setup (headers &optional replybuffer actions 5658 continue switch-function) 5659 (let ((mua (message-mail-user-agent)) 5660 subject to field yank-action) 5661 (if (not (and message-this-is-mail mua)) 5662 (message-setup-1 headers replybuffer actions) 5663 (if replybuffer 5664 (setq yank-action (list 'insert-buffer replybuffer))) 5665 (setq headers (copy-sequence headers)) 5666 (setq field (assq 'Subject headers)) 5667 (when field 5668 (setq subject (cdr field)) 5669 (setq headers (delq field headers))) 5670 (setq field (assq 'To headers)) 5671 (when field 5672 (setq to (cdr field)) 5673 (setq headers (delq field headers))) 5674 (let ((mail-user-agent mua)) 5675 (compose-mail to subject 5676 (mapcar (lambda (item) 5677 (cons 5678 (format "%s" (car item)) 5679 (cdr item))) 5680 headers) 5681 continue switch-function yank-action actions))))) 5682 5683(defun message-headers-to-generate (headers included-headers excluded-headers) 5684 "Return a list that includes all headers from HEADERS. 5685If INCLUDED-HEADERS is a list, just include those headers. If it is 5686t, include all headers. In any case, headers from EXCLUDED-HEADERS 5687are not included." 5688 (let ((result nil) 5689 header-name) 5690 (dolist (header headers) 5691 (setq header-name (cond 5692 ((and (consp header) 5693 (eq (car header) 'optional)) 5694 ;; On the form (optional . Header) 5695 (cdr header)) 5696 ((consp header) 5697 ;; On the form (Header . function) 5698 (car header)) 5699 (t 5700 ;; Just a Header. 5701 header))) 5702 (when (and (not (memq header-name excluded-headers)) 5703 (or (eq included-headers t) 5704 (memq header-name included-headers))) 5705 (push header result))) 5706 (nreverse result))) 5707 5708(defun message-setup-1 (headers &optional replybuffer actions) 5709 (dolist (action actions) 5710 (condition-case nil 5711 (add-to-list 'message-send-actions 5712 `(apply ',(car action) ',(cdr action))))) 5713 (setq message-reply-buffer replybuffer) 5714 (goto-char (point-min)) 5715 ;; Insert all the headers. 5716 (mail-header-format 5717 (let ((h headers) 5718 (alist message-header-format-alist)) 5719 (while h 5720 (unless (assq (caar h) message-header-format-alist) 5721 (push (list (caar h)) alist)) 5722 (pop h)) 5723 alist) 5724 headers) 5725 (delete-region (point) (progn (forward-line -1) (point))) 5726 (when message-default-headers 5727 (insert message-default-headers) 5728 (or (bolp) (insert ?\n))) 5729 (put-text-property 5730 (point) 5731 (progn 5732 (insert mail-header-separator "\n") 5733 (1- (point))) 5734 'read-only nil) 5735 (forward-line -1) 5736 (when (message-news-p) 5737 (when message-default-news-headers 5738 (insert message-default-news-headers) 5739 (or (bolp) (insert ?\n))) 5740 (when message-generate-headers-first 5741 (message-generate-headers 5742 (message-headers-to-generate 5743 (append message-required-news-headers 5744 message-required-headers) 5745 message-generate-headers-first 5746 '(Lines Subject))))) 5747 (when (message-mail-p) 5748 (when message-default-mail-headers 5749 (insert message-default-mail-headers) 5750 (or (bolp) (insert ?\n))) 5751 (when message-generate-headers-first 5752 (message-generate-headers 5753 (message-headers-to-generate 5754 (append message-required-mail-headers 5755 message-required-headers) 5756 message-generate-headers-first 5757 '(Lines Subject))))) 5758 (run-hooks 'message-signature-setup-hook) 5759 (message-insert-signature) 5760 (save-restriction 5761 (message-narrow-to-headers) 5762 (run-hooks 'message-header-setup-hook)) 5763 (set-buffer-modified-p nil) 5764 (setq buffer-undo-list nil) 5765 (run-hooks 'message-setup-hook) 5766 ;; Do this last to give it precedence over posting styles, etc. 5767 (when (message-mail-p) 5768 (save-restriction 5769 (message-narrow-to-headers) 5770 (if message-alternative-emails 5771 (message-use-alternative-email-as-from)))) 5772 (message-position-point) 5773 (undo-boundary)) 5774 5775(defun message-set-auto-save-file-name () 5776 "Associate the message buffer with a file in the drafts directory." 5777 (when message-auto-save-directory 5778 (unless (file-directory-p 5779 (directory-file-name message-auto-save-directory)) 5780 (make-directory message-auto-save-directory t)) 5781 (if (gnus-alive-p) 5782 (setq message-draft-article 5783 (nndraft-request-associate-buffer "drafts")) 5784 (setq buffer-file-name (expand-file-name 5785 (if (memq system-type 5786 '(ms-dos ms-windows windows-nt 5787 cygwin cygwin32 win32 w32 5788 mswindows)) 5789 "message" 5790 "*message*") 5791 message-auto-save-directory)) 5792 (setq buffer-auto-save-file-name (make-auto-save-file-name))) 5793 (clear-visited-file-modtime) 5794 (setq buffer-file-coding-system message-draft-coding-system))) 5795 5796(defun message-disassociate-draft () 5797 "Disassociate the message buffer from the drafts directory." 5798 (when message-draft-article 5799 (nndraft-request-expire-articles 5800 (list message-draft-article) "drafts" nil t))) 5801 5802(defun message-insert-headers () 5803 "Generate the headers for the article." 5804 (interactive) 5805 (save-excursion 5806 (save-restriction 5807 (message-narrow-to-headers) 5808 (when (message-news-p) 5809 (message-generate-headers 5810 (delq 'Lines 5811 (delq 'Subject 5812 (copy-sequence message-required-news-headers))))) 5813 (when (message-mail-p) 5814 (message-generate-headers 5815 (delq 'Lines 5816 (delq 'Subject 5817 (copy-sequence message-required-mail-headers)))))))) 5818 5819 5820 5821;;; 5822;;; Commands for interfacing with message 5823;;; 5824 5825;;;###autoload 5826(defun message-mail (&optional to subject 5827 other-headers continue switch-function 5828 yank-action send-actions) 5829 "Start editing a mail message to be sent. 5830OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether 5831to continue editing a message already being composed. SWITCH-FUNCTION 5832is a function used to switch to and display the mail buffer." 5833 (interactive) 5834 (let ((message-this-is-mail t) replybuffer) 5835 (unless (message-mail-user-agent) 5836 (message-pop-to-buffer 5837 ;; Search for the existing message buffer if `continue' is non-nil. 5838 (let ((message-generate-new-buffers 5839 (when (or (not continue) 5840 (eq message-generate-new-buffers 'standard) 5841 (functionp message-generate-new-buffers)) 5842 message-generate-new-buffers))) 5843 (message-buffer-name "mail" to)) 5844 switch-function)) 5845 ;; FIXME: message-mail should do something if YANK-ACTION is not 5846 ;; insert-buffer. 5847 (and (consp yank-action) (eq (car yank-action) 'insert-buffer) 5848 (setq replybuffer (nth 1 yank-action))) 5849 (message-setup 5850 (nconc 5851 `((To . ,(or to "")) (Subject . ,(or subject ""))) 5852 (when other-headers other-headers)) 5853 replybuffer send-actions continue switch-function) 5854 ;; FIXME: Should return nil if failure. 5855 t)) 5856 5857;;;###autoload 5858(defun message-news (&optional newsgroups subject) 5859 "Start editing a news article to be sent." 5860 (interactive) 5861 (let ((message-this-is-news t)) 5862 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)) 5863 (message-setup `((Newsgroups . ,(or newsgroups "")) 5864 (Subject . ,(or subject "")))))) 5865 5866(defun message-get-reply-headers (wide &optional to-address address-headers) 5867 (let (follow-to mct never-mct to cc author mft recipients) 5868 ;; Find all relevant headers we need. 5869 (save-restriction 5870 (message-narrow-to-headers-or-head) 5871 ;; Gmane renames "To". Look at "Original-To", too, if it is present in 5872 ;; message-header-synonyms. 5873 (setq to (or (message-fetch-field "to") 5874 (and (loop for synonym in message-header-synonyms 5875 when (memq 'Original-To synonym) 5876 return t) 5877 (message-fetch-field "original-to"))) 5878 cc (message-fetch-field "cc") 5879 mct (message-fetch-field "mail-copies-to") 5880 author (or (message-fetch-field "mail-reply-to") 5881 (message-fetch-field "reply-to") 5882 (message-fetch-field "from") 5883 "") 5884 mft (and message-use-mail-followup-to 5885 (message-fetch-field "mail-followup-to")))) 5886 5887 ;; Handle special values of Mail-Copies-To. 5888 (when mct 5889 (cond ((or (equal (downcase mct) "never") 5890 (equal (downcase mct) "nobody")) 5891 (setq never-mct t) 5892 (setq mct nil)) 5893 ((or (equal (downcase mct) "always") 5894 (equal (downcase mct) "poster")) 5895 (setq mct author)))) 5896 5897 (save-match-data 5898 ;; Build (textual) list of new recipient addresses. 5899 (cond 5900 ((not wide) 5901 (setq recipients (concat ", " author))) 5902 (address-headers 5903 (dolist (header address-headers) 5904 (let ((value (message-fetch-field header))) 5905 (when value 5906 (setq recipients (concat recipients ", " value)))))) 5907 ((and mft 5908 (string-match "[^ \t,]" mft) 5909 (or (not (eq message-use-mail-followup-to 'ask)) 5910 (message-y-or-n-p "Obey Mail-Followup-To? " t "\ 5911You should normally obey the Mail-Followup-To: header. In this 5912article, it has the value of 5913 5914" mft " 5915 5916which directs your response to " (if (string-match "," mft) 5917 "the specified addresses" 5918 "that address only") ". 5919 5920Most commonly, Mail-Followup-To is used by a mailing list poster to 5921express that responses should be sent to just the list, and not the 5922poster as well. 5923 5924If a message is posted to several mailing lists, Mail-Followup-To may 5925also be used to direct the following discussion to one list only, 5926because discussions that are spread over several lists tend to be 5927fragmented and very difficult to follow. 5928 5929Also, some source/announcement lists are not intended for discussion; 5930responses here are directed to other addresses. 5931 5932You may customize the variable `message-use-mail-followup-to', if you 5933want to get rid of this query permanently."))) 5934 (setq recipients (concat ", " mft))) 5935 (to-address 5936 (setq recipients (concat ", " to-address)) 5937 ;; If the author explicitly asked for a copy, we don't deny it to them. 5938 (if mct (setq recipients (concat recipients ", " mct)))) 5939 (t 5940 (setq recipients (if never-mct "" (concat ", " author))) 5941 (if to (setq recipients (concat recipients ", " to))) 5942 (if cc (setq recipients (concat recipients ", " cc))) 5943 (if mct (setq recipients (concat recipients ", " mct))))) 5944 (if (>= (length recipients) 2) 5945 ;; Strip the leading ", ". 5946 (setq recipients (substring recipients 2))) 5947 ;; Squeeze whitespace. 5948 (while (string-match "[ \t][ \t]+" recipients) 5949 (setq recipients (replace-match " " t t recipients))) 5950 ;; Remove addresses that match `rmail-dont-reply-to-names'. 5951 (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) 5952 (setq recipients (rmail-dont-reply-to recipients))) 5953 ;; Perhaps "Mail-Copies-To: never" removed the only address? 5954 (if (string-equal recipients "") 5955 (setq recipients author)) 5956 ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...). 5957 (setq recipients 5958 (mapcar 5959 (lambda (addr) 5960 (cons (downcase (mail-strip-quoted-names addr)) addr)) 5961 (message-tokenize-header recipients))) 5962 ;; Remove first duplicates. (Why not all duplicates? Is this a bug?) 5963 (let ((s recipients)) 5964 (while s 5965 (setq recipients (delq (assoc (car (pop s)) s) recipients)))) 5966 5967 ;; Remove hierarchical lists that are contained within each other, 5968 ;; if message-hierarchical-addresses is defined. 5969 (when message-hierarchical-addresses 5970 (let ((plain-addrs (mapcar 'car recipients)) 5971 subaddrs recip) 5972 (while plain-addrs 5973 (setq subaddrs (assoc (car plain-addrs) 5974 message-hierarchical-addresses) 5975 plain-addrs (cdr plain-addrs)) 5976 (when subaddrs 5977 (setq subaddrs (cdr subaddrs)) 5978 (while subaddrs 5979 (setq recip (assoc (car subaddrs) recipients) 5980 subaddrs (cdr subaddrs)) 5981 (if recip 5982 (setq recipients (delq recip recipients)))))))) 5983 5984 ;; Build the header alist. Allow the user to be asked whether 5985 ;; or not to reply to all recipients in a wide reply. 5986 (setq follow-to (list (cons 'To (cdr (pop recipients))))) 5987 (when (and recipients 5988 (or (not message-wide-reply-confirm-recipients) 5989 (y-or-n-p "Reply to all recipients? "))) 5990 (setq recipients (mapconcat 5991 (lambda (addr) (cdr addr)) recipients ", ")) 5992 (if (string-match "^ +" recipients) 5993 (setq recipients (substring recipients (match-end 0)))) 5994 (push (cons 'Cc recipients) follow-to))) 5995 follow-to)) 5996 5997(defcustom message-simplify-subject-functions 5998 '(message-strip-list-identifiers 5999 message-strip-subject-re 6000 message-strip-subject-trailing-was 6001 message-strip-subject-encoded-words) 6002 "List of functions taking a string argument that simplify subjects. 6003The functions are applied when replying to a message. 6004 6005Useful functions to put in this list include: 6006`message-strip-list-identifiers', `message-strip-subject-re', 6007`message-strip-subject-trailing-was', and 6008`message-strip-subject-encoded-words'." 6009 :version "22.1" ;; Gnus 5.10.9 6010 :group 'message-various 6011 :type '(repeat function)) 6012 6013(defun message-simplify-subject (subject &optional functions) 6014 "Return simplified SUBJECT." 6015 (unless functions 6016 ;; Simplify fully: 6017 (setq functions message-simplify-subject-functions)) 6018 (when (and (memq 'message-strip-list-identifiers functions) 6019 gnus-list-identifiers) 6020 (setq subject (message-strip-list-identifiers subject))) 6021 (when (memq 'message-strip-subject-re functions) 6022 (setq subject (concat "Re: " (message-strip-subject-re subject)))) 6023 (when (and (memq 'message-strip-subject-trailing-was functions) 6024 message-subject-trailing-was-query) 6025 (setq subject (message-strip-subject-trailing-was subject))) 6026 (when (memq 'message-strip-subject-encoded-words functions) 6027 (setq subject (message-strip-subject-encoded-words subject))) 6028 subject) 6029 6030;;;###autoload 6031(defun message-reply (&optional to-address wide) 6032 "Start editing a reply to the article in the current buffer." 6033 (interactive) 6034 (require 'gnus-sum) ; for gnus-list-identifiers 6035 (let ((cur (current-buffer)) 6036 from subject date reply-to to cc 6037 references message-id follow-to 6038 (inhibit-point-motion-hooks t) 6039 (message-this-is-mail t) 6040 gnus-warning) 6041 (save-restriction 6042 (message-narrow-to-head-1) 6043 ;; Allow customizations to have their say. 6044 (if (not wide) 6045 ;; This is a regular reply. 6046 (when (functionp message-reply-to-function) 6047 (save-excursion 6048 (setq follow-to (funcall message-reply-to-function)))) 6049 ;; This is a followup. 6050 (when (functionp message-wide-reply-to-function) 6051 (save-excursion 6052 (setq follow-to 6053 (funcall message-wide-reply-to-function))))) 6054 (setq message-id (message-fetch-field "message-id" t) 6055 references (message-fetch-field "references") 6056 date (message-fetch-field "date") 6057 from (or (message-fetch-field "from") "nobody") 6058 subject (or (message-fetch-field "subject") "none")) 6059 6060 ;; Strip list identifiers, "Re: ", and "was:" 6061 (setq subject (message-simplify-subject subject)) 6062 6063 (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) 6064 (string-match "<[^>]+>" gnus-warning)) 6065 (setq message-id (match-string 0 gnus-warning))) 6066 6067 (unless follow-to 6068 (setq follow-to (message-get-reply-headers wide to-address)))) 6069 6070 (unless (message-mail-user-agent) 6071 (message-pop-to-buffer 6072 (message-buffer-name 6073 (if wide "wide reply" "reply") from 6074 (if wide to-address nil)))) 6075 6076 (setq message-reply-headers 6077 (vector 0 subject from date message-id references 0 0 "")) 6078 6079 (message-setup 6080 `((Subject . ,subject) 6081 ,@follow-to) 6082 cur))) 6083 6084;;;###autoload 6085(defun message-wide-reply (&optional to-address) 6086 "Make a \"wide\" reply to the message in the current buffer." 6087 (interactive) 6088 (message-reply to-address t)) 6089 6090;;;###autoload 6091(defun message-followup (&optional to-newsgroups) 6092 "Follow up to the message in the current buffer. 6093If TO-NEWSGROUPS, use that as the new Newsgroups line." 6094 (interactive) 6095 (require 'gnus-sum) ; for gnus-list-identifiers 6096 (let ((cur (current-buffer)) 6097 from subject date reply-to mrt mct 6098 references message-id follow-to 6099 (inhibit-point-motion-hooks t) 6100 (message-this-is-news t) 6101 followup-to distribution newsgroups gnus-warning posted-to) 6102 (save-restriction 6103 (narrow-to-region 6104 (goto-char (point-min)) 6105 (if (search-forward "\n\n" nil t) 6106 (1- (point)) 6107 (point-max))) 6108 (when (functionp message-followup-to-function) 6109 (setq follow-to 6110 (funcall message-followup-to-function))) 6111 (setq from (message-fetch-field "from") 6112 date (message-fetch-field "date") 6113 subject (or (message-fetch-field "subject") "none") 6114 references (message-fetch-field "references") 6115 message-id (message-fetch-field "message-id" t) 6116 followup-to (message-fetch-field "followup-to") 6117 newsgroups (message-fetch-field "newsgroups") 6118 posted-to (message-fetch-field "posted-to") 6119 reply-to (message-fetch-field "reply-to") 6120 mrt (message-fetch-field "mail-reply-to") 6121 distribution (message-fetch-field "distribution") 6122 mct (message-fetch-field "mail-copies-to")) 6123 (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) 6124 (string-match "<[^>]+>" gnus-warning)) 6125 (setq message-id (match-string 0 gnus-warning))) 6126 ;; Remove bogus distribution. 6127 (when (and (stringp distribution) 6128 (let ((case-fold-search t)) 6129 (string-match "world" distribution))) 6130 (setq distribution nil)) 6131 ;; Strip list identifiers, "Re: ", and "was:" 6132 (setq subject (message-simplify-subject subject)) 6133 (widen)) 6134 6135 (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) 6136 6137 (setq message-reply-headers 6138 (vector 0 subject from date message-id references 0 0 "")) 6139 6140 (message-setup 6141 `((Subject . ,subject) 6142 ,@(cond 6143 (to-newsgroups 6144 (list (cons 'Newsgroups to-newsgroups))) 6145 (follow-to follow-to) 6146 ((and followup-to message-use-followup-to) 6147 (list 6148 (cond 6149 ((equal (downcase followup-to) "poster") 6150 (if (or (eq message-use-followup-to 'use) 6151 (message-y-or-n-p "Obey Followup-To: poster? " t "\ 6152You should normally obey the Followup-To: header. 6153 6154`Followup-To: poster' sends your response via e-mail instead of news. 6155 6156A typical situation where `Followup-To: poster' is used is when the poster 6157does not read the newsgroup, so he wouldn't see any replies sent to it. 6158 6159You may customize the variable `message-use-followup-to', if you 6160want to get rid of this query permanently.")) 6161 (progn 6162 (setq message-this-is-news nil) 6163 (cons 'To (or mrt reply-to from ""))) 6164 (cons 'Newsgroups newsgroups))) 6165 (t 6166 (if (or (equal followup-to newsgroups) 6167 (not (eq message-use-followup-to 'ask)) 6168 (message-y-or-n-p 6169 (concat "Obey Followup-To: " followup-to "? ") t "\ 6170You should normally obey the Followup-To: header. 6171 6172 `Followup-To: " followup-to "' 6173directs your response to " (if (string-match "," followup-to) 6174 "the specified newsgroups" 6175 "that newsgroup only") ". 6176 6177If a message is posted to several newsgroups, Followup-To is often 6178used to direct the following discussion to one newsgroup only, 6179because discussions that are spread over several newsgroup tend to 6180be fragmented and very difficult to follow. 6181 6182Also, some source/announcement newsgroups are not intended for discussion; 6183responses here are directed to other newsgroups. 6184 6185You may customize the variable `message-use-followup-to', if you 6186want to get rid of this query permanently.")) 6187 (cons 'Newsgroups followup-to) 6188 (cons 'Newsgroups newsgroups)))))) 6189 (posted-to 6190 `((Newsgroups . ,posted-to))) 6191 (t 6192 `((Newsgroups . ,newsgroups)))) 6193 ,@(and distribution (list (cons 'Distribution distribution))) 6194 ,@(when (and mct 6195 (not (or (equal (downcase mct) "never") 6196 (equal (downcase mct) "nobody")))) 6197 (list (cons 'Cc (if (or (equal (downcase mct) "always") 6198 (equal (downcase mct) "poster")) 6199 (or mrt reply-to from "") 6200 mct))))) 6201 6202 cur))) 6203 6204(defun message-is-yours-p () 6205 "Non-nil means current article is yours. 6206If you have added 'cancel-messages to `message-shoot-gnksa-feet', all articles 6207are yours except those that have Cancel-Lock header not belonging to you. 6208Instead of shooting GNKSA feet, you should modify `message-alternative-emails' 6209regexp to match all of yours addresses." 6210 ;; Canlock-logic as suggested by Per Abrahamsen 6211 ;; <abraham@dina.kvl.dk> 6212 ;; 6213 ;; IF article has cancel-lock THEN 6214 ;; IF we can verify it THEN 6215 ;; issue cancel 6216 ;; ELSE 6217 ;; error: cancellock: article is not yours 6218 ;; ELSE 6219 ;; Use old rules, comparing sender... 6220 (save-excursion 6221 (save-restriction 6222 (message-narrow-to-head-1) 6223 (if (message-fetch-field "Cancel-Lock") 6224 (if (null (canlock-verify)) 6225 t 6226 (error "Failed to verify Cancel-lock: This article is not yours")) 6227 (let (sender from) 6228 (or 6229 (message-gnksa-enable-p 'cancel-messages) 6230 (and (setq sender (message-fetch-field "sender")) 6231 (string-equal (downcase sender) 6232 (downcase (message-make-sender)))) 6233 ;; Email address in From field equals to our address 6234 (and (setq from (message-fetch-field "from")) 6235 (string-equal 6236 (downcase (cadr (mail-extract-address-components from))) 6237 (downcase (cadr (mail-extract-address-components 6238 (message-make-from)))))) 6239 ;; Email address in From field matches 6240 ;; 'message-alternative-emails' regexp 6241 (and from 6242 message-alternative-emails 6243 (string-match 6244 message-alternative-emails 6245 (cadr (mail-extract-address-components from)))))))))) 6246 6247;;;###autoload 6248(defun message-cancel-news (&optional arg) 6249 "Cancel an article you posted. 6250If ARG, allow editing of the cancellation message." 6251 (interactive "P") 6252 (unless (message-news-p) 6253 (error "This is not a news article; canceling is impossible")) 6254 (let (from newsgroups message-id distribution buf) 6255 (save-excursion 6256 ;; Get header info from original article. 6257 (save-restriction 6258 (message-narrow-to-head-1) 6259 (setq from (message-fetch-field "from") 6260 newsgroups (message-fetch-field "newsgroups") 6261 message-id (message-fetch-field "message-id" t) 6262 distribution (message-fetch-field "distribution"))) 6263 ;; Make sure that this article was written by the user. 6264 (unless (message-is-yours-p) 6265 (error "This article is not yours")) 6266 (when (yes-or-no-p "Do you really want to cancel this article? ") 6267 ;; Make control message. 6268 (if arg 6269 (message-news) 6270 (setq buf (set-buffer (get-buffer-create " *message cancel*")))) 6271 (erase-buffer) 6272 (insert "Newsgroups: " newsgroups "\n" 6273 "From: " from "\n" 6274 "Subject: cmsg cancel " message-id "\n" 6275 "Control: cancel " message-id "\n" 6276 (if distribution 6277 (concat "Distribution: " distribution "\n") 6278 "") 6279 mail-header-separator "\n" 6280 message-cancel-message) 6281 (run-hooks 'message-cancel-hook) 6282 (unless arg 6283 (message "Canceling your article...") 6284 (if (let ((message-syntax-checks 6285 'dont-check-for-anything-just-trust-me)) 6286 (funcall message-send-news-function)) 6287 (message "Canceling your article...done")) 6288 (kill-buffer buf)))))) 6289 6290;;;###autoload 6291(defun message-supersede () 6292 "Start composing a message to supersede the current message. 6293This is done simply by taking the old article and adding a Supersedes 6294header line with the old Message-ID." 6295 (interactive) 6296 (let ((cur (current-buffer))) 6297 ;; Check whether the user owns the article that is to be superseded. 6298 (unless (message-is-yours-p) 6299 (error "This article is not yours")) 6300 ;; Get a normal message buffer. 6301 (message-pop-to-buffer (message-buffer-name "supersede")) 6302 (insert-buffer-substring cur) 6303 (mime-to-mml) 6304 (message-narrow-to-head-1) 6305 ;; Remove unwanted headers. 6306 (when message-ignored-supersedes-headers 6307 (message-remove-header message-ignored-supersedes-headers t)) 6308 (goto-char (point-min)) 6309 (if (not (re-search-forward "^Message-ID: " nil t)) 6310 (error "No Message-ID in this article") 6311 (replace-match "Supersedes: " t t)) 6312 (goto-char (point-max)) 6313 (insert mail-header-separator) 6314 (widen) 6315 (forward-line 1))) 6316 6317;;;###autoload 6318(defun message-recover () 6319 "Reread contents of current buffer from its last auto-save file." 6320 (interactive) 6321 (let ((file-name (make-auto-save-file-name))) 6322 (cond ((save-window-excursion 6323 (if (not (eq system-type 'vax-vms)) 6324 (with-output-to-temp-buffer "*Directory*" 6325 (with-current-buffer standard-output 6326 (fundamental-mode)) ; for Emacs 20.4+ 6327 (buffer-disable-undo standard-output) 6328 (let ((default-directory "/")) 6329 (call-process 6330 "ls" nil standard-output nil "-l" file-name)))) 6331 (yes-or-no-p (format "Recover auto save file %s? " file-name))) 6332 (let ((buffer-read-only nil)) 6333 (erase-buffer) 6334 (insert-file-contents file-name nil))) 6335 (t (error "message-recover cancelled"))))) 6336 6337;;; Washing Subject: 6338 6339(defun message-wash-subject (subject) 6340 "Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT. 6341Previous forwarders, replyers, etc. may add it." 6342 (with-temp-buffer 6343 (insert subject) 6344 (goto-char (point-min)) 6345 ;; strip Re/Fwd stuff off the beginning 6346 (while (re-search-forward 6347 "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t) 6348 (replace-match "")) 6349 6350 ;; and gnus-style forwards [foo@bar.com] subject 6351 (goto-char (point-min)) 6352 (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t) 6353 (replace-match "")) 6354 6355 ;; and off the end 6356 (goto-char (point-max)) 6357 (while (re-search-backward "([Ff][Ww][Dd])" nil t) 6358 (replace-match "")) 6359 6360 ;; and finally, any whitespace that was left-over 6361 (goto-char (point-min)) 6362 (while (re-search-forward "^[ \t]+" nil t) 6363 (replace-match "")) 6364 (goto-char (point-max)) 6365 (while (re-search-backward "[ \t]+$" nil t) 6366 (replace-match "")) 6367 6368 (buffer-string))) 6369 6370;;; Forwarding messages. 6371 6372(defvar message-forward-decoded-p nil 6373 "Non-nil means the original message is decoded.") 6374 6375(defun message-forward-subject-name-subject (subject) 6376 "Generate a SUBJECT for a forwarded message. 6377The form is: [Source] Subject, where if the original message was mail, 6378Source is the name of the sender, and if the original message was 6379news, Source is the list of newsgroups is was posted to." 6380 (let* ((group (message-fetch-field "newsgroups")) 6381 (from (message-fetch-field "from")) 6382 (prefix 6383 (if group 6384 (gnus-group-decoded-name group) 6385 (or (and from (car (gnus-extract-address-components from))) 6386 "(nowhere)")))) 6387 (concat "[" 6388 (if message-forward-decoded-p 6389 prefix 6390 (mail-decode-encoded-word-string prefix)) 6391 "] " subject))) 6392 6393(defun message-forward-subject-author-subject (subject) 6394 "Generate a SUBJECT for a forwarded message. 6395The form is: [Source] Subject, where if the original message was mail, 6396Source is the sender, and if the original message was news, Source is 6397the list of newsgroups is was posted to." 6398 (let* ((group (message-fetch-field "newsgroups")) 6399 (prefix 6400 (if group 6401 (gnus-group-decoded-name group) 6402 (or (message-fetch-field "from") 6403 "(nowhere)")))) 6404 (concat "[" 6405 (if message-forward-decoded-p 6406 prefix 6407 (mail-decode-encoded-word-string prefix)) 6408 "] " subject))) 6409 6410(defun message-forward-subject-fwd (subject) 6411 "Generate a SUBJECT for a forwarded message. 6412The form is: Fwd: Subject, where Subject is the original subject of 6413the message." 6414 (if (string-match "^Fwd: " subject) 6415 subject 6416 (concat "Fwd: " subject))) 6417 6418(defun message-make-forward-subject () 6419 "Return a Subject header suitable for the message in the current buffer." 6420 (save-excursion 6421 (save-restriction 6422 (message-narrow-to-head-1) 6423 (let ((funcs message-make-forward-subject-function) 6424 (subject (message-fetch-field "Subject"))) 6425 (setq subject 6426 (if subject 6427 (if message-forward-decoded-p 6428 subject 6429 (mail-decode-encoded-word-string subject)) 6430 "")) 6431 (if message-wash-forwarded-subjects 6432 (setq subject (message-wash-subject subject))) 6433 ;; Make sure funcs is a list. 6434 (and funcs 6435 (not (listp funcs)) 6436 (setq funcs (list funcs))) 6437 ;; Apply funcs in order, passing subject generated by previous 6438 ;; func to the next one. 6439 (while funcs 6440 (when (functionp (car funcs)) 6441 (setq subject (funcall (car funcs) subject))) 6442 (setq funcs (cdr funcs))) 6443 subject)))) 6444 6445(eval-when-compile 6446 (defvar gnus-article-decoded-p)) 6447 6448 6449;;;###autoload 6450(defun message-forward (&optional news digest) 6451 "Forward the current message via mail. 6452Optional NEWS will use news to forward instead of mail. 6453Optional DIGEST will use digest to forward." 6454 (interactive "P") 6455 (let* ((cur (current-buffer)) 6456 (message-forward-decoded-p 6457 (if (local-variable-p 'gnus-article-decoded-p (current-buffer)) 6458 gnus-article-decoded-p ;; In an article buffer. 6459 message-forward-decoded-p)) 6460 (subject (message-make-forward-subject))) 6461 (if news 6462 (message-news nil subject) 6463 (message-mail nil subject)) 6464 (message-forward-make-body cur digest))) 6465 6466(defun message-forward-make-body-plain (forward-buffer) 6467 (insert 6468 "\n-------------------- Start of forwarded message --------------------\n") 6469 (let ((b (point)) e) 6470 (insert 6471 (with-temp-buffer 6472 (mm-disable-multibyte) 6473 (insert 6474 (with-current-buffer forward-buffer 6475 (mm-with-unibyte-current-buffer (buffer-string)))) 6476 (mm-enable-multibyte) 6477 (mime-to-mml) 6478 (goto-char (point-min)) 6479 (when (looking-at "From ") 6480 (replace-match "X-From-Line: ")) 6481 (buffer-string))) 6482 (setq e (point)) 6483 (insert 6484 "\n-------------------- End of forwarded message --------------------\n") 6485 (when message-forward-ignored-headers 6486 (save-restriction 6487 (narrow-to-region b e) 6488 (goto-char b) 6489 (narrow-to-region (point) 6490 (or (search-forward "\n\n" nil t) (point))) 6491 (message-remove-header message-forward-ignored-headers t))))) 6492 6493(defun message-forward-make-body-mime (forward-buffer) 6494 (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") 6495 (let ((b (point)) e) 6496 (save-restriction 6497 (narrow-to-region (point) (point)) 6498 (mml-insert-buffer forward-buffer) 6499 (goto-char (point-min)) 6500 (when (looking-at "From ") 6501 (replace-match "X-From-Line: ")) 6502 (goto-char (point-max))) 6503 (setq e (point)) 6504 (insert "<#/part>\n"))) 6505 6506(defun message-forward-make-body-mml (forward-buffer) 6507 (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") 6508 (let ((b (point)) e) 6509 (if (not message-forward-decoded-p) 6510 (insert 6511 (with-temp-buffer 6512 (mm-disable-multibyte) 6513 (insert 6514 (with-current-buffer forward-buffer 6515 (mm-with-unibyte-current-buffer (buffer-string)))) 6516 (mm-enable-multibyte) 6517 (mime-to-mml) 6518 (goto-char (point-min)) 6519 (when (looking-at "From ") 6520 (replace-match "X-From-Line: ")) 6521 (buffer-string))) 6522 (save-restriction 6523 (narrow-to-region (point) (point)) 6524 (mml-insert-buffer forward-buffer) 6525 (goto-char (point-min)) 6526 (when (looking-at "From ") 6527 (replace-match "X-From-Line: ")) 6528 (goto-char (point-max)))) 6529 (setq e (point)) 6530 (insert "<#/mml>\n") 6531 (when (and (not message-forward-decoded-p) 6532 message-forward-ignored-headers) 6533 (save-restriction 6534 (narrow-to-region b e) 6535 (goto-char b) 6536 (narrow-to-region (point) 6537 (or (search-forward "\n\n" nil t) (point))) 6538 (message-remove-header message-forward-ignored-headers t))))) 6539 6540(defun message-forward-make-body-digest-plain (forward-buffer) 6541 (insert 6542 "\n-------------------- Start of forwarded message --------------------\n") 6543 (let ((b (point)) e) 6544 (mml-insert-buffer forward-buffer) 6545 (setq e (point)) 6546 (insert 6547 "\n-------------------- End of forwarded message --------------------\n"))) 6548 6549(defun message-forward-make-body-digest-mime (forward-buffer) 6550 (insert "\n<#multipart type=digest>\n") 6551 (let ((b (point)) e) 6552 (insert-buffer-substring forward-buffer) 6553 (setq e (point)) 6554 (insert "<#/multipart>\n") 6555 (save-restriction 6556 (narrow-to-region b e) 6557 (goto-char b) 6558 (narrow-to-region (point) 6559 (or (search-forward "\n\n" nil t) (point))) 6560 (delete-region (point-min) (point-max))))) 6561 6562(defun message-forward-make-body-digest (forward-buffer) 6563 (if message-forward-as-mime 6564 (message-forward-make-body-digest-mime forward-buffer) 6565 (message-forward-make-body-digest-plain forward-buffer))) 6566 6567;;;###autoload 6568(defun message-forward-make-body (forward-buffer &optional digest) 6569 ;; Put point where we want it before inserting the forwarded 6570 ;; message. 6571 (if message-forward-before-signature 6572 (message-goto-body) 6573 (goto-char (point-max))) 6574 (if digest 6575 (message-forward-make-body-digest forward-buffer) 6576 (if message-forward-as-mime 6577 (if (and message-forward-show-mml 6578 (not (and (eq message-forward-show-mml 'best) 6579 (with-current-buffer forward-buffer 6580 (goto-char (point-min)) 6581 (re-search-forward 6582 "Content-Type: *multipart/\\(signed\\|encrypted\\)" 6583 nil t))))) 6584 (message-forward-make-body-mml forward-buffer) 6585 (message-forward-make-body-mime forward-buffer)) 6586 (message-forward-make-body-plain forward-buffer))) 6587 (message-position-point)) 6588 6589;;;###autoload 6590(defun message-forward-rmail-make-body (forward-buffer) 6591 (save-window-excursion 6592 (set-buffer forward-buffer) 6593 ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs 6594 ;; 20. FIXIT, or we drop support for rmail in Emacs 20. 6595 (if (rmail-msg-is-pruned) 6596 (rmail-msg-restore-non-pruned-header))) 6597 (message-forward-make-body forward-buffer)) 6598 6599(eval-when-compile (defvar rmail-enable-mime-composing)) 6600 6601;; Fixme: Should have defcustom. 6602;;;###autoload 6603(defun message-insinuate-rmail () 6604 "Let RMAIL use message to forward." 6605 (interactive) 6606 (setq rmail-enable-mime-composing t) 6607 (setq rmail-insert-mime-forwarded-message-function 6608 'message-forward-rmail-make-body)) 6609 6610;;;###autoload 6611(defun message-resend (address) 6612 "Resend the current article to ADDRESS." 6613 (interactive 6614 (list (message-read-from-minibuffer "Resend message to: "))) 6615 (message "Resending message to %s..." address) 6616 (save-excursion 6617 (let ((cur (current-buffer)) 6618 beg) 6619 ;; We first set up a normal mail buffer. 6620 (unless (message-mail-user-agent) 6621 (set-buffer (get-buffer-create " *message resend*")) 6622 (erase-buffer)) 6623 (let ((message-this-is-mail t) 6624 message-setup-hook) 6625 (message-setup `((To . ,address)))) 6626 ;; Insert our usual headers. 6627 (message-generate-headers '(From Date To Message-ID)) 6628 (message-narrow-to-headers) 6629 ;; Remove X-Draft-From header etc. 6630 (message-remove-header message-ignored-mail-headers t) 6631 ;; Rename them all to "Resent-*". 6632 (goto-char (point-min)) 6633 (while (re-search-forward "^[A-Za-z]" nil t) 6634 (forward-char -1) 6635 (insert "Resent-")) 6636 (widen) 6637 (forward-line) 6638 (delete-region (point) (point-max)) 6639 (setq beg (point)) 6640 ;; Insert the message to be resent. 6641 (insert-buffer-substring cur) 6642 (goto-char (point-min)) 6643 (search-forward "\n\n") 6644 (forward-char -1) 6645 (save-restriction 6646 (narrow-to-region beg (point)) 6647 (message-remove-header message-ignored-resent-headers t) 6648 (goto-char (point-max))) 6649 (insert mail-header-separator) 6650 ;; Rename all old ("Also-")Resent headers. 6651 (while (re-search-backward "^\\(Also-\\)*Resent-" beg t) 6652 (beginning-of-line) 6653 (insert "Also-")) 6654 ;; Quote any "From " lines at the beginning. 6655 (goto-char beg) 6656 (when (looking-at "From ") 6657 (replace-match "X-From-Line: ")) 6658 ;; Send it. 6659 (let ((message-inhibit-body-encoding t) 6660 message-required-mail-headers 6661 rfc2047-encode-encoded-words) 6662 (message-send-mail)) 6663 (kill-buffer (current-buffer))) 6664 (message "Resending message to %s...done" address))) 6665 6666;;;###autoload 6667(defun message-bounce () 6668 "Re-mail the current message. 6669This only makes sense if the current message is a bounce message that 6670contains some mail you have written which has been bounced back to 6671you." 6672 (interactive) 6673 (let ((handles (mm-dissect-buffer t)) 6674 boundary) 6675 (message-pop-to-buffer (message-buffer-name "bounce")) 6676 (if (stringp (car handles)) 6677 ;; This is a MIME bounce. 6678 (mm-insert-part (car (last handles))) 6679 ;; This is a non-MIME bounce, so we try to remove things 6680 ;; manually. 6681 (mm-insert-part handles) 6682 (undo-boundary) 6683 (goto-char (point-min)) 6684 (re-search-forward "\n\n+" nil t) 6685 (setq boundary (point)) 6686 ;; We remove everything before the bounced mail. 6687 (if (or (re-search-forward message-unsent-separator nil t) 6688 (progn 6689 (search-forward "\n\n" nil 'move) 6690 (re-search-backward "^Return-Path:.*\n" boundary t))) 6691 (progn 6692 (forward-line 1) 6693 (delete-region (point-min) 6694 (if (re-search-forward "^[^ \n\t]+:" nil t) 6695 (match-beginning 0) 6696 (point)))) 6697 (goto-char boundary) 6698 (when (re-search-backward "^.?From .*\n" nil t) 6699 (delete-region (match-beginning 0) (match-end 0))))) 6700 (mm-enable-multibyte) 6701 (save-restriction 6702 (message-narrow-to-head-1) 6703 (message-remove-header message-ignored-bounced-headers t) 6704 (goto-char (point-max)) 6705 (insert mail-header-separator)) 6706 (message-position-point))) 6707 6708;;; 6709;;; Interactive entry points for new message buffers. 6710;;; 6711 6712;;;###autoload 6713(defun message-mail-other-window (&optional to subject) 6714 "Like `message-mail' command, but display mail buffer in another window." 6715 (interactive) 6716 (unless (message-mail-user-agent) 6717 (let ((pop-up-windows t) 6718 (special-display-buffer-names nil) 6719 (special-display-regexps nil) 6720 (same-window-buffer-names nil) 6721 (same-window-regexps nil)) 6722 (message-pop-to-buffer (message-buffer-name "mail" to)))) 6723 (let ((message-this-is-mail t)) 6724 (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))) 6725 nil nil nil 'switch-to-buffer-other-window))) 6726 6727;;;###autoload 6728(defun message-mail-other-frame (&optional to subject) 6729 "Like `message-mail' command, but display mail buffer in another frame." 6730 (interactive) 6731 (unless (message-mail-user-agent) 6732 (let ((pop-up-frames t) 6733 (special-display-buffer-names nil) 6734 (special-display-regexps nil) 6735 (same-window-buffer-names nil) 6736 (same-window-regexps nil)) 6737 (message-pop-to-buffer (message-buffer-name "mail" to)))) 6738 (let ((message-this-is-mail t)) 6739 (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))) 6740 nil nil nil 'switch-to-buffer-other-frame))) 6741 6742;;;###autoload 6743(defun message-news-other-window (&optional newsgroups subject) 6744 "Start editing a news article to be sent." 6745 (interactive) 6746 (let ((pop-up-windows t) 6747 (special-display-buffer-names nil) 6748 (special-display-regexps nil) 6749 (same-window-buffer-names nil) 6750 (same-window-regexps nil)) 6751 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))) 6752 (let ((message-this-is-news t)) 6753 (message-setup `((Newsgroups . ,(or newsgroups "")) 6754 (Subject . ,(or subject "")))))) 6755 6756;;;###autoload 6757(defun message-news-other-frame (&optional newsgroups subject) 6758 "Start editing a news article to be sent." 6759 (interactive) 6760 (let ((pop-up-frames t) 6761 (special-display-buffer-names nil) 6762 (special-display-regexps nil) 6763 (same-window-buffer-names nil) 6764 (same-window-regexps nil)) 6765 (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))) 6766 (let ((message-this-is-news t)) 6767 (message-setup `((Newsgroups . ,(or newsgroups "")) 6768 (Subject . ,(or subject "")))))) 6769 6770;;; underline.el 6771 6772;; This code should be moved to underline.el (from which it is stolen). 6773 6774;;;###autoload 6775(defun bold-region (start end) 6776 "Bold all nonblank characters in the region. 6777Works by overstriking characters. 6778Called from program, takes two arguments START and END 6779which specify the range to operate on." 6780 (interactive "r") 6781 (save-excursion 6782 (let ((end1 (make-marker))) 6783 (move-marker end1 (max start end)) 6784 (goto-char (min start end)) 6785 (while (< (point) end1) 6786 (or (looking-at "[_\^@- ]") 6787 (insert (char-after) "\b")) 6788 (forward-char 1))))) 6789 6790;;;###autoload 6791(defun unbold-region (start end) 6792 "Remove all boldness (overstruck characters) in the region. 6793Called from program, takes two arguments START and END 6794which specify the range to operate on." 6795 (interactive "r") 6796 (save-excursion 6797 (let ((end1 (make-marker))) 6798 (move-marker end1 (max start end)) 6799 (goto-char (min start end)) 6800 (while (re-search-forward "\b" end1 t) 6801 (if (eq (char-after) (char-after (- (point) 2))) 6802 (delete-char -2)))))) 6803 6804(defun message-exchange-point-and-mark () 6805 "Exchange point and mark, but don't activate region if it was inactive." 6806 (unless (prog1 6807 (message-mark-active-p) 6808 (exchange-point-and-mark)) 6809 (setq mark-active nil))) 6810 6811(defalias 'message-make-overlay 'make-overlay) 6812(defalias 'message-delete-overlay 'delete-overlay) 6813(defalias 'message-overlay-put 'overlay-put) 6814(defun message-kill-all-overlays () 6815 (if (featurep 'xemacs) 6816 (map-extents (lambda (extent ignore) (delete-extent extent))) 6817 (mapcar #'delete-overlay (overlays-in (point-min) (point-max))))) 6818 6819;; Support for toolbar 6820(eval-when-compile 6821 (defvar tool-bar-mode)) 6822 6823;; Note: The :set function in the `message-tool-bar*' variables will only 6824;; affect _new_ message buffers. We might add a function that walks thru all 6825;; message-mode buffers and force the update. 6826(defun message-tool-bar-update (&optional symbol value) 6827 "Update message mode toolbar. 6828Setter function for custom variables." 6829 (setq-default message-tool-bar-map nil) 6830 (when symbol 6831 ;; When used as ":set" function: 6832 (set-default symbol value))) 6833 6834(defcustom message-tool-bar (if (eq gmm-tool-bar-style 'gnome) 6835 'message-tool-bar-gnome 6836 'message-tool-bar-retro) 6837 "Specifies the message mode tool bar. 6838 6839It can be either a list or a symbol refering to a list. See 6840`gmm-tool-bar-from-list' for the format of the list. The 6841default key map is `message-mode-map'. 6842 6843Pre-defined symbols include `message-tool-bar-gnome' and 6844`message-tool-bar-retro'." 6845 :type '(repeat gmm-tool-bar-list-item) 6846 :type '(choice (const :tag "GNOME style" message-tool-bar-gnome) 6847 (const :tag "Retro look" message-tool-bar-retro) 6848 (repeat :tag "User defined list" gmm-tool-bar-item) 6849 (symbol)) 6850 :version "22.1" ;; Gnus 5.10.9 6851 :initialize 'custom-initialize-default 6852 :set 'message-tool-bar-update 6853 :group 'message) 6854 6855(defcustom message-tool-bar-gnome 6856 '((ispell-message "spell" nil 6857 :visible (or (not (boundp 'flyspell-mode)) 6858 (not flyspell-mode))) 6859 (flyspell-buffer "spell" t 6860 :visible (and (boundp 'flyspell-mode) 6861 flyspell-mode) 6862 :help "Flyspell whole buffer") 6863 (gmm-ignore "separator") 6864 (message-send-and-exit "mail/send") 6865 (message-dont-send "mail/save-draft") 6866 (message-kill-buffer "close") ;; stock_cancel 6867 (mml-attach-file "attach" mml-mode-map) 6868 (mml-preview "mail/preview" mml-mode-map) 6869 ;; (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil) 6870 (message-insert-importance-high "important" nil :visible nil) 6871 (message-insert-importance-low "unimportant" nil :visible nil) 6872 (message-insert-disposition-notification-to "receipt" nil :visible nil) 6873 (gmm-customize-mode "preferences" t :help "Edit mode preferences") 6874 (message-info "help" t :help "Message manual")) 6875 "List of items for the message tool bar (GNOME style). 6876 6877See `gmm-tool-bar-from-list' for details on the format of the list." 6878 :type '(repeat gmm-tool-bar-item) 6879 :version "22.1" ;; Gnus 5.10.9 6880 :initialize 'custom-initialize-default 6881 :set 'message-tool-bar-update 6882 :group 'message) 6883 6884(defcustom message-tool-bar-retro 6885 '(;; Old Emacs 21 icon for consistency. 6886 (message-send-and-exit "gnus/mail_send") 6887 (message-kill-buffer "close") 6888 (message-dont-send "cancel") 6889 (mml-attach-file "attach" mml-mode-map) 6890 (ispell-message "spell") 6891 (mml-preview "preview" mml-mode-map) 6892 (message-insert-importance-high "gnus/important") 6893 (message-insert-importance-low "gnus/unimportant") 6894 (message-insert-disposition-notification-to "gnus/receipt")) 6895 "List of items for the message tool bar (retro style). 6896 6897See `gmm-tool-bar-from-list' for details on the format of the list." 6898 :type '(repeat gmm-tool-bar-item) 6899 :version "22.1" ;; Gnus 5.10.9 6900 :initialize 'custom-initialize-default 6901 :set 'message-tool-bar-update 6902 :group 'message) 6903 6904(defcustom message-tool-bar-zap-list 6905 '(new-file open-file dired kill-buffer write-file 6906 print-buffer customize help) 6907 "List of icon items from the global tool bar. 6908These items are not displayed on the message mode tool bar. 6909 6910See `gmm-tool-bar-from-list' for the format of the list." 6911 :type 'gmm-tool-bar-zap-list 6912 :version "22.1" ;; Gnus 5.10.9 6913 :initialize 'custom-initialize-default 6914 :set 'message-tool-bar-update 6915 :group 'message) 6916 6917(defvar image-load-path) 6918 6919(defun message-make-tool-bar (&optional force) 6920 "Make a message mode tool bar from `message-tool-bar-list'. 6921When FORCE, rebuild the tool bar." 6922 (when (and (not (featurep 'xemacs)) 6923 (boundp 'tool-bar-mode) 6924 tool-bar-mode 6925 (or (not message-tool-bar-map) force)) 6926 (setq message-tool-bar-map 6927 (let* ((load-path 6928 (gmm-image-load-path-for-library "message" 6929 "mail/save-draft.xpm" 6930 nil t)) 6931 (image-load-path (cons (car load-path) 6932 (when (boundp 'image-load-path) 6933 image-load-path)))) 6934 (gmm-tool-bar-from-list message-tool-bar 6935 message-tool-bar-zap-list 6936 'message-mode-map)))) 6937 message-tool-bar-map) 6938 6939;;; Group name completion. 6940 6941(defcustom message-newgroups-header-regexp 6942 "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):" 6943 "Regexp that match headers that lists groups." 6944 :group 'message 6945 :type 'regexp) 6946 6947(defcustom message-completion-alist 6948 (list (cons message-newgroups-header-regexp 'message-expand-group) 6949 '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name) 6950 '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" 6951 . message-expand-name) 6952 '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):" 6953 . message-expand-name)) 6954 "Alist of (RE . FUN). Use FUN for completion on header lines matching RE." 6955 :version "22.1" 6956 :group 'message 6957 :type '(alist :key-type regexp :value-type function)) 6958 6959(defcustom message-tab-body-function nil 6960 "*Function to execute when `message-tab' (TAB) is executed in the body. 6961If nil, the function bound in `text-mode-map' or `global-map' is executed." 6962 :version "22.1" 6963 :group 'message 6964 :link '(custom-manual "(message)Various Commands") 6965 :type '(choice (const nil) 6966 function)) 6967 6968(defun message-tab () 6969 "Complete names according to `message-completion-alist'. 6970Execute function specified by `message-tab-body-function' when not in 6971those headers." 6972 (interactive) 6973 (let ((alist message-completion-alist)) 6974 (while (and alist 6975 (let ((mail-abbrev-mode-regexp (caar alist))) 6976 (not (mail-abbrev-in-expansion-header-p)))) 6977 (setq alist (cdr alist))) 6978 (funcall (or (cdar alist) message-tab-body-function 6979 (lookup-key text-mode-map "\t") 6980 (lookup-key global-map "\t") 6981 'indent-relative)))) 6982 6983(eval-and-compile 6984 (condition-case nil 6985 (with-temp-buffer 6986 (let ((standard-output (current-buffer))) 6987 (eval '(display-completion-list nil ""))) 6988 (defalias 'message-display-completion-list 'display-completion-list)) 6989 (error ;; Don't use `wrong-number-of-arguments' here because of XEmacs. 6990 (defun message-display-completion-list (completions &optional ignore) 6991 "Display the list of completions, COMPLETIONS, using `standard-output'." 6992 (display-completion-list completions))))) 6993 6994(defun message-expand-group () 6995 "Expand the group name under point." 6996 (let* ((b (save-excursion 6997 (save-restriction 6998 (narrow-to-region 6999 (save-excursion 7000 (beginning-of-line) 7001 (skip-chars-forward "^:") 7002 (1+ (point))) 7003 (point)) 7004 (skip-chars-backward "^, \t\n") (point)))) 7005 (completion-ignore-case t) 7006 (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ") 7007 (point)))) 7008 (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) 7009 (completions (all-completions string hashtb)) 7010 comp) 7011 (delete-region b (point)) 7012 (cond 7013 ((= (length completions) 1) 7014 (if (string= (car completions) string) 7015 (progn 7016 (insert string) 7017 (message "Only matching group")) 7018 (insert (car completions)))) 7019 ((and (setq comp (try-completion string hashtb)) 7020 (not (string= comp string))) 7021 (insert comp)) 7022 (t 7023 (insert string) 7024 (if (not comp) 7025 (message "No matching groups") 7026 (save-selected-window 7027 (pop-to-buffer "*Completions*") 7028 (buffer-disable-undo) 7029 (let ((buffer-read-only nil)) 7030 (erase-buffer) 7031 (let ((standard-output (current-buffer))) 7032 (message-display-completion-list (sort completions 'string<) 7033 string)) 7034 (setq buffer-read-only nil) 7035 (goto-char (point-min)) 7036 (delete-region (point) (progn (forward-line 3) (point)))))))))) 7037 7038(defun message-expand-name () 7039 (if (fboundp 'bbdb-complete-name) 7040 (bbdb-complete-name) 7041 (expand-abbrev))) 7042 7043;;; Help stuff. 7044 7045(defun message-talkative-question (ask question show &rest text) 7046 "Call FUNCTION with argument QUESTION; optionally display TEXT... args. 7047If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer. 7048The following arguments may contain lists of values." 7049 (if (and show 7050 (setq text (message-flatten-list text))) 7051 (save-window-excursion 7052 (save-excursion 7053 (with-output-to-temp-buffer " *MESSAGE information message*" 7054 (set-buffer " *MESSAGE information message*") 7055 (fundamental-mode) ; for Emacs 20.4+ 7056 (mapcar 'princ text) 7057 (goto-char (point-min)))) 7058 (funcall ask question)) 7059 (funcall ask question))) 7060 7061(defun message-flatten-list (list) 7062 "Return a new, flat list that contains all elements of LIST. 7063 7064\(message-flatten-list '(1 (2 3 (4 5 (6))) 7)) 7065=> (1 2 3 4 5 6 7)" 7066 (cond ((consp list) 7067 (apply 'append (mapcar 'message-flatten-list list))) 7068 (list 7069 (list list)))) 7070 7071(defun message-generate-new-buffer-clone-locals (name &optional varstr) 7072 "Create and return a buffer with name based on NAME using `generate-new-buffer'. 7073Then clone the local variables and values from the old buffer to the 7074new one, cloning only the locals having a substring matching the 7075regexp VARSTR." 7076 (let ((oldbuf (current-buffer))) 7077 (save-excursion 7078 (set-buffer (generate-new-buffer name)) 7079 (message-clone-locals oldbuf varstr) 7080 (current-buffer)))) 7081 7082(defun message-clone-locals (buffer &optional varstr) 7083 "Clone the local variables from BUFFER to the current buffer." 7084 (let ((locals (save-excursion 7085 (set-buffer buffer) 7086 (buffer-local-variables))) 7087 (regexp "^gnus\\|^nn\\|^message\\|^sendmail\\|^smtp\\|^user-mail-address")) 7088 (mapcar 7089 (lambda (local) 7090 (when (and (consp local) 7091 (car local) 7092 (string-match regexp (symbol-name (car local))) 7093 (or (null varstr) 7094 (string-match varstr (symbol-name (car local))))) 7095 (ignore-errors 7096 (set (make-local-variable (car local)) 7097 (cdr local))))) 7098 locals))) 7099 7100;;; 7101;;; MIME functions 7102;;; 7103 7104(defvar message-inhibit-body-encoding nil) 7105 7106(defun message-encode-message-body () 7107 (unless message-inhibit-body-encoding 7108 (let ((mail-parse-charset (or mail-parse-charset 7109 message-default-charset)) 7110 (case-fold-search t) 7111 lines content-type-p) 7112 (message-goto-body) 7113 (save-restriction 7114 (narrow-to-region (point) (point-max)) 7115 (let ((new (mml-generate-mime))) 7116 (when new 7117 (delete-region (point-min) (point-max)) 7118 (insert new) 7119 (goto-char (point-min)) 7120 (if (eq (aref new 0) ?\n) 7121 (delete-char 1) 7122 (search-forward "\n\n") 7123 (setq lines (buffer-substring (point-min) (1- (point)))) 7124 (delete-region (point-min) (point)))))) 7125 (save-restriction 7126 (message-narrow-to-headers-or-head) 7127 (message-remove-header "Mime-Version") 7128 (goto-char (point-max)) 7129 (insert "MIME-Version: 1.0\n") 7130 (when lines 7131 (insert lines)) 7132 (setq content-type-p 7133 (or mml-boundary 7134 (re-search-backward "^Content-Type:" nil t)))) 7135 (save-restriction 7136 (message-narrow-to-headers-or-head) 7137 (message-remove-first-header "Content-Type") 7138 (message-remove-first-header "Content-Transfer-Encoding")) 7139 ;; We always make sure that the message has a Content-Type 7140 ;; header. This is because some broken MTAs and MUAs get 7141 ;; awfully confused when confronted with a message with a 7142 ;; MIME-Version header and without a Content-Type header. For 7143 ;; instance, Solaris' /usr/bin/mail. 7144 (unless content-type-p 7145 (goto-char (point-min)) 7146 ;; For unknown reason, MIME-Version doesn't exist. 7147 (when (re-search-forward "^MIME-Version:" nil t) 7148 (forward-line 1) 7149 (insert "Content-Type: text/plain; charset=us-ascii\n")))))) 7150 7151(defun message-read-from-minibuffer (prompt &optional initial-contents) 7152 "Read from the minibuffer while providing abbrev expansion." 7153 (if (fboundp 'mail-abbrevs-setup) 7154 (let ((mail-abbrev-mode-regexp "") 7155 (minibuffer-setup-hook 'mail-abbrevs-setup) 7156 (minibuffer-local-map message-minibuffer-local-map)) 7157 (read-from-minibuffer prompt initial-contents)) 7158 (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook) 7159 (minibuffer-local-map message-minibuffer-local-map)) 7160 (read-string prompt initial-contents)))) 7161 7162(defun message-use-alternative-email-as-from () 7163 "Set From field of the outgoing message to the first matching 7164address in `message-alternative-emails', looking at To, Cc and 7165From headers in the original article." 7166 (require 'mail-utils) 7167 (let* ((fields '("To" "Cc")) 7168 (emails 7169 (split-string 7170 (mail-strip-quoted-names 7171 (mapconcat 'message-fetch-reply-field fields ",")) 7172 "[ \f\t\n\r\v,]+")) 7173 email) 7174 (while emails 7175 (if (string-match message-alternative-emails (car emails)) 7176 (setq email (car emails) 7177 emails nil)) 7178 (pop emails)) 7179 (unless (or (not email) (equal email user-mail-address)) 7180 (message-remove-header "From") 7181 (goto-char (point-max)) 7182 (insert "From: " email "\n")))) 7183 7184(defun message-options-get (symbol) 7185 (cdr (assq symbol message-options))) 7186 7187(defun message-options-set (symbol value) 7188 (let ((the-cons (assq symbol message-options))) 7189 (if the-cons 7190 (if value 7191 (setcdr the-cons value) 7192 (setq message-options (delq the-cons message-options))) 7193 (and value 7194 (push (cons symbol value) message-options)))) 7195 value) 7196 7197(defun message-options-set-recipient () 7198 (save-restriction 7199 (message-narrow-to-headers-or-head) 7200 (message-options-set 'message-sender 7201 (mail-strip-quoted-names 7202 (message-fetch-field "from"))) 7203 (message-options-set 'message-recipients 7204 (mail-strip-quoted-names 7205 (let ((to (message-fetch-field "to")) 7206 (cc (message-fetch-field "cc")) 7207 (bcc (message-fetch-field "bcc"))) 7208 (concat 7209 (or to "") 7210 (if (and to cc) ", ") 7211 (or cc "") 7212 (if (and (or to cc) bcc) ", ") 7213 (or bcc ""))))))) 7214 7215(defun message-hide-headers () 7216 "Hide headers based on the `message-hidden-headers' variable." 7217 (let ((regexps (if (stringp message-hidden-headers) 7218 (list message-hidden-headers) 7219 message-hidden-headers)) 7220 (inhibit-point-motion-hooks t) 7221 (after-change-functions nil)) 7222 (when regexps 7223 (save-excursion 7224 (save-restriction 7225 (message-narrow-to-headers) 7226 (goto-char (point-min)) 7227 (while (not (eobp)) 7228 (if (not (message-hide-header-p regexps)) 7229 (message-next-header) 7230 (let ((begin (point))) 7231 (message-next-header) 7232 (add-text-properties 7233 begin (point) 7234 '(invisible t message-hidden t)))))))))) 7235 7236(defun message-hide-header-p (regexps) 7237 (let ((result nil) 7238 (reverse nil)) 7239 (when (eq (car regexps) 'not) 7240 (setq reverse t) 7241 (pop regexps)) 7242 (dolist (regexp regexps) 7243 (setq result (or result (looking-at regexp)))) 7244 (if reverse 7245 (not result) 7246 result))) 7247 7248(when (featurep 'xemacs) 7249 (require 'messagexmas) 7250 (message-xmas-redefine)) 7251 7252(provide 'message) 7253 7254(run-hooks 'message-load-hook) 7255 7256;; Local Variables: 7257;; coding: iso-8859-1 7258;; End: 7259 7260;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0 7261;;; message.el ends here 7262