;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(eval-when-compile
(require 'cl)
(defvar gnus-message-group-art)
- (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
+ (defvar gnus-list-identifiers) ; gnus-sum is required where necessary
+ (require 'hashcash))
(require 'canlock)
(require 'mailheader)
(require 'nnheader)
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
-(eval-and-compile
- (autoload 'sha1 "sha1-el")
- (autoload 'gnus-find-method-for-group "gnus")
- (autoload 'nnvirtual-find-group-art "nnvirtual")
- (autoload 'gnus-group-decoded-name "gnus-group"))
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
(defcustom message-fcc-externalize-attachments nil
"If non-nil, attachments are included as external parts in Fcc copies."
+ :version "22.1"
:type 'boolean
:group 'message-sending)
the article has been posted to will be inserted there.
If this variable is nil, no such courtesy message will be added."
:group 'message-sending
- :type '(radio (string :format "%t: %v\n" :size 0) (const nil)))
+ :type '(radio string (const nil)))
(defcustom message-ignored-bounced-headers
"^\\(Received\\|Return-Path\\|Delivered-To\\):"
(defcustom message-insert-canlock t
"Whether to insert a Cancel-Lock header in news postings."
- :version "21.3"
+ :version "22.1"
:group 'message-headers
:type 'boolean)
"*Headers to be generated or prompted for when sending a message.
Also see `message-required-news-headers' and
`message-required-mail-headers'."
+ :version "22.1"
:group 'message-news
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
(defcustom message-draft-headers '(References From)
"*Headers to be generated when saving a draft message."
+ :version "22.1"
:group 'message-news
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
:group 'message-news
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
- :type 'regexp)
+ :type '(repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
+ regexp))
(defcustom message-ignored-mail-headers
"^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
:link '(custom-manual "(message)Mail Headers")
:type 'regexp)
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:"
"*Header lines matching this regexp will be deleted before posting.
It's best to delete old Path and Date headers before posting to avoid
any confusion."
:group 'message-interface
:link '(custom-manual "(message)Superseding")
- :type 'regexp)
+ :type '(repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
+ regexp))
(defcustom message-subject-re-regexp
"^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
`message-subject-trailing-was-query' is t, always strip the trailing
old subject. In this case, `message-subject-trailing-was-regexp' is
used."
+ :version "22.1"
:type '(choice (const :tag "never" nil)
(const :tag "always strip" t)
(const ask))
`message-subject-trailing-was-regexp' instead.
It is okay to create some false positives here, as the user is asked."
+ :version "22.1"
:group 'message-various
:link '(custom-manual "(message)Message Headers")
:type 'regexp)
matched against `message-subject-trailing-was-regexp' in
`message-strip-subject-trailing-was'. You should use a regexp creating very
few false positives here."
+ :version "22.1"
:group 'message-various
:link '(custom-manual "(message)Message Headers")
:type 'regexp)
(defcustom message-mark-insert-begin
"--8<---------------cut here---------------start------------->8---\n"
"How to mark the beginning of some inserted text."
+ :version "22.1"
:type 'string
:link '(custom-manual "(message)Insertion Variables")
:group 'message-various)
(defcustom message-mark-insert-end
"--8<---------------cut here---------------end--------------->8---\n"
"How to mark the end of some inserted text."
+ :version "22.1"
:type 'string
:link '(custom-manual "(message)Insertion Variables")
:group 'message-various)
"X-No-Archive: Yes\n"
"Header to insert when you don't want your article to be archived.
Archives \(such as groups.google.com\) respect this header."
+ :version "22.1"
:type 'string
:link '(custom-manual "(message)Header Commands")
:group 'message-various)
"X-No-Archive: Yes - save http://groups.google.com/"
"Note to insert why you wouldn't want this posting archived.
If nil, don't insert any text in the body."
- :type '(radio (string :format "%t: %v\n" :size 0)
- (const nil))
+ :version "22.1"
+ :type '(radio string (const nil))
:link '(custom-manual "(message)Header Commands")
:group 'message-various)
If nil, `message-cross-post-followup-to' will only do a followup. Note that
you can explicitly override this setting by calling
`message-cross-post-followup-to' with a prefix."
+ :version "22.1"
:type 'boolean
:group 'message-various)
(defcustom message-cross-post-note
"Crosspost & Followup-To: "
"Note to insert before signature to notify of cross-post and follow-up."
+ :version "22.1"
:type 'string
:group 'message-various)
(defcustom message-followup-to-note
"Followup-To: "
"Note to insert before signature to notify of follow-up only."
+ :version "22.1"
:type 'string
:group 'message-various)
The function will be called with four arguments. The function should not only
insert a note, but also ensure old notes are deleted. See the documentation
for `message-cross-post-insert-note'."
+ :version "22.1"
:type 'function
:group 'message-various)
"*All headers that match this regexp will be deleted when resending a message."
:group 'message-interface
:link '(custom-manual "(message)Resending")
- :type 'regexp)
+ :type '(repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
+ regexp))
(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
"*All headers that match this regexp will be deleted when forwarding a message."
:version "21.1"
:group 'message-forwarding
- :type '(choice (const :tag "None" nil)
+ :type '(repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
regexp))
(defcustom message-ignored-cited-headers "."
(if (string-match "[[:digit:]]" "1") ;; support POSIX?
"\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
- (let ((old-table (syntax-table))
- non-word-constituents)
- (set-syntax-table text-mode-syntax-table)
- (setq non-word-constituents
- (concat
- (if (string-match "\\w" "-") "" "-")
- (if (string-match "\\w" "_") "" "_")
- (if (string-match "\\w" ".") "" ".")))
- (set-syntax-table old-table)
+ (let (non-word-constituents)
+ (with-syntax-table text-mode-syntax-table
+ (setq non-word-constituents
+ (concat
+ (if (string-match "\\w" "-") "" "-")
+ (if (string-match "\\w" "_") "" "_")
+ (if (string-match "\\w" ".") "" "."))))
(if (equal non-word-constituents "")
"\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+"
(concat "\\([ \t]*\\(\\w\\|["
non-word-constituents
"]\\)+>+\\|[ \t]*[]>|}+]\\)+"))))
"*Regexp matching the longest possible citation prefix on a line."
+ :version "22.1"
:group 'message-insertion
:link '(custom-manual "(message)Insertion Variables")
:type 'regexp)
;; Useful to set in site-init.el
;;;###autoload
-(defcustom message-send-mail-function 'message-send-mail-with-sendmail
+(defcustom message-send-mail-function
+ (let ((program (if (boundp 'sendmail-program)
+ ;; see paths.el
+ sendmail-program)))
+ (cond
+ ((and program
+ (string-match "/" program) ;; Skip path
+ (file-executable-p program))
+ 'message-send-mail-with-sendmail)
+ ((and program
+ (executable-find program))
+ 'message-send-mail-with-sendmail)
+ (t
+ 'smtpmail-send-it)))
"Function to call to send the current buffer as mail.
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'.
:link '(custom-manual "(message)Followup")
:type '(choice function (const nil)))
+(defcustom message-extra-wide-headers nil
+ "If non-nil, a list of additional address headers.
+These are used when composing a wide reply."
+ :group 'message-sending
+ :type '(repeat string))
+
(defcustom message-use-followup-to 'ask
"*Specifies what to do with Followup-To header.
If nil, always ignore the header. If it is t, use its value, but
If nil, always ignore the header. If it is the symbol `ask', always
query the user whether to use the value. If it is the symbol `use',
always use the value."
+ :version "22.1"
:group 'message-interface
:link '(custom-manual "(message)Mailing Lists")
:type '(choice (const :tag "ignore" nil)
regular expressions to match lists. These functions can be used in
conjunction with `message-subscribed-regexps' and
`message-subscribed-addresses'."
+ :version "22.1"
:group 'message-interface
:link '(custom-manual "(message)Mailing Lists")
:type '(repeat sexp))
"*A file containing addresses the user is subscribed to.
If nil, do not look at any files to determine list subscriptions. If
non-nil, each line of this file should be a mailing list address."
+ :version "22.1"
:group 'message-interface
:link '(custom-manual "(message)Mailing Lists")
- :type '(radio (file :format "%t: %v\n" :size 0)
- (const nil)))
+ :type '(radio file (const nil)))
(defcustom message-subscribed-addresses nil
"*Specifies a list of addresses the user is subscribed to.
If nil, do not use any predefined list subscriptions. This list of
addresses can be used in conjunction with
`message-subscribed-address-functions' and `message-subscribed-regexps'."
+ :version "22.1"
:group 'message-interface
:link '(custom-manual "(message)Mailing Lists")
:type '(repeat string))
If nil, do not use any predefined list subscriptions. This list of
regular expressions can be used in conjunction with
`message-subscribed-address-functions' and `message-subscribed-addresses'."
+ :version "22.1"
:group 'message-interface
:link '(custom-manual "(message)Mailing Lists")
:type '(repeat regexp))
If it is the symbol `always', the posting is allowed. If it is the
symbol `never', the posting is not allowed. If it is the symbol
`ask', you are prompted."
+ :version "22.1"
:group 'message-interface
:link '(custom-manual "(message)Message Headers")
:type '(choice (const always)
"*Envelope-from when sending mail with sendmail.
If this is nil, use `user-mail-address'. If it is the symbol
`header', use the From: header of the message."
+ :version "22.1"
:type '(choice (string :tag "From name")
(const :tag "Use From: header from message" header)
(const :tag "Use `user-mail-address'" nil))
:type '(choice (function)
(repeat string)))
-(defvar message-cater-to-broken-inn t
- "Non-nil means Gnus should not fold the `References' header.
-Folding `References' makes ancient versions of INN create incorrect
-NOV lines.")
-
(eval-when-compile
(defvar gnus-post-method)
(defvar gnus-select-method))
;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138
(defcustom message-generate-headers-first '(references)
"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
+If t, generate all required headers. This can also be a list of headers to
generate. The variables `message-required-news-headers' and
`message-required-mail-headers' specify which headers to generate.
(let ((map (make-sparse-keymap 'message-minibuffer-local-map)))
(set-keymap-parent map minibuffer-local-map)
map)
- "Keymap for `message-read-from-minibuffer'.")
+ "Keymap for `message-read-from-minibuffer'."
+ :version "22.1")
;;;###autoload
(defcustom message-citation-line-function 'message-insert-citation-line
"*Prefix inserted on cited or empty lines of yanked messages.
Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
See also `message-yank-prefix'."
+ :version "22.1"
:type 'string
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
;;;###autoload
(defcustom message-signature-insert-empty-line t
"*If non-nil, insert an empty line before the signature separator."
+ :version "22.1"
:type 'boolean
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
(or (not (listp message-shoot-gnksa-feet))
(memq feature message-shoot-gnksa-feet)))
-(defcustom message-hidden-headers nil
+(defcustom message-hidden-headers "^References:"
"Regexp of headers to be hidden when composing new messages.
This can also be a list of regexps to match headers. Or a list
starting with `not' and followed by regexps."
+ :version "22.1"
:group 'message
:link '(custom-manual "(message)Message Headers")
- :type '(repeat regexp))
+ :type '(choice
+ :format "%{%t%}: %[Value Type%] %v"
+ (regexp :menu-tag "regexp" :format "regexp\n%t: %v")
+ (repeat :menu-tag "(regexp ...)" :format "(regexp ...)\n%v%i"
+ (regexp :format "%t: %v"))
+ (cons :menu-tag "(not regexp ...)" :format "(not regexp ...)\n%v"
+ (const not)
+ (repeat :format "%v%i"
+ (regexp :format "%t: %v")))))
+
+(defcustom message-cite-articles-with-x-no-archive t
+ "If non-nil, cite text from articles that has X-No-Archive set."
+ :group 'message
+ :type 'boolean)
;;; Internal variables.
;;; Well, not really internal.
for a message, the subaddresses will be removed (if present) before
the mail is sent. All addresses in this structure should be
downcased."
+ :version "22.1"
:group 'message-headers
:type '(repeat (repeat string)))
"Like `mail-user-agent'.
Except if it is nil, use Gnus native MUA; if it is t, use
`mail-user-agent'."
+ :version "22.1"
:type '(radio (const :tag "Gnus native"
:format "%t\n"
nil)
recipients?\" before a wide reply to multiple recipients. If the user
answers yes, reply to all recipients as usual. If the user answers
no, only reply back to the author."
- :version "21.3"
+ :version "22.1"
:group 'message-headers
:link '(custom-manual "(message)Wide Reply")
:type 'boolean)
(defcustom message-user-fqdn nil
"*Domain part of Messsage-Ids."
+ :version "22.1"
:group 'message-headers
:link '(custom-manual "(message)News Headers")
:type '(radio (const :format "%v " nil)
- (string :format "FQDN: %v\n" :size 0)))
+ (string :format "FQDN: %v")))
(defcustom message-use-idna (and (condition-case nil (require 'idna)
(file-error))
(executable-find idna-program)
'ask)
"Whether to encode non-ASCII in domain names into ASCII according to IDNA."
+ :version "22.1"
:group 'message-headers
:link '(custom-manual "(message)IDNA")
:type '(choice (const :tag "Ask" ask)
(const :tag "Never" nil)
(const :tag "Always" t)))
+(defcustom message-generate-hashcash nil
+ "*Whether to generate X-Hashcash: headers.
+You must have the \"hashcash\" binary installed, see `hashcash-path'."
+ :group 'message-headers
+ :link '(custom-manual "(message)Mail Headers")
+ :type 'boolean)
+
;;; Internal variables.
(defvar message-sending-message "Sending...")
"^|? *---+ +Message text follows: +---+ *|?$")
"A regexp that matches the separator before the text of a failed message.")
+(defvar message-field-fillers
+ '((To message-fill-field-address)
+ (Cc message-fill-field-address)
+ (From message-fill-field-address))
+ "Alist of header names/filler functions.")
+
(defvar message-header-format-alist
- `((Newsgroups)
- (To . message-fill-address)
- (Cc . message-fill-address)
+ `((From)
+ (Newsgroups)
+ (To)
+ (Cc)
(Subject)
(In-Reply-To)
(Fcc)
"\\)")
"Regular expression that matches a valid FQDN."
;; see also: gnus-button-valid-fqdn-regexp
+ :version "22.1"
:group 'message-headers
:type 'regexp)
(eval-and-compile
+ (autoload 'gnus-alive-p "gnus-util")
+ (autoload 'gnus-delay-article "gnus-delay")
+ (autoload 'gnus-extract-address-components "gnus-util")
+ (autoload 'gnus-find-method-for-group "gnus")
+ (autoload 'gnus-group-decoded-name "gnus-group")
+ (autoload 'gnus-group-name-charset "gnus-group")
+ (autoload 'gnus-group-name-decode "gnus-group")
+ (autoload 'gnus-groups-from-server "gnus")
+ (autoload 'gnus-make-local-hook "gnus-util")
+ (autoload 'gnus-open-server "gnus-int")
+ (autoload 'gnus-output-to-mail "gnus-util")
+ (autoload 'gnus-output-to-rmail "gnus-util")
+ (autoload 'gnus-request-post "gnus-int")
+ (autoload 'gnus-server-string "gnus")
+ (autoload 'idna-to-ascii "idna")
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
(autoload 'mh-send-letter "mh-comp")
- (autoload 'gnus-point-at-eol "gnus-util")
- (autoload 'gnus-point-at-bol "gnus-util")
- (autoload 'gnus-output-to-rmail "gnus-util")
- (autoload 'gnus-output-to-mail "gnus-util")
(autoload 'nndraft-request-associate-buffer "nndraft")
(autoload 'nndraft-request-expire-articles "nndraft")
- (autoload 'gnus-open-server "gnus-int")
- (autoload 'gnus-request-post "gnus-int")
- (autoload 'gnus-alive-p "gnus-util")
- (autoload 'gnus-server-string "gnus")
- (autoload 'gnus-group-name-charset "gnus-group")
- (autoload 'gnus-group-name-decode "gnus-group")
- (autoload 'gnus-groups-from-server "gnus")
- (autoload 'rmail-output "rmailout")
- (autoload 'gnus-delay-article "gnus-delay")
- (autoload 'gnus-make-local-hook "gnus-util"))
+ (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
(if (not header)
nil
(let ((regexp (format "[%s]+" (or separator ",")))
- (beg 1)
(first t)
- quoted elems paren)
+ beg quoted elems paren)
(with-temp-buffer
(mm-enable-multibyte)
+ (setq beg (point-min))
(insert header)
(goto-char (point-min))
(while (not (eobp))
The buffer is expected to be narrowed to just the header of the message;
see `message-narrow-to-headers-or-head'."
(let* ((inhibit-point-motion-hooks t)
- (case-fold-search t)
(value (mail-fetch-field header nil (not not-all))))
(when value
(while (string-match "\n[\t ]+" value)
(setq value (replace-match " " t t value)))
- (set-text-properties 0 (length value) nil value)
value)))
(defun message-field-value (header &optional not-all)
(defun message-narrow-to-field ()
"Narrow the buffer to the header on the current line."
(beginning-of-line)
+ (while (looking-at "[ \t]")
+ (forward-line -1))
(narrow-to-region
(point)
(progn
(forward-line 1)
(if (re-search-forward "^[^ \n\t]" nil t)
- (progn
- (beginning-of-line)
- (point))
+ (point-at-bol)
(point-max))))
(goto-char (point-min)))
(1+ max)))))
(message-sort-headers-1))))
+(defun message-kill-address ()
+ "Kill the address under point."
+ (interactive)
+ (let ((start (point)))
+ (message-skip-to-next-address)
+ (kill-region start (point))))
\f
(define-key message-mode-map "\C-c\C-d" 'message-dont-send)
(define-key message-mode-map "\C-c\n" 'gnus-delay-article)
+ (define-key message-mode-map "\C-c\M-k" 'message-kill-address)
(define-key message-mode-map "\C-c\C-e" 'message-elide-region)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
(define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
- ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
(define-key message-mode-map [remap split-line] 'message-split-line)
(define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
packages requires these properties to be present in order to work.
If you use one of these packages, turn this option off, and hope the
message composition doesn't break too bad."
+ :version "22.1"
:group 'message-various
:link '(custom-manual "(message)Various Message Variables")
:type 'boolean)
;; fontified: is used by font-lock.
;; syntax-table, local-map: I dunno.
;; We need to add XEmacs names to the list.
- "Property list of with properties.forbidden in message buffers.
+ "Property list of with properties forbidden in message buffers.
The values of the properties are ignored, only the property names are used.")
(defun message-tamago-not-in-use-p (pos)
See also `message-forbidden-properties'."
(when (and message-strip-special-text-properties
(message-tamago-not-in-use-p begin))
- (while (not (= begin end))
- (when (not (get-text-property begin 'message-hidden))
- (remove-text-properties begin (1+ begin)
- message-forbidden-properties))
- (incf begin))))
+ (let ((buffer-read-only nil)
+ (inhibit-read-only t))
+ (remove-text-properties begin end message-forbidden-properties))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
(set (make-local-variable 'message-checksum) nil)
(set (make-local-variable 'message-mime-part) 0)
(message-setup-fill-variables)
- (set
- (make-local-variable 'paragraph-separate)
- (format "\\(%s\\)\\|\\(%s\\)"
- paragraph-separate
- "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
;; Allow using comment commands to add/remove quoting.
- (set (make-local-variable 'comment-start) message-yank-prefix)
+ ;; (set (make-local-variable 'comment-start) message-yank-prefix)
+ (when message-yank-prefix
+ (set (make-local-variable 'comment-start) message-yank-prefix)
+ (set (make-local-variable 'comment-start-skip)
+ (concat "^" (regexp-quote message-yank-prefix) "[ \t]*")))
(if (featurep 'xemacs)
(message-setup-toolbar)
(set (make-local-variable 'font-lock-defaults)
"---+$\\|" ; delimiters for forwarded messages
page-delimiter "$\\|" ; spoiler warnings
".*wrote:$\\|" ; attribution lines
- quote-prefix-regexp "$")) ; empty lines in quoted text
+ quote-prefix-regexp "$\\|" ; empty lines in quoted text
+ ; mml tags
+ "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
(setq paragraph-separate paragraph-start)
(setq adaptive-fill-regexp
(concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
(defun message-goto-mail-followup-to ()
"Move point to the Mail-Followup-To header."
(interactive)
- (message-position-on-field "Mail-Followup-To" "From"))
+ (message-position-on-field "Mail-Followup-To" "To"))
(defun message-goto-keywords ()
"Move point to the Keywords header."
(message-get-reply-headers t))))
(message-carefully-insert-headers headers)))
-(defvar message-header-synonyms
+(defcustom message-header-synonyms
'((To Cc Bcc))
"List of lists of header synonyms.
E.g., if this list contains a member list with elements `Cc' and `To',
then `message-carefully-insert-headers' will not insert a `To' header
-when the message is already `Cc'ed to the recipient.")
+when the message is already `Cc'ed to the recipient."
+ :version "22.1"
+ :group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
+ :type '(repeat sexp))
(defun message-carefully-insert-headers (headers)
"Insert the HEADERS, an alist, into the message buffer.
Does not insert the headers when they are already present there
or in the synonym headers, defined by `message-header-synonyms'."
+ ;; FIXME: Should compare only the address and not the full name. Comparison
+ ;; should be done case-folded (and with `string=' rather than
+ ;; `string-match').
+ ;; (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))
(when (message-goto-signature)
(forward-line -2)))
-(defun message-kill-to-signature ()
- "Deletes all text up to the signature."
- (interactive)
- (let ((point (point)))
- (message-goto-signature)
- (unless (eobp)
- (end-of-line -1))
- (kill-region point (point))
- (unless (bolp)
- (insert "\n"))))
+(defun message-kill-to-signature (&optional arg)
+ "Kill all text up to the signature.
+If a numberic argument or prefix arg is given, leave that number
+of lines before the signature intact."
+ (interactive "p")
+ (save-excursion
+ (save-restriction
+ (let ((point (point)))
+ (narrow-to-region point (point-max))
+ (message-goto-signature)
+ (unless (eobp)
+ (if (and arg (numberp arg))
+ (forward-line (- -1 arg))
+ (end-of-line -1)))
+ (unless (= point (point))
+ (kill-region point (point))
+ (insert "\n"))))))
(defun message-newline-and-reformat (&optional arg not-break)
"Insert four newlines, and then reformat if inside quoted text.
(interactive (list (if current-prefix-arg 'full)))
(if (if (boundp 'filladapt-mode) filladapt-mode)
nil
- (message-newline-and-reformat arg t)
+ (if (message-point-in-header-p)
+ (message-fill-field)
+ (message-newline-and-reformat arg t))
t))
;; Is it better to use `mail-header-end'?
(defun message-yank-buffer (buffer)
"Insert BUFFER into the current buffer and quote it."
(interactive "bYank buffer: ")
- (let ((message-reply-buffer buffer))
+ (let ((message-reply-buffer (get-buffer buffer)))
(save-window-excursion
(message-yank-original))))
;; Insert a blank line if it is peeled off.
(insert "\n")))
(goto-char start)
- (while functions
- (funcall (pop functions)))
+ (mapc 'funcall functions)
(when message-citation-line-function
(unless (bolp)
(insert "\n"))
(run-hooks 'mail-citation-hook)
(let* ((start (point))
(end (mark t))
+ (x-no-archive nil)
(functions
(when message-indent-citation-function
(if (listp message-indent-citation-function)
(save-restriction
(narrow-to-region start end)
(message-narrow-to-head-1)
+ (setq x-no-archive (message-fetch-field "x-no-archive"))
(vector 0
(or (message-fetch-field "subject") "none")
(message-fetch-field "from")
0 0 ""))))
(mml-quote-region start end)
(goto-char start)
- (while functions
- (funcall (pop functions)))
+ (mapc 'funcall functions)
(when message-citation-line-function
(unless (bolp)
(insert "\n"))
- (funcall message-citation-line-function)))))
+ (funcall message-citation-line-function))
+ (when (and x-no-archive
+ (not message-cite-articles-with-x-no-archive)
+ (string-match "yes" x-no-archive))
+ (undo-boundary)
+ (delete-region (point) (mark t))
+ (insert "> [Quoted text removed due to X-No-Archive]\n")
+ (forward-line -1)))))
(defun message-insert-citation-line ()
"Insert a simple citation line."
(file-exists-p auto-save-file-name))
(and file-name
(file-exists-p file-name)))
- (yes-or-no-p (format "Remove the backup file%s? "
- (if modified " too" ""))))
+ (progn
+ ;; If the message buffer has lived in a dedicated window,
+ ;; `kill-buffer' has killed the frame. Thus the
+ ;; `yes-or-no-p' may show up in a lowered frame. Make sure
+ ;; that the user can see the question by raising the
+ ;; current frame:
+ (raise-frame)
+ (yes-or-no-p (format "Remove the backup file%s? "
+ (if modified " too" "")))))
(ignore-errors
(delete-file auto-save-file-name))
(let ((message-draft-article draft-article))
"Bury this mail BUFFER."
(let ((newbuf (other-buffer buffer)))
(bury-buffer buffer)
- (if (and (fboundp 'frame-parameters)
- (cdr (assq 'dedicated (frame-parameters)))
+ (if (and (window-dedicated-p (selected-window))
(not (null (delq (selected-frame) (visible-frame-list)))))
(delete-frame (selected-frame))
(switch-to-buffer newbuf))))
(put 'message-check 'lisp-indent-function 1)
(put 'message-check 'edebug-form-spec '(form body))
-(defun message-text-with-property (prop)
- "Return a list of all points where the text has PROP."
- (let ((points nil)
- (point (point-min)))
- (save-excursion
- (while (< point (point-max))
- (when (get-text-property point prop)
- (push point points))
- (incf point)))
- (nreverse points)))
+(defun message-text-with-property (prop &optional start end reverse)
+ "Return a list of start and end positions where the text has PROP.
+START and END bound the search, they default to `point-min' and
+`point-max' respectively. If REVERSE is non-nil, find text which does
+not have PROP."
+ (unless start
+ (setq start (point-min)))
+ (unless end
+ (setq end (point-max)))
+ (let (next regions)
+ (if reverse
+ (while (and start
+ (setq start (text-property-any start end prop nil)))
+ (setq next (next-single-property-change start prop nil end))
+ (push (cons start (or next end)) regions)
+ (setq start next))
+ (while (and start
+ (or (get-text-property start prop)
+ (and (setq start (next-single-property-change
+ start prop nil end))
+ (get-text-property start prop))))
+ (setq next (text-property-any start end prop nil))
+ (push (cons start (or next end)) regions)
+ (setq start next)))
+ (nreverse regions)))
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
(unless (bolp)
(insert "\n"))
;; Make the hidden headers visible.
- (let ((points (message-text-with-property 'message-hidden)))
- (when points
- (goto-char (car points))
- (dolist (point points)
- (add-text-properties point (1+ point)
- '(invisible nil intangible nil)))))
+ (widen)
+ ;; Sort headers before sending the message.
+ (message-sort-headers)
;; Make invisible text visible.
;; It doesn't seem as if this is useful, since the invisible property
;; is clobbered by an after-change hook anyhow.
(message-check 'invisible-text
- (let ((points (message-text-with-property 'invisible)))
- (when points
- (goto-char (car points))
- (dolist (point points)
- (put-text-property point (1+ point) 'invisible nil)
- (message-overlay-put (message-make-overlay point (1+ point))
+ (let ((regions (message-text-with-property 'invisible))
+ from to)
+ (when regions
+ (while regions
+ (setq from (caar regions)
+ to (cdar regions)
+ regions (cdr regions))
+ (put-text-property from to 'invisible nil)
+ (message-overlay-put (message-make-overlay from to)
'face 'highlight))
(unless (yes-or-no-p
"Invisible text found and made visible; continue sending? ")
(when (let ((char (char-after)))
(or (< (mm-char-int char) 128)
(and (mm-multibyte-p)
- (> (length (mm-find-mime-charset-region
- (point) (point-max)))
- 1))))
+ (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))
;; use find-coding-systems-region.
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
- control-1)))))
+ control-1))
+ (not (get-text-property
+ (point) 'untranslated-utf-8)))))
(if (eq choice ?i)
(message-kill-all-overlays)
(delete-char 1)
(defun message-do-actions (actions)
"Perform all actions in ACTIONS."
;; Now perform actions on successful sending.
- (while actions
+ (dolist (action actions)
(ignore-errors
(cond
;; A simple function.
- ((functionp (car actions))
- (funcall (car actions)))
+ ((functionp action)
+ (funcall action))
;; Something to be evaled.
(t
- (eval (car actions)))))
- (pop actions)))
+ (eval action))))))
(defun message-send-mail-partially ()
"Send mail as message/partial."
(gnus-setup-posting-charset nil)
message-posting-charset))
(headers message-required-mail-headers))
+ (when message-generate-hashcash
+ (message "Generating hashcash...")
+ ;; Wait for calculations already started to finish...
+ (hashcash-wait-async)
+ ;; ...and do calculations not already done. mail-add-payment
+ ;; will leave existing X-Hashcash headers alone.
+ (mail-add-payment)
+ (message "Generating hashcash...done"))
(save-restriction
(message-narrow-to-headers)
;; Generate the Mail-Followup-To header if the header is not there...
"content-transfer-encoding")))))))
(message-insert-courtesy-copy))
(if (or (not message-send-mail-partially-limit)
- (< (point-max) message-send-mail-partially-limit)
+ (< (buffer-size) message-send-mail-partially-limit)
(not (message-y-or-n-p
"The message size is too large, split? "
t
"\
The message size, "
- (/ (point-max) 1000) "KB, is too large.
+ (/ (buffer-size) 1000) "KB, is too large.
Some mail gateways (MTA's) bounce large messages. To avoid the
problem, answer `y', and the message will be split into several
(when (eval message-mailer-swallows-blank-line)
(newline))
(when message-interactive
- (save-excursion
- (set-buffer errbuf)
+ (with-current-buffer errbuf
(erase-buffer))))
(let* ((default-directory "/")
(coding-system-for-write message-send-coding-system)
(save-excursion
(set-buffer errbuf)
(goto-char (point-min))
- (while (re-search-forward "\n\n* *" nil t)
+ (while (re-search-forward "\n+ *" nil t)
(replace-match "; "))
(if (not (zerop (buffer-size)))
(error "Sending...failed to %s"
(case
(let ((coding-system-for-write message-send-coding-system))
(apply
- 'call-process-region 1 (point-max) message-qmail-inject-program
- nil nil nil
+ 'call-process-region (point-min) (point-max)
+ message-qmail-inject-program nil nil nil
;; qmail-inject's default behaviour is to look for addresses on the
;; command line; if there're none, it scans the headers.
;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
"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
-documentation for the function `mail-source-touch-pop'."
+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-canlock-generate ()
"Return a string that is non-trivial to guess.
Do not use this for anything important, it is cryptographically weak."
+ (require 'sha1)
(let (sha1-maximum-internal-length)
(sha1 (concat (message-unique-id)
(format "%x%x%x" (random) (random t) (random))
nil))))
;; Check for control characters.
(message-check 'control-chars
- (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
+ (if (re-search-forward
+ (mm-string-as-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]")
+ nil t)
(y-or-n-p
"The article contains control characters. Really post? ")
t))
(defun message-make-date (&optional now)
"Make a valid data header.
If NOW, use that time instead."
- (let* ((now (or now (current-time)))
- (zone (nth 8 (decode-time now)))
- (sign "+"))
- (when (< zone 0)
- (setq sign "-")
- (setq zone (- zone)))
- (concat
- ;; The day name of the %a spec is locale-specific. Pfff.
- (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now))
- parse-time-weekdays))))
- (format-time-string "%d" now)
- ;; The month name of the %b spec is locale-specific. Pfff.
- (format " %s "
- (capitalize (car (rassoc (nth 4 (decode-time now))
- parse-time-months))))
- (format-time-string "%Y %H:%M:%S " now)
- ;; We do all of this because XEmacs doesn't have the %z spec.
- (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
+ (let ((system-time-locale "C"))
+ (format-time-string "%a, %d %b %Y %T %z" now)))
(defun message-make-message-id ()
"Make a unique Message-ID."
list
msg-recipients))))))
-(defun message-idna-inside-rhs-p ()
- "Return t iff point is inside a RHS (heuristically).
-Only works properly if header contains mailbox-list or address-list.
-I.e., calling it on a Subject: header is useless."
- (save-restriction
- (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t)
- (point-min)))
- (save-excursion (or (re-search-forward "^[^ \t]" nil t)
- (point-max))))
- (if (re-search-backward "[\\\n\r\t ]"
- (save-excursion (search-backward "@" nil t)) t)
- ;; whitespace between @ and point
- nil
- (let ((dquote 1) (paren 1))
- (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
- (incf dquote))
- (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
- (incf paren))
- (and (= (% dquote 2) 1) (= (% paren 2) 1))))))
-
-(autoload 'idna-to-ascii "idna")
-
(defun message-idna-to-ascii-rhs-1 (header)
"Interactively potentially IDNA encode domain names in HEADER."
- (let (rhs ace start startpos endpos ovl)
- (goto-char (point-min))
- (while (re-search-forward (concat "^" header) nil t)
- (while (re-search-forward "@\\([^ \t\r\n>,]+\\)"
- (or (save-excursion
- (re-search-forward "^[^ \t]" nil t))
- (point-max))
- t)
- (setq rhs (match-string-no-properties 1)
- startpos (match-beginning 1)
- endpos (match-end 1))
- (when (save-match-data
- (and (message-idna-inside-rhs-p)
- (setq ace (idna-to-ascii rhs))
- (not (string= rhs ace))
- (if (eq message-use-idna 'ask)
- (unwind-protect
- (progn
- (setq ovl (message-make-overlay startpos
- endpos))
- (message-overlay-put ovl 'face 'highlight)
- (y-or-n-p
- (format "Replace with `%s'? " ace)))
- (message "")
- (message-delete-overlay ovl))
- message-use-idna)))
- (replace-match (concat "@" ace)))))))
+ (let ((field (message-fetch-field header))
+ rhs ace address)
+ (when field
+ (dolist (address (mail-header-parse-addresses field))
+ (setq address (car address)
+ rhs (downcase (or (cadr (split-string address "@")) ""))
+ ace (downcase (idna-to-ascii rhs)))
+ (when (and (not (equal rhs ace))
+ (or (not (eq message-use-idna 'ask))
+ (y-or-n-p (format "Replace %s with %s? " rhs ace))))
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" header ":") nil t)
+ (message-narrow-to-field)
+ (while (search-forward (concat "@" rhs) nil t)
+ (replace-match (concat "@" ace) t t))
+ (goto-char (point-max))
+ (widen)))))))
(defun message-idna-to-ascii-rhs ()
"Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
(message-narrow-to-head)
(message-idna-to-ascii-rhs-1 "From")
(message-idna-to-ascii-rhs-1 "To")
+ (message-idna-to-ascii-rhs-1 "Reply-To")
(message-idna-to-ascii-rhs-1 "Cc")))))
(defun message-generate-headers (headers)
(if formatter
(funcall formatter header value)
(insert header-string ": " value))
+ (goto-char (message-fill-field))
;; We check whether the value was ended by a
- ;; newline. If now, we insert one.
+ ;; newline. If not, we insert one.
(unless (bolp)
(insert "\n"))
(forward-line -1)))
;; The value of this header was empty, so we clear
;; totally and insert the new value.
- (delete-region (point) (gnus-point-at-eol))
+ (delete-region (point) (point-at-eol))
;; If the header is optional, and the header was
;; empty, we con't insert it anyway.
(unless optionalp
(push header-string message-inserted-headers)
- (insert value)))
+ (insert value)
+ (message-fill-field)))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
;;; Setting up a message buffer
;;;
+(defun message-skip-to-next-address ()
+ (let ((end (save-excursion
+ (message-next-header)
+ (point)))
+ quoted char)
+ (when (looking-at ",")
+ (forward-char 1))
+ (while (and (not (= (point) end))
+ (or (not (eq char ?,))
+ quoted))
+ (skip-chars-forward "^,\"" (point-max))
+ (when (eq (setq char (following-char)) ?\")
+ (setq quoted (not quoted)))
+ (unless (= (point) end)
+ (forward-char 1)))
+ (skip-chars-forward " \t\n")))
+
(defun message-fill-address (header value)
- (save-restriction
- (narrow-to-region (point) (point))
- (insert (capitalize (symbol-name header))
- ": "
- (if (consp value) (car value) value)
- "\n")
- (narrow-to-region (point-min) (1- (point-max)))
- (let (quoted last)
- (goto-char (point-min))
- (while (not (eobp))
- (skip-chars-forward "^,\"" (point-max))
- (if (or (eq (char-after) ?,)
- (eobp))
- (when (not quoted)
- (if (and (> (current-column) 78)
- last)
- (progn
- (save-excursion
- (goto-char last)
- (insert "\n\t"))
- (setq last (1+ (point))))
- (setq last (1+ (point)))))
- (setq quoted (not quoted)))
- (unless (eobp)
- (forward-char 1))))
- (goto-char (point-max))
- (widen)
- (forward-line 1)))
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")
+ (message-fill-field-address))
(defun message-split-line ()
"Split current line, moving portion beyond point vertically down.
If the current line has `message-yank-prefix', insert it on the new line."
(interactive "*")
(condition-case nil
- (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
+ (split-line message-yank-prefix) ;; Emacs 22.1+ supports arg.
(error
(split-line))))
-
-(defun message-fill-header (header value)
+(defun message-insert-header (header value)
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)))
+
+(defun message-field-name ()
+ (save-excursion
+ (goto-char (point-min))
+ (when (looking-at "\\([^:]+\\):")
+ (intern (capitalize (match-string 1))))))
+
+(defun message-fill-field ()
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-field)
+ (let ((field-name (message-field-name)))
+ (funcall (or (cadr (assq field-name message-field-fillers))
+ 'message-fill-field-general)))
+ (point-max))))
+
+(defun message-fill-field-address ()
+ (while (not (eobp))
+ (message-skip-to-next-address)
+ (let (last)
+ (if (and (> (current-column) 78)
+ last)
+ (progn
+ (save-excursion
+ (goto-char last)
+ (insert "\n\t"))
+ (setq last (1+ (point))))
+ (setq last (1+ (point)))))))
+
+(defun message-fill-field-general ()
(let ((begin (point))
(fill-column 78)
(fill-prefix "\t"))
- (insert (capitalize (symbol-name header))
- ": "
- (if (consp value) (car value) value)
- "\n")
- (save-restriction
- (narrow-to-region begin (point))
- (fill-region-as-paragraph begin (point))
- ;; Tapdance around looong Message-IDs.
- (forward-line -1)
- (when (looking-at "[ \t]*$")
- (message-delete-line))
- (goto-char begin)
- (re-search-forward ":" nil t)
- (when (looking-at "\n[ \t]+")
- (replace-match " " t t))
- (goto-char (point-max)))))
+ (while (and (search-forward "\n" nil t)
+ (not (eobp)))
+ (replace-match " " t t))
+ (fill-region-as-paragraph begin (point-max))
+ ;; Tapdance around looong Message-IDs.
+ (forward-line -1)
+ (when (looking-at "[ \t]*$")
+ (message-delete-line))
+ (goto-char begin)
+ (search-forward ":" nil t)
+ (when (looking-at "\n[ \t]+")
+ (replace-match " " t t))
+ (goto-char (point-max))))
(defun message-shorten-1 (list cut surplus)
"Cut SURPLUS elements out of LIST, beginning with CUTth one."
(defun message-shorten-references (header references)
"Trim REFERENCES to be 21 Message-ID long or less, and fold them.
-If folding is disallowed, also check that the REFERENCES are less
-than 988 characters long, and if they are not, trim them until they are."
+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."
(let ((maxcount 21)
(count 0)
(cut 2)
(message-shorten-1 refs cut surplus)
(decf count surplus)))
- ;; If folding is disallowed, make sure the total length (including
- ;; the spaces between) will be less than MAXSIZE characters.
+ ;; When sending via news, make sure the total folded length will
+ ;; be less than 998 characters. This is to cater to broken INN
+ ;; 2.3 which counts the total number of characters in a header
+ ;; rather than the physical line length of each line, as it should.
;;
- ;; Only disallow folding for News messages. At this point the headers
- ;; have not been generated, thus we use message-this-is-news directly.
- (when (and message-this-is-news message-cater-to-broken-inn)
- (let ((maxsize 988)
- (totalsize (+ (apply #'+ (mapcar #'length refs))
- (1- count)))
- (surplus 0)
- (ptr (nthcdr (1- cut) refs)))
- ;; Decide how many elements to cut off...
- (while (> totalsize maxsize)
- (decf totalsize (1+ (length (car ptr))))
- (incf surplus)
- (setq ptr (cdr ptr)))
- ;; ...and do it.
- (when (> surplus 0)
- (message-shorten-1 refs cut surplus))))
-
+ ;; This hack should be removed when it's believed than INN 2.3 is
+ ;; no longer widely used.
+ ;;
+ ;; At this point the headers have not been generated, thus we use
+ ;; message-this-is-news directly.
+ (when message-this-is-news
+ (while (< 998
+ (with-temp-buffer
+ (message-insert-header
+ header (mapconcat #'identity refs " "))
+ (buffer-size)))
+ (message-shorten-1 refs cut 1)))
;; Finally, collect the references back into a string and insert
;; it into the buffer.
- (let ((refstring (mapconcat #'identity refs " ")))
- (if (and message-this-is-news message-cater-to-broken-inn)
- (insert (capitalize (symbol-name header)) ": "
- refstring "\n")
- (message-fill-header header refstring)))))
+ (message-insert-header header (mapconcat #'identity refs " "))))
(defun message-position-point ()
"Move point to where the user probably wants to find it."
(defcustom message-beginning-of-line t
"Whether \\<message-mode-map>\\[message-beginning-of-line]\
goes to beginning of header values."
+ :version "22.1"
:group 'message-buffers
:link '(custom-manual "(message)Movement")
:type 'boolean)
is nil.
If point is in the message header and on a (non-continued) header
-line, move point to the beginning of the header value. If point
-is already there, move point to beginning of line. Therefore,
-repeated calls will toggle point between beginning of field and
-beginning of line."
+line, move point to the beginning of the header value or the beginning of line,
+whichever is closer. If point is already at beginning of line, move point to
+beginning of header value. Therefore, repeated calls will toggle point
+between beginning of field and beginning of line."
(interactive "p")
(let ((zrs 'zmacs-region-stays))
(when (and (interactive-p) (boundp zrs))
(message-point-in-header-p))
(let* ((here (point))
(bol (progn (beginning-of-line n) (point)))
- (eol (gnus-point-at-eol))
+ (eol (point-at-eol))
(eoh (re-search-forward ": *" eol t)))
- (if (or (not eoh) (equal here eoh))
- (goto-char bol)
- (goto-char eoh)))
+ (goto-char
+ (if (and eoh (or (< eoh here) (= bol here)))
+ eoh bol)))
(beginning-of-line n)))
(defun message-buffer-name (type &optional to group)
(when message-default-headers
(insert message-default-headers)
(or (bolp) (insert ?\n)))
- (put-text-property
- (point)
- (progn
- (insert mail-header-separator "\n")
- (1- (point)))
- 'read-only nil)
+ (insert mail-header-separator "\n")
(forward-line -1)
(when (message-news-p)
(when message-default-news-headers
(run-hooks 'message-header-setup-hook))
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
+ (when message-generate-hashcash
+ ;; Generate hashcash headers for recipients already known
+ (mail-add-payment-async))
(run-hooks 'message-setup-hook)
(message-position-point)
(undo-boundary))
(Subject . ,(or subject ""))))))
(defun message-get-reply-headers (wide &optional to-address address-headers)
- (let (follow-to mct never-mct to cc author mft recipients)
+ (let (follow-to mct never-mct to cc author mft recipients extra)
;; Find all relevant headers we need.
- (setq to (message-fetch-field "to")
- cc (message-fetch-field "cc")
- mct (message-fetch-field "mail-copies-to")
- author (or (message-fetch-field "mail-reply-to")
- (message-fetch-field "reply-to")
- (message-fetch-field "from")
- "")
- mft (and message-use-mail-followup-to
- (message-fetch-field "mail-followup-to")))
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ ;; Gmane renames "To". Look at "Original-To", too, if it is present in
+ ;; message-header-synonyms.
+ (setq to (or (message-fetch-field "to")
+ (and (loop for synonym in message-header-synonyms
+ when (memq 'Original-To synonym)
+ return t)
+ (message-fetch-field "original-to")))
+ cc (message-fetch-field "cc")
+ extra (when message-extra-wide-headers
+ (mapconcat 'identity
+ (mapcar 'message-fetch-field
+ message-extra-wide-headers)
+ ", "))
+ mct (message-fetch-field "mail-copies-to")
+ author (or (message-fetch-field "mail-reply-to")
+ (message-fetch-field "reply-to")
+ (message-fetch-field "from")
+ "")
+ mft (and message-use-mail-followup-to
+ (message-fetch-field "mail-followup-to"))))
;; Handle special values of Mail-Copies-To.
(when mct
(if mct (setq recipients (concat recipients ", " mct))))
(t
(setq recipients (if never-mct "" (concat ", " author)))
- (if to (setq recipients (concat recipients ", " to)))
- (if cc (setq recipients (concat recipients ", " cc)))
+ (if to (setq recipients (concat recipients ", " to)))
+ (if cc (setq recipients (concat recipients ", " cc)))
+ (if extra (setq recipients (concat recipients ", " extra)))
(if mct (setq recipients (concat recipients ", " mct)))))
(if (>= (length recipients) 2)
;; Strip the leading ", ".
(prefix
(if group
(gnus-group-decoded-name group)
- (or (and from (cdr (mail-header-parse-address from)))
+ (or (and from (car (gnus-extract-address-components from)))
"(nowhere)"))))
(concat "["
(if message-forward-decoded-p
subject
(mail-decode-encoded-word-string subject))
""))
- (if message-wash-forwarded-subjects
- (setq subject (message-wash-subject subject)))
+ (when message-wash-forwarded-subjects
+ (setq subject (message-wash-subject subject)))
;; Make sure funcs is a list.
(and funcs
(not (listp funcs))
(setq funcs (list funcs)))
;; Apply funcs in order, passing subject generated by previous
;; func to the next one.
- (while funcs
- (when (functionp (car funcs))
- (setq subject (funcall (car funcs) subject)))
- (setq funcs (cdr funcs)))
+ (dolist (func funcs)
+ (when (functionp func)
+ (setq subject (funcall func subject))))
subject))))
(eval-when-compile
(setq e (point))
(insert
"\n-------------------- End of forwarded message --------------------\n")
- (when (and (not current-prefix-arg)
- message-forward-ignored-headers)
+ (when message-forward-ignored-headers
(save-restriction
(narrow-to-region b e)
(goto-char b)
(goto-char (point-max))))
(setq e (point))
(insert "<#/mml>\n")
- (when (and (not current-prefix-arg)
+ (when (and (not message-forward-decoded-p)
message-forward-ignored-headers)
(save-restriction
(narrow-to-region b e)
(defun message-forward-rmail-make-body (forward-buffer)
(save-window-excursion
(set-buffer forward-buffer)
- ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs
- ;; 20. FIXIT, or we drop support for rmail in Emacs 20.
(if (rmail-msg-is-pruned)
(rmail-msg-restore-non-pruned-header)))
(message-forward-make-body forward-buffer))
(replace-match "X-From-Line: "))
;; Send it.
(let ((message-inhibit-body-encoding t)
- message-required-mail-headers)
+ message-required-mail-headers
+ rfc2047-encode-encoded-words)
(message-send-mail))
(kill-buffer (current-buffer)))
(message "Resending message to %s...done" address)))
(let ((end1 (make-marker)))
(move-marker end1 (max start end))
(goto-char (min start end))
- (while (re-search-forward "\b" end1 t)
+ (while (search-forward "\b" end1 t)
(if (eq (char-after) (char-after (- (point) 2)))
(delete-char -2))))))
-(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+(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)))
+
(defalias 'message-make-overlay 'make-overlay)
(defalias 'message-delete-overlay 'delete-overlay)
(defalias 'message-overlay-put 'overlay-put)
'("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):"
. message-expand-name))
"Alist of (RE . FUN). Use FUN for completion on header lines matching RE."
+ :version "22.1"
:group 'message
:type '(alist :key-type regexp :value-type function))
+(defcustom message-expand-name-databases
+ (list '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
+ :type '(set (const bbdb) (const eudc)))
+
(defcustom message-tab-body-function nil
"*Function to execute when `message-tab' (TAB) is executed in the body.
If nil, the function bound in `text-mode-map' or `global-map' is executed."
+ :version "22.1"
:group 'message
:link '(custom-manual "(message)Various Commands")
:type 'function)
(delete-region (point) (progn (forward-line 3) (point))))))))))
(defun message-expand-name ()
- (if (fboundp 'bbdb-complete-name)
- (bbdb-complete-name)
- (expand-abbrev)))
+ (cond ((and (memq 'eudc message-expand-name-databases)
+ (boundp 'eudc-protocol)
+ eudc-protocol)
+ (eudc-expand-inline))
+ ((and (memq 'bbdb message-expand-name-databases)
+ (fboundp 'bbdb-complete-name))
+ (bbdb-complete-name))
+ (t
+ (expand-abbrev))))
;;; Help stuff.
(let ((locals (save-excursion
(set-buffer buffer)
(buffer-local-variables)))
- (regexp "^gnus\\|^nn\\|^message\\|^user-mail-address"))
+ (regexp "^gnus\\|^nn\\|^message\\|^sendmail\\|^smtp\\|^user-mail-address"))
(mapcar
(lambda (local)
(when (and (consp local)
(defun message-use-alternative-email-as-from ()
(require 'mail-utils)
- (let* ((fields '("To" "Cc"))
+ (let* ((fields '("To" "Cc" "From"))
(emails
(split-string
(mail-strip-quoted-names
(pop emails))
(unless (or (not email) (equal email user-mail-address))
(goto-char (point-max))
- (insert "From: " email "\n"))))
+ (insert "From: " (let ((user-mail-address email)) (message-make-from))
+ "\n"))))
(defun message-options-get (symbol)
(cdr (assq symbol message-options)))
(list message-hidden-headers)
message-hidden-headers))
(inhibit-point-motion-hooks t)
- (after-change-functions nil))
+ (after-change-functions nil)
+ (end-of-headers 0))
(when regexps
(save-excursion
(save-restriction
(while (not (eobp))
(if (not (message-hide-header-p regexps))
(message-next-header)
- (let ((begin (point)))
+ (let ((begin (point))
+ header header-len)
(message-next-header)
- (add-text-properties
- begin (point)
- '(invisible t message-hidden t))))))))))
+ (setq header (buffer-substring begin (point))
+ header-len (- (point) begin))
+ (delete-region begin (point))
+ (goto-char (1+ end-of-headers))
+ (insert header)
+ (setq end-of-headers
+ (+ end-of-headers header-len))))))))
+ (narrow-to-region (1+ end-of-headers) (point-max))))
(defun message-hide-header-p (regexps)
(let ((result nil)
;; coding: iso-8859-1
;; End:
+;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0
;;; message.el ends here
projects / gnus / blobdiff