X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=42d9085ed42a83e48bd7d2672ae14085832dc62e;hb=1fe907d9bc96e1b2c91fa8b9f7a7c55ec7777683;hp=c3350a85a44bdb30a12c7b22ea1867553768b77d;hpb=22d67eb69d38558636bccda449388713db84b44d;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index c3350a8..42d9085 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,8 +1,15 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: mail, news +;; MORIOKA Tomohiko +;; Shuhei KOBAYASHI +;; Keiichi Suzuki +;; Tatsuya Ichikawa +;; Katsumi Yamaoka +;; Kiyokazu SUTO +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -29,19 +36,23 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (require 'smtp) + (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary (require 'mailheader) (require 'nnheader) -(require 'easymenu) -(require 'custom) -(if (string-match "XEmacs\\|Lucid" emacs-version) - (require 'mail-abbrevs) - (require 'mailabbrev)) -(require 'mail-parse) -(require 'mm-bodies) -(require 'mm-encode) -(require 'mml) +;; This is apparently necessary even though things are autoloaded: +(if (featurep 'xemacs) + (require 'mail-abbrevs)) +(require 'mime-edit) +(eval-when-compile (require 'static)) + +;; Avoid byte-compile warnings. +(eval-when-compile + (require 'mail-parse) + (require 'mml)) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -101,6 +112,10 @@ :group 'message :group 'faces) +(defgroup message-frames nil + "Message frames" + :group 'message) + (defcustom message-directory "~/Mail/" "*Directory from which all other mail file variables are derived." :group 'message-various @@ -125,6 +140,16 @@ mailbox format." (function :tag "Other")) :group 'message-sending) +(defcustom message-encode-function 'message-maybe-encode + "*A function called to encode messages." + :group 'message-sending + :type 'function) + +(defcustom message-8bit-encoding-list '(8bit binary) + "*8bit encoding type in Content-Transfer-Encoding field." + :group 'message-sending + :type '(repeat (symbol :tag "Type"))) + (defcustom message-courtesy-message "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" "*This is inserted at the start of a mailed copy of a posted message. @@ -139,6 +164,11 @@ If this variable is nil, no such courtesy message will be added." :group 'message-interface :type 'regexp) +(defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit + "Function to setup a re-sending bounced message." + :group 'message-sending + :type 'function) + ;;;###autoload (defcustom message-from-style 'default "*Specifies how \"From\" headers look. @@ -159,7 +189,7 @@ Otherwise, most addresses look like `angles', but they look like :group 'message-headers) (defcustom message-syntax-checks nil - ; Guess this one shouldn't be easy to customize... + ;; Guess this one shouldn't be easy to customize... "*Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. @@ -167,11 +197,12 @@ To disable checking of long signatures, for instance, add Don't touch this variable unless you really know what you're doing. Checks include subject-cmsg multiple-headers sendsys message-id from -long-lines control-chars size new-text redirected-followup signature -approved sender empty empty-headers message-id from subject -shorten-followup-to existing-newsgroups buffer-file-name unchanged -newsgroups." - :group 'message-news) +long-lines control-chars size new-text quoting-style +redirected-followup signature approved sender empty empty-headers +message-id from subject shorten-followup-to existing-newsgroups +buffer-file-name unchanged newsgroups." + :group 'message-news + :type '(repeat sexp)) (defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID @@ -214,25 +245,72 @@ included. Organization, Lines and User-Agent are optional." :group 'message-headers :type 'regexp) -(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:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." :group 'message-interface :type 'regexp) +(defcustom message-supersede-setup-function + 'message-supersede-setup-for-mime-edit + "Function to setup a supersede message." + :group 'message-sending + :type 'function) + (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*" "*Regexp matching \"Re: \" in the subject line." :group 'message-various :type 'regexp) +;;; Some sender agents encode the whole subject including leading "Re: ". +;;; And if followup agent does not decode it for some reason (e.g. unknown +;;; charset) and just add a new "Re: " in front of the encoded-word, the +;;; result will contain multiple "Re: "'s. +(defcustom message-subject-encoded-re-regexp + (concat + "^[ \t]*" + (regexp-quote "=?") + "[-!#$%&'*+0-9A-Z^_`a-z{|}~]+" ; charset + (regexp-quote "?") + "\\(" + "[Bb]" (regexp-quote "?") ; B encoding + "\\(\\(CQk\\|CSA\\|IAk\\|ICA\\)[Jg]\\)*" ; \([ \t][ \t][ \t]\)* + "\\(" + "[Uc][km]U6" ; [Rr][Ee]: + "\\|" + "\\(C[VX]\\|I[FH]\\)J[Fl]O[g-v]" ; [ \t][Rr][Ee]: + "\\|" + "\\(CQl\\|CSB\\|IAl\\|ICB\\)[Sy][RZ]T[o-r]" ; [ \t][ \t][Rr][Ee]: + "\\)" + "\\|" + "[Qb]" (regexp-quote "?") ; Q encoding + "\\(_\\|=09\\|=20\\)*" + "\\([Rr]\\|=[57]2\\)\\([Ee]\\|=[46]5\\)\\(:\\|=3[Aa]\\)" + "\\)" + ) + "*Regexp matching \"Re: \" in the subject line. +Unlike `message-subject-re-regexp', this regexp matches \"Re: \" within +an encoded-word." + :group 'message-various + :type 'regexp) + +(defcustom message-use-subject-re t + "*If t, remove any (buggy) \"Re: \"'s from the subject of the precursor +and add a new \"Re: \". If it is nil, use the subject \"as-is\". If it +is the symbol `guess', try to detect \"Re: \" within an encoded-word." + :group 'message-various + :type '(choice (const :tag "off" nil) + (const :tag "on" t) + (const guess))) + ;;;###autoload (defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." :type 'regexp :group 'message-various) -(defcustom message-elide-elipsis "\n[...]\n\n" +(defcustom message-elide-ellipsis "\n[...]\n\n" "*The string which is inserted for elided text." :type 'string :group 'message-various) @@ -260,6 +338,15 @@ should return the new buffer name." :group 'message-buffers :type 'boolean) +(defcustom message-kill-buffer-query-function 'yes-or-no-p + "*A function called to query the user whether to kill buffer anyway or not. +If it is t, the buffer will be killed peremptorily." + :type '(radio (function-item yes-or-no-p) + (function-item y-or-n-p) + (function-item nnheader-Y-or-n-p) + (function :tag "Other" t)) + :group 'message-buffers) + (defvar gnus-local-organization) (defcustom message-user-organization (or (and (boundp 'gnus-local-organization) @@ -279,9 +366,27 @@ If t, use `message-user-organization-file'." :type 'file :group 'message-headers) +(defcustom message-forward-start-separator + (concat (mime-make-tag "message" "rfc822") "\n") + "*Delimiter inserted before forwarded messages." + :group 'message-forwarding + :type 'string) + +(defcustom message-forward-end-separator + (concat (mime-make-tag "text" "plain") "\n") + "*Delimiter inserted after forwarded messages." + :group 'message-forwarding + :type 'string) + +(defcustom message-included-forward-headers + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-\\|^MIME-Version:" + "*Regexp matching headers to be included in forwarded messages." + :group 'message-forwarding + :type 'regexp) + (defcustom message-make-forward-subject-function 'message-forward-subject-author-subject - "*A list of functions that are called to generate a subject header for forwarded messages. + "*A list of functions that are called to generate a subject header for forwarded messages. The subject generated by the previous function is passed into each successive function. @@ -291,9 +396,24 @@ The provided functions are: newsgroup)), in brackets followed by the subject * message-forward-subject-fwd (Subject of article with 'Fwd:' prepended to it." - :group 'message-forwarding - :type '(radio (function-item message-forward-subject-author-subject) - (function-item message-forward-subject-fwd))) + :group 'message-forwarding + :type '(radio (function-item message-forward-subject-author-subject) + (function-item message-forward-subject-fwd))) + +(defcustom message-forward-as-mime t + "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." + :group 'message-forwarding + :type 'boolean) + +(defcustom message-forward-show-mml t + "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged." + :group 'message-forwarding + :type 'boolean) + +(defcustom message-forward-before-signature t + "*If non-nil, put forwarded message before signature, else after." + :group 'message-forwarding + :type 'boolean) (defcustom message-wash-forwarded-subjects nil "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward." @@ -305,8 +425,7 @@ The provided functions are: :group 'message-interface :type 'regexp) - -(defcustom message-forward-ignored-headers nil +(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" "*All headers that match this regexp will be deleted when forwarding a message." :group 'message-forwarding :type '(choice (const :tag "None" nil) @@ -317,7 +436,7 @@ The provided functions are: :group 'message-insertion :type 'regexp) -(defcustom message-cancel-message "I am canceling my own article." +(defcustom message-cancel-message "I am canceling my own article.\n" "Message to be inserted in the cancel message." :group 'message-interface :type 'string) @@ -331,16 +450,17 @@ variable `mail-header-separator'. Valid values include `message-send-mail-with-sendmail' (the default), `message-send-mail-with-mh', `message-send-mail-with-qmail' and -`smtpmail-send-it'." +`message-send-mail-with-smtp'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) - (function-item smtpmail-send-it) + (function-item message-send-mail-with-smtp) (function :tag "Other")) :group 'message-sending :group 'message-mail) -(defcustom message-send-news-function 'message-send-news +;; 1997-09-29 by MORIOKA Tomohiko +(defcustom message-send-news-function 'message-send-news-with-gnus "Function to call to send the current buffer as news. The headers should be delimited by a line whose contents match the variable `mail-header-separator'." @@ -377,13 +497,49 @@ always query the user whether to use the value. If it is the symbol `use', always use the value." :group 'message-interface :type '(choice (const :tag "ignore" nil) - (const use) - (const ask))) + (const :tag "maybe" t) + (const :tag "always" use) + (const :tag "ask" ask))) + +(defcustom message-use-mail-copies-to 'ask + "*Specifies what to do with Mail-Copies-To header. +If nil, always ignore the header. If it is t, use its value, but +query before using the value other than \"always\" or \"never\". +If it is the symbol `ask', always query the user whether to use +the value. If it is the symbol `use', always use the value." + :group 'message-interface + :type '(choice (const :tag "ignore" nil) + (const :tag "maybe" t) + (const :tag "always" use) + (const :tag "ask" ask))) + +(defcustom message-use-mail-followup-to 'ask + "*Specifies what to do with Mail-Followup-To header. +If nil, always ignore the header. If it is the symbol `ask', always +query the user whether to use the value. If it is t or the symbol +`use', always use the value." + :group 'message-interface + :type '(choice (const :tag "ignore" nil) + (const :tag "maybe" t) + (const :tag "always" use) + (const :tag "ask" ask))) + +;;; XXX: 'ask and 'use are not implemented yet. +(defcustom message-use-mail-reply-to 'ask + "*Specifies what to do with Mail-Reply-To/Reply-To header. +If nil, always ignore the header. If it is t or the symbol `use', use +its value. If it is the symbol `ask', always query the user whether to +use the value. Note that if \"Reply-To\" is marked as \"broken\", its value +is never used." + :group 'message-interface + :type '(choice (const :tag "ignore" nil) + (const :tag "maybe" t) + (const :tag "always" use) + (const :tag "ask" ask))) -;; stuff relating to broken sendmail in MMDF (defcustom message-sendmail-f-is-evil nil - "*Non-nil means that \"-f username\" should not be added to the sendmail -command line, because it is even more evil than leaving it out." + "*Non-nil means that \"-f username\" should not be added to the sendmail command line. +Doing so would be even more evil than leaving it out." :group 'message-sending :type 'boolean) @@ -403,6 +559,11 @@ might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-sending :type '(repeat string)) +(defvar message-cater-to-broken-inn t + "Non-nil means Gnus should not fold the `References' header. +Folding `References' makes ancient versions of INN create incorrect +NOV lines.") + (defvar gnus-post-method) (defvar gnus-select-method) (defcustom message-post-method @@ -427,7 +588,7 @@ variable isn't used." :group 'message-headers :type 'boolean) -(defcustom message-setup-hook nil +(defcustom message-setup-hook '(turn-on-mime-edit) "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook." :group 'message-various @@ -445,12 +606,24 @@ the signature is inserted." :group 'message-various :type 'hook) +(defcustom message-bounce-setup-hook nil + "Normal hook, run each time a re-sending bounced message is initialized. +The function `message-bounce' runs this hook." + :group 'message-various + :type 'hook) + +(defcustom message-supersede-setup-hook nil + "Normal hook, run each time a supersede message is initialized. +The function `message-supersede' runs this hook." + :group 'message-various + :type 'hook) + (defcustom message-mode-hook nil "Hook run in message mode buffers." :group 'message-various :type 'hook) -(defcustom message-header-hook nil +(defcustom message-header-hook '((lambda () (eword-encode-header t))) "Hook run in a message mode buffer narrowed to the headers." :group 'message-various :type 'hook) @@ -472,6 +645,24 @@ the signature is inserted." :type 'string :group 'message-insertion) +(defcustom message-yank-add-new-references t + "Non-nil means new IDs will be added to \"References\" field when an +article is yanked by the command `message-yank-original' interactively. +If it is a symbol `message-id-only', only an ID from \"Message-ID\" field +is used, otherwise IDs extracted from \"References\", \"In-Reply-To\" and +\"Message-ID\" fields are used." + :type '(radio (const :tag "Do not add anything" nil) + (const :tag "From Message-Id, References and In-Reply-To fields" t) + (const :tag "From only Message-Id field." message-id-only)) + :group 'message-insertion) + +(defcustom message-list-references-add-position nil + "Integer value means position for adding to \"References\" field when +an article is yanked by the command `message-yank-original' interactively." + :type '(radio (const :tag "Add to last" nil) + (integer :tag "Position from last ID")) + :group 'message-insertion) + (defcustom message-indentation-spaces 3 "*Number of spaces to insert at the beginning of each cited line. Used by `message-yank-original' via `message-yank-cite'." @@ -486,6 +677,7 @@ Predefined functions include `message-cite-original' and Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil." :type '(radio (function-item message-cite-original) (function-item message-cite-original-without-signature) + (function-item mu-cite-original) (function-item sc-cite-original) (function :tag "Other")) :group 'message-insertion) @@ -541,8 +733,6 @@ If stringp, use this; if non-nil, use no host name (user name only)." (defvar message-reply-buffer nil) (defvar message-reply-headers nil) -(defvar message-newsreader nil) -(defvar message-mailer nil) (defvar message-sent-message-via nil) (defvar message-checksum nil) (defvar message-send-actions nil @@ -553,6 +743,9 @@ If stringp, use this; if non-nil, use no host name (user name only)." "A list of actions to be performed before killing a message buffer.") (defvar message-postpone-actions nil "A list of actions to be performed after postponing a message.") +(defvar message-original-frame nil) +(defvar message-parameter-alist nil) +(defvar message-startup-parameter-alist nil) (define-widget 'message-header-lines 'text "All header lines must be LFD terminated." @@ -574,8 +767,7 @@ these lines." :type 'message-header-lines) (defcustom message-default-news-headers "" - "*A string of header lines to be inserted in outgoing news -articles." + "*A string of header lines to be inserted in outgoing news articles." :group 'message-headers :group 'message-news :type 'message-header-lines) @@ -607,13 +799,17 @@ actually occur." :group 'message-sending :type 'sexp) -;; Ignore errors in case this is used in Emacs 19. -;; Don't use ignore-errors because this is copied into loaddefs.el. +;;; XXX: This symbol is overloaded! See below. +(defvar message-user-agent nil + "String of the form of PRODUCT/VERSION. Used for User-Agent header field.") + +(static-when (boundp 'MULE) + (require 'reporter));; `define-mail-user-agent' is here. + ;;;###autoload -(ignore-errors - (define-mail-user-agent 'message-user-agent - 'message-mail 'message-send-and-exit - 'message-kill-buffer 'message-send-hook)) +(define-mail-user-agent 'message-user-agent + 'message-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook) (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender) "If non-nil, delete the deletable headers before feeding to mh.") @@ -656,7 +852,8 @@ Valid valued are `unique' and `unsent'." :group 'message :type 'symbol) -(defcustom message-dont-reply-to-names rmail-dont-reply-to-names +(defcustom message-dont-reply-to-names + (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) "*A regexp specifying names to prune when doing wide replies. A value of nil means exclude your own name only." :group 'message @@ -802,14 +999,159 @@ Defaults to `text-mode-abbrev-table'.") "Face used for displaying MML." :group 'message-faces) -(defvar message-font-lock-keywords - (let* ((cite-prefix "A-Za-z") - (cite-suffix (concat cite-prefix "0-9_.@-")) - (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) +(defvar message-font-lock-fence-open-regexp "[+|]" + "*Regexp that matches fence open string.") + +(defvar message-font-lock-fence-close-regexp "|" + "*Regexp that matches fence close string.") + +(defvar message-font-lock-fence-open-position nil + "*Cons of SYMBOL of a function or a variable and a number of OFFSET that +indicate the fence open position. If it is non-nil, +`message-font-lock-fence-open-regexp' is not used for searching for the +fence open position. If SYMBOL is a function, it is called with one argument +last cursor position and should return the fence open position as a number +or a marker. If SYMBOL is a variable symbol, the value is examined with +`symbol-value'. OFFSET is added to the position to compensate the value. +For example, the following combinations of variable symbol and offset value +can be used: + +Egg v3: '(egg:*region-start* . -1) +Canna: '(canna:*region-start* . 0) +") + +(defvar message-font-lock-fence-close-position nil + "*Cons of SYMBOL of a function or a variable and a number of OFFSET that +indicate the fence close position. If it is non-nil, +`message-font-lock-fence-close-regexp' is not used for searching for the +fence close position. If SYMBOL is a function, it is called with one argument +last cursor position and should return the fence close position as a number +or a marker. If SYMBOL is a variable symbol, the value is examined with +`symbol-value'. OFFSET is added to the position to compensate the value. +For example, the following combinations of variable symbol and offset value +can be used: + +Egg v3: '(egg:*region-end* . 0) +Canna: '(canna:*region-end* . 0) +") + +(defvar message-font-lock-cited-text-regexp + "^[\t ]*\\([^\000- :>|}\177]*\\)[:>|}].*" + "*Regexp that matches cited text. It should have a grouping for the +citation prefix which is ended at the beginning of citation mark string.") + +(defvar message-font-lock-citation-name-max-column 10 + "*Maximun number of column for citation name for fontifying.") + +(defvar message-font-lock-last-position nil + "Internal buffer local variable to save the last cursor position +before fontifying.") + +(eval-after-load "font-lock" + '(defadvice font-lock-after-change-function + (before message-font-lock-save-last-position activate) + "Save last cursor position before fontifying." + (if (eq 'message-mode major-mode) + (setq message-font-lock-last-position (point))))) + +(defun message-font-lock-cited-text-matcher (limit) + "Search for a cited text containing `message-font-lock-cited-text-regexp' +forward. Argument LIMIT bounds the search. If a cited text is found, it +returns t and sets match data 1 and 2, otherwise it returns nil. Normally, +match data 2 has zero length, but if the FENCE (for input method) is detected +in matched text, result is divided into match data 1 and 2 across the FENCE. +See also the documentations for the following variables: + `message-font-lock-fence-open-regexp' + `message-font-lock-fence-close-regexp' + `message-font-lock-fence-open-position' + `message-font-lock-fence-close-position' +" + (prog1 + (when (re-search-forward message-font-lock-cited-text-regexp limit t) + (let* ((start0 (match-beginning 0)) + (end0 (match-end 0)) + (cite-mark (match-end 1)) + (should-fontify + (progn + (goto-char cite-mark) + (<= (current-column) + message-font-lock-citation-name-max-column))) + end1 start2) + (and + should-fontify + message-font-lock-last-position + (>= message-font-lock-last-position start0) + (<= message-font-lock-last-position end0) + (cond + (message-font-lock-fence-open-position + (let* ((symbol (car message-font-lock-fence-open-position)) + (open + (cond ((functionp symbol) + (funcall symbol message-font-lock-last-position)) + ((and (symbolp symbol) + (boundp symbol)) + (symbol-value symbol))))) + (when (markerp open) + (setq open (marker-position open))) + (and (numberp open) + (setq open + (+ open + (cdr message-font-lock-fence-open-position))) + (>= message-font-lock-last-position open) + (goto-char open) + (or (not message-font-lock-fence-open-regexp) + (looking-at message-font-lock-fence-open-regexp)) + (setq end1 open)))) + (message-font-lock-fence-open-regexp + (goto-char message-font-lock-last-position) + (when (re-search-backward + message-font-lock-fence-open-regexp start0 t) + (setq end1 (match-beginning 0))))) + (setq should-fontify + (and message-font-lock-fence-open-position + (not (eq cite-mark end1)))) + (cond + (message-font-lock-fence-close-position + (let* ((symbol (car message-font-lock-fence-close-position)) + (close + (cond ((functionp symbol) + (funcall symbol message-font-lock-last-position)) + ((and (symbolp symbol) + (boundp symbol)) + (symbol-value symbol))))) + (when (markerp close) + (setq close (marker-position close))) + (and (numberp close) + (setq close + (+ close + (cdr message-font-lock-fence-close-position))) + (<= message-font-lock-last-position close) + (setq start2 close)))) + (message-font-lock-fence-close-regexp + (goto-char message-font-lock-last-position) + (when (looking-at message-font-lock-fence-close-regexp) + (setq start2 (match-end 0))))) + (setq should-fontify + (and (not (and (not message-font-lock-fence-open-position) + (eq cite-mark end1))) + (not (eq cite-mark start2))))) + (goto-char end0) + (when should-fontify + (if start2 + (store-match-data (list start0 end0 start0 end1 start2 end0)) + (store-match-data (list start0 end0 start0 end0 end0 end0))) + t))) + (setq message-font-lock-last-position nil))) + +(defvar message-font-lock-keywords-1 + (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) `((,(concat "^\\([Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-to-face nil t)) - (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) + (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|" + "[Mm]ail-[Cc]opies-[Tt]o:\\|" + "[Mm]ail-[Rr]eply-[Tt]o:\\|" + "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-cc-face nil t)) (,(concat "^\\([Ss]ubject:\\)" content) @@ -828,18 +1170,27 @@ Defaults to `text-mode-abbrev-table'.") (not (equal mail-header-separator ""))) `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") 1 'message-separator-face)) - nil) - (,(concat "^[ \t]*" - "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "[:>|}].*") - (0 'message-cited-text-face)) - ("<#/?\\(multipart\\|part\\|external\\).*>" - (0 'message-mml-face)))) + nil)))) + +(defvar message-font-lock-keywords-2 + (append message-font-lock-keywords-1 + '((message-font-lock-cited-text-matcher + (1 'message-cited-text-face) + (2 'message-cited-text-face)) + ("<#/?\\(multipart\\|part\\|external\\).*>" + (0 'message-mml-face))))) + +(defvar message-font-lock-keywords message-font-lock-keywords-2 "Additional expressions to highlight in Message mode.") ;; XEmacs does it like this. For Emacs, we have to set the ;; `font-lock-defaults' buffer-local variable. -(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) +(put 'message-mode 'font-lock-defaults + '((message-font-lock-keywords + message-font-lock-keywords-1 + message-font-lock-keywords-2) + nil nil nil nil + (font-lock-mark-block-function . mark-paragraph))) (defvar message-face-alist '((bold . bold-region) @@ -871,13 +1222,38 @@ The cdr of ech entry is a function for applying the face to a region.") :group 'message-various :type 'hook) -(defvar message-send-coding-system 'binary - "Coding system to encode outgoing mail.") +(defcustom message-use-multi-frames nil + "Make new frame when sending messages." + :group 'message-frames + :type 'boolean) + +(defcustom message-delete-frame-on-exit nil + "Delete frame after sending messages." + :group 'message-frames + :type '(choice (const :tag "off" nil) + (const :tag "always" t) + (const :tag "ask" ask))) (defvar message-draft-coding-system - mm-auto-save-coding-system + (cond + ((boundp 'MULE) '*junet*) + ((not (fboundp 'find-coding-system)) nil) + ((find-coding-system 'emacs-mule) + (if (memq system-type '(windows-nt ms-dos ms-windows)) + 'emacs-mule-dos 'emacs-mule)) + ((find-coding-system 'escape-quoted) 'escape-quoted) + ((find-coding-system 'no-conversion) 'no-conversion) + (t nil)) "Coding system to compose mail.") +(defcustom message-send-mail-partially-limit 1000000 + "The limitation of messages sent as message/partial. +The lower bound of message size in characters, beyond which the message +should be sent in several parts. If it is nil, the size is unlimited." + :group 'message-buffers + :type '(choice (const :tag "unlimited" nil) + (integer 1000000))) + ;;; Internal variables. (defvar message-buffer-list nil) @@ -925,10 +1301,10 @@ The cdr of ech entry is a function for applying the face to a region.") "\\([^\0-\b\n-\r\^?].*\\)? " ;; The time the message was sent. - "\\([^\0-\r \^?]+\\) +" ; day of the week - "\\([^\0-\r \^?]+\\) +" ; month - "\\([0-3]?[0-9]\\) +" ; day of month - "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day + "\\([^\0-\r \^?]+\\) +" ; day of the week + "\\([^\0-\r \^?]+\\) +" ; month + "\\([0-3]?[0-9]\\) +" ; day of month + "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day ;; Perhaps a time zone, specified by an abbreviation, or by a ;; numeric offset. @@ -981,20 +1357,40 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'mh-send-letter "mh-comp") (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-point-at-bol "gnus-util") + (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'gnus-output-to-mail "gnus-util") (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") (autoload 'nndraft-request-associate-buffer "nndraft") (autoload 'nndraft-request-expire-articles "nndraft") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-request-post "gnus-int") + (autoload 'gnus-copy-article-buffer "gnus-msg") (autoload 'gnus-alive-p "gnus-util") - (autoload 'rmail-output "rmail")) + (autoload 'gnus-group-name-charset "gnus-group") + (autoload 'rmail-output "rmail") + (autoload 'mu-cite-original "mu-cite")) ;;; ;;; Utility functions. ;;; +(defun message-eval-parameter (parameter) + (condition-case () + (if (symbolp parameter) + (if (functionp parameter) + (funcall parameter) + (eval parameter)) + parameter) + (error nil))) + +(defsubst message-get-parameter (key &optional alist) + (unless alist + (setq alist message-parameter-alist)) + (cdr (assq key alist))) + +(defmacro message-get-parameter-with-eval (key &optional alist) + `(message-eval-parameter (message-get-parameter ,key ,alist))) (defmacro message-y-or-n-p (question show &rest text) "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW" @@ -1005,9 +1401,19 @@ The cdr of ech entry is a function for applying the face to a region.") `(delete-region (progn (beginning-of-line) (point)) (progn (forward-line ,(or n 1)) (point)))) +(defun message-unquote-tokens (elems) + "Remove double quotes (\") from strings in list." + (mapcar (lambda (item) + (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) + (setq item (concat (match-string 1 item) + (match-string 2 item)))) + item) + elems)) + (defun message-tokenize-header (header &optional separator) "Split HEADER into a list of header elements. -\",\" is used as the separator." +SEPARATOR is a string of characters to be used as separators. \",\" +is used by default." (if (not header) nil (let ((regexp (format "[%s]+" (or separator ","))) @@ -1037,7 +1443,7 @@ The cdr of ech entry is a function for applying the face to a region.") ((and (eq (char-after) ?\)) (not quoted)) (setq paren nil)))) - (nreverse elems))))) + (nreverse elems))))) (defun message-mail-file-mbox-p (file) "Say whether FILE looks like a Unix mbox file." @@ -1052,12 +1458,13 @@ The cdr of ech entry is a function for applying the face to a region.") (defun message-fetch-field (header &optional not-all) "The same as `mail-fetch-field', only remove all newlines." (let* ((inhibit-point-motion-hooks t) + (case-fold-search t) (value (mail-fetch-field header nil (not not-all)))) (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - ;; We remove all text props.delete-region - (format "%s" value)))) + (set-text-properties 0 (length value) nil value) + value))) (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." @@ -1080,20 +1487,21 @@ The cdr of ech entry is a function for applying the face to a region.") (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers)) (error "Invalid header `%s'" (car headers))) (setq hclean (match-string 1 (car headers))) - (save-restriction - (message-narrow-to-headers) - (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) - (insert (car headers) ?\n)))) + (save-restriction + (message-narrow-to-headers) + (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) + (insert (car headers) ?\n)))) (setq headers (cdr headers)))) (defun message-fetch-reply-field (header) "Fetch FIELD from the message we're replying to." - (when (and message-reply-buffer - (buffer-name message-reply-buffer)) - (save-excursion - (set-buffer message-reply-buffer) - (message-fetch-field header)))) + (let ((buffer (message-eval-parameter message-reply-buffer))) + (when (and buffer + (buffer-name buffer)) + (save-excursion + (set-buffer buffer) + (message-fetch-field header))))) (defun message-set-work-buffer () (if (get-buffer " *message work*") @@ -1101,8 +1509,7 @@ The cdr of ech entry is a function for applying the face to a region.") (set-buffer " *message work*") (erase-buffer)) (set-buffer (get-buffer-create " *message work*")) - (kill-all-local-variables) - (mm-enable-multibyte))) + (kill-all-local-variables))) (defun message-functionp (form) "Return non-nil if FORM is funcallable." @@ -1110,6 +1517,21 @@ The cdr of ech entry is a function for applying the face to a region.") (and (listp form) (eq (car form) 'lambda)) (byte-code-function-p form))) +(defun message-strip-list-identifiers (subject) + "Remove list identifiers in `gnus-list-identifiers'." + (require 'gnus-sum) ; for gnus-list-identifiers + (let ((regexp (if (stringp gnus-list-identifiers) + gnus-list-identifiers + (mapconcat 'identity gnus-list-identifiers " *\\|")))) + (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp + " *\\)\\)+\\(Re: +\\)?\\)") subject) + (concat (substring subject 0 (match-beginning 1)) + (or (match-string 3 subject) + (match-string 5 subject)) + (substring subject + (match-end 1))) + subject))) + (defun message-strip-subject-re (subject) "Remove \"Re:\" from subject lines." (if (string-match message-subject-re-regexp subject) @@ -1283,7 +1705,9 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject) - (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) + ;; (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) + (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-mail-reply-to) + (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to) (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) @@ -1291,11 +1715,13 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) (define-key message-mode-map "\C-c\C-b" 'message-goto-body) (define-key message-mode-map "\C-c\C-i" 'message-goto-signature) + (define-key message-mode-map "\C-c\C-fc" 'message-goto-mail-copies-to) (define-key message-mode-map "\C-c\C-t" 'message-insert-to) (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) (define-key message-mode-map "\C-c\C-y" 'message-yank-original) + (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) (define-key message-mode-map "\C-c\M-h" 'message-insert-headers) @@ -1313,9 +1739,10 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) - (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) + (define-key message-mode-map "\t" 'message-tab) - (define-key message-mode-map "\t" 'message-tab)) + (define-key message-mode-map "\C-x\C-s" 'message-save-drafts) + (define-key message-mode-map "\C-xk" 'message-mimic-kill-buffer)) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -1332,7 +1759,7 @@ Point is left at the beginning of the narrowed-to region." ["Newline and Reformat" message-newline-and-reformat t] ["Rename buffer" message-rename-buffer t] ["Spellcheck" ispell-message t] - ["Attach file as MIME" mml-attach-file t] + ["Attach file as MIME" mime-edit-insert-file t] "----" ["Send Message" message-send-and-exit t] ["Abort Message" message-dont-send t] @@ -1348,6 +1775,9 @@ Point is left at the beginning of the narrowed-to region." ["Subject" message-goto-subject t] ["Cc" message-goto-cc t] ["Reply-To" message-goto-reply-to t] + ["Mail-Reply-To" message-goto-mail-reply-to t] + ["Mail-Followup-To" message-goto-mail-followup-to t] + ["Mail-Copies-To" message-goto-mail-copies-to t] ["Summary" message-goto-summary t] ["Keywords" message-goto-keywords t] ["Newsgroups" message-goto-newsgroups t] @@ -1371,6 +1801,7 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution + C-c C-f C-m move to Mail-Followup-To C-c C-f C-f move to Followup-To C-c C-t message-insert-to (add a To header to a news followup) C-c C-n message-insert-newsgroups (add a Newsgroup header to a news reply) @@ -1383,7 +1814,7 @@ C-c C-e message-elide-region (elide the text between point and mark). C-c C-v message-delete-not-region (remove the text outside the region). C-c C-z message-kill-to-signature (kill the text up to the signature). C-c C-r message-caesar-buffer-body (rot13 the message body). -C-c C-a mml-attach-file (attach a file as MIME)." +M-RET message-newline-and-reformat (break the line and reformat)." (interactive) (kill-all-local-variables) (set (make-local-variable 'message-reply-buffer) nil) @@ -1425,16 +1856,24 @@ C-c C-a mml-attach-file (attach a file as MIME)." (setq paragraph-separate paragraph-start) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) - (make-local-variable 'message-newsreader) - (make-local-variable 'message-mailer) + (make-local-variable 'message-user-agent) (make-local-variable 'message-post-method) (set (make-local-variable 'message-sent-message-via) nil) (set (make-local-variable 'message-checksum) nil) - (set (make-local-variable 'message-mime-part) 0) + (make-local-variable 'message-parameter-alist) + (setq message-parameter-alist + (copy-sequence message-startup-parameter-alist)) ;;(when (fboundp 'mail-hist-define-keys) ;; (mail-hist-define-keys)) - (when (string-match "XEmacs\\|Lucid" emacs-version) - (message-setup-toolbar)) + (if (featurep 'xemacs) + (message-setup-toolbar) + (set (make-local-variable 'font-lock-defaults) + '((message-font-lock-keywords + message-font-lock-keywords-1 + message-font-lock-keywords-2) + nil nil nil nil + (font-lock-mark-block-function . mark-paragraph)))) + (set (make-local-variable 'message-font-lock-last-position) nil) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) ;; Allow mail alias things. @@ -1443,22 +1882,20 @@ C-c C-a mml-attach-file (attach a file as MIME)." (mail-abbrevs-setup) (mail-aliases-setup))) (message-set-auto-save-file-name) - (unless (string-match "XEmacs" emacs-version) - (set (make-local-variable 'font-lock-defaults) - '(message-font-lock-keywords t))) (make-local-variable 'adaptive-fill-regexp) (setq adaptive-fill-regexp - (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" adaptive-fill-regexp)) + (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" + adaptive-fill-regexp)) (unless (boundp 'adaptive-fill-first-line-regexp) (setq adaptive-fill-first-line-regexp nil)) (make-local-variable 'adaptive-fill-first-line-regexp) (setq adaptive-fill-first-line-regexp (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" adaptive-fill-first-line-regexp)) - (mm-enable-multibyte) + (make-local-variable 'auto-fill-inhibit-regexp) + (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:") (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation. (setq indent-tabs-mode nil) - (mml-mode) (run-hooks 'text-mode-hook 'message-mode-hook)) @@ -1499,6 +1936,36 @@ C-c C-a mml-attach-file (attach a file as MIME)." (interactive) (message-position-on-field "Reply-To" "Subject")) +(defun message-goto-mail-reply-to () + "Move point to the Mail-Reply-To header." + (interactive) + (message-position-on-field "Mail-Reply-To" "Subject")) + +(defun message-goto-mail-followup-to () + "Move point to the Mail-Followup-To header. If the header is newly created +and To field contains only one address, the address is inserted in default." + (interactive) + (unless (message-position-on-field "Mail-Followup-To" "Subject") + (let ((start (point)) + addresses) + (save-restriction + (message-narrow-to-headers) + (setq addresses (split-string (mail-strip-quoted-names + (or (std11-fetch-field "to") "")) + "[ \f\t\n\r\v,]+")) + (when (eq 1 (length addresses)) + (goto-char start) + (insert (car addresses)) + (goto-char start)))))) + +(defun message-goto-mail-copies-to () + "Move point to the Mail-Copies-To header. If the header is newly created, +a string \"never\" is inserted in default." + (interactive) + (unless (message-position-on-field "Mail-Copies-To" "Subject") + (insert "never") + (backward-char 5))) + (defun message-goto-newsgroups () "Move point to the Newsgroups header." (interactive) @@ -1570,6 +2037,24 @@ With the prefix argument FORCE, insert the header anyway." (insert (or (message-fetch-reply-field "reply-to") (message-fetch-reply-field "from") ""))) +(defun message-widen-reply () + "Widen the reply to include maximum recipients." + (interactive) + (let ((follow-to + (and message-reply-buffer + (buffer-name message-reply-buffer) + (save-excursion + (set-buffer message-reply-buffer) + (message-get-reply-headers t))))) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (dolist (elem follow-to) + (message-remove-header (symbol-name (car elem))) + (goto-char (point-min)) + (insert (symbol-name (car elem)) ": " + (cdr elem) "\n")))))) + (defun message-insert-newsgroups () "Insert the Newsgroups header from the article being replied to." (interactive) @@ -1614,19 +2099,24 @@ With the prefix argument FORCE, insert the header anyway." (defun message-newline-and-reformat () "Insert four newlines, and then reformat if inside quoted text." (interactive) - (let ((point (point)) - quoted) - (save-excursion - (beginning-of-line) - (if (looking-at (sc-cite-regexp)) - (setq quoted (buffer-substring (match-beginning 0) (match-end 0))))) - (insert "\n\n\n\n") + (let ((prefix "[]>ยป|:}+ \t]*") + (supercite-thing "[-._a-zA-Z0-9]*[>]+[ \t]*") + quoted point) + (unless (bolp) + (save-excursion + (beginning-of-line) + (when (looking-at (concat prefix + supercite-thing)) + (setq quoted (match-string 0)))) + (insert "\n")) + (setq point (point)) + (insert "\n\n\n") (delete-region (point) (re-search-forward "[ \t]*")) (when quoted (insert quoted)) (fill-paragraph nil) (goto-char point) - (forward-line 2))) + (forward-line 1))) (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." @@ -1667,13 +2157,11 @@ With the prefix argument FORCE, insert the header anyway." (defun message-elide-region (b e) "Elide the text between point and mark. -An ellipsis (from `message-elide-elipsis') will be inserted where the +An ellipsis (from `message-elide-ellipsis') will be inserted where the text was killed." (interactive "r") (kill-region b e) - (unless (bolp) - (insert "\n")) - (insert message-elide-elipsis)) + (insert message-elide-ellipsis)) (defvar message-caesar-translation-table nil) @@ -1692,16 +2180,9 @@ text was killed." ;; We build the table, if necessary. (when (or (not message-caesar-translation-table) (/= (aref message-caesar-translation-table ?a) (+ ?a n))) - (setq message-caesar-translation-table - (message-make-caesar-translation-table n))) - ;; Then we translate the region. Do it this way to retain - ;; text properties. - (while (< b e) - (when (< (char-after b) 255) - (subst-char-in-region - b (1+ b) (char-after b) - (aref message-caesar-translation-table (char-after b)))) - (incf b)))) + (setq message-caesar-translation-table + (message-make-caesar-translation-table n))) + (translate-region b e message-caesar-translation-table))) (defun message-make-caesar-translation-table (n) "Create a rot table with offset N." @@ -1738,11 +2219,8 @@ Mail and USENET news headers are not rotated." (save-restriction (when (message-goto-body) (narrow-to-region (point) (point-max))) - (let ((body (buffer-substring (point-min) (point-max)))) - (unless (equal 0 (call-process-region - (point-min) (point-max) program t t)) - (insert body) - (message "%s failed." program)))))) + (shell-command-on-region + (point-min) (point-max) program nil t)))) (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". @@ -1809,7 +2287,7 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (message-delete-line)) ;; Delete blank lines at the end of the buffer. (goto-char (point-max)) - (unless (eolp) + (unless (bolp) (insert "\n")) (while (and (zerop (forward-line -1)) (looking-at "$")) @@ -1824,6 +2302,31 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (forward-line 1)))) (goto-char start))) +(defun message-list-references (refs-list &rest refs-strs) + "Add `Message-ID's which appear in REFS-STRS but not in REFS-LIST, +to REFS-LIST." + (let (refs ref id saved-id) + (when (and refs-list + (integerp message-list-references-add-position)) + (let ((pos message-list-references-add-position)) + (while (and refs-list + (> pos 0)) + (push (pop refs-list) saved-id) + (setq pos (1- pos))))) + (while refs-strs + (when (setq refs (pop refs-strs)) + (setq refs (std11-parse-msg-ids (std11-lexical-analyze refs))) + (while refs + (when (eq (car (setq ref (pop refs))) 'msg-id) + (setq id (concat "<" (mapconcat 'cdr (cdr ref) "") ">")) + (or (member id refs-list) + (member id saved-id) + (push id refs-list)))))) + (while saved-id + (push (pop saved-id) refs-list)) + refs-list)) + +(defvar gnus-article-copy) (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. Puts point before the text and mark after. @@ -1833,13 +2336,55 @@ if `message-yank-prefix' is non-nil, insert that prefix on each line. This function uses `message-cite-function' to do the actual citing. Just \\[universal-argument] as argument means don't indent, insert no -prefix, and don't delete any headers." +prefix, and don't delete any headers. + +In addition, if `message-yank-add-new-references' is non-nil and this +command is called interactively, new IDs from the yanked article will +be added to \"References\" field. +\(See also `message-yank-add-new-references'.)" (interactive "P") - (let ((modified (buffer-modified-p))) - (when (and message-reply-buffer + (let ((modified (buffer-modified-p)) + (buffer (message-eval-parameter message-reply-buffer)) + start end refs) + (when (and buffer message-cite-function) - (delete-windows-on message-reply-buffer t) - (insert-buffer message-reply-buffer) + (delete-windows-on buffer t) + (insert-buffer buffer) ; mark will be set at the end of article. + (setq start (point) + end (mark t)) + + ;; Add new IDs to References field. + (when (and message-yank-add-new-references (interactive-p)) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (setq refs (message-list-references + nil + (message-fetch-field "References"))) + (widen) + (narrow-to-region start end) + (std11-narrow-to-header) + (when (setq refs (message-list-references + refs + (unless (eq message-yank-add-new-references + 'message-id-only) + (or (message-fetch-field "References") + (message-fetch-field "In-Reply-To"))) + (message-fetch-field "Message-ID"))) + (widen) + (message-narrow-to-headers) + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t) + (replace-match "") + (goto-char (point-max)))) + (mail-header-format + (list (or (assq 'References message-header-format-alist) + '(References . message-fill-references))) + (list (cons 'References + (mapconcat 'identity (nreverse refs) " ")))) + (backward-delete-char 1))))) + (funcall message-cite-function) (message-exchange-point-and-mark) (unless (bolp) @@ -1847,6 +2392,24 @@ prefix, and don't delete any headers." (unless modified (setq message-checksum (message-checksum)))))) +(defun message-yank-buffer (buffer) + "Insert BUFFER into the current buffer and quote it." + (interactive "bYank buffer: ") + (let ((message-reply-buffer buffer)) + (save-window-excursion + (message-yank-original)))) + +(defun message-buffers () + "Return a list of active message buffers." + (let (buffers) + (save-excursion + (dolist (buffer (buffer-list t)) + (set-buffer buffer) + (when (and (eq major-mode 'message-mode) + (null message-sent-message-via)) + (push (buffer-name buffer) buffers)))) + (nreverse buffers))) + (defun message-cite-original-without-signature () "Cite function in the standard Message manner." (let ((start (point)) @@ -1856,7 +2419,8 @@ prefix, and don't delete any headers." (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function))))) - (mml-quote-region start end) + ;; Allow undoing. + (undo-boundary) (goto-char end) (when (re-search-backward message-signature-separator start t) ;; Also peel off any blank lines before the signature. @@ -1885,8 +2449,18 @@ prefix, and don't delete any headers." (when message-indent-citation-function (if (listp message-indent-citation-function) message-indent-citation-function - (list message-indent-citation-function))))) - (mml-quote-region start end) + (list message-indent-citation-function)))) + (message-reply-headers (or message-reply-headers + (make-mail-header)))) + (mail-header-set-from message-reply-headers + (save-restriction + (narrow-to-region + (point) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (or (message-fetch-field "from") + "unknown sender"))) (goto-char start) (while functions (funcall (pop functions))) @@ -1956,11 +2530,18 @@ The text will also be indented the normal way." ;;; Sending messages ;;; +;; Avoid byte-compile warning. +(defvar message-encoding-buffer nil) +(defvar message-edit-buffer nil) +(defvar message-mime-mode nil) + (defun message-send-and-exit (&optional arg) "Send message like `message-send', then, if no errors, exit from mail buffer." (interactive "P") (let ((buf (current-buffer)) - (actions message-exit-actions)) + (actions message-exit-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (when (and (message-send arg) (buffer-name buf)) (if message-kill-buffer-on-exit @@ -1969,26 +2550,68 @@ The text will also be indented the normal way." (when (eq buf (current-buffer)) (message-bury buf))) (message-do-actions actions) + (message-delete-frame frame org-frame) t))) (defun message-dont-send () "Don't send the message you have been editing." (interactive) - (set-buffer-modified-p t) - (save-buffer) - (let ((actions message-postpone-actions)) + (message-save-drafts) + (let ((actions message-postpone-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (message-bury (current-buffer)) - (message-do-actions actions))) + (message-do-actions actions) + (message-delete-frame frame org-frame))) (defun message-kill-buffer () "Kill the current buffer." (interactive) (when (or (not (buffer-modified-p)) - (yes-or-no-p "Message modified; kill anyway? ")) - (let ((actions message-kill-actions)) + (eq t message-kill-buffer-query-function) + (funcall message-kill-buffer-query-function + "The buffer modified; kill anyway? ")) + (let ((actions message-kill-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (setq buffer-file-name nil) (kill-buffer (current-buffer)) - (message-do-actions actions)))) + (message-do-actions actions) + (message-delete-frame frame org-frame))) + (message "")) + +(defun message-mimic-kill-buffer () + "Kill the current buffer with query." + (interactive) + (unless (eq 'message-mode major-mode) + (error "%s must be invoked from a message buffer." this-command)) + (let ((command this-command) + (bufname (read-buffer (format "Kill buffer: (default %s) " + (buffer-name))))) + (if (or (not bufname) + (string-equal bufname "") + (string-equal bufname (buffer-name))) + (message-kill-buffer) + (message "%s must be invoked only for the current buffer." command)))) + +(defun message-delete-frame (frame org-frame) + "Delete frame for editing message." + (when (and (or (static-if (featurep 'xemacs) + (device-on-window-system-p) + window-system) + (>= emacs-major-version 20)) + (or (and (eq message-delete-frame-on-exit t) + (select-frame frame) + (or (eq frame org-frame) + (prog1 + (y-or-n-p "Delete this frame?") + (message "")))) + (and (eq message-delete-frame-on-exit 'ask) + (select-frame frame) + (prog1 + (y-or-n-p "Delete this frame?") + (message ""))))) + (delete-frame frame))) (defun message-bury (buffer) "Bury this mail buffer." @@ -2002,48 +2625,65 @@ The text will also be indented the normal way." (defun message-send (&optional arg) "Send the message in the current buffer. -If `message-interactive' is non-nil, wait for success indication -or error messages, and inform user. -Otherwise any failure is reported in a message back to -the user from the mailer." +If `message-interactive' is non-nil, wait for success indication or +error messages, and inform user. +Otherwise any failure is reported in a message back to the user from +the mailer. +The usage of ARG is defined by the instance that called Message. +It should typically alter the sending method in some way or other." (interactive "P") - ;; Make it possible to undo the coming changes. - (undo-boundary) - (let ((inhibit-read-only t)) - (put-text-property (point-min) (point-max) 'read-only nil)) - (message-fix-before-sending) - (run-hooks 'message-send-hook) - (message "Sending...") - (let ((alist message-send-method-alist) - (success t) - elem sent) - (while (and success - (setq elem (pop alist))) - (when (or (not (funcall (cadr elem))) - (and (or (not (memq (car elem) - message-sent-message-via)) - (y-or-n-p - (format - "Already sent message via %s; resend? " - (car elem)))) - (setq success (funcall (caddr elem) arg)))) - (setq sent t))) - (unless (or sent (not success)) - (error "No methods specified to send by")) - (when (and success sent) - (message-do-fcc) + ;; Disabled test. + (when (or (buffer-modified-p) + (message-check-element 'unchanged) + (y-or-n-p "No changes in the buffer; really send? ")) + ;; Make it possible to undo the coming changes. + (undo-boundary) + (let ((inhibit-read-only t)) + (put-text-property (point-min) (point-max) 'read-only nil)) + (run-hooks 'message-send-hook) + (message-fix-before-sending) + (message "Sending...") + (let ((message-encoding-buffer + (message-generate-new-buffer-clone-locals " message encoding")) + (message-edit-buffer (current-buffer)) + (message-mime-mode mime-edit-mode-flag) + (alist message-send-method-alist) + (success t) + elem sent) (save-excursion - (run-hooks 'message-sent-hook)) - (message "Sending...done") - ;; Mark the buffer as unmodified and delete auto-save. - (set-buffer-modified-p nil) - (delete-auto-save-file-if-necessary t) - (message-disassociate-draft) - ;; Delete other mail buffers and stuff. - (message-do-send-housekeeping) - (message-do-actions message-send-actions) - ;; Return success. - t))) + (set-buffer message-encoding-buffer) + (erase-buffer) + (insert-buffer message-edit-buffer) + (funcall message-encode-function) + (while (and success + (setq elem (pop alist))) + (when (or (not (funcall (cadr elem))) + (and (or (not (memq (car elem) + message-sent-message-via)) + (y-or-n-p + (format + "Already sent message via %s; resend? " + (car elem)))) + (setq success (funcall (caddr elem) arg)))) + (setq sent t)))) + (unless (or sent (not success)) + (error "No methods specified to send by")) + (prog1 + (when (and success sent) + (message-do-fcc) + (save-excursion + (run-hooks 'message-sent-hook)) + (message "Sending...done") + ;; Mark the buffer as unmodified and delete autosave. + (set-buffer-modified-p nil) + (delete-auto-save-file-if-necessary t) + (message-disassociate-draft) + ;; Delete other mail buffers and stuff. + (message-do-send-housekeeping) + (message-do-actions message-send-actions) + ;; Return success. + t) + (kill-buffer message-encoding-buffer))))) (defun message-send-via-mail (arg) "Send the current message via mail." @@ -2051,7 +2691,7 @@ the user from the mailer." (defun message-send-via-news (arg) "Send the current message via news." - (funcall message-send-news-function arg)) + (message-send-news arg)) (defmacro message-check (type &rest forms) "Eval FORMS if TYPE is to be checked." @@ -2062,13 +2702,42 @@ the user from the mailer." (put 'message-check 'lisp-indent-function 1) (put 'message-check 'edebug-form-spec '(form body)) +;; This function will be used by MIME-Edit when inserting invisible parts. +(defun message-invisible-region (start end) + (if (featurep 'xemacs) + (if (save-excursion + (goto-char start) + (eq (following-char) ?\n)) + (setq start (1+ start))) + (if (save-excursion + (goto-char (1- end)) + (eq (following-char) ?\n)) + (setq end (1- end)))) + (put-text-property start end 'invisible t) + (if (eq 'message-mode major-mode) + (put-text-property start end 'message-invisible t))) + +(eval-after-load "invisible" + '(defalias 'invisible-region 'message-invisible-region)) + (defun message-fix-before-sending () "Do various things to make the message nice before sending it." ;; Make sure there's a newline at the end of the message. + (widen) (goto-char (point-max)) (unless (bolp) (insert "\n")) - ;; Delete all invisible text. + ;; Expose all invisible text with the property `message-invisible'. + ;; We should believe that the things might be created by MIME-Edit. + (let (start) + (while (setq start (text-property-any (point-min) (point-max) + 'message-invisible t)) + (remove-text-properties start + (or (text-property-not-all start (point-max) + 'message-invisible t) + (point-max)) + '(invisible nil message-invisible nil)))) + ;; Expose all invisible text. (message-check 'invisible-text (when (text-property-any (point-min) (point-max) 'invisible t) (put-text-property (point-min) (point-max) 'invisible nil) @@ -2097,12 +2766,123 @@ the user from the mailer." (eval (car actions))))) (pop actions))) +(defsubst message-maybe-split-and-send-mail () + "Split a message if necessary, and send it via mail. +Returns nil if sending succeeded, returns any string if sending failed. +This sub function is for exclusive use of `message-send-mail'." + (let ((mime-edit-split-ignored-field-regexp + mime-edit-split-ignored-field-regexp) + (case-fold-search t) + failure) + (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp) + (setq mime-edit-split-ignored-field-regexp + (concat (substring mime-edit-split-ignored-field-regexp + 0 (match-beginning 0)) + "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID" + "_so_don't_rape_it!" + (substring mime-edit-split-ignored-field-regexp + (match-end 0))))) + (setq failure + (or + (catch 'message-sending-mail-failure + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (when (re-search-forward "^Message-ID:" nil t) + (delete-region (match-end 0) (std11-field-end)) + (insert " " (message-make-message-id)))) + (condition-case err + (funcall message-send-mail-function) + (error + (throw 'message-sending-mail-failure err)))))) + nil) + (condition-case err + (progn + (funcall message-send-mail-function) + nil) + (error err)))) + (when failure + (if (eq 'error (car failure)) + (cadr failure) + (prin1-to-string failure))))) + +(defun message-send-mail-partially () + "Sendmail as message/partial." + (let ((p (goto-char (point-min))) + (tembuf (message-generate-new-buffer-clone-locals " message temp")) + (curbuf (current-buffer)) + (id (message-make-message-id)) (n 1) + plist total header required-mail-headers) + (while (not (eobp)) + (if (< (point-max) (+ p message-send-mail-partially-limit)) + (goto-char (point-max)) + (goto-char (+ p message-send-mail-partially-limit)) + (beginning-of-line) + (if (<= (point) p) (forward-line 1))) ;; In case of bad message. + (push p plist) + (setq p (point))) + (setq total (length plist)) + (push (point-max) plist) + (setq plist (nreverse plist)) + (unwind-protect + (save-excursion + (setq p (pop plist)) + (while plist + (set-buffer curbuf) + (copy-to-buffer tembuf p (car plist)) + (set-buffer tembuf) + (goto-char (point-min)) + (if header + (progn + (goto-char (point-min)) + (narrow-to-region (point) (point)) + (insert header)) + (message-goto-eoh) + (setq header (buffer-substring (point-min) (point))) + (goto-char (point-min)) + (narrow-to-region (point) (point)) + (insert header) + (message-remove-header "Mime-Version") + (message-remove-header "Content-Type") + (message-remove-header "Content-Transfer-Encoding") + (message-remove-header "Message-ID") + (message-remove-header "Lines") + (goto-char (point-max)) + (insert "Mime-Version: 1.0\n") + (setq header (buffer-substring (point-min) (point-max)))) + (goto-char (point-max)) + (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n" + id n total)) + (let ((mail-header-separator "")) + (when (memq 'Message-ID message-required-mail-headers) + (insert "Message-ID: " (message-make-message-id) "\n")) + (when (memq 'Lines message-required-mail-headers) + (let ((mail-header-separator "")) + (insert "Lines: " (message-make-lines) "\n"))) + (message-goto-subject) + (end-of-line) + (insert (format " (%d/%d)" n total)) + (goto-char (point-max)) + (insert "\n") + (widen) + (mm-with-unibyte-current-buffer + (funcall message-send-mail-function))) + (setq n (+ n 1)) + (setq p (pop plist)) + (erase-buffer))) + (kill-buffer tembuf)))) + (defun message-send-mail (&optional arg) (require 'mail-utils) - (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) - (case-fold-search nil) - (news (message-news-p)) - (mailbuf (current-buffer))) + (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) + (case-fold-search nil) + (news (message-news-p)) + (message-this-is-mail t) + failure) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -2111,42 +2891,52 @@ the user from the mailer." (message-generate-headers message-required-mail-headers)) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (erase-buffer) - ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer mailbuf) - (buffer-string)))) - ;; Remove some headers. - (message-encode-message-body) - (save-restriction - (message-narrow-to-headers) - ;; We (re)generate the Lines header. - (when (memq 'Lines message-required-mail-headers) - (message-generate-headers '(Lines))) + (if (not (message-check-mail-syntax)) + (progn + (message "") + nil) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (erase-buffer) + (insert-buffer message-encoding-buffer) ;; Remove some headers. - (message-remove-header message-ignored-mail-headers t) - (mail-encode-encoded-word-buffer)) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - (when (and news - (or (message-fetch-field "cc") - (message-fetch-field "to"))) - (message-insert-courtesy-copy)) - (funcall message-send-mail-function)) - (kill-buffer tembuf)) - (set-buffer mailbuf) - (push 'mail message-sent-message-via))) + (save-restriction + (message-narrow-to-headers) +;; We Semi-gnus people have no use for it. +;; ;; We (re)generate the Lines header. +;; (when (memq 'Lines message-required-mail-headers) +;; (message-generate-headers '(Lines))) + ;; Remove some headers. + (message-remove-header message-ignored-mail-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (when + (save-restriction + (message-narrow-to-headers) + (and news + (or (message-fetch-field "cc") + (message-fetch-field "to")) + (let ((ct (mime-read-Content-Type))) + (and (eq 'text (cdr (assq 'type ct))) + (eq 'plain (cdr (assq 'subtype ct))))))) + (message-insert-courtesy-copy)) + (setq failure (message-maybe-split-and-send-mail))) + (kill-buffer tembuf)) + (set-buffer message-edit-buffer) + (if failure + (progn + (message "Couldn't send message via mail: %s" failure) + nil) + (push 'mail message-sent-message-via))))) (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." (let ((errbuf (if message-interactive - (generate-new-buffer " sendmail errors") + (message-generate-new-buffer-clone-locals + " sendmail errors") 0)) resend-to-addresses delimline) (let ((case-fold-search t)) @@ -2170,31 +2960,31 @@ the user from the mailer." (save-excursion (set-buffer errbuf) (erase-buffer)))) - (let ((default-directory "/") - (coding-system-for-write message-send-coding-system)) - (apply 'call-process-region - (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") - nil errbuf nil "-oi") - ;; Always specify who from, - ;; since some systems have broken sendmails. - ;; But some systems are more broken with -f, so - ;; we'll let users override this. - (if (null message-sendmail-f-is-evil) - (list "-f" (user-login-name))) - ;; These mean "report errors by mail" - ;; and "deliver in background". - (if (null message-interactive) '("-oem" "-odb")) - ;; Get the addresses from the message - ;; unless this is a resend. - ;; We must not do that for a resend - ;; because we would find the original addresses. - ;; For a resend, include the specific addresses. - (if resend-to-addresses - (list resend-to-addresses) - '("-t"))))) + (let ((default-directory "/")) + (as-binary-process + (apply 'call-process-region + (append (list (point-min) (point-max) + (if (boundp 'sendmail-program) + sendmail-program + "/usr/lib/sendmail") + nil errbuf nil "-oi") + ;; Always specify who from, + ;; since some systems have broken sendmails. + ;; But some systems are more broken with -f, so + ;; we'll let users override this. + (if (null message-sendmail-f-is-evil) + (list "-f" (message-make-address))) + ;; These mean "report errors by mail" + ;; and "deliver in background". + (if (null message-interactive) '("-oem" "-odb")) + ;; Get the addresses from the message + ;; unless this is a resend. + ;; We must not do that for a resend + ;; because we would find the original addresses. + ;; For a resend, include the specific addresses. + (if resend-to-addresses + (list resend-to-addresses) + '("-t")))))) (when message-interactive (save-excursion (set-buffer errbuf) @@ -2216,31 +3006,32 @@ to find out how to use this." (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") + (backward-char 1) (run-hooks 'message-send-mail-hook) ;; send the message (case - (let ((coding-system-for-write message-send-coding-system)) - (apply - 'call-process-region 1 (point-max) message-qmail-inject-program - nil nil nil - ;; qmail-inject's default behaviour is to look for addresses on the - ;; command line; if there're none, it scans the headers. - ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. - ;; - ;; in general, ALL of qmail-inject's defaults are perfect for simply - ;; reading a formatted (i. e., at least a To: or Resent-To header) - ;; message from stdin. - ;; - ;; qmail also has the advantage of not having been raped by - ;; various vendors, so we don't have to allow for that, either -- - ;; compare this with message-send-mail-with-sendmail and weep - ;; for sendmail's lost innocence. - ;; - ;; all this is way cool coz it lets us keep the arguments entirely - ;; free for -inject-arguments -- a big win for the user and for us - ;; since we don't have to play that double-guessing game and the user - ;; gets full control (no gestapo'ish -f's, for instance). --sj - message-qmail-inject-args)) + (as-binary-process + (apply + 'call-process-region 1 (point-max) message-qmail-inject-program + nil nil nil + ;; qmail-inject's default behaviour is to look for addresses on the + ;; command line; if there're none, it scans the headers. + ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. + ;; + ;; in general, ALL of qmail-inject's defaults are perfect for simply + ;; reading a formatted (i. e., at least a To: or Resent-To header) + ;; message from stdin. + ;; + ;; qmail also has the advantage of not having been raped by + ;; various vendors, so we don't have to allow for that, either -- + ;; compare this with message-send-mail-with-sendmail and weep + ;; for sendmail's lost innocence. + ;; + ;; all this is way cool coz it lets us keep the arguments entirely + ;; free for -inject-arguments -- a big win for the user and for us + ;; since we don't have to play that double-guessing game and the user + ;; gets full control (no gestapo'ish -f's, for instance). --sj + message-qmail-inject-args)) ;; qmail-inject doesn't say anything on it's stdout/stderr, ;; we have to look at the retval instead (0 nil) @@ -2267,73 +3058,135 @@ to find out how to use this." ;; Pass it on to mh. (mh-send-letter))) +(defun message-send-mail-with-smtp () + "Send off the prepared buffer with SMTP." + (require 'smtp) ; XXX + (let ((case-fold-search t) + recipients) + (save-restriction + (message-narrow-to-headers) + (setq recipients + ;; XXX: Should be replaced by better one. + (smtp-deduce-address-list (current-buffer) + (point-min) (point-max))) + ;; Remove BCC lines. + (message-remove-header "bcc")) + ;; replace the header delimiter with a blank line. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (run-hooks 'message-send-mail-hook) + (if recipients + (let ((result (smtp-via-smtp user-mail-address + recipients + (current-buffer)))) + (unless (eq result t) + (error "Sending failed; " result))) + (error "Sending failed; no recipients")))) + +(defsubst message-maybe-split-and-send-news (method) + "Split a message if necessary, and send it via news. +Returns nil if sending succeeded, returns t if sending failed. +This sub function is for exclusive use of `message-send-news'." + (let ((mime-edit-split-ignored-field-regexp + mime-edit-split-ignored-field-regexp) + (case-fold-search t)) + (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp) + (setq mime-edit-split-ignored-field-regexp + (concat (substring mime-edit-split-ignored-field-regexp + 0 (match-beginning 0)) + "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID" + "_so_don't_rape_it!" + (substring mime-edit-split-ignored-field-regexp + (match-end 0))))) + (or + (catch 'message-sending-news-failure + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (when (re-search-forward "^Message-ID:" nil t) + (delete-region (match-end 0) (std11-field-end)) + (insert " " (message-make-message-id)))) + (unless (funcall message-send-news-function method) + (throw 'message-sending-news-failure t))))) + nil) + (not (funcall message-send-news-function method))))) + (defun message-send-news (&optional arg) - (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) - (case-fold-search nil) - (method (if (message-functionp message-post-method) - (funcall message-post-method arg) - message-post-method)) - (messbuf (current-buffer)) - (message-syntax-checks - (if arg - (cons '(existing-newsgroups . disabled) - message-syntax-checks) - message-syntax-checks)) - result) - (if (not (message-check-news-body-syntax)) + (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) + (case-fold-search nil) + (method (if (message-functionp message-post-method) + (funcall message-post-method arg) + message-post-method)) + (group-name-charset (gnus-group-name-charset method "")) + (message-syntax-checks + (if arg + (cons '(existing-newsgroups . disabled) + message-syntax-checks) + message-syntax-checks)) + (message-this-is-news t) + result) + (save-restriction + (message-narrow-to-headers) + ;; Insert some headers. + (message-generate-headers message-required-news-headers) + ;; Let the user do all of the above. + (run-hooks 'message-header-hook)) + (if group-name-charset + (setq message-syntax-checks + (cons '(valid-newsgroups . disabled) + message-syntax-checks))) + (message-cleanup-headers) + (if (not (message-check-news-syntax)) nil - (save-restriction - (message-narrow-to-headers) - ;; Insert some headers. - (message-generate-headers message-required-news-headers) - ;; Let the user do all of the above. - (run-hooks 'message-header-hook)) - (message-cleanup-headers) - (if (not (message-check-news-syntax)) - nil - (unwind-protect - (save-excursion - (set-buffer tembuf) - (buffer-disable-undo) - (erase-buffer) - ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer messbuf) - (buffer-string)))) - (message-encode-message-body) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (buffer-disable-undo) + (erase-buffer) + (insert-buffer message-encoding-buffer) + ;; Remove some headers. + (save-restriction + (message-narrow-to-headers) +;; We Semi-gnus people have no use for it. +;; ;; We (re)generate the Lines header. +;; (when (memq 'Lines message-required-mail-headers) +;; (message-generate-headers '(Lines))) ;; Remove some headers. - (save-restriction - (message-narrow-to-headers) - ;; We (re)generate the Lines header. - (when (memq 'Lines message-required-mail-headers) - (message-generate-headers '(Lines))) - ;; Remove some headers. - (message-remove-header message-ignored-news-headers t) - (let ((mail-parse-charset message-posting-charset)) - (mail-encode-encoded-word-buffer))) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - (let ((case-fold-search t)) - ;; Remove the delimiter. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1)) - (run-hooks 'message-send-news-hook) - (gnus-open-server method) - (setq result (let ((mail-header-separator "")) - (gnus-request-post method)))) - (kill-buffer tembuf)) - (set-buffer messbuf) - (if result - (push 'news message-sent-message-via) - (message "Couldn't send message via news: %s" - (nnheader-get-report (car method))) - nil))))) + (message-remove-header message-ignored-news-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (setq result (message-maybe-split-and-send-news method))) + (kill-buffer tembuf)) + (set-buffer message-edit-buffer) + (if result + (progn + (message "Couldn't send message via news: %s" + (nnheader-get-report (car method))) + nil) + (push 'news message-sent-message-via))))) + +;; 1997-09-29 by MORIOKA Tomohiko +(defun message-send-news-with-gnus (method) + (let ((case-fold-search t)) + ;; Remove the delimiter. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (run-hooks 'message-send-news-hook) + (gnus-open-server method) + (gnus-request-post method) + )) ;;; ;;; Header generation & syntax checking. @@ -2352,16 +3205,21 @@ to find out how to use this." (save-excursion (save-restriction (widen) - ;; We narrow to the headers and check them first. - (save-excursion - (save-restriction - (message-narrow-to-headers) - (message-check-news-header-syntax)))))) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-news-header-syntax))) + ;; Check the body. + (save-excursion + (set-buffer message-edit-buffer) + (message-check-news-body-syntax)))))) (defun message-check-news-header-syntax () (and ;; Check Newsgroups header. - (message-check 'newsgroyps + (message-check 'newsgroups (let ((group (message-fetch-field "newsgroups"))) (or (and group @@ -2584,6 +3442,9 @@ to find out how to use this." (y-or-n-p "The article contains control characters. Really post? ") t)) + ;; Check 8bit characters. + (message-check '8bit + (message-check-8bit)) ;; Check excessive size. (message-check 'size (if (> (buffer-size) 60000) @@ -2606,7 +3467,68 @@ to find out how to use this." (format "Your .sig is %d lines; it should be max 4. Really post? " (1- (count-lines (point) (point-max))))) - t)))) + t)) + ;; Ensure that text follows last quoted portion. + (message-check 'quoting-style + (goto-char (point-max)) + (let ((no-problem t)) + (when (search-backward-regexp "^>[^\n]*\n>" nil t) + (setq no-problem nil) + (while (not (eobp)) + (when (and (not (eolp)) (looking-at "[^> \t]")) + (setq no-problem t)) + (forward-line))) + (if no-problem + t + (y-or-n-p "Your text should follow quoted text. Really post? ")))))) + +(defun message-check-mail-syntax () + "Check the syntax of the message." + (save-excursion + (save-restriction + (widen) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-mail-header-syntax))) + ;; Check the body. + (save-excursion + (set-buffer message-edit-buffer) + (message-check-mail-body-syntax)))))) + +(defun message-check-mail-header-syntax () + t) + +(defun message-check-mail-body-syntax () + (and + ;; Check 8bit characters. + (message-check '8bit + (message-check-8bit) + ))) + +(defun message-check-8bit () + "Check the article contains 8bit characters." + (save-excursion + (set-buffer message-encoding-buffer) + (message-narrow-to-headers) + (let* ((case-fold-search t) + (field-value (message-fetch-field "content-transfer-encoding"))) + (if (and field-value + (member (downcase field-value) message-8bit-encoding-list)) + t + (widen) + (set-buffer (get-buffer-create " message syntax")) + (erase-buffer) + (goto-char (point-min)) + (set-buffer-multibyte nil) + (insert-buffer message-encoding-buffer) + (goto-char (point-min)) + (if (re-search-forward "[^\x00-\x7f]" nil t) + (y-or-n-p + "The article contains 8bit characters. Really post? ") + t))))) (defun message-checksum () "Return a \"checksum\" for the current buffer." @@ -2625,12 +3547,13 @@ to find out how to use this." (defun message-do-fcc () "Process Fcc headers in the current buffer." (let ((case-fold-search t) - (buf (current-buffer)) + (coding-system-for-write 'raw-text) + (output-coding-system 'raw-text) list file) (save-excursion (set-buffer (get-buffer-create " *message temp*")) (erase-buffer) - (insert-buffer-substring buf) + (insert-buffer-substring message-encoding-buffer) (save-restriction (message-narrow-to-headers) (while (setq file (message-fetch-field "fcc")) @@ -2658,14 +3581,13 @@ to find out how to use this." (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) (rmail-output file 1 t t)))))) - (kill-buffer (current-buffer))))) (defun message-output (filename) "Append this article to Unix/babyl mail file.." (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (rmail-output-to-rmail-file filename t) + (gnus-output-to-rmail filename t) (gnus-output-to-mail filename t))) (defun message-cleanup-headers () @@ -2719,6 +3641,16 @@ If NOW, use that time instead." ;; We do all of this because XEmacs doesn't have the %z spec. (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60))))) +(defun message-make-followup-subject (subject) + "Make a followup Subject." + (cond + ((and (eq message-use-subject-re 'guess) + (string-match message-subject-encoded-re-regexp subject)) + subject) + (message-use-subject-re + (concat "Re: " (message-strip-subject-re subject))) + (t subject))) + (defun message-make-message-id () "Make a unique Message-ID." (concat "<" (message-unique-id) @@ -2784,9 +3716,9 @@ If NOW, use that time instead." "Make an Organization header." (let* ((organization (when message-user-organization - (if (message-functionp message-user-organization) - (funcall message-user-organization) - message-user-organization)))) + (if (message-functionp message-user-organization) + (funcall message-user-organization) + message-user-organization)))) (save-excursion (message-set-work-buffer) (cond ((stringp organization) @@ -2815,18 +3747,19 @@ If NOW, use that time instead." (defun message-make-in-reply-to () "Return the In-Reply-To header for this message." (when message-reply-headers - (let ((from (mail-header-from message-reply-headers)) + (let ((mid (mail-header-message-id message-reply-headers)) + (from (mail-header-from message-reply-headers)) (date (mail-header-date message-reply-headers))) - (when from - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat (if (and stop-pos - (not (zerop stop-pos))) - (substring from 0 stop-pos) from) - "'s message of \"" - (if (or (not date) (string= date "")) - "(unknown date)" date) - "\"")))))) + (when mid + (concat mid + (when from + (let ((pair (std11-extract-address-components from))) + (concat "\n (" + (or (car pair) (cadr pair)) + "'s message of \"" + (if (or (not date) (string= date "")) + "(unknown date)" date) + "\")")))))))) (defun message-make-distribution () "Make a Distribution header." @@ -2928,7 +3861,7 @@ give as trustworthy answer as possible." "Return the pertinent part of `user-mail-address'." (when user-mail-address (if (string-match " " user-mail-address) - (nth 1 (mail-extract-address-components user-mail-address)) + (nth 1 (std11-extract-address-components user-mail-address)) user-mail-address))) (defun message-make-fqdn () @@ -2964,6 +3897,31 @@ give as trustworthy answer as possible." (or mail-host-address (message-make-fqdn))) +;; Dummy to avoid byte-compile warning. +(defvar mule-version) +(defvar emacs-beta-version) +(defvar xemacs-codename) +(defvar gnus-inviolable-extended-version) + +(defun message-make-user-agent () + "Return user-agent info if the value `message-user-agent' is non-nil. If the +\"User-Agent\" field has already exist, it's value will be added in the return +string." + (when message-user-agent + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t) + user-agent start p end) + (if (re-search-forward "^User-Agent:[\t ]*" nil t) + (progn + (setq start (match-beginning 0) + p (match-end 0) + end (std11-field-end) + user-agent (buffer-substring-no-properties p end)) + (delete-region start (1+ end)) + (concat message-user-agent " " user-agent)) + message-user-agent))))) + (defun message-generate-headers (headers) "Prepare article HEADERS. Headers already prepared in the buffer are not modified." @@ -2980,7 +3938,7 @@ Headers already prepared in the buffer are not modified." (To nil) (Distribution (message-make-distribution)) (Lines (message-make-lines)) - (User-Agent message-newsreader) + (User-Agent (message-make-user-agent)) (Expires (message-make-expires)) (case-fold-search t) header value elem) @@ -3043,7 +4001,7 @@ Headers already prepared in the buffer are not modified." ;; The element is a symbol. We insert the value ;; of this symbol, if any. (symbol-value header)) - (t + ((not (message-check-element header)) ;; We couldn't generate a value for this header, ;; so we just ask the user. (read-from-minibuffer @@ -3057,12 +4015,16 @@ Headers already prepared in the buffer are not modified." ;; This header didn't exist, so we insert it. (goto-char (point-max)) (insert (if (stringp header) header (symbol-name header)) - ": " value "\n") + ": " value) + (unless (bolp) + (insert "\n")) (forward-line -1)) ;; The value of this header was empty, so we clear ;; totally and insert the new value. (delete-region (point) (gnus-point-at-eol)) - (insert value)) + (insert value) + (when (bolp) + (delete-char -1))) ;; Add the deletable property to the headers that require it. (and (memq header message-deletable-headers) (progn (beginning-of-line) (looking-at "[^:]+: ")) @@ -3077,13 +4039,13 @@ Headers already prepared in the buffer are not modified." (not (message-check-element 'sender)) (not (string= (downcase - (cadr (mail-extract-address-components from))) + (cadr (std11-extract-address-components from))) (downcase secure-sender))) (or (null sender) (not (string= (downcase - (cadr (mail-extract-address-components sender))) + (cadr (std11-extract-address-components sender))) (downcase secure-sender))))) (goto-char (point-min)) ;; Rename any old Sender headers to Original-Sender. @@ -3133,12 +4095,11 @@ Headers already prepared in the buffer are not modified." (when (not quoted) (if (and (> (current-column) 78) last) - (progn - (save-excursion - (goto-char last) - (insert "\n\t")) - (setq last (1+ (point)))) - (setq last (1+ (point))))) + (save-excursion + (goto-char last) + (looking-at "[ \t]*") + (replace-match "\n " t t))) + (setq last (1+ (point)))) (setq quoted (not quoted))) (unless (eobp) (forward-char 1)))) @@ -3146,10 +4107,17 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(defun message-fill-references (header value) + (insert (capitalize (symbol-name header)) + ": " + (std11-fill-msg-id-list-string + (if (consp value) (car value) value)) + "\n")) + (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 990) - (fill-prefix "\t")) + (fill-column 78) + (fill-prefix " ")) (insert (capitalize (symbol-name header)) ": " (if (consp value) (car value) value) @@ -3167,23 +4135,63 @@ Headers already prepared in the buffer are not modified." (replace-match " " t t)) (goto-char (point-max))))) +(defun message-shorten-1 (list cut surplus) + ;; Cut SURPLUS elements out of LIST, beginning with CUTth one. + (setcdr (nthcdr (- cut 2) list) + (nthcdr (+ (- cut 2) surplus 1) list))) + (defun message-shorten-references (header references) - "Limit REFERENCES to be shorter than 988 characters." - (let ((max 988) - (cut 4) + "Trim REFERENCES to be less than 31 Message-ID long, and fold them. +If folding is disallowed, also check that the REFERENCES are less +than 988 characters long, and if they are not, trim them until they are." + (let ((maxcount 31) + (count 0) + (cut 6) refs) (with-temp-buffer (insert references) (goto-char (point-min)) + ;; Cons a list of valid references. (while (re-search-forward "<[^>]+>" nil t) (push (match-string 0) refs)) - (setq refs (nreverse refs)) - (while (> (length (mapconcat 'identity refs " ")) max) - (when (< (length refs) (1+ cut)) - (decf cut)) - (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs))))) - (insert (capitalize (symbol-name header)) ": " - (mapconcat 'identity refs " ") "\n"))) + (setq refs (nreverse refs) + count (length refs))) + + ;; If the list has more than MAXCOUNT elements, trim it by + ;; removing the CUTth element and the required number of + ;; elements that follow. + (when (> count maxcount) + (let ((surplus (- count maxcount))) + (message-shorten-1 refs cut surplus) + (decf count surplus))) + + ;; If folding is disallowed, make sure the total length (including + ;; the spaces between) will be less than MAXSIZE characters. + ;; + ;; Only disallow folding for News messages. At this point the headers + ;; have not been generated, thus we use message-this-is-news directly. + (when (and message-this-is-news message-cater-to-broken-inn) + (let ((maxsize 988) + (totalsize (+ (apply #'+ (mapcar #'length refs)) + (1- count))) + (surplus 0) + (ptr (nthcdr (1- cut) refs))) + ;; Decide how many elements to cut off... + (while (> totalsize maxsize) + (decf totalsize (1+ (length (car ptr)))) + (incf surplus) + (setq ptr (cdr ptr))) + ;; ...and do it. + (when (> surplus 0) + (message-shorten-1 refs cut surplus)))) + + ;; Finally, collect the references back into a string and insert + ;; it into the buffer. + (let ((refstring (mapconcat #'identity refs " "))) + (if (and message-this-is-news message-cater-to-broken-inn) + (insert (capitalize (symbol-name header)) ": " + refstring "\n") + (message-fill-header header refstring))))) (defun message-position-point () "Move point to where the user probably wants to find it." @@ -3213,7 +4221,7 @@ Headers already prepared in the buffer are not modified." (concat "*" type (if to (concat " to " - (or (car (mail-extract-address-components to)) + (or (car (std11-extract-address-components to)) to) "") "") (if (and group (not (string= group ""))) (concat " on " group) "") @@ -3236,20 +4244,36 @@ Headers already prepared in the buffer are not modified." (t (format "*%s message*" type)))) +(defmacro message-pop-to-buffer-1 (buffer) + `(if pop-up-frames + (let (special-display-buffer-names + special-display-regexps + same-window-buffer-names + same-window-regexps) + (pop-to-buffer ,buffer)) + (pop-to-buffer ,buffer))) + (defun message-pop-to-buffer (name) "Pop to buffer NAME, and warn if it already exists and is modified." - (let ((buffer (get-buffer name))) + (let ((buffer (get-buffer name)) + (pop-up-frames (and (or (static-if (featurep 'xemacs) + (device-on-window-system-p) + window-system) + (>= emacs-major-version 20)) + message-use-multi-frames))) (if (and buffer (buffer-name buffer)) (progn - (set-buffer (pop-to-buffer buffer)) + (message-pop-to-buffer-1 buffer) (when (and (buffer-modified-p) (not (y-or-n-p "Message already being composed; erase? "))) (error "Message being composed"))) - (set-buffer (pop-to-buffer name))) + (message-pop-to-buffer-1 name)) (erase-buffer) - (message-mode))) + (message-mode) + (when pop-up-frames + (set (make-local-variable 'message-original-frame) (selected-frame))))) (defun message-do-send-housekeeping () "Kill old message buffers." @@ -3284,7 +4308,9 @@ Headers already prepared in the buffer are not modified." mc-modes-alist)) (when actions (setq message-send-actions actions)) - (setq message-reply-buffer replybuffer) + (setq message-reply-buffer + (or (message-get-parameter 'reply-buffer) + replybuffer)) (goto-char (point-min)) ;; Insert all the headers. (mail-header-format @@ -3346,7 +4372,9 @@ Headers already prepared in the buffer are not modified." message-auto-save-directory)) (setq buffer-auto-save-file-name (make-auto-save-file-name))) (clear-visited-file-modtime) - (setq buffer-file-coding-system message-draft-coding-system))) + (static-if (boundp 'MULE) + (set-file-coding-system message-draft-coding-system) + (setq buffer-file-coding-system message-draft-coding-system)))) (defun message-disassociate-draft () "Disassociate the message buffer from the drafts directory." @@ -3400,16 +4428,131 @@ OTHER-HEADERS is an alist of header/value pairs." (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) +(defun message-get-reply-headers (wide &optional to-address) + (let (follow-to mct never-mct from to cc reply-to mft) + ;; Find all relevant headers we need. + (setq from (message-fetch-field "from") + to (message-fetch-field "to") + cc (message-fetch-field "cc") + mct (when message-use-mail-copies-to + (message-fetch-field "mail-copies-to")) + reply-to (when message-use-mail-reply-to + (or (message-fetch-field "mail-reply-to") + (message-fetch-field "reply-to"))) + mft (when (and (not to-address) + (not reply-to) + message-use-mail-followup-to) + (message-fetch-field "mail-followup-to"))) + + ;; Handle special values of Mail-Copies-To. + (when mct + (cond + ((and (or (equal (downcase mct) "never") + (equal (downcase mct) "nobody")) + (or (not (eq message-use-mail-copies-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Copies-To: never? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: never' +directs you not to send your response to the author."))) + (setq never-mct t) + (setq mct nil)) + ((and (or (equal (downcase mct) "always") + (equal (downcase mct) "poster")) + (or (not (eq message-use-mail-copies-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Copies-To: always? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: always' +sends a copy of your response to the author."))) + (setq mct (or reply-to from))) + ((and (eq message-use-mail-copies-to 'ask) + (not + (message-y-or-n-p + (concat "Obey Mail-Copies-To: " mct " ? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: " mct "' +sends a copy of your response to " (if (string-match "," mct) + "the specified addresses" + "that address") "."))) + (setq mct nil)))) + + ;; Handle Mail-Followup-To. + (when (and mft + (eq message-use-mail-followup-to 'ask) + (not (message-y-or-n-p + (concat "Obey Mail-Followup-To: " mft "? ") t "\ +You should normally obey the Mail-Followup-To: header. + + `Mail-Followup-To: " mft "' +directs your response to " (if (string-match "," mft) + "the specified addresses" + "that address only") ". + +A typical situation where Mail-Followup-To is used is when the author thinks +that further discussion should take place only in " + (if (string-match "," mft) + "the specified mailing lists" + "that mailing list") "."))) + (setq mft nil)) + + (if (or (not wide) + to-address) + (progn + (setq follow-to (list (cons 'To (or to-address reply-to mft from)))) + (when (and wide mct) + (push (cons 'Cc mct) follow-to))) + (let (ccalist) + (save-excursion + (message-set-work-buffer) + (unless never-mct + (insert (or reply-to from ""))) + (insert (if mft (concat (if (bolp) "" ", ") mft "") "")) + (insert (if to (concat (if (bolp) "" ", ") to "") "")) + (insert (if mct (concat (if (bolp) "" ", ") mct) "")) + (insert (if cc (concat (if (bolp) "" ", ") cc) "")) + (goto-char (point-min)) + (while (re-search-forward "[ \t]+" nil t) + (replace-match " " t t)) + ;; Remove addresses that match `rmail-dont-reply-to-names'. + (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) + (insert (prog1 (rmail-dont-reply-to (buffer-string)) + (erase-buffer)))) + (goto-char (point-min)) + ;; Perhaps "Mail-Copies-To: never" removed the only address? + (when (eobp) + (insert (or reply-to from ""))) + (setq ccalist + (mapcar + (lambda (addr) + (cons (mail-strip-quoted-names addr) addr)) + (message-tokenize-header (buffer-string)))) + (let ((s ccalist)) + (while s + (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) + (setq follow-to (list (cons 'To (cdr (pop ccalist))))) + (when ccalist + (let ((ccs (cons 'Cc (mapconcat + (lambda (addr) (cdr addr)) ccalist ", ")))) + (when (string-match "^ +" (cdr ccs)) + (setcdr ccs (substring (cdr ccs) (match-end 0)))) + (push ccs follow-to))))) + follow-to)) + ;;;###autoload (defun message-reply (&optional to-address wide) "Start editing a reply to the article in the current buffer." (interactive) + (require 'gnus-sum) ; for gnus-list-identifiers (let ((cur (current-buffer)) - from subject date reply-to to cc + from subject date references message-id follow-to (inhibit-point-motion-hooks t) (message-this-is-mail t) - mct never-mct gnus-warning) + gnus-warning in-reply-to) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3422,85 +4565,37 @@ OTHER-HEADERS is an alist of header/value pairs." (save-excursion (setq follow-to (funcall message-wide-reply-to-function))))) - ;; Find all relevant headers we need. - (setq from (message-fetch-field "from") - date (message-fetch-field "date") - subject (or (message-fetch-field "subject") "none") - to (message-fetch-field "to") - cc (message-fetch-field "cc") - mct (message-fetch-field "mail-copies-to") - reply-to (message-fetch-field "reply-to") + (setq message-id (message-fetch-field "message-id" t) references (message-fetch-field "references") - message-id (message-fetch-field "message-id" t)) - ;; Remove any (buggy) Re:'s that are present and make a - ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + date (message-fetch-field "date") + from (message-fetch-field "from") + subject (or (message-fetch-field "subject") "none")) + (if gnus-list-identifiers + (setq subject (message-strip-list-identifiers subject))) + (setq subject (message-make-followup-subject subject)) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) - ;; Handle special values of Mail-Copies-To. - (when mct - (cond ((or (equal (downcase mct) "never") - (equal (downcase mct) "nobody")) - (setq never-mct t) - (setq mct nil)) - ((or (equal (downcase mct) "always") - (equal (downcase mct) "poster")) - (setq mct (or reply-to from))))) - (unless follow-to - (if (or (not wide) - to-address) - (progn - (setq follow-to (list (cons 'To (or to-address reply-to from)))) - (when (and wide mct) - (push (cons 'Cc mct) follow-to))) - (let (ccalist) - (save-excursion - (message-set-work-buffer) - (unless never-mct - (insert (or reply-to from ""))) - (insert (if to (concat (if (bolp) "" ", ") to "") "")) - (insert (if mct (concat (if (bolp) "" ", ") mct) "")) - (insert (if cc (concat (if (bolp) "" ", ") cc) "")) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+" nil t) - (replace-match " " t t)) - ;; Remove addresses that match `rmail-dont-reply-to-names'. - (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) - (insert (prog1 (rmail-dont-reply-to (buffer-string)) - (erase-buffer)))) - (goto-char (point-min)) - ;; Perhaps Mail-Copies-To: never removed the only address? - (when (eobp) - (insert (or reply-to from ""))) - (setq ccalist - (mapcar - (lambda (addr) - (cons (mail-strip-quoted-names addr) addr)) - (message-tokenize-header (buffer-string)))) - (let ((s ccalist)) - (while s - (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) - (setq follow-to (list (cons 'To (cdr (pop ccalist))))) - (when ccalist - (let ((ccs (cons 'Cc (mapconcat - (lambda (addr) (cdr addr)) ccalist ", ")))) - (when (string-match "^ +" (cdr ccs)) - (setcdr ccs (substring (cdr ccs) (match-end 0)))) - (push ccs follow-to)))))) - (widen)) + (setq follow-to (message-get-reply-headers wide to-address))) + + ;; Get the references from "In-Reply-To" field if there were + ;; no references and "In-Reply-To" field looks promising. + (unless references + (when (and (setq in-reply-to (message-fetch-field "in-reply-to")) + (string-match "<[^>]+>" in-reply-to)) + (setq references (match-string 0 in-reply-to))))) - (message-pop-to-buffer (message-buffer-name - (if wide "wide reply" "reply") from - (if wide to-address nil))) + (message-pop-to-buffer + (message-buffer-name + (if wide "wide reply" "reply") from + (if wide to-address nil))) (setq message-reply-headers - (vector 0 subject from date message-id references 0 0 "")) + (make-full-mail-header-from-decoded-header + 0 subject from date message-id references 0 0 "")) (message-setup `((Subject . ,subject) @@ -3523,75 +4618,107 @@ OTHER-HEADERS is an alist of header/value pairs." If TO-NEWSGROUPS, use that as the new Newsgroups line." (interactive) (let ((cur (current-buffer)) - from subject date reply-to mct + from subject date mct references message-id follow-to (inhibit-point-motion-hooks t) (message-this-is-news t) - followup-to distribution newsgroups gnus-warning posted-to) + followup-to distribution newsgroups gnus-warning posted-to mft mrt) (save-restriction - (narrow-to-region - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max))) + (message-narrow-to-head) (when (message-functionp message-followup-to-function) (setq follow-to (funcall message-followup-to-function))) (setq from (message-fetch-field "from") - date (message-fetch-field "date") + date (message-fetch-field "date" t) subject (or (message-fetch-field "subject") "none") references (message-fetch-field "references") message-id (message-fetch-field "message-id" t) - followup-to (message-fetch-field "followup-to") + followup-to (when message-use-followup-to + (message-fetch-field "followup-to")) + distribution (message-fetch-field "distribution") newsgroups (message-fetch-field "newsgroups") posted-to (message-fetch-field "posted-to") - reply-to (message-fetch-field "reply-to") - distribution (message-fetch-field "distribution") - mct (message-fetch-field "mail-copies-to")) - (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) - (string-match "<[^>]+>" gnus-warning)) + mct (when message-use-mail-copies-to + (message-fetch-field "mail-copies-to")) + mft (when message-use-mail-followup-to + (message-fetch-field "mail-followup-to")) + mrt (when message-use-mail-reply-to + (or (message-fetch-field "mail-reply-to") + (message-fetch-field "reply-to"))) + gnus-warning (message-fetch-field "gnus-warning")) + (when (and gnus-warning (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) ;; Remove bogus distribution. (when (and (stringp distribution) (let ((case-fold-search t)) (string-match "world" distribution))) (setq distribution nil)) - ;; Remove any (buggy) Re:'s that are present and make a - ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + (if gnus-list-identifiers + (setq subject (message-strip-list-identifiers subject))) + (setq subject (message-make-followup-subject subject)) (widen)) - (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) - - (message-setup - `((Subject . ,subject) - ,@(cond - (to-newsgroups - (list (cons 'Newsgroups to-newsgroups))) - (follow-to follow-to) - ((and followup-to message-use-followup-to) - (list - (cond - ((equal (downcase followup-to) "poster") - (if (or (eq message-use-followup-to 'use) - (message-y-or-n-p "Obey Followup-To: poster? " t "\ + ;; Handle special values of Mail-Copies-To. + (when mct + (cond + ((and (or (equal (downcase mct) "never") + (equal (downcase mct) "nobody")) + (or (not (eq message-use-mail-copies-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Copies-To: never? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: never' +directs you not to send your response to the author."))) + (setq mct nil)) + ((and (or (equal (downcase mct) "always") + (equal (downcase mct) "poster")) + (or (not (eq message-use-mail-copies-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Copies-To: always? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: always' +sends a copy of your response to the author."))) + (setq mct (or mrt from))) + ((and (eq message-use-mail-copies-to 'ask) + (not + (message-y-or-n-p + (concat "Obey Mail-Copies-To: " mct " ? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: " mct "' +sends a copy of your response to " (if (string-match "," mct) + "the specified addresses" + "that address") "."))) + (setq mct nil)) + )) + + (unless follow-to + (cond + (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups)))) + ;; Handle Followup-To. + (followup-to + (cond + ((equal (downcase followup-to) "poster") + (if (or (eq message-use-followup-to 'use) + (message-y-or-n-p "Obey Followup-To: poster? " t "\ You should normally obey the Followup-To: header. -`Followup-To: poster' sends your response via e-mail instead of news. + `Followup-To: poster' +sends your response via e-mail instead of news. -A typical situation where `Followup-To: poster' is used is when the poster +A typical situation where `Followup-To: poster' is used is when the author does not read the newsgroup, so he wouldn't see any replies sent to it.")) - (progn - (setq message-this-is-news nil) - (cons 'To (or reply-to from ""))) - (cons 'Newsgroups newsgroups))) - (t - (if (or (equal followup-to newsgroups) - (not (eq message-use-followup-to 'ask)) - (message-y-or-n-p - (concat "Obey Followup-To: " followup-to "? ") t "\ + (setq message-this-is-news nil + distribution nil + follow-to (list (cons 'To (or mrt from "")))) + (setq follow-to (list (cons 'Newsgroups newsgroups))))) + (t + (if (or (equal followup-to newsgroups) + (not (eq message-use-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Followup-To: " followup-to "? ") t "\ You should normally obey the Followup-To: header. `Followup-To: " followup-to "' @@ -3606,40 +4733,59 @@ be fragmented and very difficult to follow. Also, some source/announcement newsgroups are not indented for discussion; responses here are directed to other newsgroups.")) - (cons 'Newsgroups followup-to) - (cons 'Newsgroups newsgroups)))))) - (posted-to - `((Newsgroups . ,posted-to))) - (t - `((Newsgroups . ,newsgroups)))) - ,@(and distribution (list (cons 'Distribution distribution))) - ,@(if (or references message-id) - `((References . ,(concat (or references "") (and references " ") - (or message-id ""))))) - ,@(when (and mct - (not (or (equal (downcase mct) "never") - (equal (downcase mct) "nobody")))) - (list (cons 'Cc (if (or (equal (downcase mct) "always") - (equal (downcase mct) "poster")) - (or reply-to from "") - mct))))) + (setq follow-to (list (cons 'Newsgroups followup-to))) + (setq follow-to (list (cons 'Newsgroups newsgroups))))))) + ;; Handle Mail-Followup-To, followup via e-mail. + ((and mft + (or (not (eq message-use-mail-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Followup-To: " mft "? ") t "\ +You should normally obey the Mail-Followup-To: header. + + `Mail-Followup-To: " mft "' +directs your response to " (if (string-match "," mft) + "the specified addresses" + "that address only") " instead of news. + +A typical situation where Mail-Followup-To is used is when the author thinks +that further discussion should take place only in " + (if (string-match "," mft) + "the specified mailing lists" + "that mailing list") "."))) + (setq message-this-is-news nil + distribution nil + follow-to (list (cons 'To mft)))) + (posted-to (setq follow-to (list (cons 'Newsgroups posted-to)))) + (t + (setq follow-to (list (cons 'Newsgroups newsgroups)))))) - cur) + (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) (setq message-reply-headers - (vector 0 subject from date message-id references 0 0 "")))) + (make-full-mail-header-from-decoded-header + 0 subject from date message-id references 0 0 "")) + (message-setup + `((Subject . ,subject) + ,@follow-to + ,@(and mct (list (cons 'Cc mct))) + ,@(and distribution (list (cons 'Distribution distribution))) + ,@(if (or references message-id) + `((References . ,(concat (or references "") (and references " ") + (or message-id "")))))) + cur))) ;;;###autoload -(defun message-cancel-news () - "Cancel an article you posted." - (interactive) +(defun message-cancel-news (&optional arg) + "Cancel an article you posted. +If ARG, allow editing of the cancellation message." + (interactive "P") (unless (message-news-p) (error "This is not a news article; canceling is impossible")) (when (yes-or-no-p "Do you really want to cancel this article? ") (let (from newsgroups message-id distribution buf sender) (save-excursion - ;; Get header info. from original article. + ;; Get header info from original article. (save-restriction (message-narrow-to-head) (setq from (message-fetch-field "from") @@ -3648,20 +4794,23 @@ responses here are directed to other newsgroups.")) message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. - (unless (or (and sender - (string-equal - (downcase sender) - (downcase (message-make-sender)))) - (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (cadr (mail-extract-address-components + (unless (or (and sender + (string-equal + (downcase sender) + (downcase (message-make-sender)))) + (string-equal + (downcase (cadr (std11-extract-address-components + from))) + (downcase (cadr (std11-extract-address-components (message-make-from)))))) (error "This article is not yours")) ;; Make control message. - (setq buf (set-buffer (get-buffer-create " *message cancel*"))) + (if arg + (message-news) + (setq buf (set-buffer (get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" - "From: " (message-make-from) "\n" + "From: " from "\n" "Subject: cmsg cancel " message-id "\n" "Control: cancel " message-id "\n" (if distribution @@ -3671,11 +4820,18 @@ responses here are directed to other newsgroups.")) message-cancel-message) (run-hooks 'message-cancel-hook) (message "Canceling your article...") - (if (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me)) - (funcall message-send-news-function)) - (message "Canceling your article...done")) - (kill-buffer buf))))) + (unless arg + (if (let ((message-syntax-checks + 'dont-check-for-anything-just-trust-me) + (message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) + (message-send-news)) + (message "Canceling your article...done")) + (kill-buffer buf)))))) + +(defun message-supersede-setup-for-mime-edit () + (set (make-local-variable 'message-setup-hook) nil) + (mime-edit-again)) ;;;###autoload (defun message-supersede () @@ -3692,8 +4848,8 @@ header line with the old Message-ID." (downcase sender) (downcase (message-make-sender)))) (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (cadr (mail-extract-address-components + (downcase (cadr (std11-extract-address-components from))) + (downcase (cadr (std11-extract-address-components (message-make-from)))))) (error "This article is not yours")) ;; Get a normal message buffer. @@ -3710,7 +4866,11 @@ header line with the old Message-ID." (goto-char (point-max)) (insert mail-header-separator) (widen) - (forward-line 1))) + (when message-supersede-setup-function + (funcall message-supersede-setup-function)) + (run-hooks 'message-supersede-setup-hook) + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil t))) ;;;###autoload (defun message-recover () @@ -3720,6 +4880,8 @@ header line with the old Message-ID." (cond ((save-window-excursion (if (not (eq system-type 'vax-vms)) (with-output-to-temp-buffer "*Directory*" + (with-current-buffer standard-output + (fundamental-mode)) ; for Emacs 20.4+ (buffer-disable-undo standard-output) (let ((default-directory "/")) (call-process @@ -3785,13 +4947,16 @@ the message." "Return a Subject header suitable for the message in the current buffer." (save-excursion (save-restriction - (current-buffer) (message-narrow-to-head) (let ((funcs message-make-forward-subject-function) - (subject (if message-wash-forwarded-subjects - (message-wash-subject - (or (message-fetch-field "Subject") "")) - (or (message-fetch-field "Subject") "")))) + (subject (message-fetch-field "Subject"))) + (setq subject + (if subject + (if message-wash-forwarded-subjects + (message-wash-subject + (nnheader-decode-subject subject)) + (nnheader-decode-subject subject)) + "(none)")) ;; Make sure funcs is a list. (and funcs (not (listp funcs)) @@ -3817,28 +4982,36 @@ Optional NEWS will use news to forward instead of mail." (message-mail nil subject)) ;; Put point where we want it before inserting the forwarded ;; message. - (message-goto-body) - (insert "\n\n<#part type=message/rfc822 disposition=inline>\n") - (let ((b (point)) - e) - (mml-insert-buffer cur) - (setq e (point)) - (insert "<#/part>\n") - (when message-forward-ignored-headers - (save-restriction - (narrow-to-region b e) - (message-narrow-to-head) - (message-remove-header message-forward-ignored-headers t)))) + (if message-forward-before-signature + (message-goto-body) + (goto-char (point-max))) + ;; Make sure we're at the start of the line. + (unless (bolp) + (insert "\n")) + ;; Narrow to the area we are to insert. + (narrow-to-region (point) (point)) + ;; Insert the separators and the forwarded buffer. + (insert message-forward-start-separator) + (setq art-beg (point)) + (insert-buffer-substring cur) + (goto-char (point-max)) + (insert message-forward-end-separator) + (set-text-properties (point-min) (point-max) nil) + ;; Remove all unwanted headers. + (goto-char art-beg) + (narrow-to-region (point) (if (search-forward "\n\n" nil t) + (1- (point)) + (point))) + (goto-char (point-min)) + (message-remove-header message-included-forward-headers t nil t) + (widen) (message-position-point))) ;;;###autoload (defun message-resend (address) "Resend the current article to ADDRESS." (interactive - (list - (let ((mail-abbrev-mode-regexp "")) - (read-from-minibuffer - "Resend message to: " nil message-mode-map)))) + (list (message-read-from-minibuffer "Resend message to: "))) (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) @@ -3846,7 +5019,10 @@ Optional NEWS will use news to forward instead of mail." ;; We first set up a normal mail buffer. (set-buffer (get-buffer-create " *message resend*")) (erase-buffer) - (message-setup `((To . ,address))) + ;; avoid to turn-on-mime-edit + (let (message-setup-hook) + (message-setup `((To . ,address))) + ) ;; Insert our usual headers. (message-generate-headers '(From Date To)) (message-narrow-to-headers) @@ -3877,45 +5053,59 @@ Optional NEWS will use news to forward instead of mail." (when (looking-at "From ") (replace-match "X-From-Line: ")) ;; Send it. - (let ((message-inhibit-body-encoding t) - message-required-mail-headers) - (message-send-mail)) + (let ((message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) + (let (message-required-mail-headers) + (message-send-mail))) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) +(defun message-bounce-setup-for-mime-edit () + (set (make-local-variable 'message-setup-hook) nil) + (mime-edit-again)) + ;;;###autoload (defun message-bounce () "Re-mail the current message. -This only makes sense if the current message is a bounce message than +This only makes sense if the current message is a bounce message that contains some mail you have written which has been bounced back to you." (interactive) - (let ((handles (mm-dissect-buffer t)) + (let ((cur (current-buffer)) boundary) (message-pop-to-buffer (message-buffer-name "bounce")) - (if (stringp (car handles)) - ;; This is a MIME bounce. - (mm-insert-part (car (last handles))) - ;; This is a non-MIME bounce, so we try to remove things - ;; manually. - (mm-insert-part handles) - (undo-boundary) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (or (and (re-search-forward message-unsent-separator nil t) - (forward-line 1)) - (re-search-forward "^Return-Path:.*\n" nil t)) - ;; We remove everything before the bounced mail. - (delete-region - (point-min) - (if (re-search-forward "^[^ \n\t]+:" nil t) - (match-beginning 0) - (point)))) + (insert-buffer-substring cur) + (undo-boundary) + (message-narrow-to-head) + (if (and (message-fetch-field "MIME-Version") + (setq boundary (message-fetch-field "Content-Type"))) + (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary) + (setq boundary (concat (match-string 1 boundary) " *\n" + "Content-Type: message/rfc822")) + (setq boundary nil))) + (widen) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (or (and boundary + (re-search-forward boundary nil t) + (forward-line 2)) + (and (re-search-forward message-unsent-separator nil t) + (forward-line 1)) + (re-search-forward "^Return-Path:.*\n" nil t)) + ;; We remove everything before the bounced mail. + (delete-region + (point-min) + (if (re-search-forward "^[^ \n\t]+:" nil t) + (match-beginning 0) + (point))) (save-restriction (message-narrow-to-head) (message-remove-header message-ignored-bounced-headers t) (goto-char (point-max)) (insert mail-header-separator)) + (when message-bounce-setup-function + (funcall message-bounce-setup-function)) + (run-hooks 'message-bounce-setup-hook) (message-position-point))) ;;; @@ -4086,6 +5276,7 @@ The following arguments may contain lists of values." (save-excursion (with-output-to-temp-buffer " *MESSAGE information message*" (set-buffer " *MESSAGE information message*") + (fundamental-mode) ; for Emacs 20.4+ (mapcar 'princ text) (goto-char (point-min)))) (funcall ask question)) @@ -4109,51 +5300,99 @@ regexp varstr." (let ((oldbuf (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) - (message-clone-locals oldbuf) + (message-clone-locals oldbuf varstr) (current-buffer)))) -(defun message-clone-locals (buffer) +(defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." (let ((locals (save-excursion (set-buffer buffer) (buffer-local-variables))) - (regexp "^gnus\\|^nn\\|^message")) + (regexp + "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)")) (mapcar (lambda (local) (when (and (consp local) (car local) - (string-match regexp (symbol-name (car local)))) + (string-match regexp (symbol-name (car local))) + (or (null varstr) + (string-match varstr (symbol-name (car local))))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) locals))) + +;;; @ for MIME Edit mode +;;; + +(defun message-maybe-encode () + (when message-mime-mode + ;; Inherit the buffer local variable `mime-edit-pgp-processing'. + (let ((pgp-processing (with-current-buffer message-edit-buffer + mime-edit-pgp-processing))) + (setq mime-edit-pgp-processing pgp-processing)) + (run-hooks 'mime-edit-translate-hook) + (if (catch 'mime-edit-error + (save-excursion + (mime-edit-pgp-enclose-buffer) + (mime-edit-translate-body) + )) + (error "Translation error!") + ) + (end-of-invisible) + (run-hooks 'mime-edit-exit-hook) + )) + +(defun message-mime-insert-article (&optional full-headers) + (interactive "P") + (let ((message-cite-function 'mime-edit-inserted-message-filter) + (message-reply-buffer + (message-get-parameter-with-eval 'original-buffer)) + (start (point))) + (message-yank-original nil) + (save-excursion + (narrow-to-region (goto-char start) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (goto-char (point-min)) + (let ((message-included-forward-headers + (if full-headers "" message-included-forward-headers))) + (message-remove-header message-included-forward-headers t nil t)) + (widen)))) + +(set-alist 'mime-edit-message-inserter-alist + 'message-mode (function message-mime-insert-article)) + ;;; Miscellaneous functions ;; stolen (and renamed) from nnheader.el -(defun message-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (when (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string)) +(static-if (fboundp 'subst-char-in-string) + (defsubst message-replace-chars-in-string (string from to) + (subst-char-in-string from to string)) + (defun message-replace-chars-in-string (string from to) + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurrences of FROM with TO. + (while (< idx len) + (when (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string))) ;;; ;;; MIME functions ;;; -(defvar message-inhibit-body-encoding nil) +(defvar message-inhibit-body-encoding t) (defun message-encode-message-body () - (unless message-inhibit-body-encoding + (unless message-inhibit-body-encoding (let ((mail-parse-charset (or mail-parse-charset - message-default-charset - message-posting-charset)) + message-default-charset)) (case-fold-search t) lines content-type-p) (message-goto-body) @@ -4168,7 +5407,7 @@ regexp varstr." (delete-char 1) (search-forward "\n\n") (setq lines (buffer-substring (point-min) (1- (point)))) - (delete-region (point-min) (point)))))) + (delete-region (point-min) (point)))))) (save-restriction (message-narrow-to-headers-or-head) (message-remove-header "Mime-Version") @@ -4193,8 +5432,35 @@ regexp varstr." (forward-line 1) (insert "Content-Type: text/plain; charset=us-ascii\n"))))) +(defun message-read-from-minibuffer (prompt) + "Read from the minibuffer while providing abbrev expansion." + (if (fboundp 'mail-abbrevs-setup) + (let ((mail-abbrev-mode-regexp "") + (minibuffer-setup-hook 'mail-abbrevs-setup)) + (read-from-minibuffer prompt)) + (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) + (read-string prompt)))) + +(defun message-save-drafts () + "Postponing the message." + (interactive) + (message "Saving %s..." buffer-file-name) + (let ((reply-headers message-reply-headers) + (msg (buffer-substring-no-properties (point-min) (point-max)))) + (with-temp-file buffer-file-name + (insert msg) + (setq message-reply-headers reply-headers) + (message-generate-headers '((optional . In-Reply-To))) + (mime-edit-translate-buffer)) + (set-buffer-modified-p nil)) + (message "Saving %s...done" buffer-file-name)) + (provide 'message) (run-hooks 'message-load-hook) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; message.el ends here