X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=21fb83a2b60e73218b75fdb9ec5714fd3ed0edbb;hb=39c8ecc92d0d37c0fdcc99872120a791d9251b2d;hp=5e085f84d62dffd3ec1b85e8ed06a06e71b5b677;hpb=e2978c293a6abc74d871637b1fd6b2970e238286;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 5e085f84d..21fb83a2b 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,27 +1,25 @@ ;;; message.el --- composing mail and news messages ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, 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 +;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -31,10 +29,11 @@ ;;; Code: +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile - (require 'cl) - (defvar gnus-message-group-art) - (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary + (require 'cl)) + (require 'hashcash) (require 'canlock) (require 'mailheader) @@ -51,6 +50,12 @@ (require 'rfc822) (require 'ecomplete) +(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ + +(defvar gnus-message-group-art) +(defvar gnus-list-identifiers) ; gnus-sum is required where necessary +(defvar rmail-enable-mime-composing) + (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) "Mail and news message composing." @@ -187,8 +192,8 @@ To disable checking of long signatures, for instance, add Don't touch this variable unless you really know what you're doing. -Checks include `approved', `continuation-headers', `control-chars', -`empty', `existing-newsgroups', `from', `illegible-text', +Checks include `approved', `bogus-recipient', `continuation-headers', +`control-chars', `empty', `existing-newsgroups', `from', `illegible-text', `invisible-text', `long-header-lines', `long-lines', `message-id', `multiple-headers', `new-text', `newsgroups', `quoting-style', `repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot', @@ -223,7 +228,7 @@ Also see `message-required-news-headers' and "*Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID. Organization, Lines, In-Reply-To, Expires, and -User-Agent are optional. If don't you want message to insert some +User-Agent are optional. If you don't want message to insert some header, remove it from this list." :group 'message-news :group 'message-headers @@ -268,7 +273,7 @@ included. Organization and User-Agent are optional." :link '(custom-manual "(message)Mail 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:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:" "*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." @@ -301,7 +306,7 @@ used." :version "22.1" :type '(choice (const :tag "never" nil) (const :tag "always strip" t) - (const ask)) + (const ask)) :link '(custom-manual "(message)Message Headers") :group 'message-various) @@ -408,9 +413,17 @@ for `message-cross-post-insert-note'." ;;; End of variables adopted from `message-utils.el'. -(defcustom message-signature-separator "^-- *$" - "Regexp matching the signature separator." - :type 'regexp +(defcustom message-signature-separator "^-- $" + "Regexp matching the signature separator. +This variable is used to strip off the signature from quoted text +when `message-cite-function' is +`message-cite-original-without-signature'. Most useful values +are \"^-- $\" (strict) and \"^-- *$\" (loose; allow missing +whitespace)." + :type '(choice (const :tag "strict" "^-- $") + (const :tag "loose" "^-- *$") + regexp) + :version "22.3" ;; Gnus 5.10.12 (changed default) :link '(custom-manual "(message)Various Message Variables") :group 'message-various) @@ -428,17 +441,45 @@ nil means let mailer mail back a message to report errors." :link '(custom-manual "(message)Sending Variables") :type 'boolean) +(defcustom message-confirm-send nil + "When non-nil, ask for confirmation when sending a message." + :group 'message-sending + :group 'message-mail + :version "23.1" ;; No Gnus + :link '(custom-manual "(message)Sending Variables") + :type 'boolean) + (defcustom message-generate-new-buffers 'unique - "*Non-nil means create a new message buffer 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." + "*Say whether to create a new message buffer to compose a message. +Valid values include: + +nil + Generate the buffer name in the Message way (e.g., *mail*, *news*, + *mail to whom*, *news on group*, etc.) and continue editing in the + existing buffer of that name. If there is no such buffer, it will + be newly created. + +`unique' or t + Create the new buffer with the name generated in the Message way. + +`unsent' + Similar to `unique' but the buffer name begins with \"*unsent \". + +`standard' + Similar to nil but the buffer name is simpler like *mail message*. + +function + 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 :link '(custom-manual "(message)Message Buffers") - :type '(choice (const :tag "off" nil) - (const :tag "unique" unique) - (const :tag "unsent" unsent) - (function fun))) + :type '(choice (const nil) + (sexp :tag "unique" :format "unique\n" :value unique + :match (lambda (widget value) (memq value '(unique t)))) + (const unsent) + (const standard) + (function :format "\n %{%t%}: %v"))) (defcustom message-kill-buffer-on-exit nil "*Non-nil means that the message buffer will be killed after sending a message." @@ -449,12 +490,11 @@ should return the new buffer name." (defcustom message-kill-buffer-query t "*Non-nil means that killing a modified message buffer has to be confirmed. This is used by `message-kill-buffer'." - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :group 'message-buffers :type 'boolean) -(eval-when-compile - (defvar gnus-local-organization)) +(defvar gnus-local-organization) (defcustom message-user-organization (or (and (boundp 'gnus-local-organization) (stringp gnus-local-organization) @@ -535,7 +575,13 @@ Done before generating the new subject of a forward." :link '(custom-manual "(message)Forwarding") :type 'boolean) -(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From " +(defcustom message-ignored-resent-headers + ;; `Delivered-To' needs to be removed because some mailers use it to + ;; detect loops, so if you resend a message to an address that ultimately + ;; comes back to you (e.g. a mailing-list to which you subscribe, in which + ;; case you may be removed from the list on the grounds that mail to you + ;; bounced with a "mailing loop" error). + "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From \\|^Delivered-To:" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :link '(custom-manual "(message)Resending") @@ -564,21 +610,21 @@ Done before generating the new subject of a forward." :type 'regexp) (defcustom message-cite-prefix-regexp - (if (string-match "[[:digit:]]" "1") ;; support POSIX? - "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+" + (if (string-match "[[:digit:]]" "1") + ;; Support POSIX? XEmacs 21.5.27 doesn't. + "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|}]\\)+" ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. (let (non-word-constituents) (with-syntax-table text-mode-syntax-table (setq non-word-constituents (concat - (if (string-match "\\w" "-") "" "-") (if (string-match "\\w" "_") "" "_") (if (string-match "\\w" ".") "" ".")))) (if (equal non-word-constituents "") - "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+" + "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}]\\)+" (concat "\\([ \t]*\\(\\w\\|[" non-word-constituents - "]\\)+>+\\|[ \t]*[]>|}+]\\)+")))) + "]\\)+>+\\|[ \t]*[]>|}]\\)+")))) "*Regexp matching the longest possible citation prefix on a line." :version "22.1" :group 'message-insertion @@ -597,28 +643,37 @@ Done before generating the new subject of a forward." :link '(custom-manual "(message)Canceling News") :type 'string) +(defvar smtpmail-default-smtp-server) + +(defun message-send-mail-function () + "Return suitable value for the variable `message-send-mail-function'." + (cond ((and (require 'sendmail) + (boundp 'sendmail-program) + sendmail-program + (executable-find sendmail-program)) + 'message-send-mail-with-sendmail) + ((and (locate-library "smtpmail") + (require 'smtpmail) + smtpmail-default-smtp-server) + 'message-smtpmail-send-it) + ((locate-library "mailclient") + 'message-send-mail-with-mailclient) + (t + (lambda () + (error "Don't know how to send mail. Please customize `message-send-mail-function'"))))) + ;; Useful to set in site-init.el -(defcustom message-send-mail-function - (let ((program (if (boundp 'sendmail-program) - ;; see paths.el - sendmail-program))) - (cond - ((and program - (string-match "/" program) ;; Skip path - (file-executable-p program)) - 'message-send-mail-with-sendmail) - ((and program - (executable-find program)) - 'message-send-mail-with-sendmail) - (t - 'smtpmail-send-it))) +(defcustom message-send-mail-function (message-send-mail-function) "Function to call to send the current buffer as mail. 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), +Valid values include `message-send-mail-with-sendmail' `message-send-mail-with-mh', `message-send-mail-with-qmail', -`message-smtpmail-send-it', `smtpmail-send-it' and `feedmail-send-it'. +`message-smtpmail-send-it', `smtpmail-send-it', +`feedmail-send-it' and `message-send-mail-with-mailclient'. The +default is system dependent and determined by the function +`message-send-mail-function'. See also `send-mail-function'." :type '(radio (function-item message-send-mail-with-sendmail) @@ -627,8 +682,12 @@ See also `send-mail-function'." (function-item message-smtpmail-send-it) (function-item smtpmail-send-it) (function-item feedmail-send-it) - (function :tag "Other")) + (function-item message-send-mail-with-mailclient + :tag "Use Mailclient package") + (function :tag "Other")) :group 'message-sending + :version "23.1" ;; No Gnus + :initialize 'custom-initialize-default :link '(custom-manual "(message)Mail Variables") :group 'message-mail) @@ -770,7 +829,7 @@ If this is nil, use `user-mail-address'. If it is the symbol (defcustom message-sendmail-extra-arguments nil "Additional arguments to `sendmail-program'." ;; E.g. '("-a" "account") for msmtp - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :type '(repeat string) ;; :link '(custom-manual "(message)Mail Variables") :group 'message-sending) @@ -795,9 +854,8 @@ might set this variable to '(\"-f\" \"you@some.where\")." :type '(choice (function) (repeat string))) -(eval-when-compile - (defvar gnus-post-method) - (defvar gnus-select-method)) +(defvar gnus-post-method) +(defvar gnus-select-method) (defcustom message-post-method (cond ((and (boundp 'gnus-post-method) (listp gnus-post-method) @@ -831,9 +889,18 @@ will not have a visible effect for those headers." :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(choice (const :tag "None" nil) - (const :tag "References" '(references)) - (const :tag "All" t) - (repeat (sexp :tag "Header")))) + (const :tag "References" '(references)) + (const :tag "All" t) + (repeat (sexp :tag "Header")))) + +(defcustom message-fill-column 72 + "Column beyond which automatic line-wrapping should happen. +Local value for message buffers. If non-nil, also turn on +auto-fill in message buffers." + :group 'message-various + ;; :link '(custom-manual "(message)Message Headers") + :type '(choice (const :tag "Don't turn on auto fill" nil) + (integer))) (defcustom message-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. @@ -884,7 +951,7 @@ the signature is inserted." "*Function called to insert the \"Whomever writes:\" line. Predefined functions include `message-insert-citation-line' and -`message-insert-formated-citation-line' (see the variable +`message-insert-formatted-citation-line' (see the variable `message-citation-line-format'). Note that Gnus provides a feature where the reader can click on @@ -893,12 +960,12 @@ people who read your message will have to change their Gnus configuration. See the variable `gnus-cite-attribution-suffix'." :type '(choice (function-item :tag "plain" message-insert-citation-line) - (function-item :tag "formatted" message-insert-formated-citation-line) + (function-item :tag "formatted" message-insert-formatted-citation-line) (function :tag "Other")) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -(defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:" +(defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n" "Format of the \"Whomever writes:\" line. The string is formatted using `format-spec'. The following @@ -922,7 +989,7 @@ Please also read the note in the documentation of (const :tag "Include date" "On %a, %b %d %Y, %n wrote:") string) :link '(custom-manual "(message)Insertion Variables") - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :group 'message-insertion) (defcustom message-yank-prefix "> " @@ -957,7 +1024,7 @@ Used by `message-yank-original' via `message-yank-cite'." :link '(custom-manual "(message)Insertion Variables") :type 'integer) -(defcustom message-cite-function 'message-cite-original +(defcustom message-cite-function 'message-cite-original-without-signature "*Function for citing an original message. Predefined functions include `message-cite-original' and `message-cite-original-without-signature'. @@ -967,6 +1034,7 @@ Note that these functions use `mail-citation-hook' if that is non-nil." (function-item sc-cite-original) (function :tag "Other")) :link '(custom-manual "(message)Insertion Variables") + :version "22.3" ;; Gnus 5.10.12 (changed default) :group 'message-insertion) (defcustom message-indent-citation-function 'message-indent-citation @@ -990,11 +1058,23 @@ If a form, the result from the form will be used instead." (defcustom message-signature-file "~/.signature" "*Name of file containing the text inserted at end of message buffer. Ignored if the named file doesn't exist. -If nil, don't insert a signature." +If nil, don't insert a signature. +If a path is specified, the value of `message-signature-directory' is ignored, +even if set." :type '(choice file (const :tags "None" nil)) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) +(defcustom message-signature-directory nil + "*Name of directory containing signature files. +Comes in handy if you have many such files, handled via posting styles for +instance. +If nil, `message-signature-file' is expected to specify the directory if +needed." + :type '(choice string (const :tags "None" nil)) + :link '(custom-manual "(message)Insertion Variables") + :group 'message-insertion) + (defcustom message-signature-insert-empty-line t "*If non-nil, insert an empty line before the signature separator." :version "22.1" @@ -1026,6 +1106,8 @@ If stringp, use this; if non-nil, use no host name (user name only)." (string :tag "name") (sexp :tag "none" :format "%t" t))) +;; This can be the name of a buffer, or a cons cell (FUNCTION . ARGS) +;; for yanking the original buffer. (defvar message-reply-buffer nil) (defvar message-reply-headers nil "The headers of the current replied article. @@ -1058,8 +1140,22 @@ these lines." :link '(custom-manual "(message)Message Headers") :type 'message-header-lines) -(defcustom message-default-mail-headers "" +(defcustom message-default-mail-headers + ;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555. + (concat (if (and (boundp 'mail-default-reply-to) + (stringp mail-default-reply-to)) + (format "Reply-to: %s\n" mail-default-reply-to) + "") + (if (and (boundp 'mail-self-blind) + mail-self-blind) + (format "BCC: %s\n" user-mail-address) + "") + (if (and (boundp 'mail-archive-file-name) + (stringp mail-archive-file-name)) + (format "FCC: %s\n" mail-archive-file-name) + "")) "*A string of header lines to be inserted in outgoing mails." + :version "23.2" :group 'message-headers :group 'message-mail :link '(custom-manual "(message)Mail Headers") @@ -1080,8 +1176,7 @@ these lines." (file-readable-p "/etc/sendmail.cf") (let ((buffer (get-buffer-create " *temp*"))) (unwind-protect - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (insert-file-contents "/etc/sendmail.cf") (goto-char (point-min)) (let ((case-fold-search nil)) @@ -1163,7 +1258,7 @@ If nil, you might be asked to input the charset." (defcustom message-dont-reply-to-names (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) "*Addresses to prune when doing wide replies. -This can be a regexp or a list of regexps. Also, a value of nil means +This can be a regexp or a list of regexps. Also, a value of nil means exclude your own user name only." :version "21.1" :group 'message @@ -1172,18 +1267,8 @@ exclude your own user name only." regexp (repeat :tag "Regexp List" regexp))) -;; #### FIXME: this might become a generally usefull function at some point -;; --dlv. (defsubst message-dont-reply-to-names () - "Potentially convert a list of regexps into a single one." - (cond ((null message-dont-reply-to-names) - nil) - ((stringp message-dont-reply-to-names) - message-dont-reply-to-names) - ((listp message-dont-reply-to-names) - (mapconcat (lambda (elt) (concat "\\(" elt "\\)")) - message-dont-reply-to-names - "\\|")))) + (gmm-regexp-concat message-dont-reply-to-names)) (defvar message-shoot-gnksa-feet nil "*A list of GNKSA feet you are allowed to shoot. @@ -1195,7 +1280,7 @@ candidates: `quoted-text-only' Allow you to post quoted text only; `multiple-copies' Allow you to post multiple copies; `cancel-messages' Allow you to cancel or supersede messages from - your other email addresses.") + your other email addresses.") (defsubst message-gnksa-enable-p (feature) (or (not (listp message-shoot-gnksa-feet)) @@ -1238,7 +1323,7 @@ starting with `not' and followed by regexps." (defface message-header-to '((((class color) (background dark)) - (:foreground "green2" :bold t)) + (:foreground "DarkOliveGreen1" :bold t)) (((class color) (background light)) (:foreground "MidnightBlue" :bold t)) @@ -1248,11 +1333,12 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-to-face 'face-alias 'message-header-to) +(put 'message-header-to-face 'obsolete-face "22.1") (defface message-header-cc '((((class color) (background dark)) - (:foreground "green4" :bold t)) + (:foreground "chartreuse1" :bold t)) (((class color) (background light)) (:foreground "MidnightBlue")) @@ -1262,11 +1348,12 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-cc-face 'face-alias 'message-header-cc) +(put 'message-header-cc-face 'obsolete-face "22.1") (defface message-header-subject '((((class color) (background dark)) - (:foreground "green3")) + (:foreground "OliveDrab1")) (((class color) (background light)) (:foreground "navy blue" :bold t)) @@ -1276,6 +1363,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-subject-face 'face-alias 'message-header-subject) +(put 'message-header-subject-face 'obsolete-face "22.1") (defface message-header-newsgroups '((((class color) @@ -1290,11 +1378,12 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-newsgroups-face 'face-alias 'message-header-newsgroups) +(put 'message-header-newsgroups-face 'obsolete-face "22.1") (defface message-header-other '((((class color) (background dark)) - (:foreground "#b00000")) + (:foreground "VioletRed1")) (((class color) (background light)) (:foreground "steel blue")) @@ -1304,11 +1393,12 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-other-face 'face-alias 'message-header-other) +(put 'message-header-other-face 'obsolete-face "22.1") (defface message-header-name '((((class color) (background dark)) - (:foreground "DarkGreen")) + (:foreground "green")) (((class color) (background light)) (:foreground "cornflower blue")) @@ -1318,11 +1408,12 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-name-face 'face-alias 'message-header-name) +(put 'message-header-name-face 'obsolete-face "22.1") (defface message-header-xheader '((((class color) (background dark)) - (:foreground "blue")) + (:foreground "DeepSkyBlue1")) (((class color) (background light)) (:foreground "blue")) @@ -1332,11 +1423,12 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-xheader-face 'face-alias 'message-header-xheader) +(put 'message-header-xheader-face 'obsolete-face "22.1") (defface message-separator '((((class color) (background dark)) - (:foreground "blue3")) + (:foreground "LightSkyBlue1")) (((class color) (background light)) (:foreground "brown")) @@ -1346,11 +1438,12 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-separator-face 'face-alias 'message-separator) +(put 'message-separator-face 'obsolete-face "22.1") (defface message-cited-text '((((class color) (background dark)) - (:foreground "red")) + (:foreground "LightPink1")) (((class color) (background light)) (:foreground "red")) @@ -1360,11 +1453,12 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-cited-text-face 'face-alias 'message-cited-text) +(put 'message-cited-text-face 'obsolete-face "22.1") (defface message-mml '((((class color) (background dark)) - (:foreground "ForestGreen")) + (:foreground "MediumSpringGreen")) (((class color) (background light)) (:foreground "ForestGreen")) @@ -1374,6 +1468,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-mml-face 'face-alias 'message-mml) +(put 'message-mml-face 'obsolete-face "22.1") (defun message-font-lock-make-header-matcher (regexp) (let ((form @@ -1412,13 +1507,13 @@ starting with `not' and followed by regexps." (1 'message-header-name) (2 'message-header-newsgroups nil t)) (,(message-font-lock-make-header-matcher - (concat "^\\([A-Z][^: \n\t]+:\\)" content)) + (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) (1 'message-header-name) - (2 'message-header-other nil t)) + (2 'message-header-xheader)) (,(message-font-lock-make-header-matcher - (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) + (concat "^\\([A-Z][^: \n\t]+:\\)" content)) (1 'message-header-name) - (2 'message-header-name)) + (2 'message-header-other nil t)) ,@(if (and mail-header-separator (not (equal mail-header-separator ""))) `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") @@ -1585,7 +1680,7 @@ functionality to work." (defcustom message-generate-hashcash (if (executable-find "hashcash") t) "*Whether to generate X-Hashcash: headers. -If `t', always generate hashcash headers. If `opportunistic', +If t, always generate hashcash headers. If `opportunistic', only generate hashcash headers if it can be done without the user waiting (i.e., only asynchronously). @@ -1608,9 +1703,8 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (defvar message-inserted-headers nil) ;; Byte-compiler warning -(eval-when-compile - (defvar gnus-active-hashtb) - (defvar gnus-read-active-file)) +(defvar gnus-active-hashtb) +(defvar gnus-read-active-file) ;;; Regexp matching the delimiter of messages in UNIX mail format ;;; (UNIX From lines), minus the initial ^. It should be a copy @@ -1675,6 +1769,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." "^ *--+ +begin message +--+ *$\\|" "^ *---+ +Original message follows +---+ *$\\|" "^ *---+ +Undelivered message follows +---+ *$\\|" + "^------ This is a copy of the message, including all the headers. ------ *$\\|" "^|? *---+ +Message text follows: +---+ *|?$") "A regexp that matches the separator before the text of a failed message.") @@ -1731,32 +1826,31 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." :group 'message-headers :type 'regexp) -(eval-and-compile - (autoload 'gnus-alive-p "gnus-util") - (autoload 'gnus-delay-article "gnus-delay") - (autoload 'gnus-extract-address-components "gnus-util") - (autoload 'gnus-find-method-for-group "gnus") - (autoload 'gnus-group-decoded-name "gnus-group") - (autoload 'gnus-group-name-charset "gnus-group") - (autoload 'gnus-group-name-decode "gnus-group") - (autoload 'gnus-groups-from-server "gnus") - (autoload 'gnus-make-local-hook "gnus-util") - (autoload 'gnus-open-server "gnus-int") - (autoload 'gnus-output-to-mail "gnus-util") - (autoload 'gnus-output-to-rmail "gnus-util") - (autoload 'gnus-request-post "gnus-int") - (autoload 'gnus-server-string "gnus") - (autoload 'idna-to-ascii "idna") - (autoload 'message-setup-toolbar "messagexmas") - (autoload 'mh-new-draft-name "mh-comp") - (autoload 'mh-send-letter "mh-comp") - (autoload 'nndraft-request-associate-buffer "nndraft") - (autoload 'nndraft-request-expire-articles "nndraft") - (autoload 'nnvirtual-find-group-art "nnvirtual") - (autoload 'rmail-dont-reply-to "mail-utils") - (autoload 'rmail-msg-is-pruned "rmail") - (autoload 'rmail-msg-restore-non-pruned-header "rmail") - (autoload 'rmail-output "rmailout")) +(autoload 'gnus-alive-p "gnus-util") +(autoload 'gnus-delay-article "gnus-delay") +(autoload 'gnus-extract-address-components "gnus-util") +(autoload 'gnus-find-method-for-group "gnus") +(autoload 'gnus-group-decoded-name "gnus-group") +(autoload 'gnus-group-name-charset "gnus-group") +(autoload 'gnus-group-name-decode "gnus-group") +(autoload 'gnus-groups-from-server "gnus") +(autoload 'gnus-make-local-hook "gnus-util") +(autoload 'gnus-open-server "gnus-int") +(autoload 'gnus-output-to-mail "gnus-util") +(autoload 'gnus-output-to-rmail "gnus-util") +(autoload 'gnus-request-post "gnus-int") +(autoload 'gnus-select-frame-set-input-focus "gnus-util") +(autoload 'gnus-server-string "gnus") +(autoload 'idna-to-ascii "idna") +(autoload 'message-setup-toolbar "messagexmas") +(autoload 'mh-new-draft-name "mh-comp") +(autoload 'mh-send-letter "mh-comp") +(autoload 'nndraft-request-associate-buffer "nndraft") +(autoload 'nndraft-request-expire-articles "nndraft") +(autoload 'nnvirtual-find-group-art "nnvirtual") +(autoload 'rmail-dont-reply-to "mail-utils") +(autoload 'rmail-msg-is-pruned "rmail") +(autoload 'rmail-output "rmailout") @@ -1881,10 +1975,9 @@ see `message-narrow-to-headers-or-head'." (defmacro message-with-reply-buffer (&rest forms) "Evaluate FORMS in the reply buffer, if it exists." - `(when (and message-reply-buffer + `(when (and (bufferp message-reply-buffer) (buffer-name message-reply-buffer)) - (save-excursion - (set-buffer message-reply-buffer) + (with-current-buffer message-reply-buffer ,@forms))) (put 'message-with-reply-buffer 'lisp-indent-function 0) @@ -2327,6 +2420,8 @@ Return the number of headers removed." (point-max))) (goto-char (point-min))) +;; FIXME: clarify diffference: message-narrow-to-head, +;; message-narrow-to-headers-or-head, message-narrow-to-headers (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." @@ -2338,14 +2433,12 @@ Point is left at the beginning of the narrowed-to region." (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)))) + (if (re-search-forward (concat "\\(\n\\)\n\\|^\\(" + (regexp-quote mail-header-separator) + "\n\\)") + nil t) + (or (match-end 1) (match-beginning 2)) + (point-max))) (goto-char (point-min))) (defun message-news-p () @@ -2427,15 +2520,29 @@ Point is left at the beginning of the narrowed-to region." (kill-region start (point)))) +(autoload 'Info-goto-node "info") +(defvar mml2015-use) + (defun message-info (&optional arg) "Display the Message manual. -Prefixed with one \\[universal-argument], display the Emacs MIME manual. -Prefixed with two \\[universal-argument]'s, display the PGG manual." +Prefixed with one \\[universal-argument], display the Emacs MIME +manual. With two \\[universal-argument]'s, display the EasyPG or +PGG manual, depending on the value of `mml2015-use'." (interactive "p") - (cond ((eq arg 16) (Info-goto-node "(pgg)Top")) - ((eq arg 4) (Info-goto-node "(emacs-mime)Top")) - (t (Info-goto-node "(message)Top")))) + ;; Don't use `info' because support for `(filename)nodename' is not + ;; available in XEmacs < 21.5.12. + (Info-goto-node (format "(%s)Top" + (cond ((eq arg 16) + (require 'mml2015) + mml2015-use) + ((eq arg 4) 'emacs-mime) + ;; `booleanp' only available in Emacs 22+ + ((and (not (memq arg '(nil t))) + (symbolp arg)) + arg) + (t + 'message))))) @@ -2631,14 +2738,13 @@ Prefixed with two \\[universal-argument]'s, display the PGG manual." (defvar message-tool-bar-map nil) -(eval-when-compile - (defvar facemenu-add-face-function) - (defvar facemenu-remove-face-function)) +(defvar facemenu-add-face-function) +(defvar facemenu-remove-face-function) ;;; Forbidden properties ;; ;; We use `after-change-functions' to keep special text properties -;; that interfer with the normal function of message mode out of the +;; that interfere with the normal function of message mode out of the ;; buffer. (defcustom message-strip-special-text-properties t @@ -2714,7 +2820,7 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution - C-c C-f C-o move to From (\"Originator\") + C-c C-f C-o move to From (\"Originator\") C-c C-f C-f move to Followup-To C-c C-f C-m move to Mail-Followup-To C-c C-f C-e move to Expires @@ -2766,6 +2872,9 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (set (make-local-variable 'message-checksum) nil) (set (make-local-variable 'message-mime-part) 0) (message-setup-fill-variables) + (when message-fill-column + (setq fill-column message-fill-column) + (turn-on-auto-fill)) ;; Allow using comment commands to add/remove quoting. ;; (set (make-local-variable 'comment-start) message-yank-prefix) (when message-yank-prefix @@ -2843,6 +2952,8 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." ;; solution would be not to use `define-derived-mode', and run ;; `text-mode-hook' ourself at the end of the mode. ;; -- Per Abrahamsen Date: 2001-10-19. + ;; This kludge is unneeded in Emacs>=21 since define-derived-mode is + ;; now careful to run parent hooks after the body. --Stef (when auto-fill-function (setq auto-fill-function normal-auto-fill-function))) @@ -2982,11 +3093,11 @@ If the original author requested not to be sent mail, don't insert unless the prefix FORCE is given." (interactive "P") (let* ((mct (message-fetch-reply-field "mail-copies-to")) - (dont (and mct (or (equal (downcase mct) "never") + (dont (and mct (or (equal (downcase mct) "never") (equal (downcase mct) "nobody")))) - (to (or (message-fetch-reply-field "mail-reply-to") - (message-fetch-reply-field "reply-to") - (message-fetch-reply-field "from")))) + (to (or (message-fetch-reply-field "mail-reply-to") + (message-fetch-reply-field "reply-to") + (message-fetch-reply-field "from")))) (when (and dont to) (message (if force @@ -3026,30 +3137,29 @@ or in the synonym headers, defined by `message-header-synonyms'." ;; (mail-strip-quoted-names "Foo Bar , bla@fasel (Bla Fasel)") (dolist (header headers) (let* ((header-name (symbol-name (car header))) - (new-header (cdr header)) - (synonyms (loop for synonym in message-header-synonyms + (new-header (cdr header)) + (synonyms (loop for synonym in message-header-synonyms when (memq (car header) synonym) return synonym)) - (old-header - (loop for synonym in synonyms + (old-header + (loop for synonym in synonyms for old-header = (mail-fetch-field (symbol-name synonym)) when (and old-header (string-match new-header old-header)) return synonym))) (if old-header - (message "already have `%s' in `%s'" new-header old-header) + (message "already have `%s' in `%s'" new-header old-header) (when (and (message-position-on-field header-name) - (setq old-header (mail-fetch-field header-name)) - (not (string-match "\\` *\\'" old-header))) + (setq old-header (mail-fetch-field header-name)) + (not (string-match "\\` *\\'" old-header))) (insert ", ")) - (insert new-header))))) + (insert new-header))))) (defun message-widen-reply () "Widen the reply to include maximum recipients." (interactive) (let ((follow-to - (and message-reply-buffer + (and (bufferp message-reply-buffer) (buffer-name message-reply-buffer) - (save-excursion - (set-buffer message-reply-buffer) + (with-current-buffer message-reply-buffer (message-get-reply-headers t))))) (save-excursion (save-restriction @@ -3246,13 +3356,21 @@ Message buffers and is not meant to be called directly." ((listp message-signature) (eval message-signature)) (t message-signature))) - (signature + signature-file) + (setq signature (cond ((stringp signature) signature) - ((and (eq t signature) - message-signature-file - (file-exists-p message-signature-file)) - signature)))) + ((and (eq t signature) message-signature-file) + (setq signature-file + (if (and message-signature-directory + ;; don't actually use the signature directory + ;; if message-signature-file contains a path. + (not (file-name-directory + message-signature-file))) + (nnheader-concat message-signature-directory + message-signature-file) + message-signature-file)) + (file-exists-p signature-file)))) (when signature (goto-char (point-max)) ;; Insert the signature. @@ -3262,7 +3380,7 @@ Message buffers and is not meant to be called directly." (insert "\n")) (insert "-- \n") (if (eq signature t) - (insert-file-contents message-signature-file) + (insert-file-contents signature-file) (insert signature)) (goto-char (point-max)) (or (bolp) (insert "\n"))))) @@ -3293,8 +3411,7 @@ The three allowed values according to RFC 1327 are `high', `normal' and `low'." (interactive) (save-excursion - (let ((valid '("high" "normal" "low")) - (new "high") + (let ((new "high") cur) (save-restriction (message-narrow-to-headers) @@ -3476,6 +3593,27 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (forward-line 1)))) (goto-char start)) +(defun message-remove-blank-cited-lines (&optional remove) + "Remove cited lines containing only blanks. +If REMOVE is non-nil, remove newlines, too. + +To use this automatically, you may add this function to +`gnus-message-setup-hook'." + (interactive "P") + (let ((citexp + (concat + "^\\(" + (when (boundp 'message-yank-cited-prefix) + (concat message-yank-cited-prefix "\\|")) + message-yank-prefix + "\\)+ *\n" + ))) + (gnus-message 8 "removing `%s'" citexp) + (save-excursion + (message-goto-body) + (while (re-search-forward citexp nil t) + (replace-match (if remove "" "\n")))))) + (defvar message-cite-reply-above nil "If non-nil, start own text above the quote. @@ -3514,22 +3652,33 @@ Really top post? "))) (point-max))) (delete-region (message-goto-body) (point-max))) (set (make-local-variable 'message-cite-reply-above) nil))) - (delete-windows-on message-reply-buffer t) + (if (bufferp message-reply-buffer) + (delete-windows-on message-reply-buffer t)) (push-mark (save-excursion - (insert-buffer-substring message-reply-buffer) + (cond + ((bufferp message-reply-buffer) + (insert-buffer-substring message-reply-buffer)) + ((and (consp message-reply-buffer) + (functionp (car message-reply-buffer))) + (apply (car message-reply-buffer) + (cdr message-reply-buffer)))) + (unless (bolp) + (insert ?\n)) (point))) (unless arg - (funcall message-cite-function)) - (if message-cite-reply-above - (progn - (message-goto-body) - (insert body-text) - (newline) - (message-goto-body) - (message-exchange-point-and-mark)) - (message-exchange-point-and-mark)) - (unless (bolp) - (insert ?\n)) + (funcall message-cite-function) + (unless (eq (char-before (mark t)) ?\n) + (let ((pt (point))) + (goto-char (mark t)) + (insert-before-markers ?\n) + (goto-char pt)))) + (when message-cite-reply-above + (message-goto-body) + (insert body-text) + (insert (if (bolp) "\n" "\n\n")) + (message-goto-body)) + ;; Add a `message-setup-very-last-hook' here? + ;; Add `gnus-article-highlight-citation' here? (unless modified (setq message-checksum (message-checksum)))))) @@ -3543,7 +3692,7 @@ Really top post? "))) (defun message-buffers () "Return a list of active message buffers." (let (buffers) - (save-excursion + (save-current-buffer (dolist (buffer (buffer-list t)) (set-buffer buffer) (when (and (eq major-mode 'message-mode) @@ -3551,8 +3700,6 @@ Really top post? "))) (push (buffer-name buffer) buffers)))) (nreverse buffers))) -(eval-when-compile (defvar mail-citation-hook)) ; Compiler directive - (defun message-cite-original-1 (strip-signature) "Cite an original message. If STRIP-SIGNATURE is non-nil, strips off the signature from the @@ -3619,14 +3766,18 @@ This function uses `mail-citation-hook' if that is non-nil." "Cite function in the standard Message manner." (message-cite-original-1 nil)) -(defun message-insert-formated-citation-line (&optional from date) - "Function that inserts a formated citation line. +(defvar gnus-extract-address-components) + +(autoload 'format-spec "format-spec") + +(defun message-insert-formatted-citation-line (&optional from date) + "Function that inserts a formatted citation line. See `message-citation-line-format'." ;; The optional args are for testing/debugging. They will disappear later. ;; Example: ;; (with-temp-buffer - ;; (message-insert-formated-citation-line + ;; (message-insert-formatted-citation-line ;; "John Doe " ;; (current-time)) ;; (buffer-string)) @@ -3695,15 +3846,13 @@ See `message-citation-line-format'." (>= i ?a))) (push i lst) (push (condition-case nil - (progn (format-time-string (format "%%%c" i) - replydate)) - (format ">%c<" i)) + (format-time-string (format "%%%c" i) replydate) + (error (format ">%c<" i))) lst)) (setq i (1+ i))) (reverse lst))) (spec (apply 'format-spec-make flist))) (insert (format-spec message-citation-line-format spec))) - (newline) (newline))) (defun message-cite-original-without-signature () @@ -3855,6 +4004,9 @@ It should typically alter the sending method in some way or other." (put-text-property (point-min) (point-max) 'read-only nil)) (message-fix-before-sending) (run-hooks 'message-send-hook) + (when message-confirm-send + (or (y-or-n-p "Send message? ") + (keyboard-quit))) (message message-sending-message) (let ((alist message-send-method-alist) (success t) @@ -3952,6 +4104,33 @@ not have PROP." (setq start next))) (nreverse regions))) +(defcustom message-bogus-addresses + ;; '("noreply" "nospam" "invalid") + '("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]") + "List of regexps of potentially bogus mail addresses. +See `message-check-recipients' how to setup checking. + +This list should make it possible to catch typos or warn about +spam-trap addresses. It doesn't aim to verify strict RFC +conformance." + :version "23.1" ;; No Gnus + :group 'message-headers + :type '(choice + (const :tag "None" nil) + (list + (set :inline t + (const "noreply") + (const "nospam") + (const "invalid") + (const :tag "duplicate @" "@@") + (const :tag "non-ascii local part" "[^[:ascii:]].*@") + ;; Already caught by `message-valid-fqdn-regexp' + ;; (const :tag "`_' in domain part" "@.*_") + (const :tag "whitespace" "[ \t]")) + (repeat :inline t + :tag "Other" + (regexp))))) + (defun message-fix-before-sending () "Do various things to make the message nice before sending it." ;; Make sure there's a newline at the end of the message. @@ -3980,23 +4159,30 @@ not have PROP." "Invisible text found and made visible; continue sending? ") (error "Invisible text found and made visible"))))) (message-check 'illegible-text - (let (found choice) + (let (char found choice) (message-goto-body) - (skip-chars-forward mm-7bit-chars) - (while (not (eobp)) - (when (let ((char (char-after))) - (or (< (mm-char-int char) 128) - (and (mm-multibyte-p) - (memq (char-charset char) - '(eight-bit-control eight-bit-graphic - control-1)) - (not (get-text-property - (point) 'untranslated-utf-8))))) + (while (progn + (skip-chars-forward mm-7bit-chars) + (when (get-text-property (point) 'no-illegible-text) + ;; There is a signed or encrypted raw message part + ;; that is considered to be safe. + (goto-char (or (next-single-property-change + (point) 'no-illegible-text) + (point-max)))) + (setq char (char-after))) + (when (or (< (mm-char-int char) 128) + (and (mm-multibyte-p) + (memq (char-charset char) + '(eight-bit-control eight-bit-graphic + ;; Emacs 23, Bug#1770: + eight-bit + control-1)) + (not (get-text-property + (point) 'untranslated-utf-8)))) (message-overlay-put (message-make-overlay (point) (1+ (point))) 'face 'highlight) (setq found t)) - (forward-char) - (skip-chars-forward mm-7bit-chars)) + (forward-char)) (when found (setq choice (gnus-multiple-choice @@ -4016,10 +4202,13 @@ not have PROP." (or (< (mm-char-int char) 128) (and (mm-multibyte-p) ;; FIXME: Wrong for Emacs 23 (unicode) and for - ;; things like undecable utf-8. Should at least - ;; use find-coding-systems-region. + ;; things like undecodable utf-8 (in Emacs 21?). + ;; Should at least use find-coding-systems-region. + ;; -- fx (memq (char-charset char) '(eight-bit-control eight-bit-graphic + ;; Emacs 23, Bug#1770: + eight-bit control-1)) (not (get-text-property (point) 'untranslated-utf-8))))) @@ -4029,7 +4218,62 @@ not have PROP." (when (eq choice ?r) (insert message-replacement-char)))) (forward-char) - (skip-chars-forward mm-7bit-chars)))))) + (skip-chars-forward mm-7bit-chars))))) + (message-check 'bogus-recipient + ;; Warn before sending a mail to an invalid address. + (message-check-recipients))) + +(defun message-bogus-recipient-p (recipients) + "Check if a mail address in RECIPIENTS looks bogus. + +RECIPIENTS is a mail header. Return a list of potentially bogus +addresses. If none is found, return nil. + +An address might be bogus if the domain part is not fully +qualified, see `message-valid-fqdn-regexp', or if there's a +matching entry in `message-bogus-addresses'." + ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"? + (let (found) + (mapc (lambda (address) + (setq address (cadr address)) + (when + (or (not + (or + (not (string-match "@" address)) + (string-match + (concat ".@.*\\(" + message-valid-fqdn-regexp "\\)\\'") address))) + (and message-bogus-addresses + (let ((re + (if (listp message-bogus-addresses) + (mapconcat 'identity + message-bogus-addresses + "\\|") + message-bogus-addresses))) + (string-match re address)))) + (push address found))) + ;; + (mail-extract-address-components recipients t)) + found)) + +(defun message-check-recipients () + "Warn before composing or sending a mail to an invalid address. + +This function could be useful in `message-setup-hook'." + (interactive) + (save-restriction + (message-narrow-to-headers) + (dolist (hdr '("To" "Cc" "Bcc")) + (let ((addr (message-fetch-field hdr))) + (when (stringp addr) + (dolist (bog (message-bogus-recipient-p addr)) + (and bog + (not (y-or-n-p + (format + "Address `%s' might be bogus. Continue? " bog))) + (error "Bogus address")))))))) + +(custom-add-option 'message-setup-hook 'message-check-recipients) (defun message-add-action (action &rest types) "Add ACTION to be performed when doing an exit of type TYPES." @@ -4120,9 +4364,8 @@ not have PROP." (end-of-line) (insert (format " (%d/%d)" n total)) (widen) - (mm-with-unibyte-current-buffer - (funcall (or message-send-mail-real-function - message-send-mail-function)))) + (funcall (or message-send-mail-real-function + message-send-mail-function))) (setq n (+ n 1)) (setq p (pop plist)) (erase-buffer))) @@ -4178,8 +4421,7 @@ not have PROP." ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (unwind-protect - (save-excursion - (set-buffer tembuf) + (with-current-buffer tembuf (erase-buffer) ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer mailbuf @@ -4225,6 +4467,11 @@ not have PROP." (message-fetch-field "content-transfer-encoding"))))))) (message-insert-courtesy-copy)) + ;; Let's make sure we encoded all the body. + (assert (save-excursion + (goto-char (point-min)) + (not (re-search-forward "[^\000-\377]" nil t)))) + (mm-disable-multibyte) (if (or (not message-send-mail-partially-limit) (< (buffer-size) message-send-mail-partially-limit) (not (message-y-or-n-p @@ -4249,7 +4496,7 @@ The size limit is controlled by `message-send-mail-partially-limit'. If you always want Gnus to send messages in one piece, set `message-send-mail-partially-limit' to nil. "))) - (mm-with-unibyte-current-buffer + (progn (message "Sending via mail...") (funcall (or message-send-mail-real-function message-send-mail-function))) @@ -4322,10 +4569,10 @@ If you always want Gnus to send messages in one piece, set (list resend-to-addresses) '("-t")))))) (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) + (if errbuf (pop-to-buffer errbuf)) (error "Sending...failed with exit value %d" cpr))) (when message-interactive - (save-excursion - (set-buffer errbuf) + (with-current-buffer errbuf (goto-char (point-min)) (while (re-search-forward "\n+ *" nil t) (replace-match "; ")) @@ -4351,7 +4598,7 @@ to find out how to use this." (apply 'call-process-region (point-min) (point-max) message-qmail-inject-program nil nil nil - ;; qmail-inject's default behaviour is to look for addresses on the + ;; qmail-inject's default behavior 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. ;; @@ -4368,9 +4615,9 @@ to find out how to use this." ;; 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 - (if (functionp message-qmail-inject-args) - (funcall message-qmail-inject-args) - message-qmail-inject-args))) + (if (functionp message-qmail-inject-args) + (funcall message-qmail-inject-args) + 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) @@ -4399,13 +4646,20 @@ to find out how to use this." (defun message-smtpmail-send-it () "Send the prepared message buffer with `smtpmail-send-it'. -This only differs from `smtpmail-send-it' that this command evaluates -`message-send-mail-hook' just before sending a message. It is useful -if your ISP requires the POP-before-SMTP authentication. See the Gnus -manual for details." +The only difference from `smtpmail-send-it' is that this command +evaluates `message-send-mail-hook' just before sending a message. +It is useful if your ISP requires the POP-before-SMTP +authentication. See the Gnus manual for details." (run-hooks 'message-send-mail-hook) (smtpmail-send-it)) +(defun message-send-mail-with-mailclient () + "Send the prepared message buffer with `mailclient-send-it'. +The only difference from `mailclient-send-it' is that this +command evaluates `message-send-mail-hook' just before sending a message." + (run-hooks 'message-send-mail-hook) + (mailclient-send-it)) + (defun message-canlock-generate () "Return a string that is non-trivial to guess. Do not use this for anything important, it is cryptographically weak." @@ -4488,8 +4742,7 @@ Otherwise, generate and save a value for `canlock-password' first." (message-check-news-syntax))) nil (unwind-protect - (save-excursion - (set-buffer tembuf) + (with-current-buffer tembuf (buffer-disable-undo) (erase-buffer) ;; Avoid copying text props (except hard newlines). @@ -4809,7 +5062,8 @@ Otherwise, generate and save a value for `canlock-password' first." "Denied posting -- the From looks strange: \"%s\"." from) nil) ((let ((addresses (rfc822-addresses from))) - (while (and addresses + ;; `rfc822-addresses' returns a string if parsing fails. + (while (and (consp addresses) (not (eq (string-to-char (car addresses)) ?\())) (setq addresses (cdr addresses))) addresses) @@ -4881,7 +5135,7 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Check for control characters. (message-check 'control-chars (if (re-search-forward - (mm-string-as-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") + (mm-string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") nil t) (y-or-n-p "The article contains control characters. Really post? ") @@ -4905,13 +5159,24 @@ Otherwise, generate and save a value for `canlock-password' first." nil))) ;; 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)) + (let (sig-start sig-end) + (goto-char (point-max)) + (if (not (re-search-backward message-signature-separator nil t)) + t + (setq sig-start (1+ (point-at-eol))) + (setq sig-end + (if (re-search-forward + "<#/?\\(multipart\\|part\\|external\\|mml\\)" nil t) + (- (point-at-bol) 1) + (point-max))) + (if (>= (count-lines sig-start sig-end) 5) + (if (message-gnksa-enable-p 'signature) + (y-or-n-p + (format "Signature is excessively long (%d lines). Really post? " + (count-lines sig-start sig-end))) + (message "Denied posting -- Excessive signature.") + nil) + t)))) ;; Ensure that text follows last quoted portion. (message-check 'quoting-style (goto-char (point-max)) @@ -4990,6 +5255,13 @@ Otherwise, generate and save a value for `canlock-password' first." (if (and message-fcc-handler-function (not (eq message-fcc-handler-function 'rmail-output))) (funcall message-fcc-handler-function file) + ;; FIXME this option, rmail-output (also used if + ;; message-fcc-handler-function is nil) is not + ;; documented anywhere AFAICS. It should work in Emacs + ;; 23; I suspect it does not work in Emacs 22. + ;; FIXME I don't see the need for the two different cases here. + ;; mail-use-rfc822 makes no difference (in Emacs 23),and + ;; the third argument just controls \"Wrote file\" message. (if (and (file-readable-p file) (mail-file-babyl-p file)) (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) @@ -5093,7 +5365,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (* 25 25))) (let ((tm (current-time))) (concat - (if (or (memq system-type '(ms-dos emx vax-vms)) + (if (or (memq system-type '(ms-dos emx)) ;; message-number-base36 doesn't handle bigints. (floatp (user-uid))) (let ((user (downcase (user-login-name)))) @@ -5152,8 +5424,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." "Return the References header for this message." (when message-reply-headers (let ((message-id (mail-header-message-id message-reply-headers)) - (references (mail-header-references message-reply-headers)) - new-references) + (references (mail-header-references message-reply-headers))) (if (or references message-id) (concat (or references "") (and references " ") (or message-id "")) @@ -5174,19 +5445,18 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." ;; Quote a string containing non-ASCII characters. ;; It will make the RFC2047 encoder cause an error ;; if there are special characters. - (let ((default-enable-multibyte-characters t)) - (with-temp-buffer - (insert (car name)) - (goto-char (point-min)) - (while (search-forward "\"" nil t) - (when (prog2 - (backward-char) - (zerop (% (skip-chars-backward "\\\\") 2)) - (goto-char (match-beginning 0))) - (insert "\\")) - (forward-char)) - ;; Those quotes will be removed by the RFC2047 encoder. - (concat "\"" (buffer-string) "\""))) + (mm-with-multibyte-buffer + (insert (car name)) + (goto-char (point-min)) + (while (search-forward "\"" nil t) + (when (prog2 + (backward-char) + (zerop (% (skip-chars-backward "\\\\") 2)) + (goto-char (match-beginning 0))) + (insert "\\")) + (forward-char)) + ;; Those quotes will be removed by the RFC2047 encoder. + (concat "\"" (buffer-string) "\"")) (car name)) (nth 1 name)) "'s message of \"" @@ -5220,7 +5490,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (concat message-user-path "!" login-name)) (t login-name)))) -(defun message-make-from (&optional name address ) +(defun message-make-from (&optional name address) "Make a From header." (let* ((style message-from-style) (login (or address (message-make-address))) @@ -5248,15 +5518,15 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (string-match "[\\()]" tmp))))) (insert fullname) (goto-char (point-min)) - ;; Look for a character that cannot appear unquoted - ;; according to RFC 822. - (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) - ;; Quote fullname, escaping specials. - (goto-char (point-min)) - (insert "\"") - (while (re-search-forward "[\"\\]" nil 1) - (replace-match "\\\\\\&" t)) - (insert "\"")) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) + ;; Quote fullname, escaping specials. + (goto-char (point-min)) + (insert "\"") + (while (re-search-forward "[\"\\]" nil 1) + (replace-match "\\\\\\&" t)) + (insert "\"")) (insert " <" login ">")) (t ; 'parens or default (insert login " (") @@ -5401,8 +5671,7 @@ subscribed address (and not the additional To and Cc header contents)." (mapcar 'funcall message-subscribed-address-functions)))) (save-match-data - (let ((subscribed-lists nil) - (list + (let ((list (loop for recipient in recipients when (loop for regexp in mft-regexps when (string-match regexp recipient) return t) @@ -5422,8 +5691,13 @@ subscribed address (and not the additional To and Cc header contents)." (mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) "")) (mapcar 'downcase (mapcar - 'car (mail-header-parse-addresses field)))))) - (setq ace (downcase (idna-to-ascii rhs))) + 'cadr + (mail-extract-address-components field t)))))) + ;; Note that `rhs' will be "" if the address does not have + ;; the domain part, i.e., if it is a local user's address. + (setq ace (if (string-match "\\`[[:ascii:]]*\\'" rhs) + rhs + (downcase (idna-to-ascii rhs)))) (when (and (not (equal rhs ace)) (or (not (eq message-use-idna 'ask)) (y-or-n-p (format "Replace %s with %s in %s:? " @@ -5443,7 +5717,13 @@ See `message-idna-encode'." (when message-use-idna (save-excursion (save-restriction - (message-narrow-to-head) + ;; `message-narrow-to-head' that recognizes only the first empty + ;; line as the message header separator used to be used here. + ;; However, since there is the "--text follows this line--" line + ;; normally, it failed in narrowing to the headers and potentially + ;; caused the IDNA encoding on lines that look like headers in + ;; the message body. + (message-narrow-to-headers-or-head) (message-idna-to-ascii-rhs-1 "From") (message-idna-to-ascii-rhs-1 "To") (message-idna-to-ascii-rhs-1 "Reply-To") @@ -5730,8 +6010,10 @@ they are." (with-temp-buffer (insert references) (goto-char (point-min)) - ;; Cons a list of valid references. - (while (re-search-forward "<[^>]+>" nil t) + ;; Cons a list of valid references. GNKSA says we must not include MIDs + ;; with whitespace or missing brackets (7.a "Does not propagate broken + ;; Message-IDs in original References"). + (while (re-search-forward "<[^ <]+@[^ <]+>" nil t) (push (match-string 0) refs)) (setq refs (nreverse refs) count (length refs))) @@ -5807,7 +6089,7 @@ beginning of header value. Therefore, repeated calls will toggle point between beginning of field and beginning of line." (interactive "p") (let ((zrs 'zmacs-region-stays)) - (when (and (interactive-p) (boundp zrs)) + (when (and (featurep 'xemacs) (interactive-p) (boundp zrs)) (set zrs t))) (if (and message-beginning-of-line (message-point-in-header-p)) @@ -5824,7 +6106,7 @@ between beginning of field and beginning of line." "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) + ((memq message-generate-new-buffers '(unique t)) (generate-new-buffer-name (concat "*" type (if to @@ -5848,22 +6130,55 @@ between beginning of field and beginning of line." "") (if (and group (not (string= group ""))) (concat " on " group) "") "*"))) - ;; Use standard name. + ;; Search for the existing message buffer with the specified name. (t - (format "*%s message*" type)))) - -(defun message-pop-to-buffer (name) + (let* ((new (if (eq message-generate-new-buffers 'standard) + (generate-new-buffer-name (concat "*" type " message*")) + (let ((message-generate-new-buffers 'unique)) + (message-buffer-name type to group)))) + (regexp (concat "\\`" + (regexp-quote + (if (string-match "<[0-9]+>\\'" new) + (substring new 0 (match-beginning 0)) + new)) + "\\(?:<\\([0-9]+\\)>\\)?\\'")) + (case-fold-search nil)) + (or (cdar + (last + (sort + (delq nil + (mapcar + (lambda (b) + (when (and (string-match regexp (setq b (buffer-name b))) + (eq (with-current-buffer b major-mode) + 'message-mode)) + (cons (string-to-number (or (match-string 1 b) "1")) + b))) + (buffer-list))) + 'car-less-than-car))) + new))))) + +(defun message-pop-to-buffer (name &optional switch-function) "Pop to buffer NAME, and warn if it already exists and is modified." (let ((buffer (get-buffer name))) (if (and buffer (buffer-name buffer)) - (progn - (set-buffer (pop-to-buffer buffer)) + (let ((window (get-buffer-window buffer 0))) + (if window + ;; Raise the frame already displaying the message buffer. + (progn + (gnus-select-frame-set-input-focus (window-frame window)) + (select-window window)) + (funcall (or switch-function 'pop-to-buffer) buffer) + (set-buffer buffer)) (when (and (buffer-modified-p) - (not (y-or-n-p - "Message already being composed; erase? "))) + (not (prog1 + (y-or-n-p + "Message already being composed; erase? ") + (message nil)))) (error "Message being composed"))) - (set-buffer (pop-to-buffer name))) + (funcall (or switch-function 'pop-to-buffer) name) + (set-buffer name)) (erase-buffer) (message-mode))) @@ -5921,13 +6236,14 @@ between beginning of field and beginning of line." nil mua))) -(defun message-setup (headers &optional replybuffer actions switch-function) +;; YANK-ACTION, if non-nil, can be a buffer or a yank action of the +;; form (FUNCTION . ARGS). +(defun message-setup (headers &optional yank-action actions + continue switch-function) (let ((mua (message-mail-user-agent)) - subject to field yank-action) + subject to field) (if (not (and message-this-is-mail mua)) - (message-setup-1 headers replybuffer actions) - (if replybuffer - (setq yank-action (list 'insert-buffer replybuffer))) + (message-setup-1 headers yank-action actions) (setq headers (copy-sequence headers)) (setq field (assq 'Subject headers)) (when field @@ -5944,7 +6260,11 @@ between beginning of field and beginning of line." (format "%s" (car item)) (cdr item))) headers) - nil switch-function yank-action actions))))) + continue switch-function + (if (bufferp yank-action) + (list 'insert-buffer yank-action) + yank-action) + actions))))) (defun message-headers-to-generate (headers included-headers excluded-headers) "Return a list that includes all headers from HEADERS. @@ -5971,12 +6291,16 @@ are not included." (push header result))) (nreverse result))) -(defun message-setup-1 (headers &optional replybuffer actions) +(defun message-setup-1 (headers &optional yank-action actions) (dolist (action actions) (condition-case nil (add-to-list 'message-send-actions `(apply ',(car action) ',(cdr action))))) - (setq message-reply-buffer replybuffer) + (setq message-reply-buffer + (if (and (consp yank-action) + (eq (car yank-action) 'insert-buffer)) + (nth 1 yank-action) + yank-action)) (goto-char (point-min)) ;; Insert all the headers. (mail-header-format @@ -6021,11 +6345,12 @@ are not included." (save-restriction (message-narrow-to-headers) (run-hooks 'message-header-setup-hook)) - (set-buffer-modified-p nil) (setq buffer-undo-list nil) (when message-generate-hashcash ;; Generate hashcash headers for recipients already known (mail-add-payment-async)) + ;; Gnus posting styles are applied via buffer-local `message-setup-hook' + ;; values. (run-hooks 'message-setup-hook) ;; Do this last to give it precedence over posting styles, etc. (when (message-mail-p) @@ -6034,6 +6359,8 @@ are not included." (if message-alternative-emails (message-use-alternative-email-as-from)))) (message-position-point) + ;; Allow correct handling of `message-checksum' in `message-yank-original': + (set-buffer-modified-p nil) (undo-boundary)) (defun message-set-auto-save-file-name () @@ -6045,13 +6372,22 @@ are not included." (if (gnus-alive-p) (setq message-draft-article (nndraft-request-associate-buffer "drafts")) + + ;; If Gnus were alive, draft messages would be saved in the drafts folder. + ;; But Gnus is not alive, so arrange to save the draft message in a + ;; regular file in message-auto-save-directory. Append a unique + ;; time-based suffix to the filename to allow multiple drafts to be saved + ;; simultaneously without overwriting each other (which mimics the + ;; functionality of the Gnus drafts folder). (setq buffer-file-name (expand-file-name + (concat (if (memq system-type '(ms-dos ms-windows windows-nt cygwin cygwin32 win32 w32 mswindows)) "message" "*message*") + (format-time-string "-%Y%m%d-%H%M%S")) message-auto-save-directory)) (setq buffer-auto-save-file-name (make-auto-save-file-name))) (clear-visited-file-modtime) @@ -6091,20 +6427,26 @@ are not included." other-headers continue switch-function yank-action send-actions) "Start editing a mail message to be sent. -OTHER-HEADERS is an alist of header/value pairs." +OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether +to continue editing a message already being composed. SWITCH-FUNCTION +is a function used to switch to and display the mail buffer." (interactive) - (let ((message-this-is-mail t) replybuffer) + (let ((message-this-is-mail t)) (unless (message-mail-user-agent) - (message-pop-to-buffer (message-buffer-name "mail" to))) - ;; FIXME: message-mail should do something if YANK-ACTION is not - ;; insert-buffer. - (and (consp yank-action) (eq (car yank-action) 'insert-buffer) - (setq replybuffer (nth 1 yank-action))) + (message-pop-to-buffer + ;; Search for the existing message buffer if `continue' is non-nil. + (let ((message-generate-new-buffers + (when (or (not continue) + (eq message-generate-new-buffers 'standard) + (functionp message-generate-new-buffers)) + message-generate-new-buffers))) + (message-buffer-name "mail" to)) + switch-function)) (message-setup (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) (when other-headers other-headers)) - replybuffer send-actions) + yank-action send-actions continue switch-function) ;; FIXME: Should return nil if failure. t)) @@ -6117,6 +6459,29 @@ OTHER-HEADERS is an alist of header/value pairs." (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) +(defun message-alter-recipients-discard-bogus-full-name (addrcell) + "Discard mail address in full names. +When the full name in reply headers contains the mail +address (e.g. \"foo@bar \"), discard full name. +ADDRCELL is a cons cell where the car is the mail address and the +cdr is the complete address (full name and mail address)." + (if (string-match (concat (regexp-quote (car addrcell)) ".*" + (regexp-quote (car addrcell))) + (cdr addrcell)) + (cons (car addrcell) (car addrcell)) + addrcell)) + +(defcustom message-alter-recipients-function nil + "Function called to allow alteration of reply header structures. +It is called in `message-get-reply-headers' for each recipient. +The function is called with one parameter, a cons cell ..." + :type '(choice (const :tag "None" nil) + (const :tag "Discard bogus full name" + message-alter-recipients-discard-bogus-full-name) + function) + :version "23.1" ;; No Gnus + :group 'message-headers) + (defun message-get-reply-headers (wide &optional to-address address-headers) (let (follow-to mct never-mct to cc author mft recipients extra) ;; Find all relevant headers we need. @@ -6217,7 +6582,11 @@ want to get rid of this query permanently."))) (setq recipients (mapcar (lambda (addr) - (cons (downcase (mail-strip-quoted-names addr)) addr)) + (if message-alter-recipients-function + (funcall message-alter-recipients-function + (cons (downcase (mail-strip-quoted-names addr)) + addr)) + (cons (downcase (mail-strip-quoted-names addr)) addr))) (message-tokenize-header recipients))) ;; Remove first duplicates. (Why not all duplicates? Is this a bug?) (let ((s recipients)) @@ -6580,14 +6949,13 @@ header line with the old Message-ID." (interactive) (let ((file-name (make-auto-save-file-name))) (cond ((save-window-excursion - (if (not (eq system-type 'vax-vms)) - (with-output-to-temp-buffer "*Directory*" - (with-current-buffer standard-output - (fundamental-mode)) ; for Emacs 20.4+ - (buffer-disable-undo standard-output) - (let ((default-directory "/")) - (call-process - "ls" nil standard-output nil "-l" file-name)))) + (with-output-to-temp-buffer "*Directory*" + (with-current-buffer standard-output + (fundamental-mode)) ; for Emacs 20.4+ + (buffer-disable-undo standard-output) + (let ((default-directory "/")) + (call-process + "ls" nil standard-output nil "-l" file-name))) (yes-or-no-p (format "Recover auto save file %s? " file-name))) (let ((buffer-read-only nil)) (erase-buffer) @@ -6703,8 +7071,7 @@ the message." (setq subject (funcall func subject)))) subject)))) -(eval-when-compile - (defvar gnus-article-decoded-p)) +(defvar gnus-article-decoded-p) ;;;###autoload @@ -6759,8 +7126,8 @@ Optional DIGEST will use digest to forward." (message-remove-header elem t)))))) (defun message-forward-make-body-mime (forward-buffer) - (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") - (let ((b (point)) e) + (let ((b (point))) + (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") (save-restriction (narrow-to-region (point) (point)) (mml-insert-buffer forward-buffer) @@ -6768,8 +7135,11 @@ Optional DIGEST will use digest to forward." (when (looking-at "From ") (replace-match "X-From-Line: ")) (goto-char (point-max))) - (setq e (point)) - (insert "<#/part>\n"))) + (insert "<#/part>\n") + ;; Consider there is no illegible text. + (add-text-properties + b (point) + `(no-illegible-text t rear-nonsticky t start-open t)))) (defun message-forward-make-body-mml (forward-buffer) (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") @@ -6827,9 +7197,8 @@ Optional DIGEST will use digest to forward." (message-forward-make-body-digest-mime forward-buffer) (message-forward-make-body-digest-plain forward-buffer))) -(eval-and-compile - (autoload 'mm-uu-dissect-text-parts "mm-uu") - (autoload 'mm-uu-dissect "mm-uu")) +(autoload 'mm-uu-dissect-text-parts "mm-uu") +(autoload 'mm-uu-dissect "mm-uu") (defun message-signed-or-encrypted-p (&optional dont-emulate-mime handles) "Say whether the current buffer contains signed or encrypted message. @@ -6907,16 +7276,18 @@ is for the internal use." (message-forward-make-body-plain forward-buffer))) (message-position-point)) +(declare-function rmail-toggle-header "rmail" (&optional arg)) + ;;;###autoload (defun message-forward-rmail-make-body (forward-buffer) (save-window-excursion (set-buffer forward-buffer) (if (rmail-msg-is-pruned) - (rmail-msg-restore-non-pruned-header))) + (if (fboundp 'rmail-msg-restore-non-pruned-header) + (rmail-msg-restore-non-pruned-header) ; Emacs 22 + (rmail-toggle-header 0)))) ; Emacs 23 (message-forward-make-body forward-buffer)) -(eval-when-compile (defvar rmail-enable-mime-composing)) - ;; Fixme: Should have defcustom. ;;;###autoload (defun message-insinuate-rmail () @@ -7018,7 +7389,7 @@ you." (goto-char boundary) (when (re-search-backward "^.?From .*\n" nil t) (delete-region (match-beginning 0) (match-end 0))))) - (mm-enable-multibyte) + (mime-to-mml) (save-restriction (message-narrow-to-head-1) (message-remove-header message-ignored-bounced-headers t) @@ -7043,7 +7414,7 @@ you." (message-pop-to-buffer (message-buffer-name "mail" to)))) (let ((message-this-is-mail t)) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))) - nil nil 'switch-to-buffer-other-window))) + nil nil nil 'switch-to-buffer-other-window))) ;;;###autoload (defun message-mail-other-frame (&optional to subject) @@ -7058,7 +7429,7 @@ you." (message-pop-to-buffer (message-buffer-name "mail" to)))) (let ((message-this-is-mail t)) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))) - nil nil 'switch-to-buffer-other-frame))) + nil nil nil 'switch-to-buffer-other-frame))) ;;;###autoload (defun message-news-other-window (&optional newsgroups subject) @@ -7124,10 +7495,8 @@ which specify the range to operate on." (defun message-exchange-point-and-mark () "Exchange point and mark, but don't activate region if it was inactive." - (unless (prog1 - (message-mark-active-p) - (exchange-point-and-mark)) - (setq mark-active nil))) + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point))))) (defalias 'message-make-overlay 'make-overlay) (defalias 'message-delete-overlay 'delete-overlay) @@ -7138,8 +7507,7 @@ which specify the range to operate on." (mapcar #'delete-overlay (overlays-in (point-min) (point-max))))) ;; Support for toolbar -(eval-when-compile - (defvar tool-bar-mode)) +(defvar tool-bar-mode) ;; Note: The :set function in the `message-tool-bar*' variables will only ;; affect _new_ message buffers. We might add a function that walks thru all @@ -7168,7 +7536,7 @@ Pre-defined symbols include `message-tool-bar-gnome' and (const :tag "Retro look" message-tool-bar-retro) (repeat :tag "User defined list" gmm-tool-bar-item) (symbol)) - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) @@ -7197,14 +7565,14 @@ Pre-defined symbols include `message-tool-bar-gnome' and See `gmm-tool-bar-from-list' for details on the format of the list." :type '(repeat gmm-tool-bar-item) - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) (defcustom message-tool-bar-retro '(;; Old Emacs 21 icon for consistency. - (message-send-and-exit "gnus/mail_send") + (message-send-and-exit "gnus/mail-send") (message-kill-buffer "close") (message-dont-send "cancel") (mml-attach-file "attach" mml-mode-map) @@ -7217,7 +7585,7 @@ See `gmm-tool-bar-from-list' for details on the format of the list." See `gmm-tool-bar-from-list' for details on the format of the list." :type '(repeat gmm-tool-bar-item) - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) @@ -7230,7 +7598,7 @@ These items are not displayed on the message mode tool bar. See `gmm-tool-bar-from-list' for the format of the list." :type 'gmm-tool-bar-zap-list - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) @@ -7293,6 +7661,8 @@ If nil, the function bound in `text-mode-map' or `global-map' is executed." :type '(choice (const nil) function)) +(declare-function mail-abbrev-in-expansion-header-p "mailabbrev" ()) + (defun message-tab () "Complete names according to `message-completion-alist'. Execute function specified by `message-tab-body-function' when not in @@ -7331,37 +7701,44 @@ those headers." (point)) (skip-chars-backward "^, \t\n") (point)))) (completion-ignore-case t) - (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ") - (point)))) - (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) - (completions (all-completions string hashtb)) - comp) - (delete-region b (point)) - (cond - ((= (length completions) 1) - (if (string= (car completions) string) - (progn - (insert string) - (message "Only matching group")) - (insert (car completions)))) - ((and (setq comp (try-completion string hashtb)) - (not (string= comp string))) - (insert comp)) - (t - (insert string) - (if (not comp) - (message "No matching groups") - (save-selected-window - (pop-to-buffer "*Completions*") - (buffer-disable-undo) - (let ((buffer-read-only nil)) - (erase-buffer) - (let ((standard-output (current-buffer))) - (message-display-completion-list (sort completions 'string<) - string)) - (setq buffer-read-only nil) - (goto-char (point-min)) - (delete-region (point) (progn (forward-line 3) (point)))))))))) + (e (progn (skip-chars-forward "^,\t\n ") (point))) + (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))) + (message-completion-in-region e b hashtb))) + +(defalias 'message-completion-in-region + (if (fboundp 'completion-in-region) + 'completion-in-region + (lambda (e b hashtb) + (let* ((string (buffer-substring b e)) + (completions (all-completions string hashtb)) + comp) + (delete-region b (point)) + (cond + ((= (length completions) 1) + (if (string= (car completions) string) + (progn + (insert string) + (message "Only matching group")) + (insert (car completions)))) + ((and (setq comp (try-completion string hashtb)) + (not (string= comp string))) + (insert comp)) + (t + (insert string) + (if (not comp) + (message "No matching groups") + (save-selected-window + (pop-to-buffer "*Completions*") + (buffer-disable-undo) + (let ((buffer-read-only nil)) + (erase-buffer) + (let ((standard-output (current-buffer))) + (message-display-completion-list (sort completions 'string<) + string)) + (setq buffer-read-only nil) + (goto-char (point-min)) + (delete-region (point) + (progn (forward-line 3) (point)))))))))))) (defun message-expand-name () (cond ((and (memq 'eudc message-expand-name-databases) @@ -7383,11 +7760,10 @@ The following arguments may contain lists of values." (if (and show (setq text (message-flatten-list text))) (save-window-excursion - (save-excursion - (with-output-to-temp-buffer " *MESSAGE information message*" - (set-buffer " *MESSAGE information message*") + (with-output-to-temp-buffer " *MESSAGE information message*" + (with-current-buffer " *MESSAGE information message*" (fundamental-mode) ; for Emacs 20.4+ - (mapcar 'princ text) + (mapc 'princ text) (goto-char (point-min)))) (funcall ask question)) (funcall ask question))) @@ -7408,16 +7784,13 @@ Then clone the local variables and values from the old buffer to the new one, cloning only the locals having a substring matching the regexp VARSTR." (let ((oldbuf (current-buffer))) - (save-excursion - (set-buffer (generate-new-buffer name)) + (with-current-buffer (generate-new-buffer name) (message-clone-locals oldbuf varstr) (current-buffer)))) (defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." - (let ((locals (save-excursion - (set-buffer buffer) - (buffer-local-variables))) + (let ((locals (with-current-buffer buffer (buffer-local-variables))) (regexp "^gnus\\|^nn\\|^message\\|^sendmail\\|^smtp\\|^user-mail-address")) (mapcar (lambda (local) @@ -7554,7 +7927,7 @@ From headers in the original article." message-hidden-headers)) (inhibit-point-motion-hooks t) (after-change-functions nil) - (end-of-headers 0)) + (end-of-headers (point-min))) (when regexps (save-excursion (save-restriction @@ -7569,11 +7942,11 @@ From headers in the original article." (setq header (buffer-substring begin (point)) header-len (- (point) begin)) (delete-region begin (point)) - (goto-char (1+ end-of-headers)) + (goto-char end-of-headers) (insert header) (setq end-of-headers (+ end-of-headers header-len)))))))) - (narrow-to-region (1+ end-of-headers) (point-max)))) + (narrow-to-region end-of-headers (point-max)))) (defun message-hide-header-p (regexps) (let ((result nil) @@ -7589,7 +7962,7 @@ From headers in the original article." (defun message-put-addresses-in-ecomplete () (dolist (header '("to" "cc" "from" "reply-to")) - (let ((value (message-fetch-field header))) + (let ((value (message-field-value header))) (dolist (string (mail-header-parse-addresses value 'raw)) (setq string (gnus-replace-in-string @@ -7601,13 +7974,13 @@ From headers in the original article." (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) - (when (and (member (char-after (point-at-bol)) '(?C ?T ? )) + (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) (message-point-in-header-p) (save-excursion - (save-restriction - (message-narrow-to-field) - (goto-char (point-min)) - (looking-at "To\\|Cc")))) + (beginning-of-line) + (while (and (memq (char-after) '(?\t ? )) + (zerop (forward-line -1)))) + (looking-at "To:\\|Cc:"))) (let* ((end (point)) (start (save-excursion (and (re-search-backward "[\n\t ]" nil t) @@ -7620,6 +7993,148 @@ From headers in the original article." (delete-region start end) (insert match))))) +;; To send pre-formatted letters like the example below, you can use +;; `message-send-form-letter': +;; --8<---------------cut here---------------start------------->8--- +;; To: alice@invalid.invalid +;; Subject: Verification of your contact information +;; From: Contact verification +;; --text follows this line-- +;; Hi Alice, +;; please verify that your contact information is still valid: +;; Alice A, A avenue 11, 1111 A town, Austria +;; ----------next form letter message follows this line---------- +;; To: bob@invalid.invalid +;; Subject: Verification of your contact information +;; From: Contact verification +;; --text follows this line-- +;; Hi Bob, +;; please verify that your contact information is still valid: +;; Bob, B street 22, 22222 Be town, Belgium +;; ----------next form letter message follows this line---------- +;; To: charlie@invalid.invalid +;; Subject: Verification of your contact information +;; From: Contact verification +;; --text follows this line-- +;; Hi Charlie, +;; please verify that your contact information is still valid: +;; Charlie Chaplin, C plaza 33, 33333 C town, Chile +;; --8<---------------cut here---------------end--------------->8--- + +;; FIXME: What is the most common term (circular letter, form letter, serial +;; letter, standard letter) for such kind of letter? See also +;; + +;; FIXME: Maybe extent message-mode's font-lock support to recognize +;; `message-form-letter-separator', i.e. highlight each message like a single +;; message. + +(defcustom message-form-letter-separator + "\n----------next form letter message follows this line----------\n" + "Separator for `message-send-form-letter'." + ;; :group 'message-form-letter + :group 'message-various + :version "23.1" ;; No Gnus + :type 'string) + +(defcustom message-send-form-letter-delay 1 + "Delay in seconds when sending a message with `message-send-form-letter'. +Only used when `message-send-form-letter' is called with non-nil +argument `force'." + ;; :group 'message-form-letter + :group 'message-various + :version "23.1" ;; No Gnus + :type 'integer) + +(defun message-send-form-letter (&optional force) + "Sent all form letter messages from current buffer. +Unless FORCE, prompt before sending. + +The messages are separated by `message-form-letter-separator'. +Header and body are separated by `mail-header-separator'." + (interactive "P") + (let ((sent 0) (skipped 0) + start end text + buff + to done) + (goto-char (point-min)) + (while (not done) + (setq start (point) + end (if (search-forward message-form-letter-separator nil t) + (- (point) (length message-form-letter-separator) -1) + (setq done t) + (point-max))) + (setq text + (buffer-substring-no-properties start end)) + (setq buff (generate-new-buffer "*mail - form letter*")) + (with-current-buffer buff + (insert text) + (message-mode) + (setq to (message-fetch-field "To")) + (switch-to-buffer buff) + (when force + (sit-for message-send-form-letter-delay)) + (if (or force + (y-or-n-p (format "Send message to `%s'? " to))) + (progn + (setq sent (1+ sent)) + (message-send-and-exit)) + (message (format "Message to `%s' skipped." to)) + (setq skipped (1+ skipped))) + (when (buffer-live-p buff) + (kill-buffer buff)))) + (message "%s message(s) sent, %s skipped." sent skipped))) + +(defun message-replace-header (header new-value &optional after force) + "Remove HEADER and insert the NEW-VALUE. +If AFTER, insert after this header. If FORCE, insert new field +even if NEW-VALUE is empty." + ;; Similar to `nnheader-replace-header' but for message buffers. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-remove-header header)) + (when (or force (> (length new-value) 0)) + (if after + (message-position-on-field header after) + (message-position-on-field header)) + (insert new-value)))) + +(defcustom message-recipients-without-full-name + (list "ding@gnus.org" + "bugs@gnus.org" + "emacs-devel@gnu.org" + "emacs-pretest-bug@gnu.org" + "bug-gnu-emacs@gnu.org") + "Mail addresses that have no full name. +Used in `message-simplify-recipients'." + ;; Maybe the addresses could be extracted from + ;; `gnus-parameter-to-list-alist'? + :type '(choice (const :tag "None" nil) + (repeat string)) + :version "23.1" ;; No Gnus + :group 'message-headers) + +(defun message-simplify-recipients () + (interactive) + (dolist (hdr '("Cc" "To")) + (message-replace-header + hdr + (mapconcat + (lambda (addrcomp) + (if (and message-recipients-without-full-name + (string-match + (regexp-opt message-recipients-without-full-name) + (cadr addrcomp))) + (cadr addrcomp) + (if (car addrcomp) + (message-make-from (car addrcomp) (cadr addrcomp)) + (cadr addrcomp)))) + (when (message-fetch-field hdr) + (mail-extract-address-components + (message-fetch-field hdr) t)) + ", ")))) + (when (featurep 'xemacs) (require 'messagexmas) (message-xmas-redefine))