;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2012 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
+(require 'format-spec)
(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
;; In Emacs 24.1 this defaults to the value of `mail-from-style'
;; that defaults to:
;; `angles' in Emacs 22.1~23.1, XEmacs 21.4, 21.5, and SXEmacs 22.1;
- ;; `default' in Emacs 23.2, and 24.1
- "*Specifies how \"From\" headers look.
+ ;; `system-default' in Emacs 23.2, and 24.1
+ "Specifies how \"From\" headers look.
If nil, they contain just the return address like:
king@grassland.com
regexp))
(defcustom message-ignored-mail-headers
- "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
+ "^\\([GF]cc\\|Resent-Fcc\\|Xref\\|X-Draft-From\\|X-Gnus-Agent-Meta-Information\\):"
"*Regexp of headers to be removed unconditionally before mailing."
:group 'message-mail
:group 'message-headers
:group 'message-various)
(defcustom message-elide-ellipsis "\n[...]\n\n"
- "*The string which is inserted for elided text."
+ "*The string which is inserted for elided text.
+This is a format-spec string, and you can use %l to say how many
+lines were removed, and %c to say how many characters were
+removed."
:type 'string
:link '(custom-manual "(message)Various Commands")
:group 'message-various)
:group 'message-buffers
:type 'boolean)
-(defvar gnus-local-organization)
(defcustom message-user-organization
- (or (and (boundp 'gnus-local-organization)
- (stringp gnus-local-organization)
- gnus-local-organization)
- (getenv "ORGANIZATION")
- t)
- "*String to be used as an Organization header.
+ (or (getenv "ORGANIZATION") t)
+ "String to be used as an Organization header.
If t, use `message-user-organization-file'."
:group 'message-headers
:type '(choice string
(defcustom message-send-mail-function
(cond ((eq send-mail-function 'smtpmail-send-it) 'message-smtpmail-send-it)
((eq send-mail-function 'feedmail-send-it) 'feedmail-send-it)
+ ((eq send-mail-function 'sendmail-query-once) 'sendmail-query-once)
((eq send-mail-function 'mailclient-send-it)
'message-send-mail-with-mailclient)
(t (message-send-mail-function)))
;; create a dependence to `gnus.el'.
:type 'sexp)
-;; FIXME: This should be a temporary workaround until someone implements a
-;; proper solution. If a crash happens while replying, the auto-save file
-;; 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)
+(defcustom message-generate-headers-first nil
"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
: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"))))
: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)
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
+(defcustom message-cite-reply-position 'traditional
+ "*Where the reply should be positioned.
+If `traditional', reply inline.
+If `above', reply above quoted text.
+If `below', reply below quoted text.
+
+Note: Many newsgroups frown upon nontraditional reply styles. You
+probably want to set this variable only for specific groups,
+e.g. using `gnus-posting-styles':
+
+ (eval (set (make-local-variable 'message-cite-reply-position) 'above))"
+ :type '(choice (const :tag "Reply inline" 'traditional)
+ (const :tag "Reply above" 'above)
+ (const :tag "Reply below" 'below))
+ :group 'message-insertion)
+
+(defcustom message-cite-style nil
+ "*The overall style to be used when yanking cited text.
+Value is either `nil' (no variable overrides) or a let-style list
+of pairs (VARIABLE VALUE) that will be bound in
+`message-yank-original' to do the quoting.
+
+Presets to impersonate popular mail agents are found in the
+message-cite-style-* variables. This variable is intended for
+use in `gnus-posting-styles', such as:
+
+ ((posting-from-work-p) (eval (set (make-local-variable 'message-cite-style) message-cite-style-outlook)))"
+ :version "24.1"
+ :group 'message-insertion
+ :type '(choice (const :tag "Do not override variables" :value nil)
+ (const :tag "MS Outlook" :value message-cite-style-outlook)
+ (const :tag "Mozilla Thunderbird" :value message-cite-style-thunderbird)
+ (const :tag "Gmail" :value message-cite-style-gmail)
+ (variable :tag "User-specified")))
+
+(defconst message-cite-style-outlook
+ '((message-cite-function 'message-cite-original)
+ (message-citation-line-function 'message-insert-formatted-citation-line)
+ (message-cite-reply-position 'above)
+ (message-yank-prefix "")
+ (message-yank-cited-prefix "")
+ (message-yank-empty-prefix "")
+ (message-citation-line-format "\n\n-----------------------\nOn %a, %b %d %Y, %N wrote:\n"))
+ "Message citation style used by MS Outlook. Use with message-cite-style.")
+
+(defconst message-cite-style-thunderbird
+ '((message-cite-function 'message-cite-original)
+ (message-citation-line-function 'message-insert-formatted-citation-line)
+ (message-cite-reply-position 'above)
+ (message-yank-prefix "> ")
+ (message-yank-cited-prefix ">")
+ (message-yank-empty-prefix ">")
+ (message-citation-line-format "On %D %R %p, %N wrote:"))
+ "Message citation style used by Mozilla Thunderbird. Use with message-cite-style.")
+
+(defconst message-cite-style-gmail
+ '((message-cite-function 'message-cite-original)
+ (message-citation-line-function 'message-insert-formatted-citation-line)
+ (message-cite-reply-position 'above)
+ (message-yank-prefix " ")
+ (message-yank-cited-prefix " ")
+ (message-yank-empty-prefix " ")
+ (message-citation-line-format "On %e %B %Y %R, %f wrote:\n"))
+ "Message citation style used by Gmail. Use with message-cite-style.")
+
(defcustom message-distribution-function nil
"*Function called to return a Distribution header."
:group 'message-news
(defvar message-checksum nil)
(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 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
(if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
system-configuration)
(file-readable-p "/etc/sendmail.cf")
- (let ((buffer (get-buffer-create " *temp*")))
- (unwind-protect
- (with-current-buffer buffer
- (insert-file-contents "/etc/sendmail.cf")
- (goto-char (point-min))
- (let ((case-fold-search nil))
- (re-search-forward "^OR\\>" nil t)))
- (kill-buffer buffer))))
+ (with-temp-buffer
+ (insert-file-contents "/etc/sendmail.cf")
+ (goto-char (point-min))
+ (let ((case-fold-search nil))
+ (re-search-forward "^OR\\>" nil t))))
;; According to RFC822, "The field-name must be composed of printable
;; ASCII characters (i. e., characters that have decimal values between
;; 33 and 126, except colon)", i. e., any chars except ctl chars,
: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))
(defvar message-options nil
"Some saved answers when sending message.")
+;; FIXME: On XEmacs this causes problems since let-binding like:
+;; (let ((message-options message-options)) ...)
+;; as in `message-send' and `mml-preview' loses to buffer-local
+;; variable initialization.
+(unless (featurep 'xemacs)
+ (make-variable-buffer-local 'message-options))
(defvar message-send-mail-real-function nil
"Internal send mail function.")
-(defvar message-bogus-system-names "^localhost\\.\\|\\.local$"
+(defvar message-bogus-system-names "\\`localhost\\.\\|\\.local\\'"
"The regexp of bogus system names.")
(defcustom message-valid-fqdn-regexp
(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.
:link '(custom-manual "(message)Various Message Variables")
:type 'boolean)
-(defconst message-forbidden-properties
+(defvar message-forbidden-properties
;; No reason this should be clutter up customize. We make it a
;; property list (rather than a list of property symbols), to be
;; directly useful for `remove-text-properties'.
(set (make-local-variable 'message-reply-buffer) nil)
(set (make-local-variable 'message-inserted-headers) nil)
(set (make-local-variable 'message-send-actions) nil)
+ (set (make-local-variable 'message-return-action) 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)
(mail-aliases-setup))))
((message-mail-alias-type-p 'ecomplete)
(ecomplete-setup)))
+ (add-hook 'completion-at-point-functions 'message-completion-function nil t)
(unless buffer-file-name
(message-set-auto-save-file-name))
(unless (buffer-base-buffer)
(interactive)
(message-position-on-field "Summary" "Subject"))
-(defun message-goto-body (&optional interactivep)
+(eval-when-compile
+ (defmacro message-called-interactively-p (kind)
+ (condition-case nil
+ (progn
+ (eval '(called-interactively-p 'any))
+ ;; Emacs >=23.2
+ `(called-interactively-p ,kind))
+ ;; Emacs <23.2
+ (wrong-number-of-arguments '(called-interactively-p))
+ ;; XEmacs
+ (void-function '(interactive-p)))))
+
+(defun message-goto-body ()
"Move point to the beginning of the message body."
- (interactive (list t))
- (when (and interactivep
+ (interactive)
+ (when (and (message-called-interactively-p 'any)
(looking-at "[ \t]*\n"))
(expand-abbrev))
(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))
- (while (looking-at "^<#secure") (forward-line 1)))
+ (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
(defun message-in-body-p ()
"Return t if point is in the message body."
- (let ((body (save-excursion (message-goto-body) (point))))
+ (let ((body (save-excursion (message-goto-body))))
(>= (point) body)))
(defun message-goto-eoh ()
(defun message-point-in-header-p ()
"Return t if point is in the header."
(save-excursion
- (not (re-search-backward
- (concat "^" (regexp-quote mail-header-separator) "\n") nil t))))
+ (and
+ (not
+ (re-search-backward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t))))
(defun message-do-auto-fill ()
"Like `do-auto-fill', but don't fill in message header."
An ellipsis (from `message-elide-ellipsis') will be inserted where the
text was killed."
(interactive "r")
- (kill-region b e)
- (insert message-elide-ellipsis))
+ (let ((lines (count-lines b e))
+ (chars (- e b)))
+ (kill-region b e)
+ (insert (format-spec message-elide-ellipsis
+ `((?l . ,lines)
+ (?c . ,chars))))))
(defvar message-caesar-translation-table nil)
(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 "$"))
(while (re-search-forward citexp nil t)
(replace-match (if remove "" "\n"))))))
-(defvar message-cite-reply-above nil
- "If non-nil, start own text above the quote.
-
-Note: Top posting is bad netiquette. Don't use it unless you
-really must. You probably want to set variable only for specific
-groups, e.g. using `gnus-posting-styles':
-
- (eval (set (make-local-variable 'message-cite-reply-above) t))
-
-This variable has no effect in news postings.")
+(defun message--yank-original-internal (arg)
+ (let ((modified (buffer-modified-p))
+ body-text)
+ (when (and message-reply-buffer
+ message-cite-function)
+ (when (equal message-cite-reply-position 'above)
+ (save-excursion
+ (setq body-text
+ (buffer-substring (message-goto-body)
+ (point-max)))
+ (delete-region (message-goto-body) (point-max))))
+ (if (bufferp message-reply-buffer)
+ (delete-windows-on message-reply-buffer t))
+ (push-mark (save-excursion
+ (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)))
+ (unless arg
+ (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))))
+ (case message-cite-reply-position
+ (above
+ (message-goto-body)
+ (insert body-text)
+ (insert (if (bolp) "\n" "\n\n"))
+ (message-goto-body))
+ (below
+ (message-goto-signature)))
+ ;; Add a `message-setup-very-last-hook' here?
+ ;; Add `gnus-article-highlight-citation' here?
+ (unless modified
+ (setq message-checksum (message-checksum))))))
(defun message-yank-original (&optional arg)
"Insert the message being replied to, if any.
Just \\[universal-argument] as argument means don't indent, insert no
prefix, and don't delete any headers."
(interactive "P")
- (let ((modified (buffer-modified-p))
- body-text)
- (when (and message-reply-buffer
- message-cite-function)
- (when message-cite-reply-above
- (if (and (not (message-news-p))
- (or (eq message-cite-reply-above 'is-evil)
- (y-or-n-p "\
-Top posting is bad netiquette. Please don't top post unless you really must.
-Really top post? ")))
- (save-excursion
- (setq body-text
- (buffer-substring (message-goto-body)
- (point-max)))
- (delete-region (message-goto-body) (point-max)))
- (set (make-local-variable 'message-cite-reply-above) nil)))
- (if (bufferp message-reply-buffer)
- (delete-windows-on message-reply-buffer t))
- (push-mark (save-excursion
- (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)))
- (unless arg
- (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))))))
+ ;; eval the let forms contained in message-cite-style
+ (eval
+ `(let ,message-cite-style
+ (message--yank-original-internal ',arg))))
(defun message-yank-buffer (buffer)
"Insert BUFFER into the current buffer and quote it."
;;;
(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))
(when (and (message-send arg)
(buffer-name buf))
+ (message-bury buf)
(if message-kill-buffer-on-exit
- (kill-buffer buf)
- (bury-buffer buf)
- (when (eq buf (current-buffer))
- (message-bury buf)))
+ (kill-buffer buf))
(message-do-actions actions)
t)))
(defun message-bury (buffer)
"Bury this mail BUFFER."
- (let ((newbuf (other-buffer buffer)))
- (bury-buffer buffer)
- (if (and (window-dedicated-p (selected-window))
- (not (null (delq (selected-frame) (visible-frame-list)))))
- (delete-frame (selected-frame))
- (switch-to-buffer newbuf))))
+ (if message-return-action
+ (progn
+ (bury-buffer buffer)
+ (apply (car message-return-action) (cdr message-return-action)))
+ (with-current-buffer buffer (bury-buffer))))
(defun message-send (&optional arg)
"Send the message in the current buffer.
(nreverse regions)))
(defcustom message-bogus-addresses
- ;; '("noreply" "nospam" "invalid")
'("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]")
"List of regexps of potentially bogus mail addresses.
See `message-check-recipients' how to setup checking.
"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"
;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"?
(let (found)
(mapc (lambda (address)
- (setq address (cadr address))
+ (setq address (or (cadr address) ""))
(when
- (or (not
+ (or (string= "" address)
+ (not
(or
(not (string-match "@" address))
(string-match
"\\|")
message-bogus-addresses)))
(string-match re address))))
- (push address found)))
+ (push address found)))
;;
(mail-extract-address-components recipients t))
found))
(and bog
(not (y-or-n-p
(format
- "Address `%s' might be bogus. Continue? " bog)))
+ "Address `%s'%s might be bogus. Continue? "
+ bog
+ ;; If the encoded version of the email address
+ ;; is different from the unencoded version,
+ ;; then we likely have invisible characters or
+ ;; the like. Display the encoded version,
+ ;; too.
+ (let ((encoded (rfc2047-encode-string bog)))
+ (if (string= encoded bog)
+ ""
+ (format " (%s)" encoded))))))
(error "Bogus address"))))))))
(custom-add-option 'message-setup-hook 'message-check-recipients)
;; A simple function.
((functionp action)
(funcall action))
- ;; Something to be evaled.
+ ;; Something to be evalled.
(t
(eval action))))))
(tembuf (message-generate-new-buffer-clone-locals " message temp"))
(curbuf (current-buffer))
(id (message-make-message-id)) (n 1)
- plist total header required-mail-headers)
+ plist total header)
(while (not (eobp))
(if (< (point-max) (+ p message-send-mail-partially-limit))
(goto-char (point-max))
(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)
+
(defun message-send-mail-with-sendmail ()
"Send off the prepared buffer with sendmail."
(require 'sendmail)
(cpr (apply
'call-process-region
(append
- (list (point-min) (point-max)
- (cond ((boundp 'sendmail-program)
- sendmail-program)
- ((file-exists-p "/usr/sbin/sendmail")
- "/usr/sbin/sendmail")
- ((file-exists-p "/usr/lib/sendmail")
- "/usr/lib/sendmail")
- ((file-exists-p "/usr/ucblib/sendmail")
- "/usr/ucblib/sendmail")
- (t "fakemail"))
+ (list (point-min) (point-max) sendmail-program
nil errbuf nil "-oi")
message-sendmail-extra-arguments
;; Always specify who from,
;; should never happen
(t (error "qmail-inject reported unknown failure"))))
+(defvar mh-previous-window-config)
+
(defun message-send-mail-with-mh ()
"Send the prepared message buffer with mh."
(let ((mh-previous-window-config nil)
(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))
t))
;; Check long header lines.
(message-check 'long-header-lines
- (let ((start (point))
- (header nil)
+ (let ((header nil)
(length 0)
found)
(while (and (not found)
(setq found t
length (- (point) (match-beginning 0)))
(setq header (match-string-no-properties 1)))
- (setq start (match-beginning 0))
(forward-line 1))
(if found
(y-or-n-p (format "Your %s header is too long (%d). Really post? "
;; 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)))
(defun message-idna-to-ascii-rhs-1 (header)
"Interactively potentially IDNA encode domain names in HEADER."
(let ((field (message-fetch-field header))
- rhs ace address)
+ ace)
(when field
(dolist (rhs
(mm-delete-duplicates
(message-idna-to-ascii-rhs-1 "Mail-Followup-To")
(message-idna-to-ascii-rhs-1 "Cc")))))
+(defvar Date)
+(defvar Message-ID)
+(defvar Organization)
+(defvar From)
+(defvar Path)
+(defvar Subject)
+(defvar Newsgroups)
+(defvar In-Reply-To)
+(defvar References)
+(defvar To)
+(defvar Distribution)
+(defvar Lines)
+(defvar User-Agent)
+(defvar Expires)
+
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
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)
;; 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)
+ continue switch-function return-action)
(let ((mua (message-mail-user-agent))
subject to field)
(if (not (and message-this-is-mail mua))
- (message-setup-1 headers yank-action actions)
+ (message-setup-1 headers yank-action actions return-action)
(setq headers (copy-sequence headers))
(setq field (assq 'Subject headers))
(when field
(push header result)))
(nreverse result)))
-(defun message-setup-1 (headers &optional yank-action actions)
+(defun message-setup-1 (headers &optional yank-action actions return-action)
(dolist (action actions)
(condition-case nil
(add-to-list 'message-send-actions
`(apply ',(car action) ',(cdr action)))))
+ (setq message-return-action return-action)
(setq message-reply-buffer
(if (and (consp yank-action)
(eq (car yank-action) 'insert-buffer))
(funcall message-default-headers)
message-default-headers))
(or (bolp) (insert ?\n)))
- (insert mail-header-separator "\n")
+ (insert (concat mail-header-separator "\n"))
(forward-line -1)
- (when (message-news-p)
- (when message-default-news-headers
- (insert message-default-news-headers)
- (or (bolp) (insert ?\n)))
- (when message-generate-headers-first
+ ;; If a crash happens while replying, the auto-save file would *not* have a
+ ;; `References:' header if `message-generate-headers-first' was nil.
+ ;; Therefore, always generate it first.
+ (let ((message-generate-headers-first
+ (if (eq message-generate-headers-first t)
+ t
+ (append message-generate-headers-first '(References)))))
+ (when (message-news-p)
+ (when message-default-news-headers
+ (insert message-default-news-headers)
+ (or (bolp) (insert ?\n)))
(message-generate-headers
(message-headers-to-generate
- (append message-required-news-headers
- message-required-headers)
- message-generate-headers-first
- '(Lines Subject)))))
- (when (message-mail-p)
- (when message-default-mail-headers
- (insert message-default-mail-headers)
- (or (bolp) (insert ?\n)))
- (when message-generate-headers-first
+ (append message-required-news-headers
+ message-required-headers)
+ message-generate-headers-first
+ '(Lines Subject))))
+ (when (message-mail-p)
+ (when message-default-mail-headers
+ (insert message-default-mail-headers)
+ (or (bolp) (insert ?\n)))
(message-generate-headers
(message-headers-to-generate
- (append message-required-mail-headers
- message-required-headers)
- message-generate-headers-first
- '(Lines Subject)))))
+ (append message-required-mail-headers
+ message-required-headers)
+ message-generate-headers-first
+ '(Lines Subject)))))
(run-hooks 'message-signature-setup-hook)
(message-insert-signature)
(save-restriction
(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."
;;;
;;;###autoload
-(defun message-mail (&optional to subject
- other-headers continue switch-function
- yank-action send-actions)
+(defun message-mail (&optional to subject other-headers continue
+ switch-function yank-action send-actions
+ return-action &rest ignored)
"Start editing a mail message to be sent.
OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether
to continue editing a message already being composed. SWITCH-FUNCTION
(message-setup
(nconc
`((To . ,(or to "")) (Subject . ,(or subject "")))
- (when other-headers other-headers))
- yank-action send-actions continue switch-function)
- ;; FIXME: Should return nil if failure.
- t))
+ ;; C-h f compose-mail says that headers should be specified as
+ ;; (string . value); however all the rest of message expects
+ ;; headers to be symbols, not strings (eg message-header-format-alist).
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg00337.html
+ ;; We need to convert any string input, eg from rmail-start-mail.
+ (dolist (h other-headers other-headers)
+ (if (stringp (car h)) (setcar h (intern (capitalize (car h)))))))
+ yank-action send-actions continue switch-function
+ return-action)))
;;;###autoload
(defun message-news (&optional newsgroups subject)
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.
subject)
;;;###autoload
-(defun message-reply (&optional to-address wide)
+(defun message-reply (&optional to-address wide switch-function)
"Start editing a reply to the article in the current buffer."
(interactive)
(require 'gnus-sum) ; for gnus-list-identifiers
(let ((cur (current-buffer))
- from subject date reply-to to cc
+ from subject date
references message-id follow-to
(inhibit-point-motion-hooks t)
(message-this-is-mail t)
(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))))
-
- (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))
(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")))
+ (mml-insert-buffer forward-buffer)
+ (insert
+ "\n-------------------- End of forwarded message --------------------\n"))
(defun message-forward-make-body-digest-mime (forward-buffer)
(insert "\n<#multipart type=digest>\n")
(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
(setq rmail-insert-mime-forwarded-message-function
'message-forward-rmail-make-body))
+(defvar message-inhibit-body-encoding nil)
+
;;;###autoload
(defun message-resend (address)
"Resend the current article to ADDRESS."
;; We first set up a normal mail buffer.
(unless (message-mail-user-agent)
(set-buffer (get-buffer-create " *message resend*"))
- (erase-buffer))
+ (let ((inhibit-read-only t))
+ (erase-buffer)))
(let ((message-this-is-mail t)
message-generate-hashcash
message-setup-hook)
(insert "Resent-"))
(widen)
(forward-line)
- (delete-region (point) (point-max))
+ (let ((inhibit-read-only t))
+ (delete-region (point) (point-max)))
(setq beg (point))
;; Insert the message to be resent.
(insert-buffer-substring cur)
"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'.
(defcustom message-tool-bar-gnome
'((ispell-message "spell" nil
+ :vert-only t
:visible (or (not (boundp 'flyspell-mode))
(not flyspell-mode)))
(flyspell-buffer "spell" t
+ :vert-only t
:visible (and (boundp 'flyspell-mode)
flyspell-mode)
:help "Flyspell whole buffer")
- (gmm-ignore "separator")
- (message-send-and-exit "mail/send")
+ (message-send-and-exit "mail/send" t :label "Send")
(message-dont-send "mail/save-draft")
- (message-kill-buffer "close") ;; stock_cancel
- (mml-attach-file "attach" mml-mode-map)
+ (mml-attach-file "attach" mml-mode-map :vert-only t)
(mml-preview "mail/preview" mml-mode-map)
(mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil)
(message-insert-importance-high "important" nil :visible nil)
(message-insert-importance-low "unimportant" nil :visible nil)
- (message-insert-disposition-notification-to "receipt" nil :visible nil)
- (gmm-customize-mode "preferences" t :help "Edit mode preferences")
- (message-info "help" t :help "Message manual"))
+ (message-insert-disposition-notification-to "receipt" nil :visible nil))
"List of items for the message tool bar (GNOME style).
See `gmm-tool-bar-from-list' for details on the format of the list."
:type '(alist :key-type regexp :value-type function))
(defcustom message-expand-name-databases
- (list 'bbdb 'eudc)
+ '(bbdb eudc)
"List of databases to try for name completion (`message-expand-name').
Each element is a symbol and can be `bbdb' or `eudc'."
:group 'message
Execute function specified by `message-tab-body-function' when not in
those headers."
(interactive)
+ (cond
+ ((if (and (boundp 'completion-fail-discreetly)
+ (fboundp 'completion-at-point))
+ (let ((completion-fail-discreetly t)) (completion-at-point))
+ (funcall (or (message-completion-function) #'ignore)))
+ ;; Completion was performed; nothing else to do.
+ nil)
+ (message-tab-body-function (funcall message-tab-body-function))
+ (t (funcall (or (lookup-key text-mode-map "\t")
+ (lookup-key global-map "\t")
+ 'indent-relative)))))
+
+(defvar mail-abbrev-mode-regexp)
+
+(defun message-completion-function ()
(let ((alist message-completion-alist))
(while (and alist
(let ((mail-abbrev-mode-regexp (caar alist)))
(not (mail-abbrev-in-expansion-header-p))))
(setq alist (cdr alist)))
- (funcall (or (cdar alist) message-tab-body-function
- (lookup-key text-mode-map "\t")
- (lookup-key global-map "\t")
- 'indent-relative))))
+ (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
(eudc-expand-inline))
((and (memq 'bbdb message-expand-name-databases)
(fboundp 'bbdb-complete-name))
- (bbdb-complete-name))
+ (let ((starttick (buffer-modified-tick)))
+ (or (bbdb-complete-name)
+ ;; Apparently, bbdb-complete-name can return nil even when
+ ;; completion took place. So let's double check the buffer was
+ ;; not modified.
+ (/= starttick (buffer-modified-tick)))))
(t
(expand-abbrev))))
;;; MIME functions
;;;
-(defvar message-inhibit-body-encoding nil)
-
(defun message-encode-message-body ()
(unless message-inhibit-body-encoding
(let ((mail-parse-charset (or mail-parse-charset
(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