X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=0a38ec028c1dfc62c1411e64f4ba4e1580dede0e;hb=4303c5c768c35022c9eda800cacfa401946e144b;hp=c9d9395983267fce2cc0086403f0941463297c1f;hpb=e629c7641ea9fd830a380c12929423e78e047653;p=gnus diff --git a/lisp/message.el b/lisp/message.el index c9d939598..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 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -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)) @@ -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") @@ -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) @@ -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) @@ -3610,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) @@ -3618,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 @@ -3686,6 +3723,10 @@ This function uses `mail-citation-hook' if that is non-nil." "Cite function in the standard Message manner." (message-cite-original-1 nil)) +(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. @@ -4018,11 +4059,32 @@ not have PROP." (setq start next))) (nreverse regions))) -(defcustom message-bogus-address-regexp nil ;; "noreply\\|nospam\\|invalid" - "Regexp of potentially bogus mail addresses." - :version "23.0" ;; No Gnus +(defcustom message-bogus-addresses + ;; '("noreply" "nospam" "invalid") + '("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]") + "List of regexps of potentially bogus mail addresses. +See `message-check-recipients' how to setup checking. + +This list should make it possible to catch typos or warn about +spam-trap addresses. It doesn't aim to verify strict RFC +conformance." + :version "23.1" ;; No Gnus :group 'message-headers - :type 'regexp) + :type '(choice + (const :tag "None" nil) + (list + (set :inline t + (const "noreply") + (const "nospam") + (const "invalid") + (const :tag "duplicate @" "@@") + (const :tag "non-ascii local part" "[^[:ascii:]].*@") + ;; Already caught by `message-valid-fqdn-regexp' + ;; (const :tag "`_' in domain part" "@.*_") + (const :tag "whitespace" "[ \t]")) + (repeat :inline t + :tag "Other" + (regexp))))) (defun message-fix-before-sending () "Do various things to make the message nice before sending it." @@ -4108,7 +4170,7 @@ not have PROP." (forward-char) (skip-chars-forward mm-7bit-chars))))) (message-check 'bogus-recipient - ;; Warn before composing or sending a mail to an invalid address. + ;; Warn before sending a mail to an invalid address. (message-check-recipients))) (defun message-bogus-recipient-p (recipients) @@ -4117,9 +4179,9 @@ not have PROP." RECIPIENTS is a mail header. Return a list of potentially bogus addresses. If none is found, return nil. -An addresses might be bogus if the domain part is not fully -qualified, see `message-valid-fqdn-regexp', or if it matches -`message-bogus-address-regexp'." +An address might be bogus if the domain part is not fully +qualified, see `message-valid-fqdn-regexp', or if there's a +matching entry in `message-bogus-addresses'." ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"? (let (found) (mapc (lambda (address) @@ -4131,9 +4193,15 @@ qualified, see `message-valid-fqdn-regexp', or if it matches (string-match (concat ".@.*\\(" message-valid-fqdn-regexp "\\)\\'") address))) - (and (stringp message-bogus-address-regexp) - (string-match message-bogus-address-regexp address))) - (push address found))) + (and message-bogus-addresses + (let ((re + (if (listp message-bogus-addresses) + (mapconcat 'identity + message-bogus-addresses + "\\|") + message-bogus-addresses))) + (string-match re address)))) + (push address found))) ;; (mail-extract-address-components recipients t)) found)) @@ -4155,6 +4223,8 @@ This function could be useful in `message-setup-hook'." "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." (while types @@ -4302,8 +4372,7 @@ This function could be useful in `message-setup-hook'." ;; 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 @@ -4448,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 "; ")) @@ -4475,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. ;; @@ -4530,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." @@ -4612,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). @@ -5005,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? ") @@ -5030,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)) @@ -5276,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 "")) @@ -5298,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 \"" @@ -5525,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) @@ -5856,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))) @@ -5933,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)) @@ -6181,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) @@ -6194,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 () @@ -6287,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. @@ -6387,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)) @@ -6873,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 @@ -7000,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. @@ -7088,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 () @@ -7311,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 @@ -7341,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) @@ -7370,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) @@ -7390,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) @@ -7403,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) @@ -7466,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 @@ -7556,9 +7660,8 @@ 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+ (mapc 'princ text) (goto-char (point-min)))) @@ -7581,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) @@ -7727,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 @@ -7742,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) @@ -7793,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))