;;; 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>
(eval-when-compile
(require 'cl)
+ (defvar gnus-message-group-art)
(defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
(require 'canlock)
(require 'mailheader)
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
-(eval-and-compile
- (autoload 'sha1 "sha1-el"))
(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\\):"
+(defcustom message-ignored-bounced-headers
+ "^\\(Received\\|Return-Path\\|Delivered-To\\):"
"*Regexp that matches headers to be removed in resent bounced mail."
:group 'message-interface
:type 'regexp)
`approved', `sender', `empty', `empty-headers', `message-id', `from',
`subject', `shorten-followup-to', `existing-newsgroups',
`buffer-file-name', `unchanged', `newsgroups', `reply-to',
-'continuation-headers', and `long-header-lines'."
+`continuation-headers', `long-header-lines', `invisible-text' and
+`illegible-text'."
:group 'message-news
:type '(repeat sexp)) ; Fixme: improve this
`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
- "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message."
+ "*Non-nil means forward messages as an inline/rfc822 MIME section.
+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
- "*If non-nil, forward messages are shown as mml. Otherwise, forward 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
- "*If non-nil, put forwarded message before signature, else after."
+ "*Non-nil means put forwarded message before signature, else after."
:group 'message-forwarding
:type 'boolean)
(defcustom message-wash-forwarded-subjects nil
- "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward."
+ "*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))
(mm-coding-system-p 'utf-8)
+ (executable-find idna-program)
'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
"^|? *---+ +Message text follows: +---+ *|?$")
"A regexp that matches the separator before the text of a failed message.")
+(defvar message-field-fillers
+ '((To message-fill-field-address)
+ (Cc message-fill-field-address)
+ (From message-fill-field-address))
+ "Alist of header names/filler functions.")
+
(defvar message-header-format-alist
`((Newsgroups)
- (To . message-fill-address)
- (Cc . message-fill-address)
+ (To)
+ (Cc)
(Subject)
(In-Reply-To)
(Fcc)
: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
(looking-at message-unix-mail-delimiter))))
(defun message-fetch-field (header &optional not-all)
- "The same as `mail-fetch-field', only remove all newlines."
+ "The same as `mail-fetch-field', only remove all newlines.
+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)
+ (while (looking-at "[ \t]")
+ (forward-line -1))
(narrow-to-region
(point)
(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)))
(mail-narrow-to-head)
(message-fetch-field header))))
-(defun message-functionp (form)
- "Return non-nil if FORM is funcallable."
- (or (and (symbolp form) (fboundp form))
- (and (listp form) (eq (car form) 'lambda))
- (byte-code-function-p form)))
-
(defun message-strip-list-identifiers (subject)
"Remove list identifiers in `gnus-list-identifiers' from string SUBJECT."
(require 'gnus-sum) ; for gnus-list-identifiers
;;;###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: ")))
(zerop (string-width new-subject))
(string-match "^[ \t]*$" new-subject))))
(save-excursion
- (let ((old-subject (message-fetch-field "Subject")))
+ (let ((old-subject
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "Subject"))))
(cond ((not old-subject)
(error "No current subject"))
((not (string-match
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)
(defun message-reduce-to-to-cc ()
"Replace contents of To: header with contents of Cc: or Bcc: header."
(interactive)
- (let ((cc-content (message-fetch-field "cc"))
+ (let ((cc-content
+ (save-restriction (message-narrow-to-headers)
+ (message-fetch-field "cc")))
(bcc nil))
(if (and (not cc-content)
- (setq cc-content (message-fetch-field "bcc")))
+ (setq cc-content
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "bcc"))))
(setq bcc t))
(cond (cc-content
(save-excursion
(message-goto-to)
(message-delete-line)
(insert (concat "To: " cc-content "\n"))
- (message-remove-header (if bcc
- "bcc"
- "cc")))))))
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header (if bcc
+ "bcc"
+ "cc"))))))))
;;; End of functions adopted from `message-utils.el'.
(1+ max)))))
(message-sort-headers-1))))
+(defun message-kill-address ()
+ "Kill the address under point."
+ (interactive)
+ (let ((start (point)))
+ (message-skip-to-next-address)
+ (kill-region start (point))))
\f
(define-key message-mode-map "\C-c\C-d" 'message-dont-send)
(define-key message-mode-map "\C-c\n" 'gnus-delay-article)
+ (define-key message-mode-map "\C-c\M-k" 'message-kill-address)
(define-key message-mode-map "\C-c\C-e" 'message-elide-region)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
(define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
- ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
(define-key message-mode-map [remap split-line] 'message-split-line)
(define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
["Insert Signature" message-insert-signature t]
["Caesar (rot13) Message" message-caesar-buffer-body t]
["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)]
- ["Elide Region" message-elide-region
+ ["Elide Region" message-elide-region
:active (message-mark-active-p)
,@(if (featurep 'xemacs) nil
'(:help "Replace text in region with an ellipsis"))]
- ["Delete Outside Region" message-delete-not-region
+ ["Delete Outside Region" message-delete-not-region
:active (message-mark-active-p)
,@(if (featurep 'xemacs) nil
'(:help "Delete all quoted text outside region"))]
(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)
(when (eq message-mail-alias-type 'abbrev)
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
- (mail-aliases-setup)))
+ (if (fboundp 'mail-aliases-setup) ; warning avoidance
+ (mail-aliases-setup))))
(unless buffer-file-name
(message-set-auto-save-file-name))
(unless (buffer-base-buffer)
"---+$\\|" ; 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))
Cc: header are also put into the MFT."
(interactive "P")
- (message-remove-header "Mail-Followup-To")
- (let* ((cc (and include-cc (message-fetch-field "Cc")))
- (tos (if cc
- (concat (message-fetch-field "To") "," cc)
- (message-fetch-field "To"))))
+ (let* (cc tos)
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Mail-Followup-To")
+ (setq cc (and include-cc (message-fetch-field "Cc")))
+ (setq tos (if cc
+ (concat (message-fetch-field "To") "," cc)
+ (message-fetch-field "To"))))
(message-goto-mail-followup-to)
(insert (concat tos ", " user-mail-address))))
(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.
(interactive (list (if current-prefix-arg 'full)))
(if (if (boundp 'filladapt-mode) filladapt-mode)
nil
- (message-newline-and-reformat arg t)
+ (if (message-point-in-header-p)
+ (message-fill-field)
+ (message-newline-and-reformat arg t))
t))
;; Is it better to use `mail-header-end'?
((and (null message-signature)
force)
t)
- ((message-functionp message-signature)
+ ((functionp message-signature)
(funcall message-signature))
((listp message-signature)
(eval message-signature))
"Insert header to mark message as important."
(interactive)
(save-excursion
- (message-remove-header "Importance")
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Importance"))
(message-goto-eoh)
(insert "Importance: high\n")))
"Insert header to mark message as unimportant."
(interactive)
(save-excursion
- (message-remove-header "Importance")
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Importance"))
(message-goto-eoh)
(insert "Importance: low\n")))
(let ((valid '("high" "normal" "low"))
(new "high")
cur)
- (when (setq cur (message-fetch-field "Importance"))
- (message-remove-header "Importance")
- (setq new (cond ((string= cur "high")
- "low")
- ((string= cur "low")
- "normal")
- (t
- "high"))))
+ (save-restriction
+ (message-narrow-to-headers)
+ (when (setq cur (message-fetch-field "Importance"))
+ (message-remove-header "Importance")
+ (setq new (cond ((string= cur "high")
+ "low")
+ ((string= cur "low")
+ "normal")
+ (t
+ "high")))))
(message-goto-eoh)
(insert (format "Importance: %s\n" new)))))
Note that this should not be used in newsgroups."
(interactive)
(save-excursion
- (message-remove-header "Disposition-Notification-To")
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Disposition-Notification-To"))
(message-goto-eoh)
(insert (format "Disposition-Notification-To: %s\n"
- (or (message-fetch-field "From") (message-make-from))))))
+ (or (message-field-value "Reply-to")
+ (message-field-value "From")
+ (message-make-from))))))
(defun message-elide-region (b e)
"Elide the text in the region.
(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)
- (add-text-properties point (1+ point)
- '(invisible nil face highlight
- font-lock-face highlight)))
+ (put-text-property point (1+ point) 'invisible nil)
+ (message-overlay-put (message-make-overlay point (1+ point))
+ 'face 'highlight))
(unless (yes-or-no-p
- "Invisible text found and made visible; continue posting? ")
+ "Invisible text found and made visible; continue sending? ")
(error "Invisible text found and made visible")))))
(message-check 'illegible-text
(let (found choice)
(and (mm-multibyte-p)
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
- control-1)))))
- (add-text-properties (point) (1+ (point))
- '(font-lock-face highlight face highlight))
+ 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))
(when found
(setq choice
(gnus-multiple-choice
- "Illegible text found. Continue posting?"
- '((?d "Remove and continue posting")
- (?r "Replace with dots and continue posting")
- (?i "Ignore and continue posting")
+ "Non-printable characters found. Continue sending?"
+ '((?d "Remove non-printable characters and send")
+ (?r "Replace non-printable characters with dots and send")
+ (?i "Ignore non-printable characters and send")
(?e "Continue editing"))))
(if (eq choice ?e)
- (error "Illegible text found"))
+ (error "Non-printable characters"))
(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)
+ ;; Fixme: Wrong for Emacs 22 and for things
+ ;; like undecable utf-8. Should at least
+ ;; 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)
- (remove-text-properties (point) (1+ (point))
- '(font-lock-face highlight face highlight))
+ (message-kill-all-overlays)
(delete-char 1)
(when (eq choice ?r)
(insert "."))))
(ignore-errors
(cond
;; A simple function.
- ((message-functionp (car actions))
+ ((functionp (car actions))
(funcall (car actions)))
;; Something to be evaled.
(t
(or (= (preceding-char) ?\n)
(insert ?\n))
(message-cleanup-headers)
+ ;; FIXME: we're inserting the courtesy copy after encoding.
+ ;; This is wrong if the courtesy copy string contains
+ ;; non-ASCII characters. -- jh
(when
(save-restriction
(message-narrow-to-headers)
(or (message-fetch-field "cc")
(message-fetch-field "bcc")
(message-fetch-field "to"))
- (let ((content-type (message-fetch-field "content-type")))
- (or
- (not content-type)
- (string= "text/plain"
- (car
- (mail-header-parse-content-type
- content-type)))))))
+ (let ((content-type (message-fetch-field
+ "content-type")))
+ (and
+ (or
+ (not content-type)
+ (string= "text/plain"
+ (car
+ (mail-header-parse-content-type
+ content-type))))
+ (not
+ (string= "base64"
+ (message-fetch-field
+ "content-transfer-encoding")))))))
(message-insert-courtesy-copy))
(if (or (not message-send-mail-partially-limit)
(< (point-max) message-send-mail-partially-limit)
(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
;; 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 (message-functionp 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,
"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))
(defun message-send-news (&optional arg)
(let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
(case-fold-search nil)
- (method (if (message-functionp message-post-method)
+ (method (if (functionp message-post-method)
(funcall message-post-method arg)
message-post-method))
(newsgroups-field (save-restriction
(if followup-to
(concat newsgroups "," followup-to)
newsgroups)))
- (post-method (if (message-functionp message-post-method)
+ (post-method (if (functionp message-post-method)
(funcall message-post-method)
message-post-method))
;; KLUDGE to handle nnvirtual groups. Doing this right
"Make an Organization header."
(let* ((organization
(when message-user-organization
- (if (message-functionp message-user-organization)
+ (if (functionp message-user-organization)
(funcall message-user-organization)
message-user-organization))))
(with-temp-buffer
(defun message-make-distribution ()
"Make a Distribution header."
(let ((orig-distribution (message-fetch-reply-field "distribution")))
- (cond ((message-functionp message-distribution-function)
+ (cond ((functionp message-distribution-function)
(funcall message-distribution-function))
(t orig-distribution))))
(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)
user-domain)
;; Default to this bogus thing.
(t
- (concat system-name ".i-did-not-set--mail-host-address--so-tickle-me")))))
+ (concat system-name
+ ".i-did-not-set--mail-host-address--so-tickle-me")))))
(defun message-make-host-name ()
"Return the name of the host."
list
msg-recipients))))))
-(defun message-idna-inside-rhs-p ()
- "Return t iff point is inside a RHS (heuristically).
-Only works properly if header contains mailbox-list or address-list.
-I.e., calling it on a Subject: header is useless."
- (save-restriction
- (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t)
- (point-min)))
- (save-excursion (or (re-search-forward "^[^ \t]" nil t)
- (point-max))))
- (if (re-search-backward "[\\\n\r\t ]"
- (save-excursion (search-backward "@" nil t)) t)
- ;; whitespace between @ and point
- nil
- (let ((dquote 1) (paren 1))
- (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
- (incf dquote))
- (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
- (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>]+\\)"
- (or (save-excursion
- (re-search-forward "^[^ \t]" nil t))
- (point-max))
- t)
- (setq rhs (match-string-no-properties 1)
- startpos (match-beginning 1)
- endpos (match-end 1))
- (when (save-match-data
- (and (message-idna-inside-rhs-p)
- (setq ace (idna-to-ascii rhs))
- (not (string= rhs ace))
- (if (eq message-use-idna 'ask)
- (unwind-protect
- (progn
- (setq ovl (message-make-overlay startpos
- endpos))
- (message-overlay-put ovl 'face 'highlight)
- (y-or-n-p
- (format "Replace with `%s'? " ace)))
- (message "")
- (message-delete-overlay ovl))
- message-use-idna)))
- (replace-match (concat "@" ace)))))))
+ (let ((field (message-fetch-field header))
+ rhs ace address)
+ (when field
+ (dolist (address (mail-header-parse-addresses field))
+ (setq address (car address)
+ rhs (downcase (cadr (split-string address "@")))
+ ace (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? " rhs ace))))
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" header ":") nil t)
+ (message-narrow-to-field)
+ (while (search-forward (concat "@" rhs) nil t)
+ (replace-match (concat "@" ace) t t))
+ (goto-char (point-max))
+ (widen)))))))
(defun message-idna-to-ascii-rhs ()
"Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
(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.
(setq header (cdr elem))
- (or (and (message-functionp (cdr elem))
+ (or (and (functionp (cdr elem))
(funcall (cdr elem)))
(and (boundp (cdr elem))
(symbol-value (cdr elem)))))
;; this function.
(or (and (stringp (cdr elem))
(cdr elem))
- (and (message-functionp (cdr elem))
+ (and (functionp (cdr elem))
(funcall (cdr elem)))))
((and (boundp header)
(symbol-value 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))
+ (goto-char (message-fill-field))
;; We check whether the value was ended by a
- ;; newline. If now, we insert one.
+ ;; newline. If not, we insert one.
(unless (bolp)
(insert "\n"))
(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
- (insert value)))
+ (push header-string message-inserted-headers)
+ (insert value)
+ (message-fill-field)))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
;;; Setting up a message buffer
;;;
+(defun message-skip-to-next-address ()
+ (let ((end (save-excursion
+ (message-next-header)
+ (point)))
+ quoted char)
+ (when (looking-at ",")
+ (forward-char 1))
+ (while (and (not (= (point) end))
+ (or (not (eq char ?,))
+ quoted))
+ (skip-chars-forward "^,\"" (point-max))
+ (when (eq (setq char (following-char)) ?\")
+ (setq quoted (not quoted)))
+ (unless (= (point) end)
+ (forward-char 1)))
+ (skip-chars-forward " \t\n")))
+
(defun message-fill-address (header value)
- (save-restriction
- (narrow-to-region (point) (point))
- (insert (capitalize (symbol-name header))
- ": "
- (if (consp value) (car value) value)
- "\n")
- (narrow-to-region (point-min) (1- (point-max)))
- (let (quoted last)
- (goto-char (point-min))
- (while (not (eobp))
- (skip-chars-forward "^,\"" (point-max))
- (if (or (eq (char-after) ?,)
- (eobp))
- (when (not quoted)
- (if (and (> (current-column) 78)
- last)
- (progn
- (save-excursion
- (goto-char last)
- (insert "\n\t"))
- (setq last (1+ (point))))
- (setq last (1+ (point)))))
- (setq quoted (not quoted)))
- (unless (eobp)
- (forward-char 1))))
- (goto-char (point-max))
- (widen)
- (forward-line 1)))
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")
+ (message-fill-field-address))
(defun message-split-line ()
"Split current line, moving portion beyond point vertically down.
(split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
(error
(split-line))))
-
-(defun message-fill-header (header value)
+(defun message-insert-header (header value)
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)))
+
+(defun message-field-name ()
+ (save-excursion
+ (goto-char (point-min))
+ (when (looking-at "\\([^:]+\\):")
+ (intern (capitalize (match-string 1))))))
+
+(defun message-fill-field ()
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-field)
+ (let ((field-name (message-field-name)))
+ (funcall (or (cadr (assq field-name message-field-fillers))
+ 'message-fill-field-general)))
+ (point-max))))
+
+(defun message-fill-field-address ()
+ (while (not (eobp))
+ (message-skip-to-next-address)
+ (let (last)
+ (if (and (> (current-column) 78)
+ last)
+ (progn
+ (save-excursion
+ (goto-char last)
+ (insert "\n\t"))
+ (setq last (1+ (point))))
+ (setq last (1+ (point)))))))
+
+(defun message-fill-field-general ()
(let ((begin (point))
(fill-column 78)
(fill-prefix "\t"))
- (insert (capitalize (symbol-name header))
- ": "
- (if (consp value) (car value) value)
- "\n")
- (save-restriction
- (narrow-to-region begin (point))
- (fill-region-as-paragraph begin (point))
- ;; Tapdance around looong Message-IDs.
- (forward-line -1)
- (when (looking-at "[ \t]*$")
- (message-delete-line))
- (goto-char begin)
- (re-search-forward ":" nil t)
- (when (looking-at "\n[ \t]+")
- (replace-match " " t t))
- (goto-char (point-max)))))
+ (while (and (search-forward "\n" nil t)
+ (not (eobp)))
+ (replace-match " " t t))
+ (fill-region-as-paragraph begin (point-max))
+ ;; Tapdance around looong Message-IDs.
+ (forward-line -1)
+ (when (looking-at "[ \t]*$")
+ (message-delete-line))
+ (goto-char begin)
+ (re-search-forward ":" nil t)
+ (when (looking-at "\n[ \t]+")
+ (replace-match " " t t))
+ (goto-char (point-max))))
(defun message-shorten-1 (list cut surplus)
"Cut SURPLUS elements out of LIST, beginning with CUTth one."
(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-insert-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-insert-header header (mapconcat #'identity refs " "))))
(defun message-position-point ()
"Move point to where the user probably wants to find it."
(sit-for 0)))
(defcustom message-beginning-of-line t
- "Whether C-a goes to beginning of header values."
+ "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)
- "Move point to beginning of header value or to beginning of line."
+ "Move point to beginning of header value or to beginning of line.
+The prefix argument N is passed directly to `beginning-of-line'.
+
+This command is identical to `beginning-of-line' if point is
+outside the message header or if the option `message-beginning-of-line'
+is nil.
+
+If point is in the message header and on a (non-continued) header
+line, move point to the beginning of the header value. If point
+is already there, move point to beginning of line. Therefore,
+repeated calls will toggle point between beginning of field and
+beginning of line."
(interactive "p")
(let ((zrs 'zmacs-region-stays))
(when (and (interactive-p) (boundp zrs))
(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)
"*")))
;; Check whether `message-generate-new-buffers' is a function,
;; and if so, call it.
- ((message-functionp message-generate-new-buffers)
+ ((functionp message-generate-new-buffers)
(funcall message-generate-new-buffers type to group))
((eq message-generate-new-buffers 'unsent)
(generate-new-buffer-name
(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
;; Allow customizations to have their say.
(if (not wide)
;; This is a regular reply.
- (when (message-functionp message-reply-to-function)
+ (when (functionp message-reply-to-function)
(save-excursion
(setq follow-to (funcall message-reply-to-function))))
;; This is a followup.
- (when (message-functionp message-wide-reply-to-function)
+ (when (functionp message-wide-reply-to-function)
(save-excursion
(setq follow-to
(funcall message-wide-reply-to-function)))))
(if (search-forward "\n\n" nil t)
(1- (point))
(point-max)))
- (when (message-functionp message-followup-to-function)
+ (when (functionp message-followup-to-function)
(setq follow-to
(funcall message-followup-to-function)))
(setq from (message-fetch-field "from")
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
- (mail-decode-encoded-word-string
- 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."
;; Apply funcs in order, passing subject generated by previous
;; func to the next one.
(while funcs
- (when (message-functionp (car funcs))
+ (when (functionp (car funcs))
(setq subject (funcall (car funcs) subject)))
(setq funcs (cdr funcs)))
subject))))
(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))
+(eval-when-compile (defvar rmail-enable-mime-composing))
+
+;; Fixme: Should have defcustom.
;;;###autoload
(defun message-insinuate-rmail ()
- "Let RMAIL uses message to forward."
+ "Let RMAIL use message to forward."
(interactive)
(setq rmail-enable-mime-composing t)
(setq rmail-insert-mime-forwarded-message-function
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)
+(defun message-kill-all-overlays ()
+ (if (featurep 'xemacs)
+ (map-extents (lambda (extent ignore) (delete-extent extent)))
+ (mapcar #'delete-overlay (overlays-in (point-min) (point-max)))))
;; Support for toolbar
(eval-when-compile
"*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))
;; coding: iso-8859-1
;; End:
+;;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0
;;; message.el ends here
projects / gnus / blobdiff