;;; message.el --- composing mail and news messages
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
(string :tag "name")
(sexp :tag "none" :format "%t" t)))
+;; This can be the name of a buffer, or a cons cell (FUNCTION . ARGS)
+;; for yanking the original buffer.
(defvar message-reply-buffer nil)
(defvar message-reply-headers nil
"The headers of the current replied article.
:link '(custom-manual "(message)Message Headers")
:type 'message-header-lines)
-(defcustom message-default-mail-headers ""
+(defcustom message-default-mail-headers
+ ;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555.
+ (concat (if (and (boundp 'mail-default-reply-to)
+ (stringp mail-default-reply-to))
+ (format "Reply-to: %s\n" mail-default-reply-to)
+ "")
+ (if (and (boundp 'mail-self-blind)
+ mail-self-blind)
+ (format "BCC: %s\n" user-mail-address)
+ "")
+ (if (and (boundp 'mail-archive-file-name)
+ (stringp mail-archive-file-name))
+ (format "FCC: %s\n" mail-archive-file-name)
+ ""))
"*A string of header lines to be inserted in outgoing mails."
+ :version "23.2"
:group 'message-headers
:group 'message-mail
:link '(custom-manual "(message)Mail Headers")
:group 'message-faces)
;; backward-compatibility alias
(put 'message-header-to-face 'face-alias 'message-header-to)
+(put 'message-header-to-face 'obsolete-face "22.1")
(defface message-header-cc
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-header-cc-face 'face-alias 'message-header-cc)
+(put 'message-header-cc-face 'obsolete-face "22.1")
(defface message-header-subject
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-header-subject-face 'face-alias 'message-header-subject)
+(put 'message-header-subject-face 'obsolete-face "22.1")
(defface message-header-newsgroups
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-header-newsgroups-face 'face-alias 'message-header-newsgroups)
+(put 'message-header-newsgroups-face 'obsolete-face "22.1")
(defface message-header-other
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-header-other-face 'face-alias 'message-header-other)
+(put 'message-header-other-face 'obsolete-face "22.1")
(defface message-header-name
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-header-name-face 'face-alias 'message-header-name)
+(put 'message-header-name-face 'obsolete-face "22.1")
(defface message-header-xheader
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-header-xheader-face 'face-alias 'message-header-xheader)
+(put 'message-header-xheader-face 'obsolete-face "22.1")
(defface message-separator
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-separator-face 'face-alias 'message-separator)
+(put 'message-separator-face 'obsolete-face "22.1")
(defface message-cited-text
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-cited-text-face 'face-alias 'message-cited-text)
+(put 'message-cited-text-face 'obsolete-face "22.1")
(defface message-mml
'((((class color)
:group 'message-faces)
;; backward-compatibility alias
(put 'message-mml-face 'face-alias 'message-mml)
+(put 'message-mml-face 'obsolete-face "22.1")
(defun message-font-lock-make-header-matcher (regexp)
(let ((form
(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")
\f
(defmacro message-with-reply-buffer (&rest forms)
"Evaluate FORMS in the reply buffer, if it exists."
- `(when (and message-reply-buffer
+ `(when (and (bufferp message-reply-buffer)
(buffer-name message-reply-buffer))
(with-current-buffer message-reply-buffer
,@forms)))
(point-max)))
(goto-char (point-min)))
+;; FIXME: clarify diffference: message-narrow-to-head,
+;; message-narrow-to-headers-or-head, message-narrow-to-headers
(defun message-narrow-to-head ()
"Narrow the buffer to the head of the message.
Point is left at the beginning of the narrowed-to region."
manual. With two \\[universal-argument]'s, display the EasyPG or
PGG manual, depending on the value of `mml2015-use'."
(interactive "p")
- ;; Why not `info', which is in loaddefs.el?
+ ;; Don't use `info' because support for `(filename)nodename' is not
+ ;; available in XEmacs < 21.5.12.
(Info-goto-node (format "(%s)Top"
(cond ((eq arg 16)
(require 'mml2015)
;;; Forbidden properties
;;
;; We use `after-change-functions' to keep special text properties
-;; that interfer with the normal function of message mode out of the
+;; that interfere with the normal function of message mode out of the
;; buffer.
(defcustom message-strip-special-text-properties t
"Widen the reply to include maximum recipients."
(interactive)
(let ((follow-to
- (and message-reply-buffer
+ (and (bufferp message-reply-buffer)
(buffer-name message-reply-buffer)
(with-current-buffer message-reply-buffer
(message-get-reply-headers t)))))
(point-max)))
(delete-region (message-goto-body) (point-max)))
(set (make-local-variable 'message-cite-reply-above) nil)))
- (delete-windows-on message-reply-buffer t)
+ (if (bufferp message-reply-buffer)
+ (delete-windows-on message-reply-buffer t))
(push-mark (save-excursion
- (insert-buffer-substring message-reply-buffer)
+ (cond
+ ((bufferp message-reply-buffer)
+ (insert-buffer-substring message-reply-buffer))
+ ((and (consp message-reply-buffer)
+ (functionp (car message-reply-buffer)))
+ (apply (car message-reply-buffer)
+ (cdr message-reply-buffer))))
(unless (bolp)
(insert ?\n))
(point)))
(>= i ?a)))
(push i lst)
(push (condition-case nil
- (progn (format-time-string (format "%%%c" i)
- replydate))
- (format ">%c<" i))
+ (format-time-string (format "%%%c" i) replydate)
+ (error (format ">%c<" i)))
lst))
(setq i (1+ i)))
(reverse lst)))
(and (mm-multibyte-p)
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
+ ;; Emacs 23, Bug#1770:
+ eight-bit
control-1))
(not (get-text-property
(point) 'untranslated-utf-8))))
(or (< (mm-char-int char) 128)
(and (mm-multibyte-p)
;; FIXME: Wrong for Emacs 23 (unicode) and for
- ;; things like undecable utf-8. Should at least
- ;; use find-coding-systems-region.
+ ;; things like undecodable utf-8 (in Emacs 21?).
+ ;; Should at least use find-coding-systems-region.
+ ;; -- fx
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
+ ;; Emacs 23, Bug#1770:
+ eight-bit
control-1))
(not (get-text-property
(point) 'untranslated-utf-8)))))
(not (y-or-n-p
(format
"Address `%s' might be bogus. Continue? " bog)))
- (error "Bogus address."))))))))
+ (error "Bogus address"))))))))
(custom-add-option 'message-setup-hook 'message-check-recipients)
(defun message-smtpmail-send-it ()
"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 Gnus
-manual for details."
+The only difference from `smtpmail-send-it' is 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 Gnus manual for details."
(run-hooks 'message-send-mail-hook)
(smtpmail-send-it))
(defun message-send-mail-with-mailclient ()
"Send the prepared message buffer with `mailclient-send-it'.
-This only differs from `smtpmail-send-it' that this command evaluates
-`message-send-mail-hook' just before sending a message."
+The only difference from `mailclient-send-it' is that this
+command evaluates `message-send-mail-hook' just before sending a message."
(run-hooks 'message-send-mail-hook)
(mailclient-send-it))
"Denied posting -- the From looks strange: \"%s\"." from)
nil)
((let ((addresses (rfc822-addresses from)))
- (while (and addresses
+ ;; `rfc822-addresses' returns a string if parsing fails.
+ (while (and (consp addresses)
(not (eq (string-to-char (car addresses)) ?\()))
(setq addresses (cdr addresses)))
addresses)
nil)))
;; Check the length of the signature.
(message-check 'signature
- (goto-char (point-max))
- (if (not (re-search-backward message-signature-separator nil t))
- t
- (if (>= (count-lines (1+ (point-at-eol)) (point-max)) 5)
- (if (message-gnksa-enable-p 'signature)
- (y-or-n-p
- (format "Signature is excessively long (%d lines). Really post? "
- (count-lines (1+ (point-at-eol)) (point-max))))
- (message "Denied posting -- Excessive signature.")
- nil)
- t)))
+ (let (sig-start sig-end)
+ (goto-char (point-max))
+ (if (not (re-search-backward message-signature-separator nil t))
+ t
+ (setq sig-start (1+ (point-at-eol)))
+ (setq sig-end
+ (if (re-search-forward
+ "<#/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
+ (- (point-at-bol) 1)
+ (point-max)))
+ (if (>= (count-lines sig-start sig-end) 5)
+ (if (message-gnksa-enable-p 'signature)
+ (y-or-n-p
+ (format "Signature is excessively long (%d lines). Really post? "
+ (count-lines sig-start sig-end)))
+ (message "Denied posting -- Excessive signature.")
+ nil)
+ t))))
;; Ensure that text follows last quoted portion.
(message-check 'quoting-style
(goto-char (point-max))
(if (and message-fcc-handler-function
(not (eq message-fcc-handler-function 'rmail-output)))
(funcall message-fcc-handler-function file)
+ ;; FIXME this option, rmail-output (also used if
+ ;; message-fcc-handler-function is nil) is not
+ ;; documented anywhere AFAICS. It should work in Emacs
+ ;; 23; I suspect it does not work in Emacs 22.
+ ;; FIXME I don't see the need for the two different cases here.
+ ;; mail-use-rfc822 makes no difference (in Emacs 23),and
+ ;; the third argument just controls \"Wrote file\" message.
(if (and (file-readable-p file) (mail-file-babyl-p file))
(rmail-output file 1 nil t)
(let ((mail-use-rfc822 t))
nil
mua)))
-(defun message-setup (headers &optional replybuffer actions
+;; YANK-ACTION, if non-nil, can be a buffer or a yank action of the
+;; form (FUNCTION . ARGS).
+(defun message-setup (headers &optional yank-action actions
continue switch-function)
(let ((mua (message-mail-user-agent))
- subject to field yank-action)
+ subject to field)
(if (not (and message-this-is-mail mua))
- (message-setup-1 headers replybuffer actions)
- (if replybuffer
- (setq yank-action (list 'insert-buffer replybuffer)))
+ (message-setup-1 headers yank-action actions)
(setq headers (copy-sequence headers))
(setq field (assq 'Subject headers))
(when field
(format "%s" (car item))
(cdr item)))
headers)
- continue switch-function yank-action actions)))))
+ continue switch-function
+ (if (bufferp yank-action)
+ (list 'insert-buffer yank-action)
+ yank-action)
+ actions)))))
(defun message-headers-to-generate (headers included-headers excluded-headers)
"Return a list that includes all headers from HEADERS.
(push header result)))
(nreverse result)))
-(defun message-setup-1 (headers &optional replybuffer actions)
+(defun message-setup-1 (headers &optional yank-action actions)
(dolist (action actions)
(condition-case nil
(add-to-list 'message-send-actions
`(apply ',(car action) ',(cdr action)))))
- (setq message-reply-buffer replybuffer)
+ (setq message-reply-buffer
+ (if (and (consp yank-action)
+ (eq (car yank-action) 'insert-buffer))
+ (nth 1 yank-action)
+ yank-action))
(goto-char (point-min))
;; Insert all the headers.
(mail-header-format
to continue editing a message already being composed. SWITCH-FUNCTION
is a function used to switch to and display the mail buffer."
(interactive)
- (let ((message-this-is-mail t) replybuffer)
+ (let ((message-this-is-mail t))
(unless (message-mail-user-agent)
(message-pop-to-buffer
;; Search for the existing message buffer if `continue' is non-nil.
message-generate-new-buffers)))
(message-buffer-name "mail" to))
switch-function))
- ;; FIXME: message-mail should do something if YANK-ACTION is not
- ;; insert-buffer.
- (and (consp yank-action) (eq (car yank-action) 'insert-buffer)
- (setq replybuffer (nth 1 yank-action)))
(message-setup
(nconc
`((To . ,(or to "")) (Subject . ,(or subject "")))
(when other-headers other-headers))
- replybuffer send-actions continue switch-function)
+ yank-action send-actions continue switch-function)
;; FIXME: Should return nil if failure.
t))
(message-forward-make-body-plain forward-buffer)))
(message-position-point))
+(declare-function rmail-toggle-header "rmail" (&optional arg))
+
;;;###autoload
(defun message-forward-rmail-make-body (forward-buffer)
(save-window-excursion
(set-buffer forward-buffer)
(if (rmail-msg-is-pruned)
- (rmail-msg-restore-non-pruned-header)))
+ (if (fboundp 'rmail-msg-restore-non-pruned-header)
+ (rmail-msg-restore-non-pruned-header) ; Emacs 22
+ (rmail-toggle-header 0)))) ; Emacs 23
(message-forward-make-body forward-buffer))
;; Fixme: Should have defcustom.
(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)))
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point)))))
(defalias 'message-make-overlay 'make-overlay)
(defalias 'message-delete-overlay 'delete-overlay)
(point))
(skip-chars-backward "^, \t\n") (point))))
(completion-ignore-case t)
- (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
- (point))))
- (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
- (completions (all-completions string hashtb))
- comp)
- (delete-region b (point))
- (cond
- ((= (length completions) 1)
- (if (string= (car completions) string)
- (progn
- (insert string)
- (message "Only matching group"))
- (insert (car completions))))
- ((and (setq comp (try-completion string hashtb))
- (not (string= comp string)))
- (insert comp))
- (t
- (insert string)
- (if (not comp)
- (message "No matching groups")
- (save-selected-window
- (pop-to-buffer "*Completions*")
- (buffer-disable-undo)
- (let ((buffer-read-only nil))
- (erase-buffer)
- (let ((standard-output (current-buffer)))
- (message-display-completion-list (sort completions 'string<)
- string))
- (setq buffer-read-only nil)
- (goto-char (point-min))
- (delete-region (point) (progn (forward-line 3) (point))))))))))
+ (e (progn (skip-chars-forward "^,\t\n ") (point)))
+ (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)))
+ (message-completion-in-region e b hashtb)))
+
+(defalias 'message-completion-in-region
+ (if (fboundp 'completion-in-region)
+ 'completion-in-region
+ (lambda (e b hashtb)
+ (let* ((string (buffer-substring b e))
+ (completions (all-completions string hashtb))
+ comp)
+ (delete-region b (point))
+ (cond
+ ((= (length completions) 1)
+ (if (string= (car completions) string)
+ (progn
+ (insert string)
+ (message "Only matching group"))
+ (insert (car completions))))
+ ((and (setq comp (try-completion string hashtb))
+ (not (string= comp string)))
+ (insert comp))
+ (t
+ (insert string)
+ (if (not comp)
+ (message "No matching groups")
+ (save-selected-window
+ (pop-to-buffer "*Completions*")
+ (buffer-disable-undo)
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (message-display-completion-list (sort completions 'string<)
+ string))
+ (setq buffer-read-only nil)
+ (goto-char (point-min))
+ (delete-region (point)
+ (progn (forward-line 3) (point))))))))))))
(defun message-expand-name ()
(cond ((and (memq 'eudc message-expand-name-databases)