;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(put 'user-full-name 'custom-type 'string)
(defgroup message-various nil
- "Various Message Variables"
+ "Various Message Variables."
:link '(custom-manual "(message)Various Message Variables")
:group 'message)
(defgroup message-buffers nil
- "Message Buffers"
+ "Message Buffers."
:link '(custom-manual "(message)Message Buffers")
:group 'message)
(defgroup message-sending nil
- "Message Sending"
+ "Message Sending."
:link '(custom-manual "(message)Sending Variables")
:group 'message)
(defgroup message-interface nil
- "Message Interface"
+ "Message Interface."
:link '(custom-manual "(message)Interface")
:group 'message)
(defgroup message-forwarding nil
- "Message Forwarding"
+ "Message Forwarding."
:link '(custom-manual "(message)Forwarding")
:group 'message-interface)
(defgroup message-insertion nil
- "Message Insertion"
+ "Message Insertion."
:link '(custom-manual "(message)Insertion")
:group 'message)
(defgroup message-headers nil
- "Message Headers"
+ "Message Headers."
:link '(custom-manual "(message)Message Headers")
:group 'message)
(defgroup message-news nil
- "Composing News Messages"
+ "Composing News Messages."
:group 'message)
(defgroup message-mail nil
- "Composing Mail Messages"
+ "Composing Mail Messages."
:group 'message)
(defgroup message-faces nil
:link '(custom-manual "(message)Message Headers")
:type 'regexp)
-;; Fixme: Why are all these things autoloaded?
-
;;; marking inserted text
-;;;###autoload
(defcustom message-mark-insert-begin
"--8<---------------cut here---------------start------------->8---\n"
"How to mark the beginning of some inserted text."
:link '(custom-manual "(message)Insertion Variables")
:group 'message-various)
-;;;###autoload
(defcustom message-mark-insert-end
"--8<---------------cut here---------------end--------------->8---\n"
"How to mark the end of some inserted text."
:link '(custom-manual "(message)Insertion Variables")
:group 'message-various)
-;;;###autoload
-(defcustom message-archive-header
- "X-No-Archive: Yes\n"
+(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.google.com\) respect this header."
:version "22.1"
:link '(custom-manual "(message)Header Commands")
:group 'message-various)
-;;;###autoload
(defcustom message-archive-note
"X-No-Archive: Yes - save http://groups.google.com/"
"Note to insert why you wouldn't want this posting archived.
"Old target for cross-posts or follow-ups.")
(make-variable-buffer-local 'message-cross-post-old-target)
-;;;###autoload
(defcustom message-cross-post-default t
"When non-nil `message-cross-post-followup-to' will perform a crosspost.
If nil, `message-cross-post-followup-to' will only do a followup. Note that
:type 'boolean
:group 'message-various)
-;;;###autoload
-(defcustom message-cross-post-note
- "Crosspost & Followup-To: "
+(defcustom message-cross-post-note "Crosspost & Followup-To: "
"Note to insert before signature to notify of cross-post and follow-up."
:version "22.1"
:type 'string
:group 'message-various)
-;;;###autoload
-(defcustom message-followup-to-note
- "Followup-To: "
+(defcustom message-followup-to-note "Followup-To: "
"Note to insert before signature to notify of follow-up only."
:version "22.1"
:type 'string
:group 'message-various)
-;;;###autoload
-(defcustom message-cross-post-note-function
- 'message-cross-post-insert-note
+(defcustom message-cross-post-note-function 'message-cross-post-insert-note
"Function to use to insert note about Crosspost or Followup-To.
The function will be called with four arguments. The function should not only
insert a note, but also ensure old notes are deleted. See the documentation
:link '(custom-manual "(message)Message Buffers")
:type 'boolean)
+(defcustom message-kill-buffer-query t
+ "*Non-nil means that killing a modified message buffer has to be confirmed.
+This is used by `message-kill-buffer'."
+ :version "23.0" ;; No Gnus
+ :group 'message-buffers
+ :type 'boolean)
+
(eval-when-compile
(defvar gnus-local-organization))
(defcustom message-user-organization
(set-keymap-parent map minibuffer-local-map)
map)
"Keymap for `message-read-from-minibuffer'."
- :version "22.1")
+ :version "22.1"
+ :group 'message-various)
;;;###autoload
(defcustom message-citation-line-function 'message-insert-citation-line
(defcustom message-yank-prefix "> "
"*Prefix inserted on the lines of yanked messages.
Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
-See also `message-yank-cited-prefix'."
+See also `message-yank-cited-prefix' and `message-yank-empty-prefix'."
:type 'string
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
(defcustom message-yank-cited-prefix ">"
- "*Prefix inserted on cited or empty lines of yanked messages.
+ "*Prefix inserted on cited lines of yanked messages.
Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
-See also `message-yank-prefix'."
+See also `message-yank-prefix' and `message-yank-empty-prefix'."
+ :version "22.1"
+ :type 'string
+ :link '(custom-manual "(message)Insertion Variables")
+ :group 'message-insertion)
+
+(defcustom message-yank-empty-prefix ">"
+ "*Prefix inserted on empty lines of yanked messages.
+See also `message-yank-prefix' and `message-yank-cited-prefix'."
:version "22.1"
:type 'string
:link '(custom-manual "(message)Insertion Variables")
"*Function for citing an original message.
Predefined functions include `message-cite-original' and
`message-cite-original-without-signature'.
-Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil."
+Note that these functions use `mail-citation-hook' if that is non-nil."
:type '(radio (function-item message-cite-original)
(function-item message-cite-original-without-signature)
(function-item sc-cite-original)
table)
"Syntax table used while in Message mode.")
-(defface message-header-to-face
+(defface message-header-to
'((((class color)
(background dark))
(:foreground "green2" :bold t))
(:bold t :italic t)))
"Face used for displaying From headers."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-header-to-face 'face-alias 'message-header-to)
-(defface message-header-cc-face
+(defface message-header-cc
'((((class color)
(background dark))
(:foreground "green4" :bold t))
(:bold t)))
"Face used for displaying Cc headers."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-header-cc-face 'face-alias 'message-header-cc)
-(defface message-header-subject-face
+(defface message-header-subject
'((((class color)
(background dark))
(:foreground "green3"))
(:bold t)))
"Face used for displaying subject headers."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-header-subject-face 'face-alias 'message-header-subject)
-(defface message-header-newsgroups-face
+(defface message-header-newsgroups
'((((class color)
(background dark))
(:foreground "yellow" :bold t :italic t))
(:bold t :italic t)))
"Face used for displaying newsgroups headers."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-header-newsgroups-face 'face-alias 'message-header-newsgroups)
-(defface message-header-other-face
+(defface message-header-other
'((((class color)
(background dark))
(:foreground "#b00000"))
(:bold t :italic t)))
"Face used for displaying newsgroups headers."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-header-other-face 'face-alias 'message-header-other)
-(defface message-header-name-face
+(defface message-header-name
'((((class color)
(background dark))
(:foreground "DarkGreen"))
(:bold t)))
"Face used for displaying header names."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-header-name-face 'face-alias 'message-header-name)
-(defface message-header-xheader-face
+(defface message-header-xheader
'((((class color)
(background dark))
(:foreground "blue"))
(:bold t)))
"Face used for displaying X-Header headers."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-header-xheader-face 'face-alias 'message-header-xheader)
-(defface message-separator-face
+(defface message-separator
'((((class color)
(background dark))
(:foreground "blue3"))
(:bold t)))
"Face used for displaying the separator."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-separator-face 'face-alias 'message-separator)
-(defface message-cited-text-face
+(defface message-cited-text
'((((class color)
(background dark))
(:foreground "red"))
(:bold t)))
"Face used for displaying cited text names."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-cited-text-face 'face-alias 'message-cited-text)
-(defface message-mml-face
+(defface message-mml
'((((class color)
(background dark))
(:foreground "ForestGreen"))
(:bold t)))
"Face used for displaying MML."
:group 'message-faces)
+;; backward-compatibility alias
+(put 'message-mml-face 'face-alias 'message-mml)
(defun message-font-lock-make-header-matcher (regexp)
(let ((form
(let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
`((,(message-font-lock-make-header-matcher
(concat "^\\([Tt]o:\\)" content))
- (1 'message-header-name-face)
- (2 'message-header-to-face nil t))
+ (1 'message-header-name)
+ (2 'message-header-to nil t))
(,(message-font-lock-make-header-matcher
(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content))
- (1 'message-header-name-face)
- (2 'message-header-cc-face nil t))
+ (1 'message-header-name)
+ (2 'message-header-cc nil t))
(,(message-font-lock-make-header-matcher
(concat "^\\([Ss]ubject:\\)" content))
- (1 'message-header-name-face)
- (2 'message-header-subject-face nil t))
+ (1 'message-header-name)
+ (2 'message-header-subject nil t))
(,(message-font-lock-make-header-matcher
(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
- (1 'message-header-name-face)
- (2 'message-header-newsgroups-face nil t))
+ (1 'message-header-name)
+ (2 'message-header-newsgroups nil t))
(,(message-font-lock-make-header-matcher
(concat "^\\([A-Z][^: \n\t]+:\\)" content))
- (1 'message-header-name-face)
- (2 'message-header-other-face nil t))
+ (1 'message-header-name)
+ (2 'message-header-other nil t))
(,(message-font-lock-make-header-matcher
(concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
- (1 'message-header-name-face)
- (2 'message-header-name-face))
+ (1 'message-header-name)
+ (2 'message-header-name))
,@(if (and mail-header-separator
(not (equal mail-header-separator "")))
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
- 1 'message-separator-face))
+ 1 'message-separator))
nil)
((lambda (limit)
(re-search-forward (concat "^\\("
message-cite-prefix-regexp
"\\).*")
limit t))
- (0 'message-cited-text-face))
+ (0 'message-cited-text))
("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>"
- (0 'message-mml-face))))
+ (0 'message-mml))))
"Additional expressions to highlight in Message mode.")
(integer 1000000)))
(defcustom message-alternative-emails nil
- "A regexp to match the alternative email addresses.
-The first matched address (not primary one) is used in the From field."
+ "*Regexp matching alternative email addresses.
+The first address in the To, Cc or From headers of the original
+article matching this variable is used as the From field of
+outgoing messages.
+
+This variable has precedence over posting styles and anything that runs
+off `message-setup-hook'."
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
:type '(choice (const :tag "Always use primary" nil)
:type 'boolean)
(defcustom message-user-fqdn nil
- "*Domain part of Messsage-Ids."
+ "*Domain part of Message-Ids."
:version "22.1"
:group 'message-headers
:link '(custom-manual "(message)News Headers")
;;; Start of functions adopted from `message-utils.el'.
(defun message-strip-subject-trailing-was (subject)
- "Remove trailing \"(
Was: <old subject>)\" from SUBJECT lines.
+ "Remove trailing \"(
was: <old subject>)\" from SUBJECT lines.
Leading \"Re: \" is not stripped by this function. Use the function
`message-strip-subject-re' for this."
(let* ((query message-subject-trailing-was-query)
;;; End of functions adopted from `message-utils.el'.
+(defun message-remove-duplicates (list)
+ (let (new)
+ (while list
+ (or (member (car list) new)
+ (setq new (cons (car list) new)))
+ (setq list (cdr list)))
+ (nreverse new)))
+
(defun message-remove-header (header &optional is-regexp first reverse)
"Remove HEADER in the narrowed buffer.
If IS-REGEXP, HEADER is a regular expression.
(end-of-line -1)))
(unless (= point (point))
(kill-region point (point))
- (insert "\n"))))))
+ (unless (bolp)
+ (insert "\n")))))))
(defun message-newline-and-reformat (&optional arg not-break)
"Insert four newlines, and then reformat if inside quoted text.
Prefix arg means justify as well."
(interactive (list (if current-prefix-arg 'full)))
- (let (quoted point beg end leading-space bolp)
+ (let (quoted point beg end leading-space bolp fill-paragraph-function)
(setq point (point))
(beginning-of-line)
(setq beg (point))
(if point (goto-char point)))))
(defun message-fill-paragraph (&optional arg)
- "Like `fill-paragraph'."
+ "Message specific function to fill a paragraph.
+This function is used as the value of `fill-paragraph-function' in
+Message buffers and is not meant to be called directly."
(interactive (list (if current-prefix-arg 'full)))
(if (if (boundp 'filladapt-mode) filladapt-mode)
nil
(save-excursion
(goto-char start)
(while (< (point) (mark t))
- (if (or (looking-at ">") (looking-at "^$"))
- (insert message-yank-cited-prefix)
- (insert message-yank-prefix))
+ (cond ((looking-at ">")
+ (insert message-yank-cited-prefix))
+ ((looking-at "^$")
+ (insert message-yank-empty-prefix))
+ (t
+ (insert message-yank-prefix)))
(forward-line 1))))
(goto-char start)))
(when (and message-reply-buffer
message-cite-function)
(delete-windows-on message-reply-buffer t)
- (insert-buffer message-reply-buffer)
+ (push-mark (save-excursion
+ (insert-buffer-substring message-reply-buffer)
+ (point)))
(unless arg
(funcall message-cite-function))
(message-exchange-point-and-mark)
(push (buffer-name buffer) buffers))))
(nreverse buffers)))
-(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))))
- ;; 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)
- (goto-char end)
- (when (re-search-backward message-signature-separator start t)
- ;; Also peel off any blank lines before the signature.
- (forward-line -1)
- (while (looking-at "^[ \t]*$")
- (forward-line -1))
- (forward-line 1)
- (delete-region (point) end)
- (unless (search-backward "\n\n" start t)
- ;; Insert a blank line if it is peeled off.
- (insert "\n")))
- (goto-char start)
- (mapc 'funcall functions)
- (when message-citation-line-function
- (unless (bolp)
- (insert "\n"))
- (funcall message-citation-line-function))))
+(eval-when-compile (defvar mail-citation-hook)) ; Compiler directive
-(eval-when-compile (defvar mail-citation-hook)) ;Compiler directive
-(defun message-cite-original ()
- "Cite function in the standard Message manner."
+(defun message-cite-original-1 (strip-signature)
+ "Cite an original message.
+If STRIP-SIGNATURE is non-nil, strips off the signature from the
+original message.
+
+This function uses `mail-citation-hook' if that is non-nil."
(if (and (boundp 'mail-citation-hook)
mail-citation-hook)
(run-hooks 'mail-citation-hook)
(message-fetch-field "references")
0 0 ""))))
(mml-quote-region start end)
+ (when strip-signature
+ ;; Allow undoing.
+ (undo-boundary)
+ (goto-char end)
+ (when (re-search-backward message-signature-separator start t)
+ ;; Also peel off any blank lines before the signature.
+ (forward-line -1)
+ (while (looking-at "^[ \t]*$")
+ (forward-line -1))
+ (forward-line 1)
+ (delete-region (point) end)
+ (unless (search-backward "\n\n" start t)
+ ;; Insert a blank line if it is peeled off.
+ (insert "\n"))))
(goto-char start)
(mapc 'funcall functions)
(when message-citation-line-function
(insert "> [Quoted text removed due to X-No-Archive]\n")
(forward-line -1)))))
+(defun message-cite-original ()
+ "Cite function in the standard Message manner."
+ (message-cite-original-1 nil))
+
+(defun message-cite-original-without-signature ()
+ "Cite function in the standard Message manner.
+This function strips off the signature from the original message."
+ (message-cite-original-1 t))
+
(defun message-insert-citation-line ()
"Insert a simple citation line."
(when message-reply-headers
"Kill the current buffer."
(interactive)
(when (or (not (buffer-modified-p))
+ (not message-kill-buffer-query)
(yes-or-no-p "Message modified; kill anyway? "))
(let ((actions message-kill-actions)
(draft-article message-draft-article)
(zerop
(length
(setq to (completing-read
- "Followups to (default: no Followup-To header) "
+ "Followups to (default no Followup-To header): "
(mapcar #'list
(cons "poster"
(message-tokenize-header
(let ((field (message-fetch-field header))
rhs ace address)
(when field
- (dolist (address (mail-header-parse-addresses field))
- (setq address (car address)
- rhs (downcase (or (cadr (split-string address "@")) ""))
- ace (downcase (idna-to-ascii rhs)))
+ (dolist (rhs
+ (message-remove-duplicates
+ (mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) ""))
+ (mapcar 'downcase
+ (mapcar 'car (mail-header-parse-addresses field))))))
+ (setq 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))))
+ (y-or-n-p (format "Replace %s with %s in %s:? " rhs ace header))))
(goto-char (point-min))
(while (re-search-forward (concat "^" header ":") nil t)
(message-narrow-to-field)
(message-idna-to-ascii-rhs-1 "From")
(message-idna-to-ascii-rhs-1 "To")
(message-idna-to-ascii-rhs-1 "Reply-To")
+ (message-idna-to-ascii-rhs-1 "Mail-Reply-To")
+ (message-idna-to-ascii-rhs-1 "Mail-Followup-To")
(message-idna-to-ascii-rhs-1 "Cc")))))
(defun message-generate-headers (headers)
(when message-default-mail-headers
(insert message-default-mail-headers)
(or (bolp) (insert ?\n)))
- (save-restriction
- (message-narrow-to-headers)
- (if message-alternative-emails
- (message-use-alternative-email-as-from)))
(when message-generate-headers-first
(message-generate-headers
(message-headers-to-generate
;; Generate hashcash headers for recipients already known
(mail-add-payment-async))
(run-hooks 'message-setup-hook)
+ ;; Do this last to give it precedence over posting styles, etc.
+ (when (message-mail-p)
+ (save-restriction
+ (message-narrow-to-headers)
+ (if message-alternative-emails
+ (message-use-alternative-email-as-from))))
(message-position-point)
(undo-boundary))
fragmented and very difficult to follow.
Also, some source/announcement lists are not intended for discussion;
-responses here are directed to other addresses.")))
+responses here are directed to other addresses.
+
+You may customize the variable `message-use-mail-followup-to', if you
+want to get rid of this query permanently.")))
(setq recipients (concat ", " mft)))
(to-address
(setq recipients (concat ", " to-address))
`Followup-To: poster' sends your response via e-mail instead of news.
A typical situation where `Followup-To: poster' is used is when the poster
-does not read the newsgroup, so he wouldn't see any replies sent to it."))
+does not read the newsgroup, so he wouldn't see any replies sent to it.
+
+You may customize the variable `message-use-followup-to', if you
+want to get rid of this query permanently."))
(progn
(setq message-this-is-news nil)
(cons 'To (or mrt reply-to from "")))
be fragmented and very difficult to follow.
Also, some source/announcement newsgroups are not intended for discussion;
-responses here are directed to other newsgroups."))
+responses here are directed to other newsgroups.
+
+You may customize the variable `message-use-followup-to', if you
+want to get rid of this query permanently."))
(cons 'Newsgroups followup-to)
(cons 'Newsgroups newsgroups))))))
(posted-to
(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
+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'
+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>
:version "22.1"
:group 'message
:link '(custom-manual "(message)Various Commands")
- :type 'function)
+ :type '(choice (const nil)
+ function))
(defun message-tab ()
"Complete names according to `message-completion-alist'.
(read-string prompt initial-contents))))
(defun message-use-alternative-email-as-from ()
+ "Set From field of the outgoing message to the first matching
+address in `message-alternative-emails', looking at To, Cc and
+From headers in the original article."
(require 'mail-utils)
(let* ((fields '("To" "Cc" "From"))
(emails
emails nil))
(pop emails))
(unless (or (not email) (equal email user-mail-address))
+ (message-remove-header "From")
(goto-char (point-max))
(insert "From: " (let ((user-mail-address email)) (message-make-from))
"\n"))))
projects / gnus / blobdiff