X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmessage.el;h=bd8bacaa1b8ed3ad41337c5eee204c495dddb686;hp=8bdd3d836c5dac6a0b0a3ba901efb149639f97ad;hb=718e9a83213d0a0ab2c6af366376a15db5f7efdb;hpb=bb3d57f547bdd5f29d36b7a506dec44ac8aea51e diff --git a/lisp/message.el b/lisp/message.el index 8bdd3d836..bd8bacaa1 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, 2008 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 3, 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: @@ -36,11 +34,12 @@ (eval-when-compile (require 'cl)) -(require 'hashcash) -(require 'canlock) (require 'mailheader) (require 'gmm-utils) -(require 'nnheader) +(require 'mail-utils) +;; Only for the trivial macros mail-header-from, mail-header-date +;; mail-header-references, mail-header-subject, mail-header-id +(eval-when-compile (require 'nnheader)) ;; This is apparently necessary even though things are autoloaded. ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better ;; require mailabbrev here. @@ -50,7 +49,6 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) -(require 'ecomplete) (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ @@ -162,6 +160,10 @@ If this variable is nil, no such courtesy message will be added." :type 'regexp) (defcustom message-from-style 'default + ;; In Emacs 24.1 this defaults to the value of `mail-from-style' + ;; that defaults to: + ;; `angles' in Emacs 22.1~23.1, XEmacs 21.4, 21.5, and SXEmacs 22.1; + ;; `default' in Emacs 23.2, and 24.1 "*Specifies how \"From\" headers look. If nil, they contain just the return address like: @@ -173,6 +175,7 @@ If `angles', they look like: Otherwise, most addresses look like `angles', but they look like `parens' if `angles' would need quoting and `parens' would not." + :version "23.2" :type '(choice (const :tag "simple" nil) (const parens) (const angles) @@ -248,6 +251,15 @@ included. Organization and User-Agent are optional." :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) +(defcustom message-prune-recipient-rules nil + "Rules for how to prune the list of recipients when doing wide replies. +This is a list of regexps and regexp matches." + :version "24.1" + :group 'message-mail + :group 'message-headers + :link '(custom-manual "(message)Wide Reply") + :type '(repeat regexp)) + (defcustom message-deletable-headers '(Message-ID Date Lines) "Headers to be deleted if they already exist and were generated by message previously." :group 'message-headers @@ -275,7 +287,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-ID:\\|^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:\\|^Injection-Date:\\|^Injection-Info:" "*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." @@ -415,9 +427,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,14 +448,27 @@ for `message-cross-post-insert-note'." :group 'message-various) (defcustom message-interactive t + ;; In Emacs 24.1 this defaults to the value of `mail-interactive' + ;; that defaults to: + ;; `nil' in Emacs 22.1~22.3, XEmacs 21.4, 21.5, and SXEmacs 22.1; + ;; `t' in Emacs 23.1~24.1 "Non-nil means when sending a message wait for and display errors. -nil means let mailer mail back a message to report errors." +A value of nil means let mailer mail back a message to report errors." + :version "23.2" + :group 'message-sending + :group 'message-mail + :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 +(defcustom message-generate-new-buffers 'unsent "*Say whether to create a new message buffer to compose a message. Valid values include: @@ -458,6 +491,7 @@ 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." + :version "24.1" :group 'message-buffers :link '(custom-manual "(message)Message Buffers") :type '(choice (const nil) @@ -561,7 +595,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") @@ -590,9 +630,13 @@ Done before generating the new subject of a forward." :type 'regexp) (defcustom message-cite-prefix-regexp + ;; In Emacs 24.1 this defaults to the value of + ;; `mail-citation-prefix-regexp'; the default value varies according + ;; to the Emacs version. In XEmacs 21.4 and 21.5, sendmail.el + ;; provides it. (if (string-match "[[:digit:]]" "1") ;; Support POSIX? XEmacs 21.5.27 doesn't. - "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|}]\\)+" + "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|]\\)+" ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. (let (non-word-constituents) (with-syntax-table text-mode-syntax-table @@ -601,12 +645,12 @@ Done before generating the new subject of a forward." (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" + :version "24.1" :group 'message-insertion :link '(custom-manual "(message)Insertion Variables") :type 'regexp @@ -623,8 +667,6 @@ 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) @@ -633,17 +675,21 @@ Done before generating the new subject of a forward." (executable-find sendmail-program)) 'message-send-mail-with-sendmail) ((and (locate-library "smtpmail") - (require 'smtpmail) + (boundp 'smtpmail-default-smtp-server) 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'"))))) + (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 (message-send-mail-function) +(defcustom message-send-mail-function + (cond ((eq send-mail-function 'smtpmail-send-it) 'message-smtpmail-send-it) + ((eq send-mail-function 'feedmail-send-it) 'feedmail-send-it) + ((eq send-mail-function 'mailclient-send-it) + 'message-send-mail-with-mailclient) + (t (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'. @@ -666,7 +712,7 @@ See also `send-mail-function'." :tag "Use Mailclient package") (function :tag "Other")) :group 'message-sending - :version "23.1" ;; No Gnus + :version "23.2" :initialize 'custom-initialize-default :link '(custom-manual "(message)Mail Variables") :group 'message-mail) @@ -796,10 +842,13 @@ Doing so would be even more evil than leaving it out." :type 'boolean) (defcustom message-sendmail-envelope-from nil + ;; In Emacs 24.1 this defaults to the value of `mail-envelope-from' + ;; if it is available, or defaults to nil. sendmail.el provides it; + ;; the default value is nil in all (X)Emacsen that Gnus supports. "*Envelope-from when sending mail with sendmail. If this is nil, use `user-mail-address'. If it is the symbol `header', use the From: header of the message." - :version "22.1" + :version "23.2" :type '(choice (string :tag "From name") (const :tag "Use From: header from message" header) (const :tag "Use `user-mail-address'" nil)) @@ -823,8 +872,8 @@ If this is nil, use `user-mail-address'. If it is the symbol (defcustom message-qmail-inject-args nil "Arguments passed to qmail-inject programs. -This should be a list of strings, one string for each argument. It -may also be a function. +This should be a list of strings, one string for each argument. +It may also be a function. For e.g., if you wish to set the envelope sender address so that bounces go to the right place or to deal with listserv's usage of that address, you @@ -973,9 +1022,14 @@ Please also read the note in the documentation of :group 'message-insertion) (defcustom message-yank-prefix "> " + ;; In Emacs 24.1 this defaults to the value of `mail-yank-prefix' + ;; that defaults to: + ;; `nil' in Emacs 22.1~23.1; + ;; "> " in Emacs 23.2, 24.1, XEmacs 21.4, 21.5, and SXEmacs 22.1 "*Prefix inserted on the lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. See also `message-yank-cited-prefix' and `message-yank-empty-prefix'." + :version "23.2" :type 'string :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) @@ -998,13 +1052,18 @@ See also `message-yank-prefix' and `message-yank-cited-prefix'." :group 'message-insertion) (defcustom message-indentation-spaces 3 + ;; In Emacs 24.1 this defaults to the value of + ;; `mail-indentation-spaces' that defaults to `3' in Emacs 22.1~24.1, + ;; and SXEmacs 22.1. In XEmacs 21.4 and 21.5, sendmail.el provides + ;; it; the defalut value is `3'. "*Number of spaces to insert at the beginning of each cited line. Used by `message-yank-original' via `message-yank-cite'." + :version "23.2" :group 'message-insertion :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'. @@ -1014,6 +1073,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 @@ -1026,20 +1086,30 @@ point and mark around the citation text as modified." :group 'message-insertion) (defcustom message-signature t + ;; In Emacs 24.1 this defaults to the value of `mail-signature' that + ;; defaults to: + ;; `nil' in Emacs 22.1~23.1, XEmacs 21.4, 21.5, and SXEmacs 22.1; + ;; `t' in Emacs 23.2, and 24.1 "*String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. If a function, the result from the function will be used instead. If a form, the result from the form will be used instead." + :version "23.2" :type 'sexp :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-signature-file "~/.signature" + ;; In Emacs 24.1 this defaults to the value of `mail-signature-file' + ;; that defaults to "~/.signature" in Emacs 22.1~24.1, and SXEmacs + ;; 22.1. In XEmacs 21.4 and 21.5, sendmail.el provides it; + ;; the defalut value is "~/.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 a path is specified, the value of `message-signature-directory' is ignored, even if set." + :version "23.2" :type '(choice file (const :tags "None" nil)) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) @@ -1085,6 +1155,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. @@ -1113,12 +1185,29 @@ It is a vector of the following headers: "*A string containing header lines to be inserted in outgoing messages. It is inserted before you edit the message, so you can edit or delete these lines." + :version "23.2" :group 'message-headers :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)) + ;; Use the value of `mail-default-headers' if available. + ;; Note: as for XEmacs 21.4 and 21.5, it is unavailable + ;; unless sendmail.el is loaded. + (if (boundp 'mail-default-headers) + mail-default-headers)) "*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") @@ -1202,7 +1291,7 @@ text and it replaces `self-insert-command' with the other command, e.g. :type '(repeat function)) (defcustom message-auto-save-directory - (file-name-as-directory (nnheader-concat message-directory "drafts")) + (file-name-as-directory (expand-file-name "drafts" message-directory)) "*Directory where Message auto-saves buffers if Gnus isn't running. If nil, Message won't auto-save." :group 'message-buffers @@ -1296,6 +1385,7 @@ 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) @@ -1310,6 +1400,7 @@ 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) @@ -1324,6 +1415,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) @@ -1338,6 +1430,7 @@ 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) @@ -1352,6 +1445,7 @@ 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) @@ -1366,6 +1460,7 @@ 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) @@ -1380,6 +1475,7 @@ 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) @@ -1394,6 +1490,7 @@ 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) @@ -1408,6 +1505,7 @@ 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) @@ -1422,6 +1520,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 @@ -1535,11 +1634,11 @@ If you'd like to make it possible to share draft files between XEmacs and Emacs, you may use `iso-2022-7bit' for this value at your own risk. Note that the coding-system `iso-2022-7bit' isn't suitable to all data.") -(defcustom message-send-mail-partially-limit 1000000 +(defcustom message-send-mail-partially-limit nil "The limitation of messages sent as message/partial. The lower bound of message size in characters, beyond which the message should be sent in several parts. If it is nil, the size is unlimited." - :version "21.1" + :version "24.1" :group 'message-buffers :link '(custom-manual "(message)Mail Variables") :type '(choice (const :tag "unlimited" nil) @@ -1631,13 +1730,14 @@ functionality to work." (const :tag "Never" nil) (const :tag "Always" t))) -(defcustom message-generate-hashcash (if (executable-find "hashcash") t) +(defcustom message-generate-hashcash (if (executable-find "hashcash") 'opportunistic) "*Whether to generate X-Hashcash: headers. 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). You must have the \"hashcash\" binary installed, see `hashcash-path'." + :version "24.1" :group 'message-headers :link '(custom-manual "(message)Mail Headers") :type '(choice (const :tag "Always" t) @@ -1654,6 +1754,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (defvar message-mime-part nil) (defvar message-posting-charset nil) (defvar message-inserted-headers nil) +(defvar message-inhibit-ecomplete nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -1779,33 +1880,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-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-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") @@ -1870,6 +1969,8 @@ is used by default." (setq paren nil)))) (nreverse elems))))) +(autoload 'nnheader-insert-file-contents "nnheader") + (defun message-mail-file-mbox-p (file) "Say whether FILE looks like a Unix mbox file." (when (and (file-exists-p file) @@ -1930,7 +2031,7 @@ 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)) (with-current-buffer message-reply-buffer ,@forms))) @@ -2375,6 +2476,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." @@ -2474,6 +2577,7 @@ Point is left at the beginning of the narrowed-to region." (autoload 'Info-goto-node "info") +(defvar mml2015-use) (defun message-info (&optional arg) "Display the Message manual. @@ -2482,10 +2586,15 @@ 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") + ;; 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) mml2015-use) + (cond ((eq arg 16) + (require 'mml2015) + mml2015-use) ((eq arg 4) 'emacs-mime) - ((and (not (booleanp arg)) + ;; `booleanp' only available in Emacs 22+ + ((and (not (memq arg '(nil t))) (symbolp arg)) arg) (t @@ -2691,7 +2800,7 @@ PGG manual, depending on the value of `mml2015-use'." ;;; 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 @@ -2755,6 +2864,8 @@ See also `message-forbidden-properties'." (inhibit-read-only t)) (remove-text-properties begin end message-forbidden-properties)))) +(autoload 'ecomplete-setup "ecomplete") ;; for Emacs <23. + ;;;###autoload (define-derived-mode message-mode text-mode "Message" "Major mode for editing mail and news to be sent. @@ -3104,7 +3215,7 @@ or in the synonym headers, defined by `message-header-synonyms'." "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) (with-current-buffer message-reply-buffer (message-get-reply-headers t))))) @@ -3157,7 +3268,7 @@ or in the synonym headers, defined by `message-header-synonyms'." (defun message-kill-to-signature (&optional arg) "Kill all text up to the signature. -If a numberic argument or prefix arg is given, leave that number +If a numeric argument or prefix arg is given, leave that number of lines before the signature intact." (interactive "P") (save-excursion @@ -3314,8 +3425,8 @@ Message buffers and is not meant to be called directly." ;; if message-signature-file contains a path. (not (file-name-directory message-signature-file))) - (nnheader-concat message-signature-directory - message-signature-file) + (expand-file-name message-signature-file + message-signature-directory) message-signature-file)) (file-exists-p signature-file)))) (when signature @@ -3599,9 +3710,16 @@ 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))) @@ -3786,9 +3904,8 @@ 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))) @@ -3945,6 +4062,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) @@ -3987,7 +4107,8 @@ It should typically alter the sending method in some way or other." (run-hooks 'message-sent-hook)) (message "Sending...done") ;; Do ecomplete address snarfing. - (when (message-mail-alias-type-p 'ecomplete) + (when (and (message-mail-alias-type-p 'ecomplete) + (not message-inhibit-ecomplete)) (message-put-addresses-in-ecomplete)) ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) @@ -4042,11 +4163,32 @@ not have PROP." (setq start next))) (nreverse regions))) -(defcustom message-bogus-address-regexp nil ;; "noreply\\|nospam\\|invalid" - "Regexp of potentially bogus mail addresses." +(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 'regexp) + :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." @@ -4091,6 +4233,8 @@ not have PROP." (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)))) @@ -4117,10 +4261,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))))) @@ -4132,7 +4279,7 @@ not have PROP." (forward-char) (skip-chars-forward mm-7bit-chars))))) (message-check 'bogus-recipient - ;; Warn before composing or sending a mail to an invalid address. + ;; Warn before sending a mail to an invalid address. (message-check-recipients))) (defun message-bogus-recipient-p (recipients) @@ -4141,9 +4288,9 @@ not have PROP." RECIPIENTS is a mail header. Return a list of potentially bogus addresses. If none is found, return nil. -An addresses might be bogus if the domain part is not fully -qualified, see `message-valid-fqdn-regexp', or if it matches -`message-bogus-address-regexp'." +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) @@ -4155,9 +4302,15 @@ qualified, see `message-valid-fqdn-regexp', or if it matches (string-match (concat ".@.*\\(" message-valid-fqdn-regexp "\\)\\'") address))) - (and (stringp message-bogus-address-regexp) - (string-match message-bogus-address-regexp address))) - (push address found))) + (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)) @@ -4177,7 +4330,9 @@ This function could be useful in `message-setup-hook'." (not (y-or-n-p (format "Address `%s' might be bogus. Continue? " bog))) - (error "Bogus address.")))))))) + (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." @@ -4268,14 +4423,15 @@ This function could be useful in `message-setup-hook'." (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))) (kill-buffer tembuf)))) +(declare-function hashcash-wait-async "hashcash" (&optional buffer)) + (defun message-send-mail (&optional arg) (require 'mail-utils) (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) @@ -4283,14 +4439,26 @@ This function could be useful in `message-setup-hook'." (news (message-news-p)) (mailbuf (current-buffer)) (message-this-is-mail t) + ;; gnus-setup-posting-charset is autoloaded in mml.el (FIXME + ;; maybe it should not be), which this file requires. Hence + ;; the fboundp test is always true. Loading it from gnus-msg + ;; loads many Gnus files (Bug#5642). If + ;; gnus-group-posting-charset-alist hasn't been customized, + ;; this is just going to return nil anyway. FIXME it would + ;; be good to improve this further, because even if g-g-p-c-a + ;; has been customized, that is likely to just be for news. + ;; Eg either move the definition from gnus-msg, or separate out + ;; the mail and news parts. (message-posting-charset - (if (fboundp 'gnus-setup-posting-charset) + (if (and (fboundp 'gnus-setup-posting-charset) + (boundp 'gnus-group-posting-charset-alist)) (gnus-setup-posting-charset nil) message-posting-charset)) (headers message-required-mail-headers)) (when (and message-generate-hashcash (not (eq message-generate-hashcash 'opportunistic))) (message "Generating hashcash...") + (require 'hashcash) ;; Wait for calculations already started to finish... (hashcash-wait-async) ;; ...and do calculations not already done. mail-add-payment @@ -4372,6 +4540,11 @@ This function could be useful in `message-setup-hook'." (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 @@ -4396,7 +4569,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))) @@ -4407,6 +4580,7 @@ If you always want Gnus to send messages in one piece, set (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." + (require 'sendmail) (let ((errbuf (if message-interactive (message-generate-new-buffer-clone-locals " sendmail errors") @@ -4455,8 +4629,8 @@ If you always want Gnus to send messages in one piece, set ;; since some systems have broken sendmails. ;; But some systems are more broken with -f, so ;; we'll let users override this. - (if (null message-sendmail-f-is-evil) - (list "-f" (message-sendmail-envelope-from))) + (and (null message-sendmail-f-is-evil) + (list "-f" (message-sendmail-envelope-from))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -4469,6 +4643,7 @@ 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 (with-current-buffer errbuf @@ -4497,7 +4672,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. ;; @@ -4545,17 +4720,17 @@ 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'. -This only differs from `smtpmail-send-it' that this command evaluates -`message-send-mail-hook' just before sending a message." +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)) @@ -4569,10 +4744,14 @@ Do not use this for anything important, it is cryptographically weak." (prin1-to-string (recent-keys)) (prin1-to-string (garbage-collect)))))) +(defvar canlock-password) +(defvar canlock-password-for-verify) + (defun message-canlock-password () "The password used by message for cancel locks. This is the value of `canlock-password', if that option is non-nil. Otherwise, generate and save a value for `canlock-password' first." + (require 'canlock) (unless canlock-password (customize-save-variable 'canlock-password (message-canlock-generate)) (setq canlock-password-for-verify canlock-password)) @@ -4583,7 +4762,12 @@ Otherwise, generate and save a value for `canlock-password' first." (message-canlock-password) (canlock-insert-header))) +(autoload 'nnheader-get-report "nnheader") + +(declare-function gnus-setup-posting-charset "gnus-msg" (group)) + (defun message-send-news (&optional arg) + (require 'gnus-msg) (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) (method (if (functionp message-post-method) @@ -4961,7 +5145,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) @@ -5057,13 +5242,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)) @@ -5142,6 +5338,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)) @@ -5150,8 +5353,14 @@ Otherwise, generate and save a value for `canlock-password' first." (defun message-output (filename) "Append this article to Unix/babyl mail file FILENAME." - (if (and (file-readable-p filename) - (mail-file-babyl-p filename)) + (if (or (and (file-readable-p filename) + (mail-file-babyl-p filename)) + ;; gnus-output-to-mail does the wrong thing with live, mbox + ;; Rmail buffers in Emacs 23. + ;; http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=597255 + (let ((buff (find-buffer-visiting filename))) + (and buff (with-current-buffer buff + (eq major-mode 'rmail-mode))))) (gnus-output-to-rmail filename t) (gnus-output-to-mail filename t))) @@ -5245,7 +5454,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 (eq system-type 'ms-dos) ;; message-number-base36 doesn't handle bigints. (floatp (user-uid))) (let ((user (downcase (user-login-name)))) @@ -5303,7 +5512,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (defun message-make-references () "Return the References header for this message." (when message-reply-headers - (let ((message-id (mail-header-message-id message-reply-headers)) + (let ((message-id (mail-header-id message-reply-headers)) (references (mail-header-references message-reply-headers))) (if (or references message-id) (concat (or references "") (and references " ") @@ -5315,7 +5524,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (when message-reply-headers (let ((from (mail-header-from message-reply-headers)) (date (mail-header-date message-reply-headers)) - (msg-id (mail-header-message-id message-reply-headers))) + (msg-id (mail-header-id message-reply-headers))) (when from (let ((name (mail-extract-address-components from))) (concat @@ -5325,19 +5534,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 \"" @@ -5572,8 +5780,11 @@ 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 (if (string-match "\\`[[: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)) @@ -5595,7 +5806,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") @@ -5711,6 +5928,7 @@ Headers already prepared in the buffer are not modified." (if formatter (funcall formatter header value) (insert header-string ": " value)) + (push header-string message-inserted-headers) (goto-char (message-fill-field)) ;; We check whether the value was ended by a ;; newline. If not, we insert one. @@ -5882,8 +6100,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))) @@ -6106,14 +6326,14 @@ between beginning of field and beginning of line." nil mua))) -(defun message-setup (headers &optional replybuffer actions +;; 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 @@ -6130,7 +6350,11 @@ between beginning of field and beginning of line." (format "%s" (car item)) (cdr item))) headers) - continue 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. @@ -6157,12 +6381,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 @@ -6207,11 +6435,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) @@ -6220,6 +6449,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 () @@ -6231,13 +6462,20 @@ 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)) + '(ms-dos windows-nt cygwin)) "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) @@ -6247,7 +6485,7 @@ are not included." "Disassociate the message buffer from the drafts directory." (when message-draft-article (nndraft-request-expire-articles - (list message-draft-article) "nndraft:drafts" nil t))) + (list message-draft-article) "drafts" nil t))) (defun message-insert-headers () "Generate the headers for the article." @@ -6281,7 +6519,7 @@ 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 ;; Search for the existing message buffer if `continue' is non-nil. @@ -6292,15 +6530,11 @@ is a function used to switch to and display the mail buffer." message-generate-new-buffers))) (message-buffer-name "mail" to)) switch-function)) - ;; 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-setup (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) (when other-headers other-headers)) - replybuffer send-actions continue switch-function) + yank-action send-actions continue switch-function) ;; FIXME: Should return nil if failure. t)) @@ -6313,9 +6547,32 @@ is a function used to switch to and display the mail buffer." (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. + ;; Find all relevant headers we need. (save-restriction (message-narrow-to-headers-or-head) ;; Gmane renames "To". Look at "Original-To", too, if it is present in @@ -6413,7 +6670,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)) @@ -6437,6 +6698,8 @@ want to get rid of this query permanently."))) (if recip (setq recipients (delq recip recipients)))))))) + (setq recipients (message-prune-recipients recipients)) + ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. (setq follow-to (list (cons 'To (cdr (pop recipients))))) @@ -6450,6 +6713,22 @@ want to get rid of this query permanently."))) (push (cons 'Cc recipients) follow-to))) follow-to)) +(defun message-prune-recipients (recipients) + (dolist (rule message-prune-recipient-rules) + (let ((match (car rule)) + dup-match + address) + (dolist (recipient recipients) + (setq address (car recipient)) + (when (string-match match address) + (setq dup-match (replace-match (cadr rule) nil nil address)) + (dolist (recipient recipients) + ;; Don't delete the address that triggered this. + (when (and (not (eq address (car recipient))) + (string-match dup-match (car recipient))) + (setq recipients (delq recipient recipients)))))))) + recipients) + (defcustom message-simplify-subject-functions '(message-strip-list-identifiers message-strip-subject-re @@ -6776,14 +7055,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) @@ -6922,22 +7200,28 @@ Optional DIGEST will use digest to forward." (defun message-forward-make-body-plain (forward-buffer) (insert "\n-------------------- Start of forwarded message --------------------\n") - (let ((b (point)) e) - (insert - (with-temp-buffer - (mm-disable-multibyte) - (insert - (with-current-buffer forward-buffer - (mm-with-unibyte-current-buffer (buffer-string)))) - (mm-enable-multibyte) - (mime-to-mml) - (goto-char (point-min)) - (when (looking-at "From ") - (replace-match "X-From-Line: ")) - (buffer-string))) + (let ((b (point)) + (contents (with-current-buffer forward-buffer (buffer-string))) + e) + (unless (featurep 'xemacs) + (unless (mm-multibyte-string-p contents) + (error "Attempt to insert unibyte string from the buffer \"%s\"\ + to the multibyte buffer \"%s\"" + (if (bufferp forward-buffer) + (buffer-name forward-buffer) + forward-buffer) + (buffer-name)))) + (insert (mm-with-multibyte-buffer + (insert contents) + (mime-to-mml) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (buffer-string))) + (unless (bolp) (insert "\n")) (setq e (point)) (insert - "\n-------------------- End of forwarded message --------------------\n") + "-------------------- End of forwarded message --------------------\n") (message-remove-ignored-headers b e))) (defun message-remove-ignored-headers (b e) @@ -6973,18 +7257,22 @@ Optional DIGEST will use digest to forward." (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") (let ((b (point)) e) (if (not message-forward-decoded-p) - (insert - (with-temp-buffer - (mm-disable-multibyte) - (insert - (with-current-buffer forward-buffer - (mm-with-unibyte-current-buffer (buffer-string)))) - (mm-enable-multibyte) - (mime-to-mml) - (goto-char (point-min)) - (when (looking-at "From ") - (replace-match "X-From-Line: ")) - (buffer-string))) + (let ((contents (with-current-buffer forward-buffer (buffer-string)))) + (unless (featurep 'xemacs) + (unless (mm-multibyte-string-p contents) + (error "Attempt to insert unibyte string from the buffer \"%s\"\ + to the multibyte buffer \"%s\"" + (if (bufferp forward-buffer) + (buffer-name forward-buffer) + forward-buffer) + (buffer-name)))) + (insert (mm-with-multibyte-buffer + (insert contents) + (mime-to-mml) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (buffer-string)))) (save-restriction (narrow-to-region (point) (point)) (mml-insert-buffer forward-buffer) @@ -7025,9 +7313,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. @@ -7105,12 +7392,16 @@ 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)) ;; Fixme: Should have defcustom. @@ -7173,6 +7464,7 @@ is for the internal use." (replace-match "X-From-Line: ")) ;; Send it. (let ((message-inhibit-body-encoding t) + (message-inhibit-ecomplete t) message-required-mail-headers message-generate-hashcash rfc2047-encode-encoded-words) @@ -7320,10 +7612,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) @@ -7528,37 +7818,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) @@ -7780,7 +8077,11 @@ From headers in the original article." (not result) result))) +(declare-function ecomplete-add-item "ecomplete" (type key text)) +(declare-function ecomplete-save "ecomplete" ()) + (defun message-put-addresses-in-ecomplete () + (require 'ecomplete) (dolist (header '("to" "cc" "from" "reply-to")) (let ((value (message-field-value header))) (dolist (string (mail-header-parse-addresses value 'raw)) @@ -7791,6 +8092,8 @@ From headers in the original article." string)))) (ecomplete-save)) +(autoload 'ecomplete-display-matches "ecomplete") + (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) @@ -7905,6 +8208,56 @@ Header and body are separated by `mail-header-separator'." (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)) @@ -7917,5 +8270,4 @@ Header and body are separated by `mail-header-separator'." ;; coding: iso-8859-1 ;; End: -;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0 ;;; message.el ends here