X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=0a38ec028c1dfc62c1411e64f4ba4e1580dede0e;hb=4303c5c768c35022c9eda800cacfa401946e144b;hp=3fe09f708eb0acd56960b0edb10df4371b30b872;hpb=fed46ed48be5e3ec8569e90fd85b901ba4296b25;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 3fe09f708..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, 2007 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,11 @@ (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)) @@ -188,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', @@ -269,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." @@ -409,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) @@ -470,12 +482,11 @@ function (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) @@ -556,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") @@ -585,21 +602,21 @@ Done before generating the new subject of a forward." :type 'regexp) (defcustom message-cite-prefix-regexp - (if (string-match "[[:digit:]]" "1") ;; support POSIX? - "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+" + (if (string-match "[[:digit:]]" "1") + ;; Support POSIX? XEmacs 21.5.27 doesn't. + "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|}]\\)+" ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. (let (non-word-constituents) (with-syntax-table text-mode-syntax-table (setq non-word-constituents (concat - (if (string-match "\\w" "-") "" "-") (if (string-match "\\w" "_") "" "_") (if (string-match "\\w" ".") "" ".")))) (if (equal non-word-constituents "") - "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+" + "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}]\\)+" (concat "\\([ \t]*\\(\\w\\|[" non-word-constituents - "]\\)+>+\\|[ \t]*[]>|}+]\\)+")))) + "]\\)+>+\\|[ \t]*[]>|}]\\)+")))) "*Regexp matching the longest possible citation prefix on a line." :version "22.1" :group 'message-insertion @@ -618,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) @@ -648,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) @@ -791,7 +821,7 @@ If this is nil, use `user-mail-address'. If it is the symbol (defcustom message-sendmail-extra-arguments nil "Additional arguments to `sendmail-program'." ;; E.g. '("-a" "account") for msmtp - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :type '(repeat string) ;; :link '(custom-manual "(message)Mail Variables") :group 'message-sending) @@ -816,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) @@ -914,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 @@ -923,7 +952,7 @@ 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) @@ -952,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 "> " @@ -987,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'. @@ -997,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 @@ -1122,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)) @@ -1205,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 @@ -1617,7 +1646,7 @@ functionality to work." (defcustom message-generate-hashcash (if (executable-find "hashcash") t) "*Whether to generate X-Hashcash: headers. -If `t', always generate hashcash headers. If `opportunistic', +If t, always generate hashcash headers. If `opportunistic', only generate hashcash headers if it can be done without the user waiting (i.e., only asynchronously). @@ -1640,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 @@ -1707,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.") @@ -1763,33 +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-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-msg-restore-non-pruned-header "rmail") +(autoload 'rmail-output "rmailout") @@ -1916,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) @@ -2458,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))))) @@ -2662,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 ;; @@ -2877,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))) @@ -3082,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 @@ -3335,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) @@ -3518,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. @@ -3589,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) @@ -3597,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 @@ -3665,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)) @@ -3997,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. @@ -4079,7 +4168,62 @@ not have PROP." (when (eq choice ?r) (insert message-replacement-char)))) (forward-char) - (skip-chars-forward mm-7bit-chars)))))) + (skip-chars-forward mm-7bit-chars))))) + (message-check 'bogus-recipient + ;; Warn before sending a mail to an invalid address. + (message-check-recipients))) + +(defun message-bogus-recipient-p (recipients) + "Check if a mail address in RECIPIENTS looks bogus. + +RECIPIENTS is a mail header. Return a list of potentially bogus +addresses. If none is found, return nil. + +An address might be bogus if the domain part is not fully +qualified, see `message-valid-fqdn-regexp', or if there's a +matching entry in `message-bogus-addresses'." + ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"? + (let (found) + (mapc (lambda (address) + (setq address (cadr address)) + (when + (or (not + (or + (not (string-match "@" address)) + (string-match + (concat ".@.*\\(" + message-valid-fqdn-regexp "\\)\\'") address))) + (and message-bogus-addresses + (let ((re + (if (listp message-bogus-addresses) + (mapconcat 'identity + message-bogus-addresses + "\\|") + message-bogus-addresses))) + (string-match re address)))) + (push address found))) + ;; + (mail-extract-address-components recipients t)) + found)) + +(defun message-check-recipients () + "Warn before composing or sending a mail to an invalid address. + +This function could be useful in `message-setup-hook'." + (interactive) + (save-restriction + (message-narrow-to-headers) + (dolist (hdr '("To" "Cc" "Bcc")) + (let ((addr (message-fetch-field hdr))) + (when (stringp addr) + (dolist (bog (message-bogus-recipient-p addr)) + (and bog + (not (y-or-n-p + (format + "Address `%s' might be bogus. Continue? " bog))) + (error "Bogus address.")))))))) + +(custom-add-option 'message-setup-hook 'message-check-recipients) (defun message-add-action (action &rest types) "Add ACTION to be performed when doing an exit of type TYPES." @@ -4228,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 @@ -4374,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 "; ")) @@ -4401,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. ;; @@ -4456,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." @@ -4538,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). @@ -4931,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? ") @@ -4956,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)) @@ -5202,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 "")) @@ -5224,19 +5375,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 \"" @@ -5270,7 +5420,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (concat message-user-path "!" login-name)) (t login-name)))) -(defun message-make-from (&optional name address ) +(defun message-make-from (&optional name address) "Make a From header." (let* ((style message-from-style) (login (or address (message-make-address))) @@ -5451,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) @@ -5473,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:? " @@ -5780,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))) @@ -5857,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)) @@ -6105,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) @@ -6118,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 () @@ -6211,6 +6367,29 @@ 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. @@ -6311,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)) @@ -6797,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 @@ -6852,8 +7034,7 @@ Optional DIGEST will use digest to forward." (dolist (elem ignored) (message-remove-header elem t)))))) -(defun message-forward-make-body-mime (forward-buffer - &optional signed-or-encrypted) +(defun message-forward-make-body-mime (forward-buffer) (let ((b (point))) (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") (save-restriction @@ -6864,11 +7045,10 @@ Optional DIGEST will use digest to forward." (replace-match "X-From-Line: ")) (goto-char (point-max))) (insert "<#/part>\n") - (when signed-or-encrypted - ;; Consider there is no illegible text. - (add-text-properties - b (point) - `(no-illegible-text t rear-nonsticky t start-open t))))) + ;; 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") @@ -6926,9 +7106,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. @@ -6992,20 +7171,17 @@ is for the internal use." (if digest (message-forward-make-body-digest forward-buffer) (if message-forward-as-mime - (let (signed-or-encrypted) - (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 - (condition-case nil - (setq signed-or-encrypted - (message-signed-or-encrypted-p)) - (error t)))))) - (message-forward-make-body-mml forward-buffer) - (message-forward-make-body-mime forward-buffer - signed-or-encrypted))) + (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 + (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))) (message-position-point)) @@ -7017,8 +7193,6 @@ is for the internal use." (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 () @@ -7240,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 @@ -7270,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) @@ -7299,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) @@ -7319,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) @@ -7332,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) @@ -7395,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 @@ -7485,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))) @@ -7510,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) @@ -7656,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 @@ -7671,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) @@ -7703,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) @@ -7722,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))