X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=0a38ec028c1dfc62c1411e64f4ba4e1580dede0e;hb=4303c5c768c35022c9eda800cacfa401946e144b;hp=827016440a04ad5b3c1a17f37c62c1ed616a3a5a;hpb=cfc32f0dd120826f6d92181350d0b23100c0f9f2;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 827016440..0a38ec028 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 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008 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', @@ -208,7 +213,7 @@ Also see `message-required-news-headers' and :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) -(defcustom message-draft-headers '(References From) +(defcustom message-draft-headers '(References From Date) "*Headers to be generated when saving a draft message." :version "22.1" :group 'message-news @@ -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) @@ -429,16 +442,36 @@ nil means let mailer mail back a message to report errors." :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 +482,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 +567,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,26 +602,32 @@ 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 :link '(custom-manual "(message)Insertion Variables") - :type 'regexp) + :type 'regexp + :set (lambda (symbol value) + (prog1 + (custom-set-default symbol value) + (if (boundp 'gnus-message-cite-prefix-regexp) + (setq gnus-message-cite-prefix-regexp + (concat "^\\(?:" value "\\)")))))) (defcustom message-cancel-message "I am canceling my own article.\n" "Message to be inserted in the cancel message." @@ -591,28 +635,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) @@ -621,8 +674,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) @@ -761,6 +818,14 @@ If this is nil, use `user-mail-address'. If it is the symbol :link '(custom-manual "(message)Mail Variables") :group 'message-sending) +(defcustom message-sendmail-extra-arguments nil + "Additional arguments to `sendmail-program'." + ;; E.g. '("-a" "account") for msmtp + :version "23.1" ;; No Gnus + :type '(repeat string) + ;; :link '(custom-manual "(message)Mail Variables") + :group 'message-sending) + ;; qmail-related stuff (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" "Location of the qmail-inject program." @@ -781,9 +846,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) @@ -817,9 +881,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. @@ -870,7 +943,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 @@ -879,12 +952,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 @@ -908,7 +981,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 "> " @@ -943,7 +1016,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'. @@ -953,6 +1026,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 @@ -976,11 +1050,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" @@ -1066,8 +1152,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)) @@ -1149,7 +1234,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 @@ -1158,18 +1243,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. @@ -1181,7 +1256,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)) @@ -1224,7 +1299,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)) @@ -1238,7 +1313,7 @@ starting with `not' and followed by regexps." (defface message-header-cc '((((class color) (background dark)) - (:foreground "green4" :bold t)) + (:foreground "chartreuse1" :bold t)) (((class color) (background light)) (:foreground "MidnightBlue")) @@ -1252,7 +1327,7 @@ starting with `not' and followed by regexps." (defface message-header-subject '((((class color) (background dark)) - (:foreground "green3")) + (:foreground "OliveDrab1")) (((class color) (background light)) (:foreground "navy blue" :bold t)) @@ -1280,7 +1355,7 @@ starting with `not' and followed by regexps." (defface message-header-other '((((class color) (background dark)) - (:foreground "#b00000")) + (:foreground "VioletRed1")) (((class color) (background light)) (:foreground "steel blue")) @@ -1294,7 +1369,7 @@ starting with `not' and followed by regexps." (defface message-header-name '((((class color) (background dark)) - (:foreground "DarkGreen")) + (:foreground "green")) (((class color) (background light)) (:foreground "cornflower blue")) @@ -1308,7 +1383,7 @@ starting with `not' and followed by regexps." (defface message-header-xheader '((((class color) (background dark)) - (:foreground "blue")) + (:foreground "DeepSkyBlue1")) (((class color) (background light)) (:foreground "blue")) @@ -1322,7 +1397,7 @@ starting with `not' and followed by regexps." (defface message-separator '((((class color) (background dark)) - (:foreground "blue3")) + (:foreground "LightSkyBlue1")) (((class color) (background light)) (:foreground "brown")) @@ -1336,7 +1411,7 @@ starting with `not' and followed by regexps." (defface message-cited-text '((((class color) (background dark)) - (:foreground "red")) + (:foreground "LightPink1")) (((class color) (background light)) (:foreground "red")) @@ -1350,7 +1425,7 @@ starting with `not' and followed by regexps." (defface message-mml '((((class color) (background dark)) - (:foreground "ForestGreen")) + (:foreground "MediumSpringGreen")) (((class color) (background light)) (:foreground "ForestGreen")) @@ -1398,13 +1473,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) "\\)$") @@ -1571,10 +1646,16 @@ 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', +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'." :group 'message-headers :link '(custom-manual "(message)Mail Headers") - :type 'boolean) + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Opportunistic" opportunistic))) ;;; Internal variables. @@ -1588,9 +1669,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 @@ -1655,6 +1735,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.") @@ -1689,7 +1770,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (defvar message-send-mail-real-function nil "Internal send mail function.") -(defvar message-bogus-system-names "^localhost\\." +(defvar message-bogus-system-names "^localhost\\.\\|\\.local$" "The regexp of bogus system names.") (defcustom message-valid-fqdn-regexp @@ -1711,32 +1792,32 @@ 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-msg-restore-non-pruned-header "rmail") +(autoload 'rmail-output "rmailout") @@ -1863,8 +1944,7 @@ see `message-narrow-to-headers-or-head'." "Evaluate FORMS in the reply buffer, if it exists." `(when (and 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) @@ -1898,6 +1978,96 @@ see `message-narrow-to-headers-or-head'." (substring subject (match-end 0)) subject)) +(defcustom message-replacement-char "." + "Replacement character used instead of unprintable or not decodable chars." + :group 'message-various + :version "22.1" ;; Gnus 5.10.9 + :type '(choice string + (const ".") + (const "?"))) + +;; FIXME: We also should call `message-strip-subject-encoded-words' +;; when forwarding. Probably in `message-make-forward-subject' and +;; `message-forward-make-body'. + +(defun message-strip-subject-encoded-words (subject) + "Fix non-decodable words in SUBJECT." + ;; Cf. `gnus-simplify-subject-fully'. + (let* ((case-fold-search t) + (replacement-chars (format "[%s%s%s]" + message-replacement-char + message-replacement-char + message-replacement-char)) + (enc-word-re "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?\\([^?]+\\)\\(\\?=\\)") + cs-string + (have-marker + (with-temp-buffer + (insert subject) + (goto-char (point-min)) + (when (re-search-forward enc-word-re nil t) + (setq cs-string (match-string 1))))) + cs-coding q-or-b word-beg word-end) + (if (or (not have-marker) ;; No encoded word found... + ;; ... or double encoding was correct: + (and (stringp cs-string) + (setq cs-string (downcase cs-string)) + (mm-coding-system-p (intern cs-string)) + (not (prog1 + (y-or-n-p + (format "\ +Decoded Subject \"%s\" +contains a valid encoded word. Decode again? " + subject)) + (setq cs-coding (intern cs-string)))))) + subject + (with-temp-buffer + (insert subject) + (goto-char (point-min)) + (while (re-search-forward enc-word-re nil t) + (setq cs-string (downcase (match-string 1)) + q-or-b (match-string 2) + word-beg (match-beginning 0) + word-end (match-end 0)) + (setq cs-coding + (if (mm-coding-system-p (intern cs-string)) + (setq cs-coding (intern cs-string)) + nil)) + ;; No double encoded subject? => bogus charset. + (unless cs-coding + (setq cs-coding + (mm-read-coding-system + (format "\ +Decoded Subject \"%s\" +contains an encoded word. The charset `%s' is unknown or invalid. +Hit RET to replace non-decodable characters with \"%s\" or enter replacement +charset: " + subject cs-string message-replacement-char))) + (if cs-coding + (replace-match (concat "=?" (symbol-name cs-coding) + "?\\2?\\3\\4\\5")) + (save-excursion + (goto-char word-beg) + (re-search-forward "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?" word-end t) + (replace-match "") + ;; QP or base64 + (if (string-match "\\`Q\\'" q-or-b) + ;; QP + (progn + (message "Replacing non-decodable characters with \"%s\"." + message-replacement-char) + (while (re-search-forward "\\(=[A-F0-9][A-F0-9]\\)+" + word-end t) + (replace-match message-replacement-char))) + ;; base64 + (message "Replacing non-decodable characters with \"%s\"." + replacement-chars) + (re-search-forward "[^?]+" word-end t) + (replace-match replacement-chars)) + (re-search-forward "\\?=") + (replace-match ""))))) + (rfc2047-decode-region (point-min) (point-max)) + (buffer-string))))) + ;;; Start of functions adopted from `message-utils.el'. (defun message-strip-subject-trailing-was (subject) @@ -2228,14 +2398,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 () @@ -2317,15 +2485,28 @@ 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")))) + ;; Why not `info', which is in loaddefs.el? + (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))))) @@ -2521,9 +2702,8 @@ 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 ;; @@ -2604,7 +2784,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 @@ -2656,6 +2836,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 @@ -2733,6 +2916,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))) @@ -2872,11 +3057,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 @@ -2916,21 +3101,21 @@ 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." @@ -2938,8 +3123,7 @@ or in the synonym headers, defined by `message-header-synonyms'." (let ((follow-to (and 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 @@ -3136,13 +3320,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. @@ -3152,7 +3344,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"))))) @@ -3183,8 +3375,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) @@ -3257,17 +3448,17 @@ text was killed." (substring table ?a (+ ?a n)) (substring table (+ ?a 26) 255)))) -(defun message-caesar-buffer-body (&optional rotnum) +(defun message-caesar-buffer-body (&optional rotnum wide) "Caesar rotate all letters in the current buffer by 13 places. Used to encode/decode possibly offensive messages (commonly in rec.humor). With prefix arg, specifies the number of places to rotate each letter forward. -Mail and USENET news headers are not rotated." +Mail and USENET news headers are not rotated unless WIDE is non-nil." (interactive (if current-prefix-arg (list (prefix-numeric-value current-prefix-arg)) (list nil))) (save-excursion (save-restriction - (when (message-goto-body) + (when (and (not wide) (message-goto-body)) (narrow-to-region (point) (point-max))) (message-caesar-region (point-min) (point-max) rotnum)))) @@ -3366,6 +3557,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. @@ -3407,19 +3619,23 @@ Really top post? "))) (delete-windows-on message-reply-buffer t) (push-mark (save-excursion (insert-buffer-substring 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)))))) @@ -3433,7 +3649,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) @@ -3441,8 +3657,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 @@ -3470,7 +3684,7 @@ This function uses `mail-citation-hook' if that is non-nil." (setq x-no-archive (message-fetch-field "x-no-archive")) (vector 0 (or (message-fetch-field "subject") "none") - (message-fetch-field "from") + (or (message-fetch-field "from") "nobody") (message-fetch-field "date") (message-fetch-field "message-id" t) (message-fetch-field "references") @@ -3509,14 +3723,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)) @@ -3540,7 +3758,7 @@ See `message-citation-line-format'." date ;; We need Gnus functionality if the user wants date or time from ;; the original article: - (when (string-match "%[^EFLn]" message-citation-line-format) + (when (string-match "%[^fnNFL]" message-citation-line-format) (autoload 'gnus-date-get-time "gnus-util") (gnus-date-get-time (mail-header-date message-reply-headers))))) (flist @@ -3560,19 +3778,19 @@ See `message-citation-line-format'." (setq fname name lname "")))) ;; The following letters are not used in `format-time-string': - (push ?E lst) (push net lst) + (push ?E lst) (push "" lst) (push ?F lst) (push fname lst) ;; We might want to use "" instead of "" later. (push ?J lst) (push "" lst) (push ?K lst) (push "" lst) (push ?L lst) (push lname lst) - (push ?N lst) (push "" lst) + (push ?N lst) (push name-or-net lst) (push ?O lst) (push "" lst) (push ?P lst) (push "

" lst) (push ?Q lst) (push "" lst) - (push ?f lst) (push "" lst) + (push ?f lst) (push from lst) (push ?i lst) (push "" lst) - (push ?n lst) (push name-or-net lst) + (push ?n lst) (push net lst) (push ?o lst) (push "" lst) (push ?q lst) (push "" lst) (push ?t lst) (push "" lst) @@ -3593,7 +3811,6 @@ See `message-citation-line-format'." (reverse lst))) (spec (apply 'format-spec-make flist))) (insert (format-spec message-citation-line-format spec))) - (newline) (newline))) (defun message-cite-original-without-signature () @@ -3842,6 +4059,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. @@ -3870,29 +4114,36 @@ 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 + 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 "Non-printable characters found. Continue sending?" - '((?d "Remove non-printable characters and send") - (?r "Replace non-printable characters with dots and send") + `((?d "Remove non-printable characters and send") + (?r ,(format + "Replace non-printable characters with \"%s\" and send" + message-replacement-char)) (?i "Ignore non-printable characters and send") (?e "Continue editing")))) (if (eq choice ?e) @@ -3915,9 +4166,64 @@ not have PROP." (message-kill-all-overlays) (delete-char 1) (when (eq choice ?r) - (insert ".")))) + (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." @@ -4028,7 +4334,8 @@ not have PROP." (gnus-setup-posting-charset nil) message-posting-charset)) (headers message-required-mail-headers)) - (when message-generate-hashcash + (when (and message-generate-hashcash + (not (eq message-generate-hashcash 'opportunistic))) (message "Generating hashcash...") ;; Wait for calculations already started to finish... (hashcash-wait-async) @@ -4065,8 +4372,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 @@ -4180,10 +4486,17 @@ If you always want Gnus to send messages in one piece, set 'call-process-region (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") + (cond ((boundp 'sendmail-program) + sendmail-program) + ((file-exists-p "/usr/sbin/sendmail") + "/usr/sbin/sendmail") + ((file-exists-p "/usr/lib/sendmail") + "/usr/lib/sendmail") + ((file-exists-p "/usr/ucblib/sendmail") + "/usr/ucblib/sendmail") + (t "fakemail")) nil errbuf nil "-oi") + message-sendmail-extra-arguments ;; Always specify who from, ;; since some systems have broken sendmails. ;; But some systems are more broken with -f, so @@ -4204,8 +4517,7 @@ If you always want Gnus to send messages in one piece, set (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) (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 "; ")) @@ -4231,7 +4543,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. ;; @@ -4248,9 +4560,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) @@ -4286,6 +4598,13 @@ 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." + (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." @@ -4368,8 +4687,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). @@ -4761,7 +5079,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? ") @@ -4786,12 +5104,16 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Check the length of the signature. (message-check 'signature (goto-char (point-max)) - (if (> (count-lines (point) (point-max)) 5) - (y-or-n-p - (format - "Your .sig is %d lines; it should be max 4. Really post? " - (1- (count-lines (point) (point-max))))) - t)) + (if (not (re-search-backward message-signature-separator nil t)) + t + (if (>= (count-lines (1+ (point-at-eol)) (point-max)) 5) + (if (message-gnksa-enable-p 'signature) + (y-or-n-p + (format "Signature is excessively long (%d lines). Really post? " + (count-lines (1+ (point-at-eol)) (point-max)))) + (message "Denied posting -- Excessive signature.") + nil) + t))) ;; Ensure that text follows last quoted portion. (message-check 'quoting-style (goto-char (point-max)) @@ -5032,8 +5354,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 "")) @@ -5047,13 +5368,31 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (msg-id (mail-header-message-id message-reply-headers))) (when from (let ((name (mail-extract-address-components from))) - (concat msg-id (if msg-id " (") - (or (car name) - (nth 1 name)) - "'s message of \"" - (if (or (not date) (string= date "")) - "(unknown date)" date) - "\"" (if msg-id ")"))))))) + (concat + msg-id (if msg-id " (") + (if (car name) + (if (string-match "[^\000-\177]" (car name)) + ;; Quote a string containing non-ASCII characters. + ;; It will make the RFC2047 encoder cause an error + ;; if there are special characters. + (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 \"" + (if (or (not date) (string= date "")) + "(unknown date)" date) + "\"" (if msg-id ")"))))))) (defun message-make-distribution () "Make a Distribution header." @@ -5081,14 +5420,14 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (concat message-user-path "!" login-name)) (t login-name)))) -(defun message-make-from () +(defun message-make-from (&optional name address) "Make a From header." (let* ((style message-from-style) - (login (message-make-address)) - (fullname - (or (and (boundp 'user-full-name) - user-full-name) - (user-full-name)))) + (login (or address (message-make-address))) + (fullname (or name + (and (boundp 'user-full-name) + user-full-name) + (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) (with-temp-buffer @@ -5109,15 +5448,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 " (") @@ -5183,8 +5522,8 @@ give as trustworthy answer as possible." (stringp message-user-fqdn) (string-match message-valid-fqdn-regexp message-user-fqdn) (not (string-match message-bogus-system-names message-user-fqdn))) + ;; `message-user-fqdn' seems to be valid message-user-fqdn) - ;; `message-user-fqdn' seems to be valid ((and (string-match message-valid-fqdn-regexp system-name) (not (string-match message-bogus-system-names system-name))) ;; `system-name' returned the right result. @@ -5262,8 +5601,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) @@ -5284,7 +5622,9 @@ subscribed address (and not the additional To and Cc header contents)." (mapcar 'downcase (mapcar 'car (mail-header-parse-addresses field)))))) - (setq ace (downcase (idna-to-ascii rhs))) + (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:? " @@ -5591,8 +5931,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))) @@ -5668,7 +6010,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)) @@ -5685,7 +6027,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 @@ -5709,22 +6051,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))) @@ -5782,7 +6157,8 @@ between beginning of field and beginning of line." nil mua))) -(defun message-setup (headers &optional replybuffer actions switch-function) +(defun message-setup (headers &optional replybuffer actions + continue switch-function) (let ((mua (message-mail-user-agent)) subject to field yank-action) (if (not (and message-this-is-mail mua)) @@ -5805,11 +6181,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 yank-action actions))))) (defun message-headers-to-generate (headers included-headers excluded-headers) "Return a list that includes all headers from HEADERS. -If INCLUDED-HEADERS is a list, just include those headers. If if is +If INCLUDED-HEADERS is a list, just include those headers. If it is t, include all headers. In any case, headers from EXCLUDED-HEADERS are not included." (let ((result nil) @@ -5882,11 +6258,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) @@ -5895,6 +6272,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 () @@ -5952,11 +6331,21 @@ 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) (unless (message-mail-user-agent) - (message-pop-to-buffer (message-buffer-name "mail" to))) + (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)) ;; FIXME: message-mail should do something if YANK-ACTION is not ;; insert-buffer. (and (consp yank-action) (eq (car yank-action) 'insert-buffer) @@ -5965,7 +6354,7 @@ OTHER-HEADERS is an alist of header/value pairs." (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) (when other-headers other-headers)) - replybuffer send-actions) + replybuffer send-actions continue switch-function) ;; FIXME: Should return nil if failure. t)) @@ -5978,9 +6367,32 @@ 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. + ;; 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 @@ -6078,7 +6490,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)) @@ -6115,6 +6531,39 @@ want to get rid of this query permanently."))) (push (cons 'Cc recipients) follow-to))) follow-to)) +(defcustom message-simplify-subject-functions + '(message-strip-list-identifiers + message-strip-subject-re + message-strip-subject-trailing-was + message-strip-subject-encoded-words) + "List of functions taking a string argument that simplify subjects. +The functions are applied when replying to a message. + +Useful functions to put in this list include: +`message-strip-list-identifiers', `message-strip-subject-re', +`message-strip-subject-trailing-was', and +`message-strip-subject-encoded-words'." + :version "22.1" ;; Gnus 5.10.9 + :group 'message-various + :type '(repeat function)) + +(defun message-simplify-subject (subject &optional functions) + "Return simplified SUBJECT." + (unless functions + ;; Simplify fully: + (setq functions message-simplify-subject-functions)) + (when (and (memq 'message-strip-list-identifiers functions) + gnus-list-identifiers) + (setq subject (message-strip-list-identifiers subject))) + (when (memq 'message-strip-subject-re functions) + (setq subject (concat "Re: " (message-strip-subject-re subject)))) + (when (and (memq 'message-strip-subject-trailing-was functions) + message-subject-trailing-was-query) + (setq subject (message-strip-subject-trailing-was subject))) + (when (memq 'message-strip-subject-encoded-words functions) + (setq subject (message-strip-subject-encoded-words subject))) + subject) + ;;;###autoload (defun message-reply (&optional to-address wide) "Start editing a reply to the article in the current buffer." @@ -6142,13 +6591,11 @@ want to get rid of this query permanently."))) (setq message-id (message-fetch-field "message-id" t) references (message-fetch-field "references") date (message-fetch-field "date") - from (message-fetch-field "from") + from (or (message-fetch-field "from") "nobody") subject (or (message-fetch-field "subject") "none")) - (when gnus-list-identifiers - (setq subject (message-strip-list-identifiers subject))) - (setq subject (concat "Re: " (message-strip-subject-re subject))) - (when message-subject-trailing-was-query - (setq subject (message-strip-subject-trailing-was subject))) + + ;; Strip list identifiers, "Re: ", and "was:" + (setq subject (message-simplify-subject subject)) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) @@ -6218,11 +6665,8 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (let ((case-fold-search t)) (string-match "world" distribution))) (setq distribution nil)) - (if gnus-list-identifiers - (setq subject (message-strip-list-identifiers subject))) - (setq subject (concat "Re: " (message-strip-subject-re subject))) - (when message-subject-trailing-was-query - (setq subject (message-strip-subject-trailing-was subject))) + ;; Strip list identifiers, "Re: ", and "was:" + (setq subject (message-simplify-subject subject)) (widen)) (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) @@ -6536,8 +6980,7 @@ the message." (setq subject (funcall func subject)))) subject)))) -(eval-when-compile - (defvar gnus-article-decoded-p)) +(defvar gnus-article-decoded-p) ;;;###autoload @@ -6592,8 +7035,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) @@ -6601,8 +7044,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") @@ -6660,6 +7106,61 @@ Optional DIGEST will use digest to forward." (message-forward-make-body-digest-mime forward-buffer) (message-forward-make-body-digest-plain forward-buffer))) +(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. +If DONT-EMULATE-MIME is nil, this function does the MIME emulation on +messages that don't conform to PGP/MIME described in RFC2015. HANDLES +is for the internal use." + (unless handles + (let ((mm-decrypt-option 'never) + (mm-verify-option 'never)) + (if (setq handles (mm-dissect-buffer nil t)) + (unless dont-emulate-mime + (mm-uu-dissect-text-parts handles)) + (unless dont-emulate-mime + (setq handles (mm-uu-dissect)))))) + ;; Check text/plain message in which there is a signed or encrypted + ;; body that has been encoded by B or Q. + (unless (or handles dont-emulate-mime) + (let ((cur (current-buffer)) + (mm-decrypt-option 'never) + (mm-verify-option 'never)) + (with-temp-buffer + (insert-buffer-substring cur) + (when (setq handles (mm-dissect-buffer t t)) + (if (and (prog1 + (bufferp (car handles)) + (mm-destroy-parts handles)) + (equal (mm-handle-media-type handles) "text/plain")) + (progn + (mm-decode-content-transfer-encoding + (mm-handle-encoding handles)) + (setq handles (mm-uu-dissect))) + (setq handles nil)))))) + (when handles + (prog1 + (catch 'found + (dolist (handle (if (stringp (car handles)) + (if (member (car handles) + '("multipart/signed" + "multipart/encrypted")) + (throw 'found t) + (cdr handles)) + (list handles))) + (if (stringp (car handle)) + (when (message-signed-or-encrypted-p dont-emulate-mime handle) + (throw 'found t)) + (when (and (bufferp (car handle)) + (equal (mm-handle-media-type handle) + "message/rfc822")) + (with-current-buffer (mm-handle-buffer handle) + (when (message-signed-or-encrypted-p dont-emulate-mime) + (throw 'found t))))))) + (mm-destroy-parts handles)))) + ;;;###autoload (defun message-forward-make-body (forward-buffer &optional digest) ;; Put point where we want it before inserting the forwarded @@ -6672,11 +7173,13 @@ Optional DIGEST will use digest to forward." (if message-forward-as-mime (if (and message-forward-show-mml (not (and (eq message-forward-show-mml 'best) + ;; Use the raw form in the body if it contains + ;; signed or encrypted message so as not to be + ;; destroyed by re-encoding. (with-current-buffer forward-buffer - (goto-char (point-min)) - (re-search-forward - "Content-Type: *multipart/\\(signed\\|encrypted\\)" - nil t))))) + (condition-case nil + (message-signed-or-encrypted-p) + (error t)))))) (message-forward-make-body-mml forward-buffer) (message-forward-make-body-mime forward-buffer)) (message-forward-make-body-plain forward-buffer))) @@ -6690,8 +7193,6 @@ Optional DIGEST will use digest to forward." (rmail-msg-restore-non-pruned-header))) (message-forward-make-body forward-buffer)) -(eval-when-compile (defvar rmail-enable-mime-composing)) - ;; Fixme: Should have defcustom. ;;;###autoload (defun message-insinuate-rmail () @@ -6793,7 +7294,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) @@ -6818,7 +7319,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) @@ -6833,7 +7334,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) @@ -6913,8 +7414,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 @@ -6943,7 +7443,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) @@ -6972,14 +7472,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) @@ -6992,7 +7492,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) @@ -7005,7 +7505,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) @@ -7068,6 +7568,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 @@ -7158,11 +7660,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))) @@ -7183,16 +7684,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) @@ -7329,7 +7827,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 @@ -7344,11 +7842,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) @@ -7364,7 +7862,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 @@ -7376,13 +7874,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) @@ -7395,6 +7893,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))