;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
(require 'rfc822)
(require 'ecomplete)
+
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
"Mail and news message composing."
"*Headers to be generated or prompted for when posting an article.
RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
Message-ID. Organization, Lines, In-Reply-To, Expires, and
-User-Agent are optional. If don't you want message to insert some
+User-Agent are optional. If you don't want message to insert some
header, remove it from this list."
:group 'message-news
:group 'message-headers
:version "22.1"
:type '(choice (const :tag "never" nil)
(const :tag "always strip" t)
- (const ask))
+ (const ask))
:link '(custom-manual "(message)Message Headers")
:group 'message-various)
:type 'boolean)
(defcustom message-generate-new-buffers 'unique
- "*Non-nil means create a new message buffer whenever `message-setup' is called.
-If this is a function, call that function with three parameters: The type,
-the to address and the group name. (Any of these may be nil.) The function
-should return the new buffer name."
+ "*Say whether to create a new message buffer to compose a message.
+Valid values include:
+
+nil
+ Generate the buffer name in the Message way (e.g., *mail*, *news*,
+ *mail to whom*, *news on group*, etc.) and continue editing in the
+ existing buffer of that name. If there is no such buffer, it will
+ be newly created.
+
+`unique' or t
+ Create the new buffer with the name generated in the Message way.
+
+`unsent'
+ Similar to `unique' but the buffer name begins with \"*unsent \".
+
+`standard'
+ Similar to nil but the buffer name is simpler like *mail message*.
+
+function
+ If this is a function, call that function with three parameters:
+ The type, the To address and the group name (any of these may be nil).
+ The function should return the new buffer name."
:group 'message-buffers
:link '(custom-manual "(message)Message Buffers")
- :type '(choice (const :tag "off" nil)
- (const :tag "unique" unique)
- (const :tag "unsent" unsent)
- (function fun)))
+ :type '(choice (const nil)
+ (sexp :tag "unique" :format "unique\n" :value unique
+ :match (lambda (widget value) (memq value '(unique t))))
+ (const unsent)
+ (const standard)
+ (function :format "\n %{%t%}: %v")))
(defcustom message-kill-buffer-on-exit nil
"*Non-nil means that the message buffer will be killed after sending a message."
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
:type '(choice (const :tag "None" nil)
- (const :tag "References" '(references))
- (const :tag "All" t)
- (repeat (sexp :tag "Header"))))
+ (const :tag "References" '(references))
+ (const :tag "All" t)
+ (repeat (sexp :tag "Header"))))
+
+(defcustom message-fill-column 72
+ "Column beyond which automatic line-wrapping should happen.
+Local value for message buffers. If non-nil, also turn on
+auto-fill in message buffers."
+ :group 'message-various
+ ;; :link '(custom-manual "(message)Message Headers")
+ :type '(choice (const :tag "Don't turn on auto fill" nil)
+ (integer)))
(defcustom message-setup-hook nil
"Normal hook, run each time a new outgoing message is initialized.
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-(defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:"
+(defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n"
"Format of the \"Whomever writes:\" line.
The string is formatted using `format-spec'. The following
(defcustom message-signature-file "~/.signature"
"*Name of file containing the text inserted at end of message buffer.
Ignored if the named file doesn't exist.
-If nil, don't insert a signature."
+If nil, don't insert a signature.
+If a path is specified, the value of `message-signature-directory' is ignored,
+even if set."
:type '(choice file (const :tags "None" nil))
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
+(defcustom message-signature-directory nil
+ "*Name of directory containing signature files.
+Comes in handy if you have many such files, handled via posting styles for
+instance.
+If nil, `message-signature-file' is expected to specify the directory if
+needed."
+ :type '(choice string (const :tags "None" nil))
+ :link '(custom-manual "(message)Insertion Variables")
+ :group 'message-insertion)
+
(defcustom message-signature-insert-empty-line t
"*If non-nil, insert an empty line before the signature separator."
:version "22.1"
regexp
(repeat :tag "Regexp List" regexp)))
-;; #### FIXME: this might become a generally usefull function at some point
-;; --dlv.
(defsubst message-dont-reply-to-names ()
- "Potentially convert a list of regexps into a single one."
- (cond ((null message-dont-reply-to-names)
- nil)
- ((stringp message-dont-reply-to-names)
- message-dont-reply-to-names)
- ((listp message-dont-reply-to-names)
- (mapconcat (lambda (elt) (concat "\\(" elt "\\)"))
- message-dont-reply-to-names
- "\\|"))))
+ (gmm-regexp-concat message-dont-reply-to-names))
(defvar message-shoot-gnksa-feet nil
"*A list of GNKSA feet you are allowed to shoot.
`quoted-text-only' Allow you to post quoted text only;
`multiple-copies' Allow you to post multiple copies;
`cancel-messages' Allow you to cancel or supersede messages from
- your other email addresses.")
+ your other email addresses.")
(defsubst message-gnksa-enable-p (feature)
(or (not (listp message-shoot-gnksa-feet))
(defface message-header-to
'((((class color)
(background dark))
- (:foreground "green2" :bold t))
+ (:foreground "DarkOliveGreen1" :bold t))
(((class color)
(background light))
(:foreground "MidnightBlue" :bold t))
(defface message-header-cc
'((((class color)
(background dark))
- (:foreground "green4" :bold t))
+ (:foreground "chartreuse1" :bold t))
(((class color)
(background light))
(:foreground "MidnightBlue"))
(defface message-header-subject
'((((class color)
(background dark))
- (:foreground "green3"))
+ (:foreground "OliveDrab1"))
(((class color)
(background light))
(:foreground "navy blue" :bold t))
(defface message-header-other
'((((class color)
(background dark))
- (:foreground "#b00000"))
+ (:foreground "VioletRed1"))
(((class color)
(background light))
(:foreground "steel blue"))
(defface message-header-name
'((((class color)
(background dark))
- (:foreground "DarkGreen"))
+ (:foreground "green"))
(((class color)
(background light))
(:foreground "cornflower blue"))
(defface message-header-xheader
'((((class color)
(background dark))
- (:foreground "blue"))
+ (:foreground "DeepSkyBlue1"))
(((class color)
(background light))
(:foreground "blue"))
(defface message-separator
'((((class color)
(background dark))
- (:foreground "blue3"))
+ (:foreground "LightSkyBlue1"))
(((class color)
(background light))
(:foreground "brown"))
(defface message-cited-text
'((((class color)
(background dark))
- (:foreground "red"))
+ (:foreground "LightPink1"))
(((class color)
(background light))
(:foreground "red"))
(defface message-mml
'((((class color)
(background dark))
- (:foreground "ForestGreen"))
+ (:foreground "MediumSpringGreen"))
(((class color)
(background light))
(:foreground "ForestGreen"))
(1 'message-header-name)
(2 'message-header-newsgroups nil t))
(,(message-font-lock-make-header-matcher
- (concat "^\\([A-Z][^: \n\t]+:\\)" content))
+ (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
(1 'message-header-name)
- (2 'message-header-other nil t))
+ (2 'message-header-xheader))
(,(message-font-lock-make-header-matcher
- (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
+ (concat "^\\([A-Z][^: \n\t]+:\\)" content))
(1 'message-header-name)
- (2 'message-header-name))
+ (2 'message-header-other nil t))
,@(if (and mail-header-separator
(not (equal mail-header-separator "")))
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
(autoload 'gnus-output-to-mail "gnus-util")
(autoload 'gnus-output-to-rmail "gnus-util")
(autoload 'gnus-request-post "gnus-int")
+ (autoload 'gnus-select-frame-set-input-focus "gnus-util")
(autoload 'gnus-server-string "gnus")
(autoload 'idna-to-ascii "idna")
(autoload 'message-setup-toolbar "messagexmas")
(widen)
(narrow-to-region
(goto-char (point-min))
- (cond
- ((re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
- (match-beginning 0))
- ((search-forward "\n\n" nil t)
- (1- (point)))
- (t
- (point-max))))
+ (if (re-search-forward (concat "\\(\n\\)\n\\|^\\("
+ (regexp-quote mail-header-separator)
+ "\n\\)")
+ nil t)
+ (or (match-end 1) (match-beginning 2))
+ (point-max)))
(goto-char (point-min)))
(defun message-news-p ()
C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To
C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups
C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution
- C-c C-f C-o move to From (\"Originator\")
+ C-c C-f C-o move to From (\"Originator\")
C-c C-f C-f move to Followup-To
C-c C-f C-m move to Mail-Followup-To
C-c C-f C-e move to Expires
(set (make-local-variable 'message-checksum) nil)
(set (make-local-variable 'message-mime-part) 0)
(message-setup-fill-variables)
+ (when message-fill-column
+ (setq fill-column message-fill-column)
+ (turn-on-auto-fill))
;; Allow using comment commands to add/remove quoting.
;; (set (make-local-variable 'comment-start) message-yank-prefix)
(when message-yank-prefix
prefix FORCE is given."
(interactive "P")
(let* ((mct (message-fetch-reply-field "mail-copies-to"))
- (dont (and mct (or (equal (downcase mct) "never")
+ (dont (and mct (or (equal (downcase mct) "never")
(equal (downcase mct) "nobody"))))
- (to (or (message-fetch-reply-field "mail-reply-to")
- (message-fetch-reply-field "reply-to")
- (message-fetch-reply-field "from"))))
+ (to (or (message-fetch-reply-field "mail-reply-to")
+ (message-fetch-reply-field "reply-to")
+ (message-fetch-reply-field "from"))))
(when (and dont to)
(message
(if force
;; (mail-strip-quoted-names "Foo Bar <foo@bar>, bla@fasel (Bla Fasel)")
(dolist (header headers)
(let* ((header-name (symbol-name (car header)))
- (new-header (cdr header))
- (synonyms (loop for synonym in message-header-synonyms
+ (new-header (cdr header))
+ (synonyms (loop for synonym in message-header-synonyms
when (memq (car header) synonym) return synonym))
- (old-header
- (loop for synonym in synonyms
+ (old-header
+ (loop for synonym in synonyms
for old-header = (mail-fetch-field (symbol-name synonym))
when (and old-header (string-match new-header old-header))
return synonym)))
(if old-header
- (message "already have `%s' in `%s'" new-header old-header)
+ (message "already have `%s' in `%s'" new-header old-header)
(when (and (message-position-on-field header-name)
- (setq old-header (mail-fetch-field header-name))
- (not (string-match "\\` *\\'" old-header)))
+ (setq old-header (mail-fetch-field header-name))
+ (not (string-match "\\` *\\'" old-header)))
(insert ", "))
- (insert new-header)))))
+ (insert new-header)))))
(defun message-widen-reply ()
"Widen the reply to include maximum recipients."
((listp message-signature)
(eval message-signature))
(t message-signature)))
- (signature
+ signature-file)
+ (setq signature
(cond ((stringp signature)
signature)
- ((and (eq t signature)
- message-signature-file
- (file-exists-p message-signature-file))
- signature))))
+ ((and (eq t signature) message-signature-file)
+ (setq signature-file
+ (if (and message-signature-directory
+ ;; don't actually use the signature directory
+ ;; if message-signature-file contains a path.
+ (not (file-name-directory
+ message-signature-file)))
+ (nnheader-concat message-signature-directory
+ message-signature-file)
+ message-signature-file))
+ (file-exists-p signature-file))))
(when signature
(goto-char (point-max))
;; Insert the signature.
(insert "\n"))
(insert "-- \n")
(if (eq signature t)
- (insert-file-contents message-signature-file)
+ (insert-file-contents signature-file)
(insert signature))
(goto-char (point-max))
(or (bolp) (insert "\n")))))
(delete-windows-on message-reply-buffer t)
(push-mark (save-excursion
(insert-buffer-substring message-reply-buffer)
+ (unless (bolp)
+ (insert ?\n))
(point)))
(unless arg
- (funcall message-cite-function))
- (if message-cite-reply-above
- (progn
- (message-goto-body)
- (insert body-text)
- (newline)
- (message-goto-body)
- (message-exchange-point-and-mark))
- (message-exchange-point-and-mark))
- (unless (bolp)
- (insert ?\n))
+ (funcall message-cite-function)
+ (unless (eq (char-before (mark t)) ?\n)
+ (let ((pt (point)))
+ (goto-char (mark t))
+ (insert-before-markers ?\n)
+ (goto-char pt))))
+ (when message-cite-reply-above
+ (message-goto-body)
+ (insert body-text)
+ (insert (if (bolp) "\n" "\n\n"))
+ (message-goto-body))
+ ;; Add a `message-setup-very-last-hook' here?
+ ;; Add `gnus-article-highlight-citation' here?
(unless modified
(setq message-checksum (message-checksum))))))
(reverse lst)))
(spec (apply 'format-spec-make flist)))
(insert (format-spec message-citation-line-format spec)))
- (newline)
(newline)))
(defun message-cite-original-without-signature ()
"Invisible text found and made visible; continue sending? ")
(error "Invisible text found and made visible")))))
(message-check 'illegible-text
- (let (found choice)
+ (let (char found choice)
(message-goto-body)
- (skip-chars-forward mm-7bit-chars)
- (while (not (eobp))
- (when (let ((char (char-after)))
- (or (< (mm-char-int char) 128)
- (and (mm-multibyte-p)
- (memq (char-charset char)
- '(eight-bit-control eight-bit-graphic
- control-1))
- (not (get-text-property
- (point) 'untranslated-utf-8)))))
+ (while (progn
+ (skip-chars-forward mm-7bit-chars)
+ (when (get-text-property (point) 'no-illegible-text)
+ ;; There is a signed or encrypted raw message part
+ ;; that is considered to be safe.
+ (goto-char (or (next-single-property-change
+ (point) 'no-illegible-text)
+ (point-max))))
+ (setq char (char-after)))
+ (when (or (< (mm-char-int char) 128)
+ (and (mm-multibyte-p)
+ (memq (char-charset char)
+ '(eight-bit-control eight-bit-graphic
+ control-1))
+ (not (get-text-property
+ (point) 'untranslated-utf-8))))
(message-overlay-put (message-make-overlay (point) (1+ (point)))
'face 'highlight)
(setq found t))
- (forward-char)
- (skip-chars-forward mm-7bit-chars))
+ (forward-char))
(when found
(setq choice
(gnus-multiple-choice
;; free for -inject-arguments -- a big win for the user and for us
;; since we don't have to play that double-guessing game and the user
;; gets full control (no gestapo'ish -f's, for instance). --sj
- (if (functionp message-qmail-inject-args)
- (funcall message-qmail-inject-args)
- message-qmail-inject-args)))
+ (if (functionp message-qmail-inject-args)
+ (funcall message-qmail-inject-args)
+ message-qmail-inject-args)))
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(0 nil)
(string-match "[\\()]" tmp)))))
(insert fullname)
(goto-char (point-min))
- ;; Look for a character that cannot appear unquoted
- ;; according to RFC 822.
- (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
- ;; Quote fullname, escaping specials.
- (goto-char (point-min))
- (insert "\"")
- (while (re-search-forward "[\"\\]" nil 1)
- (replace-match "\\\\\\&" t))
- (insert "\""))
+ ;; Look for a character that cannot appear unquoted
+ ;; according to RFC 822.
+ (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
+ ;; Quote fullname, escaping specials.
+ (goto-char (point-min))
+ (insert "\"")
+ (while (re-search-forward "[\"\\]" nil 1)
+ (replace-match "\\\\\\&" t))
+ (insert "\""))
(insert " <" login ">"))
(t ; 'parens or default
(insert login " (")
"Return a new (unique) buffer name based on TYPE and TO."
(cond
;; Generate a new buffer name The Message Way.
- ((eq message-generate-new-buffers 'unique)
+ ((memq message-generate-new-buffers '(unique t))
(generate-new-buffer-name
(concat "*" type
(if to
"")
(if (and group (not (string= group ""))) (concat " on " group) "")
"*")))
- ;; Use standard name.
+ ;; Search for the existing message buffer with the specified name.
(t
- (format "*%s message*" type))))
-
-(defun message-pop-to-buffer (name)
+ (let* ((new (if (eq message-generate-new-buffers 'standard)
+ (generate-new-buffer-name (concat "*" type " message*"))
+ (let ((message-generate-new-buffers 'unique))
+ (message-buffer-name type to group))))
+ (regexp (concat "\\`"
+ (regexp-quote
+ (if (string-match "<[0-9]+>\\'" new)
+ (substring new 0 (match-beginning 0))
+ new))
+ "\\(?:<\\([0-9]+\\)>\\)?\\'"))
+ (case-fold-search nil))
+ (or (cdar
+ (last
+ (sort
+ (delq nil
+ (mapcar
+ (lambda (b)
+ (when (and (string-match regexp (setq b (buffer-name b)))
+ (eq (with-current-buffer b major-mode)
+ 'message-mode))
+ (cons (string-to-number (or (match-string 1 b) "1"))
+ b)))
+ (buffer-list)))
+ 'car-less-than-car)))
+ new)))))
+
+(defun message-pop-to-buffer (name &optional switch-function)
"Pop to buffer NAME, and warn if it already exists and is modified."
(let ((buffer (get-buffer name)))
(if (and buffer
(buffer-name buffer))
- (progn
- (set-buffer (pop-to-buffer buffer))
+ (let ((window (get-buffer-window buffer 0)))
+ (if window
+ ;; Raise the frame already displaying the message buffer.
+ (progn
+ (gnus-select-frame-set-input-focus (window-frame window))
+ (select-window window))
+ (funcall (or switch-function 'pop-to-buffer) buffer)
+ (set-buffer buffer))
(when (and (buffer-modified-p)
- (not (y-or-n-p
- "Message already being composed; erase? ")))
+ (not (prog1
+ (y-or-n-p
+ "Message already being composed; erase? ")
+ (message nil))))
(error "Message being composed")))
- (set-buffer (pop-to-buffer name)))
+ (funcall (or switch-function 'pop-to-buffer) name)
+ (set-buffer name))
(erase-buffer)
(message-mode)))
nil
mua)))
-(defun message-setup (headers &optional replybuffer actions switch-function)
+(defun message-setup (headers &optional replybuffer actions
+ continue switch-function)
(let ((mua (message-mail-user-agent))
subject to field yank-action)
(if (not (and message-this-is-mail mua))
(format "%s" (car item))
(cdr item)))
headers)
- nil switch-function yank-action actions)))))
+ continue switch-function yank-action actions)))))
(defun message-headers-to-generate (headers included-headers excluded-headers)
"Return a list that includes all headers from HEADERS.
other-headers continue switch-function
yank-action send-actions)
"Start editing a mail message to be sent.
-OTHER-HEADERS is an alist of header/value pairs."
+OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether
+to continue editing a message already being composed. SWITCH-FUNCTION
+is a function used to switch to and display the mail buffer."
(interactive)
(let ((message-this-is-mail t) replybuffer)
(unless (message-mail-user-agent)
- (message-pop-to-buffer (message-buffer-name "mail" to)))
+ (message-pop-to-buffer
+ ;; Search for the existing message buffer if `continue' is non-nil.
+ (let ((message-generate-new-buffers
+ (when (or (not continue)
+ (eq message-generate-new-buffers 'standard)
+ (functionp message-generate-new-buffers))
+ message-generate-new-buffers)))
+ (message-buffer-name "mail" to))
+ switch-function))
;; FIXME: message-mail should do something if YANK-ACTION is not
;; insert-buffer.
(and (consp yank-action) (eq (car yank-action) 'insert-buffer)
(nconc
`((To . ,(or to "")) (Subject . ,(or subject "")))
(when other-headers other-headers))
- replybuffer send-actions)
+ replybuffer send-actions continue switch-function)
;; FIXME: Should return nil if failure.
t))
(message-remove-header elem t))))))
(defun message-forward-make-body-mime (forward-buffer)
- (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
- (let ((b (point)) e)
+ (let ((b (point)))
+ (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
(save-restriction
(narrow-to-region (point) (point))
(mml-insert-buffer forward-buffer)
(when (looking-at "From ")
(replace-match "X-From-Line: "))
(goto-char (point-max)))
- (setq e (point))
- (insert "<#/part>\n")))
+ (insert "<#/part>\n")
+ ;; Consider there is no illegible text.
+ (add-text-properties
+ b (point)
+ `(no-illegible-text t rear-nonsticky t start-open t))))
(defun message-forward-make-body-mml (forward-buffer)
(insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
(goto-char boundary)
(when (re-search-backward "^.?From .*\n" nil t)
(delete-region (match-beginning 0) (match-end 0)))))
- (mm-enable-multibyte)
+ (mime-to-mml)
(save-restriction
(message-narrow-to-head-1)
(message-remove-header message-ignored-bounced-headers t)
(message-pop-to-buffer (message-buffer-name "mail" to))))
(let ((message-this-is-mail t))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
- nil nil 'switch-to-buffer-other-window)))
+ nil nil nil 'switch-to-buffer-other-window)))
;;;###autoload
(defun message-mail-other-frame (&optional to subject)
(message-pop-to-buffer (message-buffer-name "mail" to))))
(let ((message-this-is-mail t))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
- nil nil 'switch-to-buffer-other-frame)))
+ nil nil nil 'switch-to-buffer-other-frame)))
;;;###autoload
(defun message-news-other-window (&optional newsgroups subject)
(defun message-put-addresses-in-ecomplete ()
(dolist (header '("to" "cc" "from" "reply-to"))
- (let ((value (message-fetch-field header)))
+ (let ((value (message-field-value header)))
(dolist (string (mail-header-parse-addresses value 'raw))
(setq string
(gnus-replace-in-string
(defun message-display-abbrev (&optional choose)
"Display the next possible abbrev for the text before point."
(interactive (list t))
- (when (and (member (char-after (point-at-bol)) '(?C ?T ? ))
+ (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? ))
(message-point-in-header-p)
(save-excursion
- (save-restriction
- (message-narrow-to-field)
- (goto-char (point-min))
- (looking-at "To\\|Cc"))))
+ (beginning-of-line)
+ (while (and (memq (char-after) '(?\t ? ))
+ (zerop (forward-line -1))))
+ (looking-at "To:\\|Cc:")))
(let* ((end (point))
(start (save-excursion
(and (re-search-backward "[\n\t ]" nil t)
projects / gnus / blobdiff