;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
-(eval-and-compile
- (autoload 'sha1 "sha1-el")
- (autoload 'gnus-find-method-for-group "gnus")
- (autoload 'nnvirtual-find-group-art "nnvirtual"))
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
the article has been posted to will be inserted there.
If this variable is nil, no such courtesy message will be added."
:group 'message-sending
- :type 'string)
+ :type '(radio (string :format "%t: %v\n" :size 0) (const nil)))
(defcustom message-ignored-bounced-headers
"^\\(Received\\|Return-Path\\|Delivered-To\\):"
`message-required-mail-headers'."
:group 'message-news
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type '(repeat sexp))
(defcustom message-draft-headers '(References From)
"*Headers to be generated when saving a draft message."
:group 'message-news
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type '(repeat sexp))
(defcustom message-required-news-headers
header, remove it from this list."
:group 'message-news
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type '(repeat sexp))
(defcustom message-required-mail-headers
included. Organization and User-Agent are optional."
:group 'message-mail
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type '(repeat sexp))
(defcustom message-deletable-headers '(Message-ID Date Lines)
"Headers to be deleted if they already exist and were generated by message previously."
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type 'sexp)
(defcustom message-ignored-news-headers
"*Regexp of headers to be removed unconditionally before posting."
:group 'message-news
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type 'regexp)
(defcustom message-ignored-mail-headers
"*Regexp of headers to be removed unconditionally before mailing."
:group 'message-mail
: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:"
+(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:"
"*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."
:group 'message-interface
+ :link '(custom-manual "(message)Superseding")
:type 'regexp)
(defcustom message-subject-re-regexp
"^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
"*Regexp matching \"Re: \" in the subject line."
:group 'message-various
+ :link '(custom-manual "(message)Message Headers")
:type 'regexp)
;;; Start of variables adopted from `message-utils.el'.
(defcustom message-subject-trailing-was-query 'ask
- ;; should it default to nil or ask?
"*What to do with trailing \"(was: <old subject>)\" in subject lines.
If nil, leave the subject unchanged. If it is the symbol `ask', query
the user what do do. In this case, the subject is matched against
:type '(choice (const :tag "never" nil)
(const :tag "always strip" t)
(const ask))
+ :link '(custom-manual "(message)Message Headers")
:group 'message-various)
(defcustom message-subject-trailing-was-ask-regexp
It is okay to create some false positives here, as the user is asked."
:group 'message-various
+ :link '(custom-manual "(message)Message Headers")
:type 'regexp)
(defcustom message-subject-trailing-was-regexp
`message-strip-subject-trailing-was'. You should use a regexp creating very
few false positives here."
:group 'message-various
+ :link '(custom-manual "(message)Message Headers")
:type 'regexp)
;; Fixme: Why are all these things autoloaded?
"--8<---------------cut here---------------start------------->8---\n"
"How to mark the beginning of some inserted text."
:type 'string
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-various)
;;;###autoload
"--8<---------------cut here---------------end--------------->8---\n"
"How to mark the end of some inserted text."
:type 'string
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-various)
;;;###autoload
(defcustom message-archive-header
"X-No-Archive: Yes\n"
"Header to insert when you don't want your article to be archived.
-Archives \(such as groups.googgle.com\) respect this header."
+Archives \(such as groups.google.com\) respect this header."
:type 'string
+ :link '(custom-manual "(message)Header Commands")
:group 'message-various)
;;;###autoload
"X-No-Archive: Yes - save http://groups.google.com/"
"Note to insert why you wouldn't want this posting archived.
If nil, don't insert any text in the body."
- :type 'string
+ :type '(radio (string :format "%t: %v\n" :size 0)
+ (const nil))
+ :link '(custom-manual "(message)Header Commands")
:group 'message-various)
;;; Crossposts and Followups
(defcustom message-signature-separator "^-- *$"
"Regexp matching the signature separator."
:type 'regexp
+ :link '(custom-manual "(message)Various Message Variables")
:group 'message-various)
(defcustom message-elide-ellipsis "\n[...]\n\n"
"*The string which is inserted for elided text."
:type 'string
+ :link '(custom-manual "(message)Various Commands")
:group 'message-various)
(defcustom message-interactive t
nil means let mailer mail back a message to report errors."
:group 'message-sending
:group 'message-mail
+ :link '(custom-manual "(message)Sending Variables")
:type 'boolean)
(defcustom message-generate-new-buffers 'unique
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)
(defcustom message-kill-buffer-on-exit nil
"*Non-nil means that the message buffer will be killed after sending a message."
:group 'message-buffers
+ :link '(custom-manual "(message)Message Buffers")
:type 'boolean)
(eval-when-compile
(defcustom message-user-organization-file "/usr/lib/news/organization"
"*Local news organization file."
:type 'file
+ :link '(custom-manual "(message)News Headers")
:group 'message-headers)
(defcustom message-make-forward-subject-function
- 'message-forward-subject-name-subject
+ #'message-forward-subject-name-subject
"*List of functions called to generate subject headers for forwarded messages.
The subject generated by the previous function is passed into each
successive function.
The provided functions are:
-* `message-forward-subject-author-subject' (Source of article (author or
- newsgroup)), in brackets followed by the subject
-* `message-forward-subject-name-subject' (Source of article (name of author
- or newsgroup)), in brackets followed by the subject
-* `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended
+* `message-forward-subject-author-subject' Source of article (author or
+ newsgroup), in brackets followed by the subject
+* `message-forward-subject-name-subject' Source of article (name of author
+ or newsgroup), in brackets followed by the subject
+* `message-forward-subject-fwd' Subject of article with 'Fwd:' prepended
to it."
:group 'message-forwarding
+ :link '(custom-manual "(message)Forwarding")
:type '(radio (function-item message-forward-subject-author-subject)
(function-item message-forward-subject-fwd)
+ (function-item message-forward-subject-name-subject)
(repeat :tag "List of functions" function)))
(defcustom message-forward-as-mime t
Otherwise, directly inline the old message in the forwarded message."
:version "21.1"
:group 'message-forwarding
+ :link '(custom-manual "(message)Forwarding")
:type 'boolean)
-(defcustom message-forward-show-mml t
- "*Non-nil means show forwarded messages as mml.
-Otherwise, forwarded messages are unchanged."
+(defcustom message-forward-show-mml 'best
+ "*Non-nil means show forwarded messages as MML (decoded from MIME).
+Otherwise, forwarded messages are unchanged.
+Can also be the symbol `best' to indicate that MML should be
+used, except when it is a bad idea to use MML. One example where
+it is a bad idea is when forwarding a signed or encrypted
+message, because converting MIME to MML would invalidate the
+digital signature."
:version "21.1"
:group 'message-forwarding
- :type 'boolean)
+ :type '(choice (const :tag "use MML" t)
+ (const :tag "don't use MML " nil)
+ (const :tag "use MML when appropriate" best)))
(defcustom message-forward-before-signature t
"*Non-nil means put forwarded message before signature, else after."
"*Non-nil means try to remove as much cruft as possible from the subject.
Done before generating the new subject of a forward."
:group 'message-forwarding
+ :link '(custom-manual "(message)Forwarding")
:type 'boolean)
(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From "
"*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-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
(defcustom message-ignored-cited-headers "."
"*Delete these headers from the messages you yank."
:group 'message-insertion
+ :link '(custom-manual "(message)Insertion Variables")
:type 'regexp)
(defcustom message-cite-prefix-regexp
(if (string-match "[[:digit:]]" "1") ;; support POSIX?
"\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
- (let ((old-table (syntax-table))
- non-word-constituents)
- (set-syntax-table text-mode-syntax-table)
- (setq non-word-constituents
- (concat
- (if (string-match "\\w" "-") "" "-")
- (if (string-match "\\w" "_") "" "_")
- (if (string-match "\\w" ".") "" ".")))
- (set-syntax-table old-table)
+ (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]*[]>|}+]\\)+"
(concat "\\([ \t]*\\(\\w\\|["
"]\\)+>+\\|[ \t]*[]>|}+]\\)+"))))
"*Regexp matching the longest possible citation prefix on a line."
:group 'message-insertion
+ :link '(custom-manual "(message)Insertion Variables")
:type 'regexp)
(defcustom message-cancel-message "I am canceling my own article.\n"
"Message to be inserted in the cancel message."
:group 'message-interface
+ :link '(custom-manual "(message)Canceling News")
:type 'string)
;; Useful to set in site-init.el
(function-item feedmail-send-it)
(function :tag "Other"))
:group 'message-sending
+ :link '(custom-manual "(message)Mail Variables")
:group 'message-mail)
(defcustom message-send-news-function 'message-send-news
variable `mail-header-separator'."
:group 'message-sending
:group 'message-news
+ :link '(custom-manual "(message)News Variables")
:type 'function)
(defcustom message-reply-to-function nil
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
+ :link '(custom-manual "(message)Reply")
:type '(choice function (const nil)))
(defcustom message-wide-reply-to-function nil
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
+ :link '(custom-manual "(message)Wide Reply")
:type '(choice function (const nil)))
(defcustom message-followup-to-function nil
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
+ :link '(custom-manual "(message)Followup")
:type '(choice function (const nil)))
(defcustom message-use-followup-to 'ask
always query the user whether to use the value. If it is the symbol
`use', always use the value."
:group 'message-interface
+ :link '(custom-manual "(message)Followup")
:type '(choice (const :tag "ignore" nil)
(const :tag "use & query" t)
(const use)
query the user whether to use the value. If it is the symbol `use',
always use the value."
:group 'message-interface
+ :link '(custom-manual "(message)Mailing Lists")
:type '(choice (const :tag "ignore" nil)
(const use)
(const ask)))
(defcustom message-subscribed-address-functions nil
"*Specifies functions for determining list subscription.
-If nil, do not attempt to determine list subscribtion with functions.
+If nil, do not attempt to determine list subscription with functions.
If non-nil, this variable contains a list of functions which return
regular expressions to match lists. These functions can be used in
conjunction with `message-subscribed-regexps' and
`message-subscribed-addresses'."
:group 'message-interface
+ :link '(custom-manual "(message)Mailing Lists")
:type '(repeat sexp))
(defcustom message-subscribed-address-file nil
If nil, do not look at any files to determine list subscriptions. If
non-nil, each line of this file should be a mailing list address."
:group 'message-interface
- :type 'string)
+ :link '(custom-manual "(message)Mailing Lists")
+ :type '(radio (file :format "%t: %v\n" :size 0)
+ (const nil)))
(defcustom message-subscribed-addresses nil
"*Specifies a list of addresses the user is subscribed to.
If nil, do not use any predefined list subscriptions. This list of
-addresses can be used in conjuction with
+addresses can be used in conjunction with
`message-subscribed-address-functions' and `message-subscribed-regexps'."
:group 'message-interface
+ :link '(custom-manual "(message)Mailing Lists")
:type '(repeat string))
(defcustom message-subscribed-regexps nil
"*Specifies a list of addresses the user is subscribed to.
If nil, do not use any predefined list subscriptions. This list of
-regular expressions can be used in conjuction with
+regular expressions can be used in conjunction with
`message-subscribed-address-functions' and `message-subscribed-addresses'."
:group 'message-interface
+ :link '(custom-manual "(message)Mailing Lists")
:type '(repeat regexp))
(defcustom message-allow-no-recipients 'ask
symbol `never', the posting is not allowed. If it is the symbol
`ask', you are prompted."
:group 'message-interface
+ :link '(custom-manual "(message)Message Headers")
:type '(choice (const always)
(const never)
(const ask)))
"*Non-nil means don't add \"-f username\" to the sendmail command line.
Doing so would be even more evil than leaving it out."
:group 'message-sending
+ :link '(custom-manual "(message)Mail Variables")
:type 'boolean)
(defcustom message-sendmail-envelope-from nil
:type '(choice (string :tag "From name")
(const :tag "Use From: header from message" header)
(const :tag "Use `user-mail-address'" nil))
+ :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."
:group 'message-sending
+ :link '(custom-manual "(message)Mail Variables")
:type 'file)
(defcustom message-qmail-inject-args nil
go to the right place or to deal with listserv's usage of that address, you
might set this variable to '(\"-f\" \"you@some.where\")."
:group 'message-sending
+ :link '(custom-manual "(message)Mail Variables")
:type '(choice (function)
(repeat string)))
-(defvar message-cater-to-broken-inn t
- "Non-nil means Gnus should not fold the `References' header.
-Folding `References' makes ancient versions of INN create incorrect
-NOV lines.")
-
(eval-when-compile
(defvar gnus-post-method)
(defvar gnus-select-method))
;; will *not* have a `References:' header if `message-generate-headers-first'
;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138
(defcustom message-generate-headers-first '(references)
- "*If non-nil, generate all required headers before composing.
-The variables `message-required-news-headers' and
+ "Which headers should be generated before starting to compose a message.
+If t, generate all required headers. This can also be a list of headers to
+generate. The variables `message-required-news-headers' and
`message-required-mail-headers' specify which headers to generate.
-This can also be a list of headers that should be generated before
-composing.
Note that the variable `message-deletable-headers' specifies headers which
are to be deleted and then re-generated before sending, so this variable
will not have a visible effect for those headers."
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type '(choice (const :tag "None" nil)
(const :tag "References" '(references))
(const :tag "All" t)
"Normal hook, run each time a new outgoing message is initialized.
The function `message-setup' runs this hook."
:group 'message-various
+ :link '(custom-manual "(message)Various Message Variables")
:type 'hook)
(defcustom message-cancel-hook nil
"Hook run when cancelling articles."
:group 'message-various
+ :link '(custom-manual "(message)Various Message Variables")
:type 'hook)
(defcustom message-signature-setup-hook nil
It is run after the headers have been inserted and before
the signature is inserted."
:group 'message-various
+ :link '(custom-manual "(message)Various Message Variables")
:type 'hook)
(defcustom message-mode-hook nil
(defcustom message-header-setup-hook nil
"Hook called narrowed to the headers when setting up a message buffer."
:group 'message-various
+ :link '(custom-manual "(message)Various Message Variables")
:type 'hook)
(defcustom message-minibuffer-local-map
people who read your message will have to change their Gnus
configuration. See the variable `gnus-cite-attribution-suffix'."
:type 'function
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
;;;###autoload
Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
See also `message-yank-cited-prefix'."
:type 'string
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
(defcustom message-yank-cited-prefix ">"
Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
See also `message-yank-prefix'."
:type 'string
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
(defcustom message-indentation-spaces 3
"*Number of spaces to insert at the beginning of each cited line.
Used by `message-yank-original' via `message-yank-cite'."
:group 'message-insertion
+ :link '(custom-manual "(message)Insertion Variables")
:type 'integer)
;;;###autoload
(function-item message-cite-original-without-signature)
(function-item sc-cite-original)
(function :tag "Other"))
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
;;;###autoload
citation between (point) and (mark t). And each function should leave
point and mark around the citation text as modified."
:type 'function
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
;;;###autoload
If a function, the result from the function will be used instead.
If a form, the result from the form will be used instead."
:type 'sexp
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
;;;###autoload
Ignored if the named file doesn't exist.
If nil, don't insert a signature."
:type '(choice file (const :tags "None" nil))
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
;;;###autoload
(defcustom message-signature-insert-empty-line t
"*If non-nil, insert an empty line before the signature separator."
:type 'boolean
+ :link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
(defcustom message-distribution-function nil
"*Function called to return a Distribution header."
:group 'message-news
:group 'message-headers
+ :link '(custom-manual "(message)News Headers")
:type '(choice function (const nil)))
(defcustom message-expires 14
It is inserted before you edit the message, so you can edit or delete
these lines."
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type 'message-header-lines)
(defcustom message-default-mail-headers ""
"*A string of header lines to be inserted in outgoing mails."
:group 'message-headers
:group 'message-mail
+ :link '(custom-manual "(message)Mail Headers")
:type 'message-header-lines)
(defcustom message-default-news-headers ""
"*A string of header lines to be inserted in outgoing news articles."
:group 'message-headers
:group 'message-news
+ :link '(custom-manual "(message)News Headers")
:type 'message-header-lines)
;; Note: could use /usr/ucb/mail instead of sendmail;
The value should be an expression to test whether the problem will
actually occur."
:group 'message-sending
+ :link '(custom-manual "(message)Mail Variables")
:type 'sexp)
;;;###autoload
"*Directory where Message auto-saves buffers if Gnus isn't running.
If nil, Message won't auto-save."
:group 'message-buffers
+ :link '(custom-manual "(message)Various Message Variables")
:type '(choice directory (const :tag "Don't auto-save" nil)))
(defcustom message-default-charset
If nil, you might be asked to input the charset."
:version "21.1"
:group 'message
+ :link '(custom-manual "(message)Various Message Variables")
:type 'symbol)
(defcustom message-dont-reply-to-names
A value of nil means exclude your own user name only."
:version "21.1"
:group 'message
+ :link '(custom-manual "(message)Wide Reply")
:type '(choice (const :tag "Yourself" nil)
regexp))
(defcustom message-hidden-headers nil
"Regexp of headers to be hidden when composing new messages.
This can also be a list of regexps to match headers. Or a list
-starting with `not' and followed by regexps.."
+starting with `not' and followed by regexps."
:group 'message
+ :link '(custom-manual "(message)Message Headers")
:type '(repeat regexp))
;;; Internal variables.
This hook is run quite early when sending."
:group 'message-various
:options '(ispell-message)
+ :link '(custom-manual "(message)Various Message Variables")
:type 'hook)
(defcustom message-send-mail-hook nil
This hook is run very late -- just before the message is sent as
mail."
:group 'message-various
+ :link '(custom-manual "(message)Various Message Variables")
:type 'hook)
(defcustom message-send-news-hook nil
This hook is run very late -- just before the message is sent as
news."
:group 'message-various
+ :link '(custom-manual "(message)Various Message Variables")
:type 'hook)
(defcustom message-sent-hook nil
should be sent in several parts. If it is nil, the size is unlimited."
:version "21.1"
:group 'message-buffers
+ :link '(custom-manual "(message)Mail Variables")
:type '(choice (const :tag "unlimited" nil)
(integer 1000000)))
"A regexp to match the alternative email addresses.
The first matched address (not primary one) is used in the From field."
:group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
:type '(choice (const :tag "Always use primary" nil)
regexp))
no, only reply back to the author."
:version "21.3"
:group 'message-headers
+ :link '(custom-manual "(message)Wide Reply")
:type 'boolean)
(defcustom message-user-fqdn nil
"*Domain part of Messsage-Ids."
:group 'message-headers
:link '(custom-manual "(message)News Headers")
- :type 'string)
+ :type '(radio (const :format "%v " nil)
+ (string :format "FQDN: %v\n" :size 0)))
(defcustom message-use-idna (and (condition-case nil (require 'idna)
(file-error))
'ask)
"Whether to encode non-ASCII in domain names into ASCII according to IDNA."
:group 'message-headers
+ :link '(custom-manual "(message)IDNA")
:type '(choice (const :tag "Ask" ask)
(const :tag "Never" nil)
(const :tag "Always" t)))
(defvar message-draft-article nil)
(defvar message-mime-part nil)
(defvar message-posting-charset nil)
+(defvar message-inserted-headers nil)
;; Byte-compiler warning
(eval-when-compile
:type 'regexp)
(eval-and-compile
+ (autoload 'gnus-alive-p "gnus-util")
+ (autoload 'gnus-delay-article "gnus-delay")
+ (autoload 'gnus-extract-address-components "gnus-util")
+ (autoload 'gnus-find-method-for-group "gnus")
+ (autoload 'gnus-group-decoded-name "gnus-group")
+ (autoload 'gnus-group-name-charset "gnus-group")
+ (autoload 'gnus-group-name-decode "gnus-group")
+ (autoload 'gnus-groups-from-server "gnus")
+ (autoload 'gnus-make-local-hook "gnus-util")
+ (autoload 'gnus-open-server "gnus-int")
+ (autoload 'gnus-output-to-mail "gnus-util")
+ (autoload 'gnus-output-to-rmail "gnus-util")
+ (autoload 'gnus-request-post "gnus-int")
+ (autoload 'gnus-server-string "gnus")
+ (autoload 'idna-to-ascii "idna")
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
(autoload 'mh-send-letter "mh-comp")
- (autoload 'gnus-point-at-eol "gnus-util")
- (autoload 'gnus-point-at-bol "gnus-util")
- (autoload 'gnus-output-to-rmail "gnus-util")
- (autoload 'gnus-output-to-mail "gnus-util")
(autoload 'nndraft-request-associate-buffer "nndraft")
(autoload 'nndraft-request-expire-articles "nndraft")
- (autoload 'gnus-open-server "gnus-int")
- (autoload 'gnus-request-post "gnus-int")
- (autoload 'gnus-alive-p "gnus-util")
- (autoload 'gnus-server-string "gnus")
- (autoload 'gnus-group-name-charset "gnus-group")
- (autoload 'gnus-group-name-decode "gnus-group")
- (autoload 'gnus-groups-from-server "gnus")
- (autoload 'rmail-output "rmailout")
- (autoload 'gnus-delay-article "gnus-delay")
- (autoload 'gnus-make-local-hook "gnus-util"))
+ (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"))
+
+(eval-when-compile
+ (autoload 'sha1 "sha1-el"))
\f
The buffer is expected to be narrowed to just the header of the message;
see `message-narrow-to-headers-or-head'."
(let* ((inhibit-point-motion-hooks t)
- (case-fold-search t)
(value (mail-fetch-field header nil (not not-all))))
(when value
(while (string-match "\n[\t ]+" value)
(set-text-properties 0 (length value) nil value)
value)))
+(defun message-field-value (header &optional not-all)
+ "The same as `message-fetch-field', only narrow to the headers first."
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-fetch-field header not-all))))
+
(defun message-narrow-to-field ()
"Narrow the buffer to the header on the current line."
(beginning-of-line)
(progn
(forward-line 1)
(if (re-search-forward "^[^ \n\t]" nil t)
- (progn
- (beginning-of-line)
- (point))
+ (point-at-bol)
(point-max))))
(goto-char (point-min)))
;;;###autoload
(defun message-change-subject (new-subject)
"Ask for NEW-SUBJECT header, append (was: <Old Subject>)."
+ ;; <URL:http://www.landfield.com/usefor/drafts/draft-ietf-usefor-useage--1.02.unpaged>
(interactive
(list
(read-from-minibuffer "New subject: ")))
See `message-mark-insert-begin' and `message-mark-insert-end'."
(interactive "r")
(save-excursion
- ; add to the end of the region first, otherwise end would be invalid
+ ;; add to the end of the region first, otherwise end would be invalid
(goto-char end)
(insert message-mark-insert-end)
(goto-char beg)
(easy-menu-define
message-mode-field-menu message-mode-map ""
`("Field"
- ["Fetch To" message-insert-to t]
- ["Fetch Newsgroups" message-insert-newsgroups t]
- "----"
["To" message-goto-to t]
["From" message-goto-from t]
["Subject" message-goto-subject t]
["Summary" message-goto-summary t]
["Keywords" message-goto-keywords t]
["Newsgroups" message-goto-newsgroups t]
+ ["Fetch Newsgroups" message-insert-newsgroups t]
["Followup-To" message-goto-followup-to t]
;; ["Followup-To (with note in body)" message-cross-post-followup-to t]
["Crosspost / Followup-To..." message-cross-post-followup-to t]
["X-No-Archive:" message-add-archive-header t ]
"----"
;; (typical) mailing-lists stuff
+ ["Fetch To" message-insert-to
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Insert a To header that points to the author."))]
+ ["Fetch To and Cc" message-insert-wide-reply
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help
+ "Insert To and Cc headers as if you were doing a wide reply."))]
+ "----"
["Send to list only" message-to-list-only t]
["Mail-Followup-To" message-goto-mail-followup-to t]
+ ["Unsubscribed list post" message-generate-unsubscribed-mail-followup-to
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Insert a reasonable `Mail-Followup-To:' header."))]
["Reduce To: to Cc:" message-reduce-to-to-cc t]
"----"
["Sort Headers" message-sort-headers t]
If you use one of these packages, turn this option off, and hope the
message composition doesn't break too bad."
:group 'message-various
+ :link '(custom-manual "(message)Various Message Variables")
:type 'boolean)
(defconst message-forbidden-properties
M-RET `message-newline-and-reformat' (break the line and reformat)."
(setq local-abbrev-table text-mode-abbrev-table)
(set (make-local-variable 'message-reply-buffer) nil)
- (make-local-variable 'message-send-actions)
- (make-local-variable 'message-exit-actions)
- (make-local-variable 'message-kill-actions)
- (make-local-variable 'message-postpone-actions)
- (make-local-variable 'message-draft-article)
+ (set (make-local-variable 'message-inserted-headers) nil)
+ (set (make-local-variable 'message-send-actions) nil)
+ (set (make-local-variable 'message-exit-actions) nil)
+ (set (make-local-variable 'message-kill-actions) nil)
+ (set (make-local-variable 'message-postpone-actions) nil)
+ (set (make-local-variable 'message-draft-article) nil)
(setq buffer-offer-save t)
(set (make-local-variable 'facemenu-add-face-function)
(lambda (face end)
(set (make-local-variable 'message-checksum) nil)
(set (make-local-variable 'message-mime-part) 0)
(message-setup-fill-variables)
- (set
- (make-local-variable 'paragraph-separate)
- (format "\\(%s\\)\\|\\(%s\\)"
- paragraph-separate
- "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
;; Allow using comment commands to add/remove quoting.
(set (make-local-variable 'comment-start) message-yank-prefix)
(if (featurep 'xemacs)
"---+$\\|" ; delimiters for forwarded messages
page-delimiter "$\\|" ; spoiler warnings
".*wrote:$\\|" ; attribution lines
- quote-prefix-regexp "$")) ; empty lines in quoted text
+ quote-prefix-regexp "$\\|" ; empty lines in quoted text
+ ; mml tags
+ "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
(setq paragraph-separate paragraph-start)
(setq adaptive-fill-regexp
(concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
(defun message-insert-to (&optional force)
"Insert a To header that points to the author of the article being replied to.
-If the original author requested not to be sent mail, the function signals
-an error.
-With the prefix argument FORCE, insert the header anyway."
+If the original author requested not to be sent mail, don't insert unless the
+prefix FORCE is given."
(interactive "P")
- (let ((co (message-fetch-reply-field "mail-copies-to")))
- (when (and (null force)
- co
- (or (equal (downcase co) "never")
- (equal (downcase co) "nobody")))
- (error "The user has requested not to have copies sent via mail")))
- (message-carefully-insert-headers
- (list (cons 'To
- (or (message-fetch-reply-field "mail-reply-to")
- (message-fetch-reply-field "reply-to")
- (message-fetch-reply-field "from")
- "")))))
+ (let* ((mct (message-fetch-reply-field "mail-copies-to"))
+ (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"))))
+ (when (and dont to)
+ (message
+ (if force
+ "Ignoring the user request not to have copies sent via mail"
+ "Complying with the user request not to have copies sent via mail")))
+ (when (and force (not to))
+ (error "No mail address in the article"))
+ (when (and to (or force (not dont)))
+ (message-carefully-insert-headers (list (cons 'To to))))))
(defun message-insert-wide-reply ()
"Insert To and Cc headers as if you were doing a wide reply."
(message-get-reply-headers t))))
(message-carefully-insert-headers headers)))
+(defcustom message-header-synonyms
+ '((To Cc Bcc))
+ "List of lists of header synonyms.
+E.g., if this list contains a member list with elements `Cc' and `To',
+then `message-carefully-insert-headers' will not insert a `To' header
+when the message is already `Cc'ed to the recipient."
+ :group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
+ :type '(repeat sexp))
+
(defun message-carefully-insert-headers (headers)
+ "Insert the HEADERS, an alist, into the message buffer.
+Does not insert the headers when they are already present there
+or in the synonym headers, defined by `message-header-synonyms'."
+ ;; FIXME: Should compare only the address and not the full name. Comparison
+ ;; should be done case-folded (and with `string=' rather than
+ ;; `string-match').
(dolist (header headers)
- (let ((header-name (symbol-name (car header))))
- (when (and (message-position-on-field header-name)
- (mail-fetch-field header-name)
- (not (string-match "\\` *\\'"
- (mail-fetch-field header-name))))
- (insert ", "))
- (insert (cdr header)))))
+ (let* ((header-name (symbol-name (car header)))
+ (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
+ 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)
+ (when (and (message-position-on-field header-name)
+ (setq old-header (mail-fetch-field header-name))
+ (not (string-match "\\` *\\'" old-header)))
+ (insert ", "))
+ (insert new-header)))))
(defun message-widen-reply ()
"Widen the reply to include maximum recipients."
(when (message-goto-signature)
(forward-line -2)))
-(defun message-kill-to-signature ()
- "Deletes all text up to the signature."
- (interactive)
- (let ((point (point)))
- (message-goto-signature)
- (unless (eobp)
- (end-of-line -1))
- (kill-region point (point))
- (unless (bolp)
- (insert "\n"))))
+(defun message-kill-to-signature (&optional arg)
+ "Kill all text up to the signature.
+If a numberic argument or prefix arg is given, leave that number
+of lines before the signature intact."
+ (interactive "p")
+ (save-excursion
+ (save-restriction
+ (let ((point (point)))
+ (narrow-to-region point (point-max))
+ (message-goto-signature)
+ (unless (eobp)
+ (if (and arg (numberp arg))
+ (forward-line (- -1 arg))
+ (end-of-line -1)))
+ (unless (= point (point))
+ (kill-region point (point))
+ (insert "\n"))))))
(defun message-newline-and-reformat (&optional arg not-break)
"Insert four newlines, and then reformat if inside quoted text.
(message-remove-header "Disposition-Notification-To"))
(message-goto-eoh)
(insert (format "Disposition-Notification-To: %s\n"
- (or (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (message-fetch-field "From")))
+ (or (message-field-value "Reply-to")
+ (message-field-value "From")
(message-make-from))))))
(defun message-elide-region (b e)
(defun message-yank-buffer (buffer)
"Insert BUFFER into the current buffer and quote it."
(interactive "bYank buffer: ")
- (let ((message-reply-buffer buffer))
+ (let ((message-reply-buffer (get-buffer buffer)))
(save-window-excursion
(message-yank-original))))
(defun message-cite-original-without-signature ()
"Cite function in the standard Message manner."
- (let ((start (point))
- (end (mark t))
- (functions
- (when message-indent-citation-function
- (if (listp message-indent-citation-function)
- message-indent-citation-function
- (list message-indent-citation-function)))))
+ (let* ((start (point))
+ (end (mark t))
+ (functions
+ (when message-indent-citation-function
+ (if (listp message-indent-citation-function)
+ message-indent-citation-function
+ (list message-indent-citation-function))))
+ ;; This function may be called by `gnus-summary-yank-message' and
+ ;; may insert a different article from the original. So, we will
+ ;; modify the value of `message-reply-headers' with that article.
+ (message-reply-headers
+ (save-restriction
+ (narrow-to-region start end)
+ (message-narrow-to-head-1)
+ (vector 0
+ (or (message-fetch-field "subject") "none")
+ (message-fetch-field "from")
+ (message-fetch-field "date")
+ (message-fetch-field "message-id" t)
+ (message-fetch-field "references")
+ 0 0 ""))))
(mml-quote-region start end)
;; Allow undoing.
(undo-boundary)
(if (and (boundp 'mail-citation-hook)
mail-citation-hook)
(run-hooks 'mail-citation-hook)
- (let ((start (point))
- (end (mark t))
- (functions
- (when message-indent-citation-function
- (if (listp message-indent-citation-function)
- message-indent-citation-function
- (list message-indent-citation-function)))))
+ (let* ((start (point))
+ (end (mark t))
+ (functions
+ (when message-indent-citation-function
+ (if (listp message-indent-citation-function)
+ message-indent-citation-function
+ (list message-indent-citation-function))))
+ ;; This function may be called by `gnus-summary-yank-message' and
+ ;; may insert a different article from the original. So, we will
+ ;; modify the value of `message-reply-headers' with that article.
+ (message-reply-headers
+ (save-restriction
+ (narrow-to-region start end)
+ (message-narrow-to-head-1)
+ (vector 0
+ (or (message-fetch-field "subject") "none")
+ (message-fetch-field "from")
+ (message-fetch-field "date")
+ (message-fetch-field "message-id" t)
+ (message-fetch-field "references")
+ 0 0 ""))))
(mml-quote-region start end)
(goto-char start)
(while functions
(when (funcall (cadr elem))
(when (and (or (not (memq (car elem)
message-sent-message-via))
- (not (message-fetch-field "supersedes"))
+ (message-fetch-field "supersedes")
(if (or (message-gnksa-enable-p 'multiple-copies)
(not (eq (car elem) 'news)))
(y-or-n-p
(add-text-properties point (1+ point)
'(invisible nil intangible nil)))))
;; Make invisible text visible.
+ ;; It doesn't seem as if this is useful, since the invisible property
+ ;; is clobbered by an after-change hook anyhow.
(message-check 'invisible-text
(let ((points (message-text-with-property 'invisible)))
(when points
(goto-char (car points))
(dolist (point points)
+ (put-text-property point (1+ point) 'invisible nil)
(message-overlay-put (message-make-overlay point (1+ point))
'face 'highlight))
(unless (yes-or-no-p
(when (let ((char (char-after)))
(or (< (mm-char-int char) 128)
(and (mm-multibyte-p)
- (> (length (mm-find-mime-charset-region
- (point) (point-max)))
- 1))))
+ (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))
;; use find-coding-systems-region.
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
- control-1)))))
+ control-1))
+ (not (get-text-property
+ (point) 'untranslated-utf-8)))))
(if (eq choice ?i)
(message-kill-all-overlays)
(delete-char 1)
(if resend-to-addresses
(list resend-to-addresses)
'("-t"))))))
- (unless (or (null cpr) (zerop cpr))
+ (unless (or (null cpr) (and (numberp cpr) (zerop cpr)))
(error "Sending...failed with exit value %d" cpr)))
(when message-interactive
(save-excursion
"Send the prepared message buffer with `smtpmail-send-it'.
This only differs from `smtpmail-send-it' that this command evaluates
`message-send-mail-hook' just before sending a message. It is useful
-if your ISP requires the POP-before-SMTP authentication. See the
-documentation for the function `mail-source-touch-pop'."
+if your ISP requires the POP-before-SMTP authentication. See the Gnus
+manual for details."
(run-hooks 'message-send-mail-hook)
(smtpmail-send-it))
(defun message-canlock-generate ()
- "Return a string that is non-trival to guess.
+ "Return a string that is non-trivial to guess.
Do not use this for anything important, it is cryptographically weak."
+ (require 'sha1-el)
(let (sha1-maximum-internal-length)
(sha1 (concat (message-unique-id)
(format "%x%x%x" (random) (random t) (random))
(aset tmp (1- (match-end 0)) ?-))
(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 "\""))
(insert " <" login ">"))
(t ; 'parens or default
(insert login " (")
(user-domain
(if (and user-mail
(string-match "@\\(.*\\)\\'" user-mail))
- (match-string 1 user-mail))))
+ (match-string 1 user-mail)))
+ (case-fold-search t))
(cond
((and message-user-fqdn
(stringp message-user-fqdn)
(incf paren))
(and (= (% dquote 2) 1) (= (% paren 2) 1))))))
-(autoload 'idna-to-ascii "idna")
-
(defun message-idna-to-ascii-rhs-1 (header)
"Interactively potentially IDNA encode domain names in HEADER."
(let (rhs ace start startpos endpos ovl)
(goto-char (point-min))
(while (re-search-forward (concat "^" header) nil t)
- (while (re-search-forward "@\\([^ \t\r\n>]+\\)"
+ (while (re-search-forward "@\\([^ \t\r\n>,]+\\)"
(or (save-excursion
(re-search-forward "^[^ \t]" nil t))
(point-max))
(Expires (message-make-expires))
(case-fold-search t)
(optionalp nil)
- header value elem)
+ header value elem header-string)
;; First we remove any old generated headers.
(let ((headers message-deletable-headers))
(unless (buffer-modified-p)
optionalp t)
(setq header (car elem)))
(setq header elem))
+ (setq header-string (if (stringp header)
+ header
+ (symbol-name header)))
(when (or (not (re-search-forward
(concat "^"
- (regexp-quote
- (downcase
- (if (stringp header)
- header
- (symbol-name header))))
+ (regexp-quote (downcase header-string))
":")
nil t))
(progn
(setq value
(cond
((and (consp elem)
- (eq (car elem) 'optional))
+ (eq (car elem) 'optional)
+ (not (member header-string message-inserted-headers)))
;; This is an optional header. If the cdr of this
;; is something that is nil, then we do not insert
;; this header.
(cdr (assq header message-header-format-alist))))
(if formatter
(funcall formatter header value)
- (insert (if (stringp header)
- header (symbol-name header))
- ": " value))
+ (insert header-string ": " value))
;; We check whether the value was ended by a
;; newline. If now, we insert one.
(unless (bolp)
(forward-line -1)))
;; The value of this header was empty, so we clear
;; totally and insert the new value.
- (delete-region (point) (gnus-point-at-eol))
+ (delete-region (point) (point-at-eol))
;; If the header is optional, and the header was
;; empty, we con't insert it anyway.
(unless optionalp
+ (push header-string message-inserted-headers)
(insert value)))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(error
(split-line))))
-
(defun message-fill-header (header value)
(let ((begin (point))
(fill-column 78)
(defun message-shorten-references (header references)
"Trim REFERENCES to be 21 Message-ID long or less, and fold them.
-If folding is disallowed, also check that the REFERENCES are less
-than 988 characters long, and if they are not, trim them until they are."
+When sending via news, also check that the REFERENCES are less
+than 988 characters long, and if they are not, trim them until
+they are."
(let ((maxcount 21)
(count 0)
(cut 2)
(message-shorten-1 refs cut surplus)
(decf count surplus)))
- ;; If folding is disallowed, make sure the total length (including
- ;; the spaces between) will be less than MAXSIZE characters.
+ ;; When sending via news, make sure the total folded length will
+ ;; be less than 998 characters. This is to cater to broken INN
+ ;; 2.3 which counts the total number of characters in a header
+ ;; rather than the physical line length of each line, as it shuld.
;;
- ;; Only disallow folding for News messages. At this point the headers
- ;; have not been generated, thus we use message-this-is-news directly.
- (when (and message-this-is-news message-cater-to-broken-inn)
- (let ((maxsize 988)
- (totalsize (+ (apply #'+ (mapcar #'length refs))
- (1- count)))
- (surplus 0)
- (ptr (nthcdr (1- cut) refs)))
- ;; Decide how many elements to cut off...
- (while (> totalsize maxsize)
- (decf totalsize (1+ (length (car ptr))))
- (incf surplus)
- (setq ptr (cdr ptr)))
- ;; ...and do it.
- (when (> surplus 0)
- (message-shorten-1 refs cut surplus))))
-
+ ;; This hack should be removed when it's believed than INN 2.3 is
+ ;; no longer widely used.
+ ;;
+ ;; At this point the headers have not been generated, thus we use
+ ;; message-this-is-news directly.
+ (when message-this-is-news
+ (while (< 998
+ (with-temp-buffer
+ (message-fill-header header (mapconcat #'identity refs " "))
+ (buffer-size)))
+ (message-shorten-1 refs cut 1)))
;; Finally, collect the references back into a string and insert
;; it into the buffer.
- (let ((refstring (mapconcat #'identity refs " ")))
- (if (and message-this-is-news message-cater-to-broken-inn)
- (insert (capitalize (symbol-name header)) ": "
- refstring "\n")
- (message-fill-header header refstring)))))
+ (message-fill-header header (mapconcat #'identity refs " "))))
(defun message-position-point ()
"Move point to where the user probably wants to find it."
"Whether \\<message-mode-map>\\[message-beginning-of-line]\
goes to beginning of header values."
:group 'message-buffers
+ :link '(custom-manual "(message)Movement")
:type 'boolean)
(defun message-beginning-of-line (&optional n)
(message-point-in-header-p))
(let* ((here (point))
(bol (progn (beginning-of-line n) (point)))
- (eol (gnus-point-at-eol))
+ (eol (point-at-eol))
(eoh (re-search-forward ": *" eol t)))
(if (or (not eoh) (equal here eoh))
(goto-char bol)
(when message-default-headers
(insert message-default-headers)
(or (bolp) (insert ?\n)))
- (put-text-property
- (point)
- (progn
- (insert mail-header-separator "\n")
- (1- (point)))
- 'read-only nil)
+ (insert mail-header-separator "\n")
(forward-line -1)
(when (message-news-p)
(when message-default-news-headers
(defun message-get-reply-headers (wide &optional to-address address-headers)
(let (follow-to mct never-mct to cc author mft recipients)
;; Find all relevant headers we need.
- (setq to (message-fetch-field "to")
- cc (message-fetch-field "cc")
- mct (message-fetch-field "mail-copies-to")
- author (or (message-fetch-field "mail-reply-to")
- (message-fetch-field "reply-to")
- (message-fetch-field "from")
- "")
- mft (and message-use-mail-followup-to
- (message-fetch-field "mail-followup-to")))
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ ;; Gmane renames "To". Look at "Original-To", too, if it is present in
+ ;; message-header-synonyms.
+ (setq to (or (message-fetch-field "to")
+ (and (loop for synonym in message-header-synonyms
+ when (memq 'Original-To synonym)
+ return t)
+ (message-fetch-field "original-to")))
+ cc (message-fetch-field "cc")
+ mct (message-fetch-field "mail-copies-to")
+ author (or (message-fetch-field "mail-reply-to")
+ (message-fetch-field "reply-to")
+ (message-fetch-field "from")
+ "")
+ mft (and message-use-mail-followup-to
+ (message-fetch-field "mail-followup-to"))))
;; Handle special values of Mail-Copies-To.
(when mct
cur)))
+(defun message-is-yours-p ()
+ "Non-nil means current article is yours.
+If you have added 'cancel-messages to 'message-shoot-gnksa-feet', all articles
+are yours except those that have Cancel-Lock header not belonging to you.
+Instead of shooting GNKSA feet, you should modify 'message-alternative-emails'
+regexp to match all of yours addresses."
+ ;; Canlock-logic as suggested by Per Abrahamsen
+ ;; <abraham@dina.kvl.dk>
+ ;;
+ ;; IF article has cancel-lock THEN
+ ;; IF we can verify it THEN
+ ;; issue cancel
+ ;; ELSE
+ ;; error: cancellock: article is not yours
+ ;; ELSE
+ ;; Use old rules, comparing sender...
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head-1)
+ (if (message-fetch-field "Cancel-Lock")
+ (if (null (canlock-verify))
+ t
+ (error "Failed to verify Cancel-lock: This article is not yours"))
+ (let (sender from)
+ (or
+ (message-gnksa-enable-p 'cancel-messages)
+ (and (setq sender (message-fetch-field "sender"))
+ (string-equal (downcase sender)
+ (downcase (message-make-sender))))
+ ;; Email address in From field equals to our address
+ (and (setq from (message-fetch-field "from"))
+ (string-equal
+ (downcase (cadr (mail-extract-address-components from)))
+ (downcase (cadr (mail-extract-address-components
+ (message-make-from))))))
+ ;; Email address in From field matches
+ ;; 'message-alternative-emails' regexp
+ (and from
+ message-alternative-emails
+ (string-match
+ message-alternative-emails
+ (cadr (mail-extract-address-components from))))))))))
;;;###autoload
(defun message-cancel-news (&optional arg)
(interactive "P")
(unless (message-news-p)
(error "This is not a news article; canceling is impossible"))
- (let (from newsgroups message-id distribution buf sender)
+ (let (from newsgroups message-id distribution buf)
(save-excursion
;; Get header info from original article.
(save-restriction
(message-narrow-to-head-1)
(setq from (message-fetch-field "from")
- sender (message-fetch-field "sender")
newsgroups (message-fetch-field "newsgroups")
message-id (message-fetch-field "message-id" t)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
- (unless (or
- ;; Canlock-logic as suggested by Per Abrahamsen
- ;; <abraham@dina.kvl.dk>
- ;;
- ;; IF article has cancel-lock THEN
- ;; IF we can verify it THEN
- ;; issue cancel
- ;; ELSE
- ;; error: cancellock: article is not yours
- ;; ELSE
- ;; Use old rules, comparing sender...
- (if (message-fetch-field "Cancel-Lock")
- (if (null (canlock-verify))
- t
- (error "Failed to verify Cancel-lock: This article is not yours"))
- nil)
- (message-gnksa-enable-p 'cancel-messages)
- (and sender
- (string-equal
- (downcase sender)
- (downcase (message-make-sender))))
- (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
+ (unless (message-is-yours-p)
(error "This article is not yours"))
(when (yes-or-no-p "Do you really want to cancel this article? ")
;; Make control message.
This is done simply by taking the old article and adding a Supersedes
header line with the old Message-ID."
(interactive)
- (let ((cur (current-buffer))
- (sender (message-fetch-field "sender"))
- (from (message-fetch-field "from")))
+ (let ((cur (current-buffer)))
;; Check whether the user owns the article that is to be superseded.
- (unless (or
- ;; Canlock-logic as suggested by Per Abrahamsen
- ;; <abraham@dina.kvl.dk>
- ;;
- ;; IF article has cancel-lock THEN
- ;; IF we can verify it THEN
- ;; issue cancel
- ;; ELSE
- ;; error: cancellock: article is not yours
- ;; ELSE
- ;; Use old rules, comparing sender...
- (if (message-fetch-field "Cancel-Lock")
- (if (null (canlock-verify))
- t
- (error "Failed to verify Cancel-lock: This article is not yours"))
- nil)
- (message-gnksa-enable-p 'cancel-messages)
- (and sender
- (string-equal
- (downcase sender)
- (downcase (message-make-sender))))
- (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
+ (unless (message-is-yours-p)
(error "This article is not yours"))
;; Get a normal message buffer.
(message-pop-to-buffer (message-buffer-name "supersede"))
(defvar message-forward-decoded-p nil
"Non-nil means the original message is decoded.")
-(defun message-forward-subject-author-subject (subject)
+(defun message-forward-subject-name-subject (subject)
"Generate a SUBJECT for a forwarded message.
The form is: [Source] Subject, where if the original message was mail,
-Source is the sender, and if the original message was news, Source is
-the list of newsgroups is was posted to."
- (concat "["
- (let ((prefix
- (or (message-fetch-field "newsgroups")
- (message-fetch-field "from")
- "(nowhere)")))
+Source is the name of the sender, and if the original message was
+news, Source is the list of newsgroups is was posted to."
+ (let* ((group (message-fetch-field "newsgroups"))
+ (from (message-fetch-field "from"))
+ (prefix
+ (if group
+ (gnus-group-decoded-name group)
+ (or (and from (car (gnus-extract-address-components from)))
+ "(nowhere)"))))
+ (concat "["
(if message-forward-decoded-p
prefix
- (mail-decode-encoded-word-string prefix)))
- "] " subject))
+ (mail-decode-encoded-word-string prefix))
+ "] " subject)))
-(defun message-forward-subject-name-subject (subject)
+(defun message-forward-subject-author-subject (subject)
"Generate a SUBJECT for a forwarded message.
The form is: [Source] Subject, where if the original message was mail,
-Source is the name of the sender, and if the original message was
-news, Source is the list of newsgroups is was posted to."
- (concat "["
- (let ((prefix
- (or (message-fetch-field "newsgroups")
- (let ((from (message-fetch-field "from")))
- (and from
- (cdr (mail-header-parse-address from))))
- "(nowhere)")))
+Source is the sender, and if the original message was news, Source is
+the list of newsgroups is was posted to."
+ (let* ((group (message-fetch-field "newsgroups"))
+ (prefix
+ (if group
+ (gnus-group-decoded-name group)
+ (or (message-fetch-field "from")
+ "(nowhere)"))))
+ (concat "["
(if message-forward-decoded-p
prefix
- (mail-decode-encoded-word-string prefix)))
- "] " subject))
+ (mail-decode-encoded-word-string prefix))
+ "] " subject)))
(defun message-forward-subject-fwd (subject)
"Generate a SUBJECT for a forwarded message.
The form is: Fwd: Subject, where Subject is the original subject of
the message."
- (concat "Fwd: " subject))
+ (if (string-match "^Fwd: " subject)
+ subject
+ (concat "Fwd: " subject)))
(defun message-make-forward-subject ()
"Return a Subject header suitable for the message in the current buffer."
(message-mail nil subject))
(message-forward-make-body cur digest)))
+(defun message-forward-make-body-plain (forward-buffer)
+ (insert
+ "\n-------------------- Start of forwarded message --------------------\n")
+ (let ((b (point)) e)
+ (insert
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (insert
+ (with-current-buffer forward-buffer
+ (mm-with-unibyte-current-buffer (buffer-string))))
+ (mm-enable-multibyte)
+ (mime-to-mml)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (buffer-string)))
+ (setq e (point))
+ (insert
+ "\n-------------------- End of forwarded message --------------------\n")
+ (when (and (not current-prefix-arg)
+ message-forward-ignored-headers)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (message-remove-header message-forward-ignored-headers 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)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mml-insert-buffer forward-buffer)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (goto-char (point-max)))
+ (setq e (point))
+ (insert "<#/part>\n")))
+
+(defun message-forward-make-body-mml (forward-buffer)
+ (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
+ (let ((b (point)) e)
+ (if (not message-forward-decoded-p)
+ (insert
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (insert
+ (with-current-buffer forward-buffer
+ (mm-with-unibyte-current-buffer (buffer-string))))
+ (mm-enable-multibyte)
+ (mime-to-mml)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (buffer-string)))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mml-insert-buffer forward-buffer)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (goto-char (point-max))))
+ (setq e (point))
+ (insert "<#/mml>\n")
+ (when (and (not current-prefix-arg)
+ message-forward-ignored-headers)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (message-remove-header message-forward-ignored-headers t)))))
+
+(defun message-forward-make-body-digest-plain (forward-buffer)
+ (insert
+ "\n-------------------- Start of forwarded message --------------------\n")
+ (let ((b (point)) e)
+ (mml-insert-buffer forward-buffer)
+ (setq e (point))
+ (insert
+ "\n-------------------- End of forwarded message --------------------\n")))
+
+(defun message-forward-make-body-digest-mime (forward-buffer)
+ (insert "\n<#multipart type=digest>\n")
+ (let ((b (point)) e)
+ (insert-buffer-substring forward-buffer)
+ (setq e (point))
+ (insert "<#/multipart>\n")
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (delete-region (point-min) (point-max)))))
+
+(defun message-forward-make-body-digest (forward-buffer)
+ (if message-forward-as-mime
+ (message-forward-make-body-digest-mime forward-buffer)
+ (message-forward-make-body-digest-plain forward-buffer)))
+
;;;###autoload
(defun message-forward-make-body (forward-buffer &optional digest)
;; Put point where we want it before inserting the forwarded
(if message-forward-before-signature
(message-goto-body)
(goto-char (point-max)))
- (if message-forward-as-mime
- (if digest
- (insert "\n<#multipart type=digest>\n")
- (if message-forward-show-mml
- (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
- (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))
- (insert "\n-------------------- Start of forwarded message --------------------\n"))
- (let ((b (point)) e)
- (if digest
- (if message-forward-as-mime
- (insert-buffer-substring forward-buffer)
- (mml-insert-buffer forward-buffer))
- (if (and message-forward-show-mml
- (not message-forward-decoded-p))
- (insert
- (with-temp-buffer
- (mm-disable-multibyte)
- (insert
- (with-current-buffer forward-buffer
- (mm-with-unibyte-current-buffer (buffer-string))))
- (mm-enable-multibyte)
- (mime-to-mml)
- (goto-char (point-min))
- (when (looking-at "From ")
- (replace-match "X-From-Line: "))
- (buffer-string)))
- (save-restriction
- (narrow-to-region (point) (point))
- (mml-insert-buffer forward-buffer)
- (goto-char (point-min))
- (when (looking-at "From ")
- (replace-match "X-From-Line: "))
- (goto-char (point-max)))))
- (setq e (point))
+ (if digest
+ (message-forward-make-body-digest forward-buffer)
(if message-forward-as-mime
- (if digest
- (insert "<#/multipart>\n")
- (if message-forward-show-mml
- (insert "<#/mml>\n")
- (insert "<#/part>\n")))
- (insert "\n-------------------- End of forwarded message --------------------\n"))
- (if (and digest message-forward-as-mime)
- (save-restriction
- (narrow-to-region b e)
- (goto-char b)
- (narrow-to-region (point)
- (or (search-forward "\n\n" nil t) (point)))
- (delete-region (point-min) (point-max)))
- (when (and (not current-prefix-arg)
- message-forward-ignored-headers
- ;; don't remove CTE, X-Gnus etc when doing "raw" forward:
- message-forward-show-mml)
- (save-restriction
- (narrow-to-region b e)
- (goto-char b)
- (narrow-to-region (point)
- (or (search-forward "\n\n" nil t) (point)))
- (message-remove-header message-forward-ignored-headers t)))))
+ (if (and message-forward-show-mml
+ (not (and (eq message-forward-show-mml 'best)
+ (with-current-buffer forward-buffer
+ (goto-char (point-min))
+ (re-search-forward
+ "Content-Type: *multipart/\\(signed\\|encrypted\\)"
+ nil t)))))
+ (message-forward-make-body-mml forward-buffer)
+ (message-forward-make-body-mime forward-buffer))
+ (message-forward-make-body-plain forward-buffer)))
(message-position-point))
;;;###autoload
(defun message-forward-rmail-make-body (forward-buffer)
(save-window-excursion
(set-buffer forward-buffer)
- ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs
- ;; 20. FIXIT, or we drop support for rmail in Emacs 20.
(if (rmail-msg-is-pruned)
(rmail-msg-restore-non-pruned-header)))
(message-forward-make-body forward-buffer))
message-setup-hook)
(message-setup `((To . ,address))))
;; Insert our usual headers.
- (message-generate-headers '(From Date To))
+ (message-generate-headers '(From Date To Message-ID))
(message-narrow-to-headers)
;; Remove X-Draft-From header etc.
(message-remove-header message-ignored-mail-headers t)
(mm-insert-part handles)
(undo-boundary)
(goto-char (point-min))
- (search-forward "\n\n" nil t)
- (if (or (and (re-search-forward message-unsent-separator nil t)
- (forward-line 1))
- (re-search-forward "^Return-Path:.*\n" nil t))
- ;; We remove everything before the bounced mail.
- (delete-region
- (point-min)
- (if (re-search-forward "^[^ \n\t]+:" nil t)
- (match-beginning 0)
- (point)))
+ (re-search-forward "\n\n+" nil t)
+ (setq boundary (point))
+ ;; We remove everything before the bounced mail.
+ (if (or (re-search-forward message-unsent-separator nil t)
+ (progn
+ (search-forward "\n\n" nil 'move)
+ (re-search-backward "^Return-Path:.*\n" boundary t)))
+ (progn
+ (forward-line 1)
+ (delete-region (point-min)
+ (if (re-search-forward "^[^ \n\t]+:" nil t)
+ (match-beginning 0)
+ (point))))
+ (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)
(if (eq (char-after) (char-after (- (point) 2)))
(delete-char -2))))))
-(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+(defun message-exchange-point-and-mark ()
+ "Exchange point and mark, but don't activate region if it was inactive."
+ (unless (prog1
+ (message-mark-active-p)
+ (exchange-point-and-mark))
+ (setq mark-active nil)))
+
(defalias 'message-make-overlay 'make-overlay)
(defalias 'message-delete-overlay 'delete-overlay)
(defalias 'message-overlay-put 'overlay-put)
"*Function to execute when `message-tab' (TAB) is executed in the body.
If nil, the function bound in `text-mode-map' or `global-map' is executed."
:group 'message
+ :link '(custom-manual "(message)Various Commands")
:type 'function)
(defun message-tab ()
(delete-region (point) (progn (forward-line 3) (point))))))))))
(defun message-expand-name ()
- (if (fboundp 'bbdb-complete-name)
- (bbdb-complete-name)
- (expand-abbrev)))
+ (cond ((when (boundp 'eudc-protocol) eudc-protocol)
+ (eudc-expand-inline))
+ ((fboundp 'bbdb-complete-name)
+ (bbdb-complete-name))
+ (t
+ (expand-abbrev))))
;;; Help stuff.
(list list))))
(defun message-generate-new-buffer-clone-locals (name &optional varstr)
- "Create and return a buffer with name based on NAME using `generate-new-buffer.'
+ "Create and return a buffer with name based on NAME using `generate-new-buffer'.
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."
+regexp VARSTR."
(let ((oldbuf (current-buffer)))
(save-excursion
(set-buffer (generate-new-buffer name))