From: keiichi Date: Thu, 23 Dec 1999 10:18:05 +0000 (+0000) Subject: Copy from Nana-gnus 6.13. X-Git-Tag: nana-gnus-7_1_0_16~94 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=5eb474dc80283876c1cabc5d19a77598ae7df779;p=elisp%2Fgnus.git- Copy from Nana-gnus 6.13. --- diff --git a/lisp/mess-bbdb.el b/lisp/mess-bbdb.el new file mode 100644 index 0000000..b85a841 --- /dev/null +++ b/lisp/mess-bbdb.el @@ -0,0 +1,39 @@ +;; mess-bbdb.el --- Interface to message (For after Nana-gnus 6.12.1). + +;; Copyright (C) 1998 Keiichi Suzuki + +;; Author: Keiichi Suzuki +;; Keywords: BBDB, mail, news + +;; This file is part of Nana-gnus. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'bbdb) + +(defvar message-bbdb/mailing-list-field 'ml-name) + +(defun message-bbdb/mailing-list-p (address) + (let ((record (bbdb-search-simple nil address))) + (and record + (bbdb-record-getprop record message-bbdb/mailing-list-field) + ))) + +(provide 'mess-bbdb) + +;; mess-bbdb.el ends here. diff --git a/lisp/mess-lcl.el b/lisp/mess-lcl.el new file mode 100644 index 0000000..b0d1ffb --- /dev/null +++ b/lisp/mess-lcl.el @@ -0,0 +1,374 @@ +;;; mess-lcl.el --- Control message format with recipient's locale +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. + +;; Author: Keiichi Suzuki +;; Keywords: mail, news, MIME + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module controls message format with recipient's locale. + +;;; Code: + +(eval-when-compile + (require 'cl) + ) + +(require 'message) + +(defgroup message-locale '((message-encode-function custom-variable)) + "Control message format with recipient." + :link '(custom-manual "(message)Top") + :group 'message) + +(defcustom message-locale-default nil + "Default locale for sending message." + :group 'message-locale + :type 'symbol) + +(defcustom message-locale-detect-for-mail nil + "*A function called to detect locale from recipient mail address." + :group 'message-locale + :type 'function) + +(defcustom message-locale-detect-for-news + 'message-locale-detect-with-newsgroup-alist + "*A function called to detect locale from newsgroup." + :group 'message-locale + :type 'function) + +(defcustom message-mime-charset-recover-function + 'message-mime-charset-recover-by-ask + "A function called to recover \ +when could not found legal MIME charset for sending message." + :type '(radio (function-item message-mime-charset-recover-by-ask) + (function :tag "Other")) + :group 'message-locale) + +(defvar message-locale-newsgroup-alist + '(("^fj\\." . fj) + )) + +(defvar message-locale-mail-address-alist nil) + +(defcustom message-mime-charset-recover-ask-function + 'message-mime-charset-recover-ask-y-or-n + "A function called to ask MIME charset. +This funtion will by called from \`message-mime-charset-recover-by-ask\'." + :type '(radio (function-item message-mime-charset-recover-ask-y-or-n) + (function-item message-mime-charset-recover-ask-charset) + (function :tag "Other")) + :group 'message-locale) + +(defvar message-locale-mime-charsets-alist + '((fj . (us-ascii iso-2022-jp iso-2022-jp-2)) + (none . nil) + )) + +(defface message-illegal-charsets-face + '((((class color)) + (:foreground "black" :background "red")) + (t + (:bold t :underline t))) + "Face used for displaying illegal charset." + :group 'message-faces) + +(defface message-warning-charsets-face + '((((class color)) + (:foreground "black" :background "yellow")) + (t + (:bold t :underline t))) + "Face used for displaying illegal charset." + :group 'message-faces) + + +;;; Internal variable. +(defvar message-locale-args nil) + + +;;; +;;; Utility functions. +;;; +(defun message-set-charsets-face (charsets face &optional start end) + (or start (setq start (point-min))) + (or end (setq end (point-max))) + (goto-char start) + (when charsets + (let (top) + (while (< (point) end) + (if (memq (charset-after) charsets) + (let ((start (point))) + (unless top + (setq top (point))) + (forward-char 1) + (while (and (< (point) end) + (memq (charset-after) charsets)) + (forward-char 1)) + (put-text-property start (point) 'face face)) + (forward-char 1))) + top))) + +(defmacro message-locale-args (symbol) + `(cdr (assq (quote ,symbol) message-locale-args)) + ) + +(defmacro message-locale-args-set (symbol val) + `(setq message-locale-args + (put-alist (quote ,symbol) ,val message-locale-args)) + ) + +(defmacro message-locale-args-original (symbol) + `(or (message-locale-args ,symbol) ,symbol) + ) + +(defmacro message-locale-args-original-set (symbol) + `(message-locale-args-set ,symbol ,symbol) + ) + +;;; +;;; Call from message.el +;;; +(defun message-locale-maybe-encode () + "Control MIME encoding for message sending. + +If would you like to control MIME encoding with recipient's locale, +then set this function to `message-encode-function'." + (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)) + (let ((locale-list (message-locale-detect))) + (when message-mime-mode + (let ((message-save-encoder message-save-encoder) + (default-mime-charset-detect-method-for-write + default-mime-charset-detect-method-for-write) + (charsets-mime-charset-alist charsets-mime-charset-alist) + message-locale-args) + (message-locale-setup-mime-charset locale-list) + (when (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)))) + +;;; +;;; Detect locale. +;;; +(defun message-locale-detect () + (when (or message-locale-detect-for-news + message-locale-detect-for-mail) + (save-excursion + (save-restriction + (message-narrow-to-head) + (let (lc dest) + (when message-locale-detect-for-news + (setq lc (mapcar + (lambda (newsgroup) + (funcall message-locale-detect-for-news + (and (string-match "[^ \t]+" newsgroup) + (match-string 0 newsgroup)))) + (message-tokenize-header + (message-fetch-field "newsgroups"))))) + (when message-locale-detect-for-mail + (let ((field-list '("to" "cc" "bcc"))) + (while (car field-list) + (setq lc (append + lc + (mapcar + (lambda (address) + (funcall message-locale-detect-for-mail + (car + (cdr (std11-extract-address-components + address))))) + (message-tokenize-header + (message-fetch-field (pop field-list))))))))) + (setq lc (delq nil lc)) + (while lc + (setq dest (cons (car lc) dest) + lc (delq (car lc) lc))) + (or dest + (and message-locale-default (list message-locale-default))) + ))))) + +(defun message-locale-detect-with-newsgroup-alist (newsgroup) + (let ((rest message-locale-newsgroup-alist) + done) + (while (and (not done) + rest) + (when (string-match (car (car rest)) newsgroup) + (setq done (car rest))) + (setq rest (cdr rest))) + (cdr done) + )) + +(defun message-locale-detect-with-mail-address-alist (address) + (let ((rest message-locale-mail-address-alist) + done) + (while (and (not done) + rest) + (when (string-match (car (car rest)) address) + (setq done (car rest))) + (setq rest (cdr rest))) + (cdr done) + )) + +;;; +;;; Control MIME charset with recipient's locale. +;;; +(defun message-locale-setup-mime-charset (locale-list) + (message-locale-args-original-set charsets-mime-charset-alist) + (message-locale-args-original-set + default-mime-charset-detect-method-for-write) + (setq default-mime-charset-detect-method-for-write + (or message-mime-charset-recover-function + default-mime-charset-detect-method-for-write) + message-save-encoder 'message-locale-mime-save-encoder) + (let (locale-cs) + (while (and charsets-mime-charset-alist + locale-list) + (unless (setq locale-cs + (assq (car locale-list) + message-locale-mime-charsets-alist)) + (error "Unknown locale \`%s\'. Add locale to \`%s\'." + (car locale-list) + 'message-locale-mime-charsets-alist)) + (setq locale-cs (cdr locale-cs) + charsets-mime-charset-alist (delq nil + (mapcar + (lambda (cs) + (and (memq (cdr cs) locale-cs) + cs)) + charsets-mime-charset-alist)) + locale-list (cdr locale-list)) + ))) + +;;; +;;; Recover MIME charset. +;;; +(defun message-mime-charset-recover-by-ask (type charsets &rest args) + (let ((default-charset + (let ((charsets-mime-charset-alist + (message-locale-args-original charsets-mime-charset-alist))) + (charsets-to-mime-charset charsets))) + charset) + (save-excursion + (save-restriction + (save-window-excursion + (when (eq type 'region) + (narrow-to-region (car args) (car (cdr args))) + (message-mime-highlight-illegal-chars charsets) + (pop-to-buffer (current-buffer) nil t) + (recenter 1)) + (if (setq charset + (funcall message-mime-charset-recover-ask-function + (upcase (symbol-name + (or default-charset + default-mime-charset-for-write))) + charsets)) + (intern (downcase charset)) + (throw 'message-sending-cancel t))))))) + +(defun message-mime-charset-recover-ask-y-or-n (default-charset charsets) + (and (y-or-n-p (format "MIME charset %s is selected. OK? " + default-charset)) + default-charset)) + +(defun message-mime-charset-recover-ask-charset (default-charset charsets) + (let ((alist (mapcar + (lambda (cs) + (list (upcase (symbol-name cs)))) + (mime-charset-list))) + charset) + (while (not charset) + (setq charset + (completing-read "What MIME charset: " + alist nil t default-charset)) + (when (string= charset "") + (setq charset nil))) + charset)) + +(defun message-mime-highlight-illegal-chars (charsets) + (when charsets-mime-charset-alist + (let* ((min 65535) + (delta-lists + (delq nil + (mapcar + (lambda (x) + (when (<= (length x) min) + x)) + (delq nil (mapcar + (lambda (x) + (setq x (delq nil + (mapcar + (lambda (y) + (unless (memq y (car x)) + y)) + charsets) + )) + (when (<= (length x) min) + (setq min (length x)) + x)) + charsets-mime-charset-alist))))) + top cs done rest errors warns list) + (while (setq top (pop delta-lists)) + (while (setq cs (pop top)) + (setq done nil + list delta-lists) + (when cs + (while (setq rest (pop list)) + (if (setq rest (memq cs rest)) + (setcar rest nil) + (push cs warns) + (setq done t))) + (unless done + (push cs errors))))) + (put-text-property (point-min) (point-max) 'face nil) + (if (setq top (message-set-charsets-face + errors + 'message-illegal-charsets-face)) + (message-set-charsets-face warns 'message-warning-charsets-face) + (setq top (message-set-charsets-face + warns 'message-warning-charsets-face))) + (if top + (goto-char top) + (goto-char (point-min)))))) + +;;; @ for MIME Edit mode +;;; +(defun message-locale-mime-save-encoder (orig-buf) + (when (with-current-buffer orig-buf mime-edit-mode-flag) + (let ((charsets-mime-charset-alist + (message-locale-args-original charsets-mime-charset-alist)) + (default-mime-charset-detect-method-for-write + (message-locale-args-original + default-mime-charset-detect-method-for-write))) + (mime-edit-translate-body) + (mime-edit-translate-header) + ))) + +(run-hooks 'mess-lcl-load-hook) + +(provide 'mess-lcl) + +;;; mess-lcl.el ends here diff --git a/lisp/message.el b/lisp/message.el index a0642c1..3fe18df 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,8 +1,14 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 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 +35,20 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (require 'smtp) + ) (require 'mailheader) (require 'nnheader) +(require 'timezone) (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) +(require 'mime-edit) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -101,6 +108,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 +136,19 @@ mailbox format." (function :tag "Other")) :group 'message-sending) +(autoload 'message-locale-maybe-encode "mess-lcl") +(defcustom message-encode-function 'message-locale-maybe-encode + "*A function called to encode messages." + :type '(radio (function-item message-locale-maybe-encode) + (function-item message-maybe-encode) + (function :tag "Other")) + :group 'message-sending) + +(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 +163,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. @@ -169,8 +198,7 @@ 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." +shorten-followup-to existing-newsgroups buffer-file-name unchanged." :group 'message-news) (defcustom message-required-news-headers @@ -214,13 +242,19 @@ 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:\\|^X-Trace:\\|^X-Complaints-To:" "*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 @@ -232,7 +266,7 @@ any confusion." :type 'regexp :group 'message-various) -(defcustom message-elide-ellipsis "\n[...]\n\n" +(defcustom message-elide-elipsis "\n[...]\n\n" "*The string which is inserted for elided text." :type 'string :group 'message-various) @@ -244,15 +278,14 @@ nil means let mailer mail back a message to report errors." :group 'message-mail :type 'boolean) -(defcustom message-generate-new-buffers 'unique +(defcustom message-generate-new-buffers t "*Non-nil means that a new message buffer will be created whenever `message-setup' is called. If this is a function, call that function with three parameters: The type, the to address and the group name. (Any of these may be nil.) The function should return the new buffer name." :group 'message-buffers :type '(choice (const :tag "off" nil) - (const :tag "unique" unique) - (const :tag "unsent" unsent) + (const :tag "on" t) (function fun))) (defcustom message-kill-buffer-on-exit nil @@ -260,6 +293,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,7 +321,30 @@ If t, use `message-user-organization-file'." :type 'file :group 'message-headers) -(defcustom message-make-forward-subject-function +(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-signature-before-forwarded-message t + "*If non-nil, put the signature before any included forwarded message." + :group 'message-forwarding + :type 'boolean) + +(defcustom message-included-forward-headers + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^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. The subject generated by the previous function is passed into each @@ -295,27 +360,16 @@ The provided functions are: :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-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." :group 'message-forwarding :type 'boolean) -(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:" +(defcustom message-ignored-resent-headers "^Return-Receipt" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :type 'regexp) -(defcustom message-forward-ignored-headers nil - "*All headers that match this regexp will be deleted when forwarding a message." - :group 'message-forwarding - :type '(choice (const :tag "None" nil) - regexp)) - (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion @@ -333,18 +387,19 @@ The provided functions are: The headers should be delimited by a line whose contents match the variable `mail-header-separator'. -Valid values include `message-send-mail-with-sendmail' (the default), +Legal 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'." @@ -384,9 +439,10 @@ always query the user whether to use the value. If it is the symbol (const use) (const 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. -Doing so would be even more evil than leaving it out." + "*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." :group 'message-sending :type 'boolean) @@ -406,11 +462,6 @@ 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 @@ -435,17 +486,12 @@ variable isn't used." :group 'message-headers :type 'boolean) -(defcustom message-setup-hook nil +(defcustom message-setup-hook '(message-mime-setup) "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook." :group 'message-various :type 'hook) -(defcustom message-cancel-hook nil - "Hook run when cancelling articles." - :group 'message-various - :type 'hook) - (defcustom message-signature-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. It is run after the headers have been inserted and before @@ -453,13 +499,38 @@ the signature is inserted." :group 'message-various :type 'hook) +(defcustom message-bounce-setup-hook nil + "Normal hook, run each time a 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 - "Hook run in a message mode buffer narrowed to the headers." + "Hook run in a message mode before header encode. Buffer narrowed +to the headers." + :group 'message-various + :type 'hook) + +(defcustom message-header-encode-function + '(lambda () (eword-encode-header t)) + "A function called to encode header." + :group 'message-various + :type 'function) + +(defcustom message-header-encoded-hook nil + "Hook run in a message mode after header encoded. Buffer narrowed +to the headers." :group 'message-various :type 'hook) @@ -476,10 +547,26 @@ the signature is inserted." ;;;###autoload (defcustom message-yank-prefix "> " - "*Prefix inserted on the lines of yanked messages." + "*Prefix inserted on the lines of yanked messages. +nil means use indentation." :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." + :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'." @@ -493,7 +580,6 @@ Predefined functions include `message-cite-original' and `message-cite-original-without-signature'. 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 sc-cite-original) (function :tag "Other")) :group 'message-insertion) @@ -549,8 +635,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 @@ -561,6 +645,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." @@ -588,6 +675,11 @@ articles." :group 'message-news :type 'message-header-lines) +(defcustom message-mail-follow-up-address-checker nil + "A function of check follow up mail address." + :group 'message-mail + :type 'function) + ;; Note: could use /usr/ucb/mail instead of sendmail; ;; options -t, and -v if not interactive. (defcustom message-mailer-swallows-blank-line @@ -615,13 +707,18 @@ actually occur." :group 'message-sending :type 'sexp) +;;; 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.") + ;; Ignore errors in case this is used in Emacs 19. ;; Don't use ignore-errors because this is copied into loaddefs.el. ;;;###autoload -(ignore-errors - (define-mail-user-agent 'message-user-agent - 'message-mail 'message-send-and-exit - 'message-kill-buffer 'message-send-hook)) +(condition-case nil + (define-mail-user-agent 'message-user-agent + 'message-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook) + (error nil)) (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender) "If non-nil, delete the deletable headers before feeding to mh.") @@ -652,33 +749,12 @@ If nil, Message won't auto-save." :group 'message-buffers :type 'directory) -(defcustom message-buffer-naming-style 'unique - "*The way new message buffers are named. -Valid valued are `unique' and `unsent'." - :group 'message-buffers - :type '(choice (const :tag "unique" unique) - (const :tag "unsent" unsent))) - -(defcustom message-default-charset nil - "Default charset used in non-MULE XEmacsen." - :group 'message - :type 'symbol) - -(defcustom message-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 - :type '(choice (const :tag "Yourself" nil) - regexp)) - ;;; Internal variables. ;;; Well, not really internal. (defvar message-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?% ". " table) - (modify-syntax-entry ?> ". " table) - (modify-syntax-entry ?< ". " table) table) "Syntax table used while in Message mode.") @@ -798,18 +874,6 @@ Defaults to `text-mode-abbrev-table'.") "Face used for displaying cited text names." :group 'message-faces) -(defface message-mml-face - '((((class color) - (background dark)) - (:foreground "ForestGreen")) - (((class color) - (background light)) - (:foreground "ForestGreen")) - (t - (:bold t))) - "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_.@-")) @@ -840,9 +904,7 @@ Defaults to `text-mode-abbrev-table'.") (,(concat "^[ \t]*" "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[:>|}].*") - (0 'message-cited-text-face)) - ("<#/?\\(multipart\\|part\\|external\\).*>" - (0 'message-mml-face)))) + (0 'message-cited-text-face)))) "Additional expressions to highlight in Message mode.") ;; XEmacs does it like this. For Emacs, we have to set the @@ -879,12 +941,17 @@ 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) -(defvar message-draft-coding-system - mm-auto-save-coding-system - "Coding system to compose mail.") +(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))) ;;; Internal variables. @@ -892,8 +959,6 @@ The cdr of ech entry is a function for applying the face to a region.") (defvar message-this-is-news nil) (defvar message-this-is-mail nil) (defvar message-draft-article nil) -(defvar message-mime-part nil) -(defvar message-posting-charset nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -961,7 +1026,6 @@ The cdr of ech entry is a function for applying the face to a region.") "^ *---+ +Original message +---+ *$\\|" "^ *--+ +begin message +--+ *$\\|" "^ *---+ +Original message follows +---+ *$\\|" - "^ *---+ +Undelivered message follows +---+ *$\\|" "^|? *---+ +Message text follows: +---+ *|?$") "A regexp that matches the separator before the text of a failed message.") @@ -979,7 +1043,7 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - (References . message-shorten-references) + (References . message-fill-references) (User-Agent)) "Alist used for formatting headers.") @@ -990,11 +1054,13 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-point-at-bol "gnus-util") (autoload 'gnus-output-to-mail "gnus-util") + (autoload 'gnus-output-to-rmail "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")) @@ -1003,6 +1069,22 @@ The cdr of ech entry is a function for applying the face to a region.") ;;; ;;; 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" @@ -1062,24 +1144,7 @@ The cdr of ech entry is a function for applying the face to a region.") (let* ((inhibit-point-motion-hooks 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. - (format "%s" value)))) - -(defun message-narrow-to-field () - "Narrow the buffer to the header on the current line." - (beginning-of-line) - (narrow-to-region - (point) - (progn - (forward-line 1) - (if (re-search-forward "^[^ \n\t]" nil t) - (progn - (beginning-of-line) - (point)) - (point-max)))) - (goto-char (point-min))) + (nnheader-replace-chars-in-string value ?\n ? )))) (defun message-add-header (&rest headers) "Add the HEADERS to the message header, skipping those already present." @@ -1094,14 +1159,14 @@ The cdr of ech entry is a function for applying the face to a region.") (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*") @@ -1110,7 +1175,7 @@ The cdr of ech entry is a function for applying the face to a region.") (erase-buffer)) (set-buffer (get-buffer-create " *message work*")) (kill-all-local-variables) - (mm-enable-multibyte))) + (buffer-disable-undo (current-buffer)))) (defun message-functionp (form) "Return non-nil if FORM is funcallable." @@ -1155,21 +1220,9 @@ Return the number of headers removed." (forward-line 1) (if (re-search-forward "^[^ \t]" nil t) (goto-char (match-beginning 0)) - (goto-char (point-max))))) + (point-max)))) number)) -(defun message-remove-first-header (header) - "Remove the first instance of HEADER if there is more than one." - (let ((count 0) - (regexp (concat "^" (regexp-quote header) ":"))) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (incf count))) - (while (> count 1) - (message-remove-header header nil t) - (decf count)))) - (defun message-narrow-to-headers () "Narrow the buffer to the head of the message." (widen) @@ -1182,8 +1235,7 @@ Return the number of headers removed." (goto-char (point-min))) (defun message-narrow-to-head () - "Narrow the buffer to the head of the message. -Point is left at the beginning of the narrowed-to region." + "Narrow the buffer to the head of the message." (widen) (narrow-to-region (goto-char (point-min)) @@ -1192,21 +1244,6 @@ Point is left at the beginning of the narrowed-to region." (point-max))) (goto-char (point-min))) -(defun message-narrow-to-headers-or-head () - "Narrow the buffer to the head of the message." - (widen) - (narrow-to-region - (goto-char (point-min)) - (cond - ((re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil t) - (match-beginning 0)) - ((search-forward "\n\n" nil t) - (1- (point))) - (t - (point-max)))) - (goto-char (point-min))) - (defun message-news-p () "Say whether the current buffer contains a news message." (and (not message-this-is-mail) @@ -1239,7 +1276,6 @@ Point is left at the beginning of the narrowed-to region." (defun message-sort-headers-1 () "Sort the buffer as headers using `message-rank' text props." (goto-char (point-min)) - (require 'sort) (sort-subr nil 'message-next-header (lambda () @@ -1270,7 +1306,6 @@ Point is left at the beginning of the narrowed-to region." (- max rank) (1+ max))))) (message-sort-headers-1)))) - ;;; @@ -1282,8 +1317,7 @@ Point is left at the beginning of the narrowed-to region." (defvar message-mode-map nil) (unless message-mode-map - (setq message-mode-map (make-keymap)) - (set-keymap-parent message-mode-map text-mode-map) + (setq message-mode-map (copy-keymap text-mode-map)) (define-key message-mode-map "\C-c?" 'describe-mode) (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) @@ -1307,7 +1341,6 @@ Point is left at the beginning of the narrowed-to region." (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) (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body) (define-key message-mode-map "\C-c\C-o" 'message-sort-headers) (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer) @@ -1322,9 +1355,9 @@ 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-xk" 'message-mimic-kill-buffer)) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -1341,7 +1374,6 @@ 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] "----" ["Send Message" message-send-and-exit t] ["Abort Message" message-dont-send t] @@ -1373,7 +1405,6 @@ Point is left at the beginning of the narrowed-to region." "Major mode for editing mail and news to be sent. Like Text Mode but with these additional commands: C-c C-s message-send (send the message) C-c C-c message-send-and-exit -C-c C-d Pospone sending the message C-c C-k Kill the message C-c C-f move to a header field (and create it if there isn't): C-c C-f C-t move to To C-c C-f C-s move to Subject C-c C-f C-c move to Cc C-c C-f C-b move to Bcc @@ -1389,16 +1420,14 @@ C-c C-w message-insert-signature (insert `message-signature-file' file). C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). 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)." +C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (kill-all-local-variables) - (set (make-local-variable 'message-reply-buffer) nil) - (make-local-variable 'message-send-actions) - (make-local-variable 'message-exit-actions) + (make-local-variable 'message-reply-buffer) + (setq message-reply-buffer nil) + (make-local-variable 'message-send-actions) + (make-local-variable 'message-exit-actions) (make-local-variable 'message-kill-actions) (make-local-variable 'message-postpone-actions) (make-local-variable 'message-draft-article) @@ -1435,12 +1464,15 @@ M-RET message-newline-and-reformat (break the line and reformat)." (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-sent-message-via) + (setq message-sent-message-via nil) + (make-local-variable 'message-checksum) + (setq message-checksum nil) + (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) @@ -1458,17 +1490,13 @@ M-RET message-newline-and-reformat (break the line and reformat)." '(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]*\\|" 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]*\\|" + (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-first-line-regexp)) - (mm-enable-multibyte) - (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)) @@ -1539,8 +1567,7 @@ M-RET message-newline-and-reformat (break the line and reformat)." (interactive) (if (looking-at "[ \t]*\n") (expand-abbrev)) (goto-char (point-min)) - (or (search-forward (concat "\n" mail-header-separator "\n") nil t) - (search-forward "\n\n" nil t))) + (search-forward (concat "\n" mail-header-separator "\n") nil t)) (defun message-goto-eoh () "Move point to the end of the headers." @@ -1570,8 +1597,7 @@ With the prefix argument FORCE, insert the header anyway." (let ((co (message-fetch-reply-field "mail-copies-to"))) (when (and (null force) co - (or (equal (downcase co) "never") - (equal (downcase co) "nobody"))) + (equal (downcase co) "never")) (error "The user has requested not to have copies sent via mail"))) (when (and (message-position-on-field "To") (mail-fetch-field "to") @@ -1624,24 +1650,17 @@ 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 ((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]*")) + (let ((point (point)) + quoted) + (save-excursion + (beginning-of-line) + (setq quoted (looking-at (regexp-quote message-yank-prefix)))) + (insert "\n\n\n\n") (when quoted - (insert quoted)) + (insert message-yank-prefix)) (fill-paragraph nil) (goto-char point) - (forward-line 1))) + (forward-line 2))) (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." @@ -1652,7 +1671,8 @@ With the prefix argument FORCE, insert the header anyway." (eq force 0)) (save-excursion (goto-char (point-max)) - (not (re-search-backward message-signature-separator nil t)))) + (not (re-search-backward + message-signature-separator nil t)))) ((and (null message-signature) force) t) @@ -1682,11 +1702,13 @@ 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-ellipsis') will be inserted where the +An ellipsis (from `message-elide-elipsis') will be inserted where the text was killed." (interactive "r") (kill-region b e) - (insert message-elide-ellipsis)) + (unless (bolp) + (insert "\n")) + (insert message-elide-elipsis)) (defvar message-caesar-translation-table nil) @@ -1710,10 +1732,9 @@ text was killed." ;; 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)))) + (subst-char-in-region + b (1+ b) (char-after b) + (aref message-caesar-translation-table (char-after b))) (incf b)))) (defun message-make-caesar-translation-table (n) @@ -1755,7 +1776,7 @@ Mail and USENET news headers are not rotated." (unless (equal 0 (call-process-region (point-min) (point-max) program t t)) (insert body) - (message "%s failed" program)))))) + (message "%s failed." program)))))) (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". @@ -1789,7 +1810,7 @@ Numeric argument means justify as well." (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t) (let ((fill-prefix message-yank-prefix)) - (fill-individual-paragraphs (point) (point-max) justifyp)))) + (fill-individual-paragraphs (point) (point-max) justifyp t)))) (defun message-indent-citation () "Modify text just inserted from a message to be cited. @@ -1837,6 +1858,40 @@ 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)) + (setq saved-id (cons (car refs-list) saved-id) + refs-list (cdr refs-list) + pos (1- pos))))) + (while refs-strs + (setq refs (car refs-strs) + refs-strs (cdr refs-strs)) + (when refs + (setq refs (std11-parse-msg-ids (std11-lexical-analyze refs))) + (while refs + (setq ref (car refs) + refs (cdr refs)) + (when (eq (car ref) 'msg-id) + (setq id (concat "<" + (mapconcat + (function (lambda (p) (cdr p))) + (cdr ref) "") + ">")) + (or (member id refs-list) + (push id refs-list)))))) + (while saved-id + (setq refs-list (cons (car saved-id) refs-list) + saved-id (cdr saved-id))) + 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. @@ -1846,13 +1901,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) @@ -1867,17 +1964,6 @@ prefix, and don't delete any headers." (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)) @@ -1887,9 +1973,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) (goto-char end) - (when (re-search-backward message-signature-separator start t) + (when (re-search-backward "^-- $" start t) ;; Also peel off any blank lines before the signature. (forward-line -1) (while (looking-at "^[ \t]*$") @@ -1904,20 +1989,18 @@ prefix, and don't delete any headers." (insert "\n")) (funcall message-citation-line-function)))) -(defvar mail-citation-hook) ;Compiler directive +(defvar mail-citation-hook) ;Compiler directive (defun message-cite-original () "Cite function in the standard Message manner." (if (and (boundp 'mail-citation-hook) mail-citation-hook) (run-hooks 'mail-citation-hook) (let ((start (point)) - (end (mark t)) (functions (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) (goto-char start) (while functions (funcall (pop functions))) @@ -1987,11 +2070,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 @@ -2000,6 +2090,7 @@ 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 () @@ -2007,19 +2098,62 @@ The text will also be indented the normal way." (interactive) (set-buffer-modified-p t) (save-buffer) - (let ((actions message-postpone-actions)) + (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))) + (let ((message-delete-frame-on-exit nil)) + (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 (and (featurep 'xemacs) + (not (eq 'tty (device-type)))) + 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." @@ -2038,43 +2172,62 @@ or error messages, and inform user. Otherwise any failure is reported in a message back to the user from the mailer." (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) - (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))) + (if (catch 'message-sending-cancel + ;; Disabled test. + (unless (or (buffer-modified-p) + (message-check-element 'unchanged) + (y-or-n-p "No changes in the buffer; really send? ")) + (throw 'message-sending-cancel t)) + ;; 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 "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) + (unwind-protect + (if (save-excursion + (set-buffer message-encoding-buffer) + (erase-buffer) + (insert-buffer message-edit-buffer) + (funcall message-encode-function) + (message-fix-before-sending) + (while (and success + (setq elem (pop alist))) + (and (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))) + (not (and success sent))) + (throw 'message-sending-cancel t) + (message-do-fcc) + (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) + nil) + (kill-buffer message-encoding-buffer)))) + (progn + (message "Canceled") + nil) + ;; Return success. + t)) (defun message-send-via-mail (arg) "Send the current message via mail." @@ -2082,16 +2235,7 @@ the user from the mailer." (defun message-send-via-news (arg) "Send the current message via news." - (funcall message-send-news-function arg)) - -(defmacro message-check (type &rest forms) - "Eval FORMS if TYPE is to be checked." - `(or (message-check-element ,type) - (save-excursion - ,@forms))) - -(put 'message-check 'lisp-indent-function 1) -(put 'message-check 'edebug-form-spec '(form body)) + (message-send-news arg)) (defun message-fix-before-sending () "Do various things to make the message nice before sending it." @@ -2099,13 +2243,12 @@ the user from the mailer." (goto-char (point-max)) (unless (bolp) (insert "\n")) - ;; Delete 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) - (unless (yes-or-no-p - "Invisible text found and made visible; continue posting? ") - (error "Invisible text found and made visible"))))) + ;; Make all invisible text visible. + ;;(when (text-property-any (point-min) (point-max) 'invisible t) + ;; (put-text-property (point-min) (point-max) 'invisible nil) + ;; (unless (yes-or-no-p "Invisible text found and made visible; continue posting?") + ;; (error "Invisible text found and made visible"))) + ) (defun message-add-action (action &rest types) "Add ACTION to be performed when doing an exit of type TYPES." @@ -2128,12 +2271,56 @@ 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 (&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))) + failure) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -2141,43 +2328,45 @@ the user from the mailer." (if news nil message-deletable-headers))) (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))) + (run-hooks 'message-header-hook) + (when (functionp message-header-encode-function) + (funcall message-header-encode-function)) + (run-hooks 'message-header-encoded-hook)) + (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) + ;; Remove some headers. + (message-remove-header message-ignored-mail-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (eq (char-before) ?\n) + (insert ?\n)) + (when (and news + (or (message-fetch-field "cc") + (message-fetch-field "to"))) + (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 - (message-generate-new-buffer-clone-locals " sendmail errors") + (generate-new-buffer " sendmail errors") 0)) resend-to-addresses delimline) (let ((case-fold-search t)) @@ -2201,34 +2390,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" - (if (null user-mail-address) - (user-login-name) - user-mail-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"))))) + (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" (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")))))) (when message-interactive (save-excursion (set-buffer errbuf) @@ -2253,28 +2439,28 @@ to find out how to use this." (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) @@ -2301,78 +2487,148 @@ 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)) + (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) + (when (functionp message-header-encode-function) + (funcall message-header-encode-function)) + (run-hooks 'message-header-encoded-hook)) + (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 (current-buffer)) + (erase-buffer) + (insert-buffer message-encoding-buffer) + ;; Remove some headers. + (save-restriction + (message-narrow-to-headers) ;; 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 (eq (char-before) ?\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) + ;;(require (car method)) + ;;(funcall (intern (format "%s-open-server" (car method))) + ;;(cadr method) (cddr method)) + ;;(setq result + ;; (funcall (intern (format "%s-request-post" (car method))) + ;; (cadr method))) + (gnus-open-server method) + (gnus-request-post method) + )) ;;; ;;; Header generation & syntax checking. ;;; +(defmacro message-check (type &rest forms) + "Eval FORMS if TYPE is to be checked." + `(or (message-check-element ,type) + (save-excursion + ,@forms))) + +(put 'message-check 'lisp-indent-function 1) +(put 'message-check 'edebug-form-spec '(form body)) + (defun message-check-element (type) "Returns non-nil if this type is not to be checked." (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me) @@ -2386,23 +2642,19 @@ 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 - (let ((group (message-fetch-field "newsgroups"))) - (or - (and group - (not (string-match "\\`[ \t]*\\'" group))) - (ignore - (message - "The newsgroups field is empty or missing. Posting is denied."))))) ;; Check the Subject header. (message-check 'subject (let* ((case-fold-search t) @@ -2565,15 +2817,12 @@ to find out how to use this." (message-check 'from (let* ((case-fold-search t) (from (message-fetch-field "from")) - ad) + (ad (nth 1 (mail-extract-address-components from)))) (cond ((not from) (message "There is no From line. Posting is denied.") nil) - ((or (not (string-match - "@[^\\.]*\\." - (setq ad (nth 1 (mail-extract-address-components - from))))) ;larsi@ifi + ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi (string-match "\\.\\." ad) ;larsi@ifi..uio (string-match "@\\." ad) ;larsi@.ifi.uio (string-match "\\.$" ad) ;larsi@ifi.uio. @@ -2614,10 +2863,13 @@ to find out how to use this." (y-or-n-p "Empty article. Really post? ")))) ;; Check for control characters. (message-check 'control-chars - (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t) + (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) (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) @@ -2635,12 +2887,63 @@ to find out how to use this." ;; Check the length of the signature. (message-check 'signature (goto-char (point-max)) - (if (> (count-lines (point) (point-max)) 5) - (y-or-n-p - (format - "Your .sig is %d lines; it should be max 4. Really post? " - (1- (count-lines (point) (point-max))))) - t)))) + (if (or (not (re-search-backward message-signature-separator nil t)) + (search-forward message-forward-end-separator nil t)) + t + (if (> (count-lines (point) (point-max)) 5) + (y-or-n-p + (format + "Your .sig is %d lines; it should be max 4. Really post? " + (1- (count-lines (point) (point-max))))) + t))))) + +(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." @@ -2651,20 +2954,21 @@ to find out how to use this." (concat "^" (regexp-quote mail-header-separator) "$")) (while (not (eobp)) (when (not (looking-at "[ \t\n]")) - (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) - (char-after)))) + (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) + (char-after)))) (forward-char 1))) sum)) (defun message-do-fcc () "Process Fcc headers in the current buffer." (let ((case-fold-search t) - (buf (current-buffer)) + (coding-system-for-write nnheader-file-coding-system) list file) (save-excursion (set-buffer (get-buffer-create " *message temp*")) + (buffer-disable-undo (current-buffer)) (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")) @@ -2699,7 +3003,7 @@ to find out how to use this." "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 () @@ -2850,17 +3154,21 @@ If NOW, use that time instead." "Return the In-Reply-To header for this message." (when message-reply-headers (let ((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) - "\"")))))) + (date (mail-header-date message-reply-headers)) + (msg-id (mail-header-message-id message-reply-headers))) + (when msg-id + (concat msg-id + (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) + "\")")))))))) (defun message-make-distribution () "Make a Distribution header." @@ -2876,7 +3184,9 @@ If NOW, use that time instead." ;; Add the future to current. (setcar current (+ (car current) (round (/ future (expt 2 16))))) (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16)))) - (message-make-date current))) + ;; Return the date in the future in UT. + (timezone-make-date-arpa-standard + (current-time-string current) (current-time-zone current) '(0 "UT")))) (defun message-make-path () "Return uucp path." @@ -2998,6 +3308,24 @@ give as trustworthy answer as possible." (or mail-host-address (message-make-fqdn))) +(defun message-make-user-agent () + "Return user-agent info." + (if message-user-agent + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t) + user-agent beg p end) + (if (re-search-forward "^User-Agent:[ \t]*" nil t) + (progn + (setq beg (match-beginning 0) + p (match-end 0) + end (std11-field-end) + user-agent (buffer-substring p end)) + (delete-region beg (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." @@ -3014,7 +3342,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) @@ -3053,9 +3381,11 @@ Headers already prepared in the buffer are not modified." (progn ;; The header was found. We insert a space after the ;; colon, if there is none. - (if (/= (char-after) ? ) (insert " ") (forward-char 1)) + (if (eq (char-after) ? ) + (forward-char 1) + (insert " ")) ;; Find out whether the header is empty... - (looking-at "[ \t]*\n[^ \t]"))) + (looking-at "[ \t]*$"))) ;; So we find out what value we should insert. (setq value (cond @@ -3180,9 +3510,16 @@ 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 78) + (fill-column 990) (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " @@ -3201,60 +3538,23 @@ 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) - "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) + "Limit REFERENCES to be shorter than 988 characters." + (let ((max 988) + (cut 4) 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) - 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. - (when 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 message-cater-to-broken-inn - (insert (capitalize (symbol-name header)) ": " - refstring "\n") - (message-fill-header header refstring))))) + (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"))) (defun message-position-point () "Move point to where the user probably wants to find it." @@ -3278,24 +3578,14 @@ than 988 characters long, and if they are not, trim them until they are." (defun message-buffer-name (type &optional to group) "Return a new (unique) buffer name based on TYPE and TO." (cond - ;; Generate a new buffer name The Message Way. - ((eq message-generate-new-buffers 'unique) - (generate-new-buffer-name - (concat "*" type - (if to - (concat " to " - (or (car (mail-extract-address-components to)) - to) "") - "") - (if (and group (not (string= group ""))) (concat " on " group) "") - "*"))) ;; Check whether `message-generate-new-buffers' is a function, ;; and if so, call it. ((message-functionp message-generate-new-buffers) (funcall message-generate-new-buffers type to group)) - ((eq message-generate-new-buffers 'unsent) + ;; Generate a new buffer name The Message Way. + (message-generate-new-buffers (generate-new-buffer-name - (concat "*unsent " type + (concat "*" type (if to (concat " to " (or (car (mail-extract-address-components to)) @@ -3309,7 +3599,24 @@ than 988 characters long, and if they are not, trim them until they are." (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 ((pop-up-frames pop-up-frames) + (special-display-buffer-names special-display-buffer-names) + (special-display-regexps special-display-regexps) + (same-window-buffer-names same-window-buffer-names) + (same-window-regexps same-window-regexps) + (buffer (get-buffer name)) + (cur (current-buffer))) + (if (or (and (featurep 'xemacs) + (not (eq 'tty (device-type)))) + window-system + (>= emacs-major-version 20)) + (when message-use-multi-frames + (setq pop-up-frames t + special-display-buffer-names nil + special-display-regexps nil + same-window-buffer-names nil + same-window-regexps nil)) + (setq pop-up-frames nil)) (if (and buffer (buffer-name buffer)) (progn @@ -3320,7 +3627,10 @@ than 988 characters long, and if they are not, trim them until they are." (error "Message being composed"))) (set-buffer (pop-to-buffer name))) (erase-buffer) - (message-mode))) + (message-mode) + (when pop-up-frames + (make-local-variable 'message-original-frame) + (setq message-original-frame (selected-frame))))) (defun message-do-send-housekeeping () "Kill old message buffers." @@ -3338,7 +3648,7 @@ than 988 characters long, and if they are not, trim them until they are." ;; Rename the buffer. (if message-send-rename-function (funcall message-send-rename-function) - (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name)) + (when (string-match "\\`\\*" (buffer-name)) (rename-buffer (concat "*sent " (substring (buffer-name) (match-end 0))) t))) ;; Push the current buffer onto the list. @@ -3355,7 +3665,9 @@ than 988 characters long, and if they are not, trim them until they are." 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 @@ -3403,6 +3715,8 @@ than 988 characters long, and if they are not, trim them until they are." (run-hooks 'message-header-setup-hook)) (set-buffer-modified-p nil) (setq buffer-undo-list nil) + (add-to-list 'buffer-file-format 'message) + (set-buffer-file-coding-system nnheader-file-coding-system) (run-hooks 'message-setup-hook) (message-position-point) (undo-boundary)) @@ -3416,8 +3730,7 @@ than 988 characters long, and if they are not, trim them until they are." (setq buffer-file-name (expand-file-name "*message*" 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))) + (clear-visited-file-modtime))) (defun message-disassociate-draft () "Disassociate the message buffer from the drafts directory." @@ -3425,23 +3738,6 @@ than 988 characters long, and if they are not, trim them until they are." (nndraft-request-expire-articles (list message-draft-article) "drafts" nil t))) -(defun message-insert-headers () - "Generate the headers for the article." - (interactive) - (save-excursion - (save-restriction - (message-narrow-to-headers) - (when (message-news-p) - (message-generate-headers - (delq 'Lines - (delq 'Subject - (copy-sequence message-required-news-headers))))) - (when (message-mail-p) - (message-generate-headers - (delq 'Lines - (delq 'Subject - (copy-sequence message-required-mail-headers)))))))) - ;;; @@ -3479,8 +3775,7 @@ OTHER-HEADERS is an alist of header/value pairs." from subject date reply-to to cc references message-id follow-to (inhibit-point-motion-hooks t) - (message-this-is-mail t) - mct never-mct gnus-warning) + mct never-mct gnus-warning in-reply-to) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3503,6 +3798,12 @@ OTHER-HEADERS is an alist of header/value pairs." reply-to (message-fetch-field "reply-to") references (message-fetch-field "references") message-id (message-fetch-field "message-id" t)) + ;; 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)))) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. (when (string-match message-subject-re-regexp subject) @@ -3515,12 +3816,10 @@ OTHER-HEADERS is an alist of header/value pairs." ;; Handle special values of Mail-Copies-To. (when mct - (cond ((or (equal (downcase mct) "never") - (equal (downcase mct) "nobody")) + (cond ((equal (downcase mct) "never") (setq never-mct t) (setq mct nil)) - ((or (equal (downcase mct) "always") - (equal (downcase mct) "poster")) + ((equal (downcase mct) "always") (setq mct (or reply-to from))))) (unless follow-to @@ -3542,9 +3841,8 @@ OTHER-HEADERS is an alist of header/value pairs." (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)))) + (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) @@ -3556,7 +3854,10 @@ OTHER-HEADERS is an alist of header/value pairs." (message-tokenize-header (buffer-string)))) (let ((s ccalist)) (while s - (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) + (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))) + (when (functionp message-mail-follow-up-address-checker) + (setq ccalist (funcall message-mail-follow-up-address-checker + ccalist)))) (setq follow-to (list (cons 'To (cdr (pop ccalist))))) (when ccalist (let ((ccs (cons 'Cc (mapconcat @@ -3571,7 +3872,8 @@ OTHER-HEADERS is an alist of header/value pairs." (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) @@ -3688,17 +3990,16 @@ responses here are directed to other newsgroups.")) `((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")) + (not (equal (downcase mct) "never"))) + (list (cons 'Cc (if (equal (downcase mct) "always") (or reply-to from "") mct))))) cur) (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 "")))) ;;;###autoload @@ -3719,17 +4020,18 @@ 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 - (message-make-from)))))) + (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 + (message-make-from)))))) (error "This article is not yours")) ;; Make control message. (setq buf (set-buffer (get-buffer-create " *message cancel*"))) + (buffer-disable-undo (current-buffer)) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " (message-make-from) "\n" @@ -3740,14 +4042,19 @@ responses here are directed to other newsgroups.")) "") mail-header-separator "\n" 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)) + '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 () "Start composing a message to supersede the current message. @@ -3781,7 +4088,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 () @@ -3832,7 +4143,7 @@ header line with the old Message-ID." (replace-match "")) (buffer-string))) - + ;;; Forwarding messages. (defun message-forward-subject-author-subject (subject) @@ -3859,10 +4170,14 @@ the message." (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)) @@ -3883,43 +4198,50 @@ Optional NEWS will use news to forward instead of mail." (let ((cur (current-buffer)) (subject (message-make-forward-subject)) art-beg) - (if news - (message-news nil subject) - (message-mail nil subject)) + (if news (message-news nil subject) (message-mail nil subject)) ;; Put point where we want it before inserting the forwarded ;; message. - (message-goto-body) - (if message-forward-as-mime - (insert "\n\n<#part type=message/rfc822 disposition=inline>\n") - (insert "\n\n")) - (let ((b (point)) - e) - (mml-insert-buffer cur) - (setq e (point)) - (and message-forward-as-mime - (insert "<#/part>\n")) - (when (and (not current-prefix-arg) - message-forward-ignored-headers) - (save-restriction - (narrow-to-region b e) - (goto-char b) - (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) - (message-remove-header message-forward-ignored-headers t)))) + (if message-signature-before-forwarded-message + (goto-char (point-max)) + (message-goto-body)) + ;; Make sure we're at the start of the line. + (unless (eolp) + (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 (message-read-from-minibuffer "Resend message to: "))) + (interactive "sResend message to: ") (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) beg) ;; We first set up a normal mail buffer. (set-buffer (get-buffer-create " *message resend*")) + (buffer-disable-undo (current-buffer)) (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) @@ -3950,12 +4272,16 @@ 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) + (let ((message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) (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. @@ -3963,32 +4289,41 @@ This only makes sense if the current message is a bounce message than 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))) ;;; @@ -4139,7 +4474,7 @@ Do a `tab-to-tab-stop' if not in those headers." (message "No matching groups") (save-selected-window (pop-to-buffer "*Completions*") - (buffer-disable-undo) + (buffer-disable-undo (current-buffer)) (let ((buffer-read-only nil)) (erase-buffer) (let ((standard-output (current-buffer))) @@ -4182,103 +4517,171 @@ regexp varstr." (let ((oldbuf (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) - (message-clone-locals oldbuf varstr) + (message-clone-locals oldbuf) (current-buffer)))) -(defun message-clone-locals (buffer &optional varstr) +(defun message-clone-locals (buffer) "Clone the local variables from BUFFER to the current buffer." (let ((locals (save-excursion (set-buffer buffer) (buffer-local-variables))) - (regexp "^gnus\\|^nn\\|^message\\|^user-mail-address")) + (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))) - (or (null varstr) - (string-match varstr (symbol-name (car local))))) + (string-match regexp (symbol-name (car local)))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) locals))) -;;; 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)) +;; @ For `message-mail-follow-up-address-checker'. +(defcustom message-mailing-list-address-list nil + "*Regexp matching addresses that are mailing lists. +It must be a simple regexp string or a list of regexp strings. +This variable is used by \`message-check-mailing-list-with-address-list\'." + :group 'message-mail + :type '(repeat regexp)) + +(defun message-check-mailing-list-with-address-list (alist) + (let ((s alist) + (regexp (if (stringp message-mailing-list-address-list) + message-mailing-list-address-list + (mapconcat + (lambda (x) + x) + message-mailing-list-address-list + "\\|"))) + address non-mailing-list mailing-list) + (while (setq address (car (pop s))) + (if (string-match regexp address) + (setq mailing-list t) + (setq non-mailing-list + (append non-mailing-list (list address))))) + (if (or (not non-mailing-list) + (not mailing-list) + (not (y-or-n-p "Do you want to remove private address? "))) + alist + (setq s non-mailing-list) + (while s + (setq alist (delq (assoc (pop s) alist) alist))) + alist) + )) + +(defcustom message-mailing-list-address-p nil + "*The function return t if address is a mailing list. +It must be function, and interface is (ADDRESS). +ADDRESS is a string of mail address. +This variable is used by \`message-check-mailing-list-with-function\'." + :group 'message-mail + :type 'function) + +(defun message-check-mailing-list-with-function (alist) + (let ((s alist) + address non-mailing-list mailing-list) + (while (setq address (car (pop s))) + (if (funcall message-mailing-list-address-p address) + (setq mailing-list t) + (setq non-mailing-list + (append non-mailing-list (list address))))) + (if (or (not non-mailing-list) + (not mailing-list) + (not (y-or-n-p "Do you want to remove private address? "))) + alist + (setq s non-mailing-list) + (while s + (setq alist (delq (assoc (pop s) alist) alist))) + alist) + )) + +;;; @ Encode buffer. ;;; -;;; MIME functions + +(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) + ) + +;;; @ for saving buffer ;;; -(defvar message-inhibit-body-encoding nil) +(defvar message-save-encoder 'message-mime-save-encoder) -(defun message-encode-message-body () - (unless message-inhibit-body-encoding - (let ((mail-parse-charset (or mail-parse-charset - message-default-charset - message-posting-charset)) - (case-fold-search t) - lines content-type-p) - (message-goto-body) - (save-restriction - (narrow-to-region (point) (point-max)) - (let ((new (mml-generate-mime))) - (when new - (delete-region (point-min) (point-max)) - (insert new) - (goto-char (point-min)) - (if (eq (aref new 0) ?\n) - (delete-char 1) - (search-forward "\n\n") - (setq lines (buffer-substring (point-min) (1- (point)))) - (delete-region (point-min) (point)))))) - (save-restriction - (message-narrow-to-headers-or-head) - (message-remove-header "Mime-Version") - (goto-char (point-max)) - (insert "MIME-Version: 1.0\n") - (when lines - (insert lines)) - (setq content-type-p - (re-search-backward "^Content-Type:" nil t))) - (save-restriction - (message-narrow-to-headers-or-head) - (message-remove-first-header "Content-Type") - (message-remove-first-header "Content-Transfer-Encoding")) - ;; We always make sure that the message has a Content-Type header. - ;; This is because some broken MTAs and MUAs get awfully confused - ;; when confronted with a message with a MIME-Version header and - ;; without a Content-Type header. For instance, Solaris' - ;; /usr/bin/mail. - (unless content-type-p - (goto-char (point-min)) - (re-search-forward "^MIME-Version:") - (forward-line 1) - (insert "Content-Type: text/plain; charset=us-ascii\n"))))) +(defun message-save-formatter (start end &optional orig-buf) + "Format message, when save message buffer. [message.el]" + (save-restriction + (narrow-to-region start end) + (and message-save-encoder + (funcall message-save-encoder orig-buf)) + (goto-char start) + (and (search-forward (concat "\n" mail-header-separator "\n") nil t) + (replace-match "\n\n")) + )) + +(set-alist 'format-alist + 'message + '("Message." + "1\\(^\\)" + nil + message-save-formatter + t nil)) + +;;; @ for MIME Edit mode +;;; + +(defun message-mime-insert-article (&optional message) + (interactive) + (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)) + (message-remove-header message-included-forward-headers t nil t) + (widen)))) -(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))) +(set-alist 'mime-edit-message-inserter-alist + 'message-mode (function message-mime-insert-article)) -(provide 'message) +(defun message-mime-save-encoder (orig-buf) + (when (with-current-buffer orig-buf mime-edit-mode-flag) + (mime-edit-translate-body) + (mime-edit-translate-header) + )) + +(defun message-mime-after-save-hook () + (set-buffer-file-coding-system nnheader-file-coding-system) + (set-buffer-modified-p nil) + ) + +(defun message-mime-setup () + (turn-on-mime-edit) + (make-local-hook 'after-save-hook) + (add-hook 'after-save-hook 'message-mime-after-save-hook nil t) + ) (run-hooks 'message-load-hook) +(provide 'message) + ;;; message.el ends here