;;; 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 <larsi@gnus.org>
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; 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)
(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."
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',
: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
"*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
: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."
: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)
;;; 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)
: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."
(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)
: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")
: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."
: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)
(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)
: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."
: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)
: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.
"*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
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
(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 "> "
: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'.
(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
(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"
(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))
(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
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.
`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))
(defface message-header-to
'((((class color)
(background dark))
- (:foreground "green2" :bold t))
+ (:foreground "DarkOliveGreen1" :bold t))
(((class color)
(background light))
(:foreground "MidnightBlue" :bold t))
(defface message-header-cc
'((((class color)
(background dark))
- (:foreground "green4" :bold t))
+ (:foreground "chartreuse1" :bold t))
(((class color)
(background light))
(:foreground "MidnightBlue"))
(defface message-header-subject
'((((class color)
(background dark))
- (:foreground "green3"))
+ (:foreground "OliveDrab1"))
(((class color)
(background light))
(:foreground "navy blue" :bold t))
(defface message-header-other
'((((class color)
(background dark))
- (:foreground "#b00000"))
+ (:foreground "VioletRed1"))
(((class color)
(background light))
(:foreground "steel blue"))
(defface message-header-name
'((((class color)
(background dark))
- (:foreground "DarkGreen"))
+ (:foreground "green"))
(((class color)
(background light))
(:foreground "cornflower blue"))
(defface message-header-xheader
'((((class color)
(background dark))
- (:foreground "blue"))
+ (:foreground "DeepSkyBlue1"))
(((class color)
(background light))
(:foreground "blue"))
(defface message-separator
'((((class color)
(background dark))
- (:foreground "blue3"))
+ (:foreground "LightSkyBlue1"))
(((class color)
(background light))
(:foreground "brown"))
(defface message-cited-text
'((((class color)
(background dark))
- (:foreground "red"))
+ (:foreground "LightPink1"))
(((class color)
(background light))
(:foreground "red"))
(defface message-mml
'((((class color)
(background dark))
- (:foreground "ForestGreen"))
+ (:foreground "MediumSpringGreen"))
(((class color)
(background light))
(:foreground "ForestGreen"))
(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) "\\)$")
(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.
(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
"^ *--+ +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.")
(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
(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")
"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)
(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)
(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 ()
(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)))))
\f
(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
;;
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
(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
;; solution would be not to use `define-derived-mode', and run
;; `text-mode-hook' ourself at the end of the mode.
;; -- Per Abrahamsen <abraham@dina.kvl.dk> 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)))
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
;; (mail-strip-quoted-names "Foo Bar <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."
(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
((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.
(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")))))
and `low'."
(interactive)
(save-excursion
- (let ((valid '("high" "normal" "low"))
- (new "high")
+ (let ((new "high")
cur)
(save-restriction
(message-narrow-to-headers)
(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.
(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))))))
(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)
(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
"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 <john.doe@example.invalid>"
;; (current-time))
;; (buffer-string))
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
(setq fname name
lname ""))))
;; The following letters are not used in `format-time-string':
- (push ?E lst) (push net lst)
+ (push ?E lst) (push "<E>" lst)
(push ?F lst) (push fname lst)
;; We might want to use "" instead of "<X>" later.
(push ?J lst) (push "<J>" lst)
(push ?K lst) (push "<K>" lst)
(push ?L lst) (push lname lst)
- (push ?N lst) (push "<N>" lst)
+ (push ?N lst) (push name-or-net lst)
(push ?O lst) (push "<O>" lst)
(push ?P lst) (push "<P>" lst)
(push ?Q lst) (push "<Q>" lst)
(push ?f lst) (push from lst)
(push ?i lst) (push "<i>" lst)
- (push ?n lst) (push name-or-net lst)
+ (push ?n lst) (push net lst)
(push ?o lst) (push "<o>" lst)
(push ?q lst) (push "<q>" lst)
(push ?t lst) (push "<t>" lst)
(reverse lst)))
(spec (apply 'format-spec-make flist)))
(insert (format-spec message-citation-line-format spec)))
- (newline)
(newline)))
(defun message-cite-original-without-signature ()
(setq start next)))
(nreverse regions)))
-(defcustom message-replacement-char "."
- "Replacement character used instead of unprintable or not decodable chars."
- :group 'message-various
- :version "23.0" ;; No Gnus
- :type '(choice string
- (const ".")
- (const "?")))
+(defcustom message-bogus-address-regexp nil ;; "noreply\\|nospam\\|invalid"
+ "Regexp of potentially bogus mail addresses."
+ :version "23.1" ;; No Gnus
+ :group 'message-headers
+ :type '(choice (const :tag "None" nil)
+ (repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
+ regexp)
+ (const "noreply\\|nospam\\|invalid")
+ regexp))
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
"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
(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 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'."
+ ;; 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 (stringp message-bogus-address-regexp)
+ (string-match message-bogus-address-regexp 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."
(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)
;; 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
"/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
(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 "; "))
;; 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)
(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."
(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).
;; 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? ")
;; 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))
"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 ""))
(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."
(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
(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 " (")
(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.
(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)
(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:? "
(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)))
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))
"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
"")
(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)))
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))
(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)
(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)
(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 ()
"Disassociate the message buffer from the drafts directory."
(when message-draft-article
(nndraft-request-expire-articles
- (list message-draft-article) "drafts" nil t)))
+ (list message-draft-article) "nndraft:drafts" nil t)))
(defun message-insert-headers ()
"Generate the headers for the article."
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)
(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))
(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 <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
(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))
(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."
date (message-fetch-field "date")
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))
(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))
(setq subject (funcall func subject))))
subject))))
-(eval-when-compile
- (defvar gnus-article-decoded-p))
+(defvar gnus-article-decoded-p)
;;;###autoload
(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)
(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")
(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"))
+
+(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
(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)))
(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 ()
(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)
(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)
(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)
(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
(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)
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)
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)
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)
: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
(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)))
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)
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
(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)
(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
(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)
(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 <admin@foo.invalid>
+;; --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 <admin@foo.invalid>
+;; --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 <admin@foo.invalid>
+;; --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
+;; <http://en.wikipedia.org/wiki/Form_letter>
+
+;; 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))
projects / gnus / blobdiff