;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2012 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
:type 'hook)
(defcustom message-cancel-hook nil
- "Hook run when cancelling articles."
+ "Hook run when canceling articles."
:group 'message-various
:link '(custom-manual "(message)Various Message Variables")
:type 'hook)
(defvar message-send-actions nil
"A list of actions to be performed upon successful sending of a message.")
(defvar message-return-action nil
- "Action to return to the caller after sending or postphoning a message.")
+ "Action to return to the caller after sending or postponing a message.")
(defvar message-exit-actions nil
"A list of actions to be performed upon exiting after sending a message.")
(defvar message-kill-actions nil
:type '(repeat function))
(defcustom message-auto-save-directory
- (file-name-as-directory (expand-file-name "drafts" message-directory))
+ (if (file-writable-p message-directory)
+ (file-name-as-directory (expand-file-name "drafts" message-directory))
+ "~/")
"*Directory where Message auto-saves buffers if Gnus isn't running.
If nil, Message won't auto-save."
:group 'message-buffers
`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;
+`canlock-verify' Allow you to cancel messages without verifying canlock.")
(defsubst message-gnksa-enable-p (feature)
(or (not (listp message-shoot-gnksa-feet))
(concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
;; valid TLDs:
"\\([a-z][a-z]\\|" ;; two letter country TDLs
- "aero\\|arpa\\|bitnet\\|biz\\|bofh\\|"
+ "aero\\|arpa\\|asia\\|bitnet\\|biz\\|bofh\\|"
"cat\\|com\\|coop\\|edu\\|gov\\|"
"info\\|int\\|jobs\\|"
"mil\\|mobi\\|museum\\|name\\|net\\|"
- "org\\|pro\\|travel\\|uucp\\)")
+ "org\\|pro\\|tel\\|travel\\|uucp\\)")
;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
;; http://en.wikipedia.org/wiki/GTLD
- ;; `in the process of being approved': .asia .post .tel .sex
+ ;; `approved, but not yet in operation': .xxx
;; "dead" nato bitnet uucp
"Regular expression that matches a valid FQDN."
;; see also: gnus-button-valid-fqdn-regexp
(point-max)))
(goto-char (point-min)))
-;; FIXME: clarify diffference: message-narrow-to-head,
+;; FIXME: clarify difference: 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.
(defun message-goto-to ()
"Move point to the To header."
(interactive)
+ (push-mark)
(message-position-on-field "To"))
(defun message-goto-from ()
"Move point to the From header."
(interactive)
+ (push-mark)
(message-position-on-field "From"))
(defun message-goto-subject ()
"Move point to the Subject header."
(interactive)
+ (push-mark)
(message-position-on-field "Subject"))
(defun message-goto-cc ()
"Move point to the Cc header."
(interactive)
+ (push-mark)
(message-position-on-field "Cc" "To"))
(defun message-goto-bcc ()
"Move point to the Bcc header."
(interactive)
+ (push-mark)
(message-position-on-field "Bcc" "Cc" "To"))
(defun message-goto-fcc ()
"Move point to the Fcc header."
(interactive)
+ (push-mark)
(message-position-on-field "Fcc" "To" "Newsgroups"))
(defun message-goto-reply-to ()
"Move point to the Reply-To header."
(interactive)
+ (push-mark)
(message-position-on-field "Reply-To" "Subject"))
(defun message-goto-newsgroups ()
"Move point to the Newsgroups header."
(interactive)
+ (push-mark)
(message-position-on-field "Newsgroups"))
(defun message-goto-distribution ()
"Move point to the Distribution header."
(interactive)
+ (push-mark)
(message-position-on-field "Distribution"))
(defun message-goto-followup-to ()
"Move point to the Followup-To header."
(interactive)
+ (push-mark)
(message-position-on-field "Followup-To" "Newsgroups"))
(defun message-goto-mail-followup-to ()
"Move point to the Mail-Followup-To header."
(interactive)
+ (push-mark)
(message-position-on-field "Mail-Followup-To" "To"))
(defun message-goto-keywords ()
"Move point to the Keywords header."
(interactive)
+ (push-mark)
(message-position-on-field "Keywords" "Subject"))
(defun message-goto-summary ()
"Move point to the Summary header."
(interactive)
+ (push-mark)
(message-position-on-field "Summary" "Subject"))
(eval-when-compile
(when (and (message-called-interactively-p 'any)
(looking-at "[ \t]*\n"))
(expand-abbrev))
+ (push-mark)
(goto-char (point-min))
(or (search-forward (concat "\n" mail-header-separator "\n") nil t)
(search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
If there is no signature in the article, go to the end and
return nil."
(interactive)
+ (push-mark)
(goto-char (point-min))
(if (re-search-forward message-signature-separator nil t)
(forward-line 1)
(message-delete-line))
;; Delete blank lines at the end of the buffer.
(goto-char (point-max))
- (unless (eolp)
+ (unless (eq (preceding-char) ?\n)
(insert "\n"))
(while (and (zerop (forward-line -1))
(looking-at "$"))
;;;
(defun message-send-and-exit (&optional arg)
- "Send message like `message-send', then, if no errors, exit from mail buffer."
+ "Send message like `message-send', then, if no errors, exit from mail buffer.
+The usage of ARG is defined by the instance that called Message.
+It should typically alter the sending method in some way or other."
(interactive "P")
(let ((buf (current-buffer))
(actions message-exit-actions))
"Invisible text found and made visible; continue sending? ")
(error "Invisible text found and made visible")))))
(message-check 'illegible-text
- (let (char found choice)
+ (let (char found choice nul-chars)
(message-goto-body)
+ (setq nul-chars (save-excursion
+ (search-forward "\000" nil t)))
(while (progn
(skip-chars-forward mm-7bit-chars)
(when (get-text-property (point) 'no-illegible-text)
(when found
(setq choice
(gnus-multiple-choice
- "Non-printable characters found. Continue sending?"
+ (if nul-chars
+ "NUL characters found, which may cause problems. Continue sending?"
+ "Non-printable characters found. Continue sending?")
`((?d "Remove non-printable characters and send")
(?r ,(format
"Replace non-printable characters with \"%s\" and send"
;; A simple function.
((functionp action)
(funcall action))
- ;; Something to be evaled.
+ ;; Something to be evalled.
(t
(eval action))))))
(boundp 'gnus-group-posting-charset-alist))
(gnus-setup-posting-charset nil)
message-posting-charset))
- (headers message-required-mail-headers))
+ (headers message-required-mail-headers)
+ options)
(when (and message-generate-hashcash
(not (eq message-generate-hashcash 'opportunistic)))
(message "Generating hashcash...")
(error "Failed to send the message")))))
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
+ (setq options message-options)
(unwind-protect
(with-current-buffer tembuf
(erase-buffer)
+ (setq message-options options)
;; Avoid copying text props (except hard newlines).
(insert (with-current-buffer mailbuf
(mml-buffer-substring-no-properties-except-hard-newlines
(message "Sending via mail...")
(funcall (or message-send-mail-real-function
message-send-mail-function)))
- (message-send-mail-partially)))
+ (message-send-mail-partially))
+ (setq options message-options))
(kill-buffer tembuf))
(set-buffer mailbuf)
+ (setq message-options options)
(push 'mail message-sent-message-via)))
(defvar sendmail-program)
(require 'sha1)
(let (sha1-maximum-internal-length)
(sha1 (concat (message-unique-id)
- (format "%x%x%x" (random) (random t) (random))
+ (format "%x%x%x" (random)
+ (progn (random t) (random))
+ (random))
(prin1-to-string (recent-keys))
(prin1-to-string (garbage-collect))))))
(message-fetch-field "Followup-To")))
;; BUG: We really need to get the charset for each name in the
;; Newsgroups and Followup-To lines to allow crossposting
- ;; between group namess with incompatible character sets.
+ ;; between group names with incompatible character sets.
;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
(group-field-charset
(gnus-group-name-charset method newsgroups-field))
;; You might for example insert a "." somewhere (not next to another dot
;; or string boundary), or modify the "fsf" string.
(defun message-unique-id ()
+ (random t)
;; Don't use microseconds from (current-time), they may be unsupported.
;; Instead we use this randomly inited counter.
(setq message-unique-id-char
- (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
+ (% (1+ (or message-unique-id-char
+ (logand (random most-positive-fixnum) (1- (lsh 1 20)))))
;; (current-time) returns 16-bit ints,
;; and 2^16*25 just fits into 4 digits i base 36.
(* 25 25)))
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."
- ;; 21 is the number suggested by USEAGE.
+ ;; 21 is the number suggested by USAGE.
(let ((maxcount 21)
(count 0)
(cut 2)
(progn
(gnus-select-frame-set-input-focus (window-frame window))
(select-window window))
- (funcall (or switch-function 'pop-to-buffer) buffer)
+ (funcall (or switch-function #'pop-to-buffer) buffer)
(set-buffer buffer))
(when (and (buffer-modified-p)
(not (prog1
"Message already being composed; erase? ")
(message nil))))
(error "Message being composed")))
- (funcall (or switch-function 'pop-to-buffer) name)
+ (funcall (or switch-function
+ (if (fboundp #'pop-to-buffer-same-window)
+ #'pop-to-buffer-same-window
+ #'pop-to-buffer))
+ name)
(set-buffer name))
(erase-buffer)
(message-mode)))
;; Rename the buffer.
(if message-send-rename-function
(funcall message-send-rename-function)
- ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
- (when (string-match
- "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
- (buffer-name))
- (let ((name (match-string 2 (buffer-name)))
- to group)
- (if (not (or (null name)
- (string-equal name "mail")
- (string-equal name "posting")))
- (setq name (concat "*sent " name "*"))
- (message-narrow-to-headers)
- (setq to (message-fetch-field "to"))
- (setq group (message-fetch-field "newsgroups"))
- (widen)
- (setq name
- (cond
- (to (concat "*sent mail to "
- (or (car (mail-extract-address-components to))
- to) "*"))
- ((and group (not (string= group "")))
- (concat "*sent posting on " group "*"))
- (t "*sent mail*"))))
- (unless (string-equal name (buffer-name))
- (rename-buffer name t)))))
+ (message-default-send-rename-function))
;; Push the current buffer onto the list.
(when message-max-buffers
(setq message-buffer-list
(nconc message-buffer-list (list (current-buffer))))))
+(defun message-default-send-rename-function ()
+ ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
+ (when (string-match
+ "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
+ (buffer-name))
+ (let ((name (match-string 2 (buffer-name)))
+ to group)
+ (if (not (or (null name)
+ (string-equal name "mail")
+ (string-equal name "posting")))
+ (setq name (concat "*sent " name "*"))
+ (message-narrow-to-headers)
+ (setq to (message-fetch-field "to"))
+ (setq group (message-fetch-field "newsgroups"))
+ (widen)
+ (setq name
+ (cond
+ (to (concat "*sent mail to "
+ (or (car (mail-extract-address-components to))
+ to) "*"))
+ ((and group (not (string= group "")))
+ (concat "*sent posting on " group "*"))
+ (t "*sent mail*"))))
+ (unless (string-equal name (buffer-name))
+ (rename-buffer name t)))))
+
(defun message-mail-user-agent ()
(let ((mua (cond
((not message-mail-user-agent) nil)
(message-position-point)
;; Allow correct handling of `message-checksum' in `message-yank-original':
(set-buffer-modified-p nil)
- (undo-boundary))
+ (undo-boundary)
+ ;; rmail-start-mail expects message-mail to return t (Bug#9392)
+ t)
(defun message-set-auto-save-file-name ()
"Associate the message buffer with a file in the drafts directory."
addr))
(cons (downcase (mail-strip-quoted-names addr)) addr)))
(message-tokenize-header recipients)))
- ;; Remove first duplicates. (Why not all duplicates? Is this a bug?)
+ ;; Remove all duplicates.
(let ((s recipients))
(while s
- (setq recipients (delq (assoc (car (pop s)) s) recipients))))
+ (let ((address (car (pop s))))
+ (while (assoc address s)
+ (setq recipients (delq (assoc address s) recipients)
+ s (delq (assoc address s) s))))))
;; Remove hierarchical lists that are contained within each other,
;; if message-hierarchical-addresses is defined.
(unless follow-to
(setq follow-to (message-get-reply-headers wide to-address))))
- (unless (message-mail-user-agent)
- (message-pop-to-buffer
- (message-buffer-name
- (if wide "wide reply" "reply") from
- (if wide to-address nil))
- switch-function))
-
- (setq message-reply-headers
- (vector 0 subject from date message-id references 0 0 ""))
-
- (message-setup
- `((Subject . ,subject)
- ,@follow-to)
- cur)))
+ (let ((headers
+ `((Subject . ,subject)
+ ,@follow-to)))
+ (unless (message-mail-user-agent)
+ (message-pop-to-buffer
+ (message-buffer-name
+ (if wide "wide reply" "reply") from
+ (if wide to-address nil))
+ switch-function))
+ (setq message-reply-headers
+ (vector 0 (cdr (assq 'Subject headers))
+ from date message-id references 0 0 ""))
+ (message-setup headers cur))))
;;;###autoload
(defun message-wide-reply (&optional to-address)
(save-excursion
(save-restriction
(message-narrow-to-head-1)
- (if (message-fetch-field "Cancel-Lock")
+ (if (and (message-fetch-field "Cancel-Lock")
+ (message-gnksa-enable-p 'canlock-verify))
(if (null (canlock-verify))
t
(error "Failed to verify Cancel-lock: This article is not yours"))
(defun message-wash-subject (subject)
"Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT.
-Previous forwarders, replyers, etc. may add it."
+Previous forwarders, repliers, etc. may add it."
(with-temp-buffer
(insert subject)
(goto-char (point-min))
(with-temp-buffer
(insert-buffer-substring cur)
(when (setq handles (mm-dissect-buffer t t))
- (if (and (prog1
- (bufferp (car handles))
- (mm-destroy-parts handles))
+ (if (and (bufferp (car handles))
(equal (mm-handle-media-type handles) "text/plain"))
(progn
+ (erase-buffer)
+ (insert-buffer-substring (car handles))
(mm-decode-content-transfer-encoding
(mm-handle-encoding handles))
+ (mm-destroy-parts handles)
(setq handles (mm-uu-dissect)))
+ (mm-destroy-parts handles)
(setq handles nil))))))
(when handles
(prog1
"Like `message-mail' command, but display mail buffer in another window."
(interactive)
(unless (message-mail-user-agent)
- (let ((pop-up-windows t)
- (special-display-buffer-names nil)
- (special-display-regexps nil)
- (same-window-buffer-names nil)
- (same-window-regexps nil))
- (message-pop-to-buffer (message-buffer-name "mail" to))))
+ (message-pop-to-buffer (message-buffer-name "mail" to)
+ 'switch-to-buffer-other-window))
(let ((message-this-is-mail t))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
nil nil nil 'switch-to-buffer-other-window)))
"Like `message-mail' command, but display mail buffer in another frame."
(interactive)
(unless (message-mail-user-agent)
- (let ((pop-up-frames t)
- (special-display-buffer-names nil)
- (special-display-regexps nil)
- (same-window-buffer-names nil)
- (same-window-regexps nil))
- (message-pop-to-buffer (message-buffer-name "mail" to))))
+ (message-pop-to-buffer (message-buffer-name "mail" to)
+ 'switch-to-buffer-other-frame))
(let ((message-this-is-mail t))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
nil nil nil 'switch-to-buffer-other-frame)))
(defun message-news-other-window (&optional newsgroups subject)
"Start editing a news article to be sent."
(interactive)
- (let ((pop-up-windows t)
- (special-display-buffer-names nil)
- (special-display-regexps nil)
- (same-window-buffer-names nil)
- (same-window-regexps nil))
- (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
+ (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)
+ 'switch-to-buffer-other-window)
(let ((message-this-is-news t))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
(defun message-news-other-frame (&optional newsgroups subject)
"Start editing a news article to be sent."
(interactive)
- (let ((pop-up-frames t)
- (special-display-buffer-names nil)
- (special-display-regexps nil)
- (same-window-buffer-names nil)
- (same-window-regexps nil))
- (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
+ (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)
+ 'switch-to-buffer-other-frame)
(let ((message-this-is-news t))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
'message-tool-bar-retro)
"Specifies the message mode tool bar.
-It can be either a list or a symbol refering to a list. See
+It can be either a list or a symbol referring to a list. See
`gmm-tool-bar-from-list' for the format of the list. The
default key map is `message-mode-map'.
(let ((mail-abbrev-mode-regexp (caar alist)))
(not (mail-abbrev-in-expansion-header-p))))
(setq alist (cdr alist)))
- (cdar alist)))
+ (when (cdar alist)
+ (lexical-let ((fun (cdar alist)))
+ ;; Even if completion fails, return a non-nil value, so as to avoid
+ ;; falling back to message-tab-body-function.
+ (lambda () (funcall fun) 'completion-attempted)))))
(eval-and-compile
(condition-case nil
(defun message-read-from-minibuffer (prompt &optional initial-contents)
"Read from the minibuffer while providing abbrev expansion."
(if (fboundp 'mail-abbrevs-setup)
- (let ((mail-abbrev-mode-regexp "")
- (minibuffer-setup-hook 'mail-abbrevs-setup)
+ (let ((minibuffer-setup-hook 'mail-abbrevs-setup)
(minibuffer-local-map message-minibuffer-local-map))
- (read-from-minibuffer prompt initial-contents))
+ (flet ((mail-abbrev-in-expansion-header-p nil t))
+ (read-from-minibuffer prompt initial-contents)))
(let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
(minibuffer-local-map message-minibuffer-local-map))
(read-string prompt initial-contents))))
projects / gnus / blobdiff