;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'canlock)))
(require 'mailheader)
(require 'nnheader)
-;; This is apparently necessary even though things are autoloaded:
+;; This is apparently necessary even though things are autoloaded.
+;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better
+;; require mailabbrev here.
(if (featurep 'xemacs)
- (require 'mail-abbrevs))
+ (require 'mail-abbrevs)
+ (require 'mailabbrev))
(require 'mime-edit)
(eval-when-compile (require 'static))
:group 'message-sending
:type 'function)
+;;; Start of variables adopted from `message-utils.el'.
+
+(defcustom message-subject-trailing-was-query 'ask
+ ;; should it default to nil or ask?
+ "*What to do with trailing \"(was: <old subject>)\" in subject lines.
+If nil, leave the subject unchanged. If it is the symbol `ask', query
+the user what do do. In this case, the subject is matched against
+`message-subject-trailing-was-ask-regexp'. If
+`message-subject-trailing-was-query' is t, always strip the trailing
+old subject. In this case, `message-subject-trailing-was-regexp' is
+used."
+ :type '(choice (const :tag "never" nil)
+ (const :tag "always strip" t)
+ (const ask))
+ :group 'message-various)
+
+(defcustom message-subject-trailing-was-ask-regexp
+ "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)"
+ "*Regexp matching \"(was: <old subject>)\" in the subject line.
+
+The function `message-strip-subject-trailing-was' uses this regexp if
+`message-subject-trailing-was-query' is set to the symbol `ask'. If
+the variable is t instead of `ask', use
+`message-subject-trailing-was-regexp' instead.
+
+It is okay to create some false positives here, as the user is asked."
+ :group 'message-various
+ :type 'regexp)
+
+(defcustom message-subject-trailing-was-regexp
+ "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)"
+ "*Regexp matching \"(was: <old subject>)\" in the subject line.
+
+If `message-subject-trailing-was-query' is set to t, the subject is
+matched against `message-subject-trailing-was-regexp' in
+`message-strip-subject-trailing-was'. You should use a regexp creating very
+few false positives here."
+ :group 'message-various
+ :type 'regexp)
+
+;;; marking inserted text
+
+;;;###autoload
+(defcustom message-mark-insert-begin
+ "--8<---------------cut here---------------start------------->8---\n"
+ "How to mark the beginning of some inserted text."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-mark-insert-end
+ "--8<---------------cut here---------------end--------------->8---\n"
+ "How to mark the end of some inserted text."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-archive-header
+ "X-No-Archive: Yes\n"
+ "Header to insert when you don't want your article to be archived.
+Archives \(such as groups.googgle.com\) respect this header."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-archive-note
+ "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 'string
+ :group 'message-various)
+
+;;; Crossposts and Followups
+;; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de>
+;; new suggestions by R. Weikusat <rw at another.de>
+
+(defvar message-cross-post-old-target nil
+ "Old target for cross-posts or follow-ups.")
+(make-variable-buffer-local 'message-cross-post-old-target)
+
+;;;###autoload
+(defcustom message-cross-post-default t
+ "When non-nil `message-cross-post-followup-to' will perform a crosspost.
+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."
+ :type 'boolean
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-cross-post-note
+ "Crosspost & Followup-To: "
+ "Note to insert before signature to notify of xpost and follow-up."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-followup-to-note
+ "Followup-To: "
+ "Note to insert before signature to notify of follow-up only."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-cross-post-note-function
+ 'message-cross-post-insert-note
+ "Function to use to insert note about Crosspost or Followup-To.
+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'."
+ :type 'function
+ :group 'message-various)
+
+;;; End of variables adopted from `message-utils.el'.
+
;;;###autoload
(defcustom message-from-style 'default
"*Specifies how \"From\" headers look.
(const default))
:group 'message-headers)
-(defcustom message-syntax-checks nil
+(defcustom message-insert-canlock t
+ "Whether to insert a Cancel-Lock header in news postings."
+ :version "21.3"
+ :group 'message-headers
+ :type 'boolean)
+
+(defcustom message-syntax-checks
+ (if message-insert-canlock '((sender . disabled)) nil)
;; Guess this one shouldn't be easy to customize...
"*Controls what syntax checks should not be performed on outgoing posts.
To disable checking of long signatures, for instance, add
`new-text', `quoting-style', `redirected-followup', `signature',
`approved', `sender', `empty', `empty-headers', `message-id', `from',
`subject', `shorten-followup-to', `existing-newsgroups',
-`buffer-file-name', `unchanged', `newsgroups', `reply-to'."
+`buffer-file-name', `unchanged', `newsgroups', `reply-to',
+'continuation-headers', and `long-header-lines'."
:group 'message-news
:type '(repeat sexp)) ; Fixme: improve this
+(defcustom message-required-headers '((optional . References) From)
+ "*Headers to be generated or prompted for when sending a message.
+Also see `message-required-news-headers' and
+`message-required-mail-headers'."
+ :group 'message-news
+ :group 'message-headers
+ :type '(repeat sexp))
+
+(defcustom message-draft-headers '(References From)
+ "*Headers to be generated when saving a draft message."
+ :group 'message-news
+ :group 'message-headers
+ :type '(repeat sexp))
+
(defcustom message-required-news-headers
'(From Newsgroups Subject Date Message-ID
- (optional . Organization) Lines
+ (optional . Organization)
(optional . User-Agent))
"*Headers to be generated or prompted for when posting an article.
RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
:type '(repeat sexp))
(defcustom message-required-mail-headers
- '(From Subject Date (optional . In-Reply-To) Message-ID Lines
+ '(From Subject Date (optional . In-Reply-To) Message-ID
(optional . User-Agent))
"*Headers to be generated or prompted for when mailing a message.
It is recommended that From, Date, To, Subject and Message-ID be
-included. Organization, Lines and User-Agent are optional."
+included. Organization and User-Agent are optional."
:group 'message-mail
:group 'message-headers
:type '(repeat sexp))
:group 'message-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:"
+(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:"
"*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-sending
:type 'function)
-(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"
+(defcustom message-subject-re-regexp
+ "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
"*Regexp matching \"Re: \" in the subject line."
:group 'message-various
:type 'regexp)
:type 'string
:group 'message-various)
-(defcustom message-interactive nil
+(defcustom message-interactive t
"Non-nil means when sending a message wait for and display errors.
nil means let mailer mail back a message to report errors."
:group 'message-sending
:type 'regexp)
(defcustom message-make-forward-subject-function
- 'message-forward-subject-author-subject
+ 'message-forward-subject-name-subject
"*List of functions called to generate subject headers for forwarded messages.
The subject generated by the previous function is passed into each
successive function.
* `message-forward-subject-author-subject' (Source of article (author or
newsgroup)), in brackets followed by the subject
+* `message-forward-subject-name-subject' (Source of article (name of author
+ or newsgroup)), in brackets followed by the subject
* `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended
to it."
:group 'message-forwarding
:group 'message-forwarding
:type 'boolean)
-(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"
+(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From "
"*All headers that match this regexp will be deleted when resending a message."
:group 'message-interface
:type 'regexp)
(defcustom message-cite-prefix-regexp
(if (string-match "[[:digit:]]" "1") ;; support POSIX?
- "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>»|:}+]\\)+"
+ "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
- "\\([ \t]*\\(\\w\\|[-_.]\\)+>+\\|[ \t]*[]>»|:}+]\\)+")
+ (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)
+ (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."
:group 'message-insertion
:type 'regexp)
Valid values include `message-send-mail-with-sendmail' (the default),
`message-send-mail-with-mh', `message-send-mail-with-qmail',
-`message-send-mail-with-smtp', `smtpmail-send-it' and `feedmail-send-it'.
+`message-send-mail-with-smtp', `message-smtpmail-send-it',
+`smtpmail-send-it' and `feedmail-send-it'.
See also `send-mail-function'."
:type '(radio (function-item message-send-mail-with-sendmail)
(function-item message-send-mail-with-mh)
(function-item message-send-mail-with-qmail)
(function-item message-send-mail-with-smtp)
+ (function-item message-smtpmail-send-it)
(function-item smtpmail-send-it)
(function-item feedmail-send-it)
(function :tag "Other"))
:group 'message-sending
:type 'boolean)
+(defcustom message-sendmail-envelope-from nil
+ "*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."
+ :type '(choice (string :tag "From name")
+ (const :tag "Use From: header from message" header)
+ (const :tag "Use `user-mail-address'" nil))
+ :group 'message-sending)
+
;; qmail-related stuff
(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
"Location of the qmail-inject program."
(defcustom message-qmail-inject-args nil
"Arguments passed to qmail-inject programs.
-This should be a list of strings, one string for each argument.
+This should be a list of strings, one string for each argument. It
+may also be a function.
For e.g., if you wish to set the envelope sender address so that bounces
go to the right place or to deal with listserv's usage of that address, you
might set this variable to '(\"-f\" \"you@some.where\")."
:group 'message-sending
- :type '(repeat string))
+ :type '(choice (function)
+ (repeat string)))
(defvar message-cater-to-broken-inn t
"Non-nil means Gnus should not fold the `References' header.
"*If non-nil, generate all required headers before composing.
The variables `message-required-news-headers' and
`message-required-mail-headers' specify which headers to generate.
+This can also be a list of headers that should be generated before
+composing.
Note that the variable `message-deletable-headers' specifies headers which
are to be deleted and then re-generated before sending, so this variable
will not have a visible effect for those headers."
:group 'message-headers
- :type 'boolean)
+ :type '(choice (const :tag "None" nil)
+ (const :tag "All" t)
+ (repeat (sexp :tag "Header"))))
(defcustom message-setup-hook '(turn-on-mime-edit)
"Normal hook, run each time a new outgoing message is initialized.
:group 'message-various
:type 'hook)
-(defcustom message-header-hook '((lambda () (eword-encode-header t)))
+(defcustom message-header-hook '((lambda () (mime-encode-header-in-buffer t)))
"Hook run in a message mode buffer narrowed to the headers."
:group 'message-various
:type 'hook)
:type 'function
:group 'message-insertion)
-(defvar message-abbrevs-loaded nil)
-
;;;###autoload
(defcustom message-signature t
"*String to be inserted at the end of the message buffer.
:type '(choice file (const :tags "None" nil))
:group 'message-insertion)
+;;;###autoload
+(defcustom message-signature-insert-empty-line t
+ "*If non-nil, insert an empty line before the signature separator."
+ :type 'boolean
+ :group 'message-insertion)
+
(defcustom message-distribution-function nil
"*Function called to return a Distribution header."
:group 'message-news
(sexp :tag "none" :format "%t" t)))
(defvar message-reply-buffer nil)
-(defvar message-reply-headers nil)
+(defvar message-reply-headers nil
+ "The headers of the current replied article.
+It is a vector of the following headers:
+\[number subject from date id references chars lines xref extra].")
(defvar message-sent-message-via nil)
(defvar message-checksum nil)
(defvar message-send-actions nil
:group 'message-buffers
:type '(choice directory (const :tag "Don't auto-save" nil)))
-(defcustom message-buffer-naming-style 'unique
- "*The way new message buffers are named.
-Valid valued are `unique' and `unsent'."
- :version "21.1"
- :group 'message-buffers
- :type '(choice (const :tag "unique" unique)
- (const :tag "unsent" unsent)))
-
(defcustom message-default-charset
(and (featurep 'xemacs) (not (featurep 'mule)) 'iso-8859-1)
"Default charset used in non-MULE XEmacsen."
"*A list of GNKSA feet you are allowed to shoot.
Gnus gives you all the opportunity you could possibly want for
shooting yourself in the foot. Also, Gnus allows you to shoot the
-feet of Good Net-Keeping Seal of Approval. The following are foot
+feet of Good Net-Keeping Seal of Approval. The following are foot
candidates:
`empty-article' Allow you to post an empty article;
`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 others' messages.
+`multiple-copies' Allow you to post multiple copies;
+`cancel-messages' Allow you to cancel or supersede messages from
+ your other email addresses.")
(defsubst message-gnksa-enable-p (feature)
(or (not (listp message-shoot-gnksa-feet))
(memq feature message-shoot-gnksa-feet)))
+(defcustom message-hidden-headers nil
+ "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.."
+ :group 'message
+ :type '(repeat regexp))
+
;;; Internal variables.
;;; Well, not really internal.
"Face used for displaying MML."
:group 'message-faces)
+(defun message-font-lock-make-header-matcher (regexp)
+ (let ((form
+ `(lambda (limit)
+ (let ((start (point)))
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$")
+ nil t)
+ (setq limit (min limit (match-beginning 0))))
+ (goto-char start))
+ (and (< start limit)
+ (re-search-forward ,regexp limit t))))))
+ (if (featurep 'bytecomp)
+ (byte-compile form)
+ form)))
+
(defvar message-font-lock-keywords
(let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
- `((,(concat "^\\([Tt]o:\\)" content)
+ `((,(message-font-lock-make-header-matcher
+ (concat "^\\([Tt]o:\\)" content))
(1 'message-header-name-face)
(2 'message-header-to-face nil t))
- (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
- "[Mm]ail-[Cc]opies-[Tt]o:\\|"
- "[Mm]ail-[Rr]eply-[Tt]o:\\|"
- "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
+ "[Mm]ail-[Cc]opies-[Tt]o:\\|"
+ "[Mm]ail-[Rr]eply-[Tt]o:\\|"
+ "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content))
(1 'message-header-name-face)
(2 'message-header-cc-face nil t))
- (,(concat "^\\([Ss]ubject:\\)" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\([Ss]ubject:\\)" content))
(1 'message-header-name-face)
(2 'message-header-subject-face nil t))
- (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
(1 'message-header-name-face)
(2 'message-header-newsgroups-face nil t))
- (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\([A-Z][^: \n\t]+:\\)" content))
(1 'message-header-name-face)
(2 'message-header-other-face nil t))
- (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
(1 'message-header-name-face)
(2 'message-header-name-face))
,@(if (and mail-header-separator
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1 'message-separator-face))
nil)
- (,(concat "^\\(" message-cite-prefix-regexp "\\).*")
+ ((lambda (limit)
+ (re-search-forward (concat "^\\("
+ message-cite-prefix-regexp
+ "\\).*")
+ limit t))
(0 'message-cited-text-face))
(,mime-edit-tag-regexp
(0 'message-mml-face))))
(unbold-region b e)
(ununderline-region b e))))
"Alist of mail and news faces for facemenu.
-The cdr of ech entry is a function for applying the face to a region.")
+The cdr of each entry is a function for applying the face to a region.")
(defcustom message-send-hook nil
- "Hook run before sending messages."
+ "Hook run before sending messages.
+This hook is run quite early when sending."
:group 'message-various
:options '(ispell-message)
:type 'hook)
(defcustom message-send-mail-hook nil
- "Hook run before sending mail messages."
+ "Hook run before sending mail messages.
+This hook is run very late -- just before the message is sent as
+mail."
:group 'message-various
:type 'hook)
(defcustom message-send-news-hook nil
- "Hook run before sending news messages."
+ "Hook run before sending news messages.
+This hook is run very late -- just before the message is sent as
+news."
:group 'message-various
:type 'hook)
(const :tag "ask" ask)))
(defvar message-draft-coding-system
- (cond
- ((boundp 'MULE) '*junet*)
- ((not (fboundp 'find-coding-system)) nil)
- ((find-coding-system 'emacs-mule)
- (if (memq system-type '(windows-nt ms-dos ms-windows))
- 'emacs-mule-dos 'emacs-mule))
- ((find-coding-system 'escape-quoted) 'escape-quoted)
- ((find-coding-system 'no-conversion) 'no-conversion)
- (t nil))
- "Coding system to compose mail.")
+ nnheader-auto-save-coding-system
+ "*Coding system to compose mail.
+If you'd like to make it possible to share draft files between XEmacs
+and Emacs, you may use `iso-2022-7bit' for this value at your own risk.
+Note that the coding-system `iso-2022-7bit' isn't suitable to all data.")
(defcustom message-send-mail-partially-limit 1000000
"The limitation of messages sent as message/partial.
:type '(choice (const :tag "Always use primary" nil)
regexp))
+(defcustom message-hierarchical-addresses nil
+ "A list of hierarchical mail address definitions.
+
+Inside each entry, the first address is the \"top\" address, and
+subsequent addresses are subaddresses; this is used to indicate that
+mail sent to the first address will automatically be delivered to the
+subaddresses. So if the first address appears in the recipient list
+for a message, the subaddresses will be removed (if present) before
+the mail is sent. All addresses in this structure should be
+downcased."
+ :group 'message-headers
+ :type '(repeat (repeat string)))
+
(defcustom message-mail-user-agent nil
"Like `mail-user-agent'.
Except if it is nil, use Gnus native MUA; if it is t, use
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"
:group 'message-headers
:type 'boolean)
-(defcustom message-insert-canlock t
- "Whether to insert a Cancel-Lock header in news postings."
+(defcustom message-user-fqdn nil
+ "*Domain part of Messsage-Ids."
:group 'message-headers
- :type 'boolean)
+ :link '(custom-manual "(message)News Headers")
+ :type 'string)
+
+(defcustom message-use-idna (and (condition-case nil (require 'idna)
+ (file-error))
+ (fboundp 'coding-system-p)
+ (coding-system-p 'utf-8)
+ 'ask)
+ "Whether to encode non-ASCII in domain names into ASCII according to IDNA."
+ :group 'message-headers
+ :type '(choice (const :tag "Ask" ask)
+ (const :tag "Never" nil)
+ (const :tag "Always" t)))
;;; Internal variables.
;; We want to match the results of any of these manglings.
;; The following regexp rejects names whose first characters are
;; obviously bogus, but after that anything goes.
- "\\([^\0-\b\n-\r\^?].*\\)? "
+ "\\([^\0-\b\n-\r\^?].*\\)?"
;; The time the message was sent.
"\\([^\0-\r \^?]+\\) +" ; day of the week
(defvar message-bogus-system-names "^localhost\\."
"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
+ "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
+ "\\|aero\\|coop\\|info\\|name\\|museum"
+ "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
+ "\\)")
+ "Regular expression that matches a valid FQDN."
+ ;; see also: gnus-button-valid-fqdn-regexp
+ :group 'message-headers
+ :type 'regexp)
+
(eval-and-compile
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
(autoload 'gnus-point-at-bol "gnus-util")
(autoload 'gnus-output-to-rmail "gnus-util")
(autoload 'gnus-output-to-mail "gnus-util")
- (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")
(autoload 'nndraft-request-associate-buffer "nndraft")
(autoload 'nndraft-request-expire-articles "nndraft")
(autoload 'gnus-open-server "gnus-int")
(autoload 'gnus-group-name-decode "gnus-group")
(autoload 'gnus-groups-from-server "gnus")
(autoload 'rmail-output "rmailout")
+ (autoload 'gnus-delay-article "gnus-delay")
(autoload 'mu-cite-original "mu-cite"))
\f
`(delete-region (progn (beginning-of-line) (point))
(progn (forward-line ,(or n 1)) (point))))
+(defun message-mark-active-p ()
+ "Non-nil means the mark and region are currently active in this buffer."
+ mark-active)
+
(defun message-unquote-tokens (elems)
"Remove double quotes (\") from strings in list ELEMS."
(mapcar (lambda (item)
(insert (car headers) ?\n)))))
(setq headers (cdr headers))))
+(defmacro message-with-reply-buffer (&rest forms)
+ "Evaluate FORMS in the reply buffer, if it exists."
+ `(let ((buffer (message-eval-parameter message-reply-buffer)))
+ (when (and buffer
+ (buffer-name buffer))
+ (save-excursion
+ (set-buffer buffer)
+ ,@forms))))
+
+(put 'message-with-reply-buffer 'lisp-indent-function 0)
+(put 'message-with-reply-buffer 'edebug-form-spec '(body))
(defun message-fetch-reply-field (header)
"Fetch field HEADER from the message we're replying to."
- (let ((buffer (message-eval-parameter message-reply-buffer)))
- (when (and buffer
- (buffer-name buffer))
- (save-excursion
- (set-buffer buffer)
- (message-fetch-field header)))))
+ (message-with-reply-buffer
+ (save-restriction
+ (mail-narrow-to-head)
+ (message-fetch-field header))))
(defun message-set-work-buffer ()
(if (get-buffer " *message work*")
(substring subject (match-end 0))
subject))
+;;; Start of functions adopted from `message-utils.el'.
+
+(defun message-strip-subject-trailing-was (subject)
+ "Remove trailing \"(Was: <old subject>)\" from SUBJECT lines.
+Leading \"Re: \" is not stripped by this function. Use the function
+`message-strip-subject-re' for this."
+ (let* ((query message-subject-trailing-was-query)
+ (new) (found))
+ (setq found
+ (string-match
+ (if (eq query 'ask)
+ message-subject-trailing-was-ask-regexp
+ message-subject-trailing-was-regexp)
+ subject))
+ (if found
+ (setq new (substring subject 0 (match-beginning 0))))
+ (if (or (not found) (eq query nil))
+ subject
+ (if (eq query 'ask)
+ (if (message-y-or-n-p
+ "Strip `(was: <old subject>)' in subject? " t
+ (concat
+ "Strip `(was: <old subject>)' in subject "
+ "and use the new one instead?\n\n"
+ "Current subject is: \""
+ subject "\"\n\n"
+ "New subject would be: \""
+ new "\"\n\n"
+ "See the variable `message-subject-trailing-was-query' "
+ "to get rid of this query."
+ ))
+ new subject)
+ new))))
+
+;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/
+
+;;;###autoload
+(defun message-change-subject (new-subject)
+ "Ask for NEW-SUBJECT header, append (was: <Old Subject>)."
+ (interactive
+ (list
+ (read-from-minibuffer "New subject: ")))
+ (cond ((and (not (or (null new-subject) ; new subject not empty
+ (zerop (string-width new-subject))
+ (string-match "^[ \t]*$" new-subject))))
+ (save-excursion
+ (let ((old-subject (message-fetch-field "Subject")))
+ (cond ((not old-subject)
+ (error "No current subject"))
+ ((not (string-match
+ (concat "^[ \t]*"
+ (regexp-quote new-subject)
+ " \t]*$")
+ old-subject)) ; yes, it really is a new subject
+ ;; delete eventual Re: prefix
+ (setq old-subject
+ (message-strip-subject-re old-subject))
+ (message-goto-subject)
+ (message-delete-line)
+ (insert (concat "Subject: "
+ new-subject
+ " (was: "
+ old-subject ")\n")))))))))
+
+;;;###autoload
+(defun message-mark-inserted-region (beg end)
+ "Mark some region in the current article with enclosing tags.
+See `message-mark-insert-begin' and `message-mark-insert-end'."
+ (interactive "r")
+ (save-excursion
+ ; add to the end of the region first, otherwise end would be invalid
+ (goto-char end)
+ (insert message-mark-insert-end)
+ (goto-char beg)
+ (insert message-mark-insert-begin)))
+
+;;;###autoload
+(defun message-mark-insert-file (file)
+ "Insert FILE at point, marking it with enclosing tags.
+See `message-mark-insert-begin' and `message-mark-insert-end'."
+ (interactive "fFile to insert: ")
+ ;; reverse insertion to get correct result.
+ (let ((p (point)))
+ (insert message-mark-insert-end)
+ (goto-char p)
+ (insert-file-contents file)
+ (goto-char p)
+ (insert message-mark-insert-begin)))
+
+;;;###autoload
+(defun message-add-archive-header ()
+ "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
+The note can be customized using `message-archive-note'. When called with a
+prefix argument, ask for a text to insert. If you don't want the note in the
+body, set `message-archive-note' to nil."
+ (interactive)
+ (if current-prefix-arg
+ (setq message-archive-note
+ (read-from-minibuffer "Reason for No-Archive: "
+ (cons message-archive-note 0))))
+ (save-excursion
+ (if (message-goto-signature)
+ (re-search-backward message-signature-separator))
+ (when message-archive-note
+ (insert message-archive-note)
+ (newline))
+ (message-add-header message-archive-header)
+ (message-sort-headers)))
+
+;;;###autoload
+(defun message-cross-post-followup-to-header (target-group)
+ "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
+With prefix-argument just set Follow-Up, don't cross-post."
+ (interactive
+ (list ; Completion based on Gnus
+ (completing-read "Followup To: "
+ (if (boundp 'gnus-newsrc-alist)
+ gnus-newsrc-alist)
+ nil nil '("poster" . 0)
+ (if (boundp 'gnus-group-history)
+ 'gnus-group-history))))
+ (message-remove-header "Follow[Uu]p-[Tt]o" t)
+ (message-goto-newsgroups)
+ (beginning-of-line)
+ ;; if we already did a crosspost before, kill old target
+ (if (and message-cross-post-old-target
+ (re-search-forward
+ (regexp-quote (concat "," message-cross-post-old-target))
+ nil t))
+ (replace-match ""))
+ ;; unless (followup is to poster or user explicitly asked not
+ ;; to cross-post, or target-group is already in Newsgroups)
+ ;; add target-group to Newsgroups line.
+ (cond ((and (or
+ ;; def: cross-post, req:no
+ (and message-cross-post-default (not current-prefix-arg))
+ ;; def: no-cross-post, req:yes
+ (and (not message-cross-post-default) current-prefix-arg))
+ (not (string-match "poster" target-group))
+ (not (string-match (regexp-quote target-group)
+ (message-fetch-field "Newsgroups"))))
+ (end-of-line)
+ (insert (concat "," target-group))))
+ (end-of-line) ; ensure Followup: comes after Newsgroups:
+ ;; unless new followup would be identical to Newsgroups line
+ ;; make a new Followup-To line
+ (if (not (string-match (concat "^[ \t]*"
+ target-group
+ "[ \t]*$")
+ (message-fetch-field "Newsgroups")))
+ (insert (concat "\nFollowup-To: " target-group)))
+ (setq message-cross-post-old-target target-group))
+
+;;;###autoload
+(defun message-cross-post-insert-note (target-group cross-post in-old
+ old-groups)
+ "Insert a in message body note about a set Followup or Crosspost.
+If there have been previous notes, delete them. TARGET-GROUP specifies the
+group to Followup-To. When CROSS-POST is t, insert note about
+crossposting. IN-OLD specifies whether TARGET-GROUP is a member of
+OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have
+been made to before the user asked for a Crosspost."
+ ;; start scanning body for previous uses
+ (message-goto-signature)
+ (let ((head (re-search-backward
+ (concat "^" mail-header-separator)
+ nil t))) ; just search in body
+ (message-goto-signature)
+ (while (re-search-backward
+ (concat "^" (regexp-quote message-cross-post-note) ".*")
+ head t)
+ (message-delete-line))
+ (message-goto-signature)
+ (while (re-search-backward
+ (concat "^" (regexp-quote message-followup-to-note) ".*")
+ head t)
+ (message-delete-line))
+ ;; insert new note
+ (if (message-goto-signature)
+ (re-search-backward message-signature-separator))
+ (if (or in-old
+ (not cross-post)
+ (string-match "^[ \t]*poster[ \t]*$" target-group))
+ (insert (concat message-followup-to-note target-group "\n"))
+ (insert (concat message-cross-post-note target-group "\n")))))
+
+;;;###autoload
+(defun message-cross-post-followup-to (target-group)
+ "Crossposts message and set Followup-To to TARGET-GROUP.
+With prefix-argument just set Follow-Up, don't cross-post."
+ (interactive
+ (list ; Completion based on Gnus
+ (completing-read "Followup To: "
+ (if (boundp 'gnus-newsrc-alist)
+ gnus-newsrc-alist)
+ nil nil '("poster" . 0)
+ (if (boundp 'gnus-group-history)
+ 'gnus-group-history))))
+ (cond ((not (or (null target-group) ; new subject not empty
+ (zerop (string-width target-group))
+ (string-match "^[ \t]*$" target-group)))
+ (save-excursion
+ (let* ((old-groups (message-fetch-field "Newsgroups"))
+ (in-old (string-match
+ (regexp-quote target-group)
+ (or old-groups ""))))
+ ;; check whether target exactly matches old Newsgroups
+ (cond ((not old-groups)
+ (error "No current newsgroup"))
+ ((or (not in-old)
+ (not (string-match
+ (concat "^[ \t]*"
+ (regexp-quote target-group)
+ "[ \t]*$")
+ old-groups)))
+ ;; yes, Newsgroups line must change
+ (message-cross-post-followup-to-header target-group)
+ ;; insert note whether we do cross-post or followup-to
+ (funcall message-cross-post-note-function
+ target-group
+ (if (or (and message-cross-post-default
+ (not current-prefix-arg))
+ (and (not message-cross-post-default)
+ current-prefix-arg)) t)
+ in-old old-groups))))))))
+
+;;; Reduce To: to Cc: or Bcc: header
+
+;;;###autoload
+(defun message-reduce-to-to-cc ()
+ "Replace contents of To: header with contents of Cc: or Bcc: header."
+ (interactive)
+ (let ((cc-content (message-fetch-field "cc"))
+ (bcc nil))
+ (if (and (not cc-content)
+ (setq cc-content (message-fetch-field "bcc")))
+ (setq bcc t))
+ (cond (cc-content
+ (save-excursion
+ (message-goto-to)
+ (message-delete-line)
+ (insert (concat "To: " cc-content "\n"))
+ (message-remove-header (if bcc
+ "bcc"
+ "cc")))))))
+
+;;; End of functions adopted from `message-utils.el'.
+
(defun message-remove-header (header &optional is-regexp first reverse)
"Remove HEADER in the narrowed buffer.
If IS-REGEXP, HEADER is a regular expression.
(message-fetch-field "cc")
(message-fetch-field "bcc")))))))
+(defun message-subscribed-p ()
+ "Say whether we need to insert a MFT header."
+ (or message-subscribed-regexps
+ message-subscribed-addresses
+ message-subscribed-address-file
+ message-subscribed-address-functions))
+
(defun message-next-header ()
"Go to the beginning of the next header."
(beginning-of-line)
(define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
(define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
(define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
- (define-key message-mode-map "\C-c\C-f\C-i" 'message-insert-or-toggle-importance)
+ (define-key message-mode-map "\C-c\C-f\C-i"
+ 'message-insert-or-toggle-importance)
+ (define-key message-mode-map "\C-c\C-f\C-a"
+ 'message-generate-unsubscribed-mail-followup-to)
+
+ ;; modify headers (and insert notes in body)
+ (define-key message-mode-map "\C-c\C-fs" 'message-change-subject)
+ ;;
+ (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to)
+ ;; prefix+message-cross-post-followup-to = same w/o cross-post
+ (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc)
+ (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header)
+ ;; mark inserted text
+ (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region)
+ (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file)
+
(define-key message-mode-map "\C-c\C-b" 'message-goto-body)
(define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
(define-key message-mode-map "\C-c\C-fc" 'message-goto-mail-copies-to)
(define-key message-mode-map "\C-c\C-t" 'message-insert-to)
+ (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
(define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
+ (define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
(define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance)
- (define-key message-mode-map "\C-c\M-n" 'message-insert-disposition-notification-to)
+ (define-key message-mode-map "\C-c\M-n"
+ 'message-insert-disposition-notification-to)
(define-key message-mode-map "\C-c\C-y" 'message-yank-original)
(define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)
(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-a" 'message-beginning-of-line)
(define-key message-mode-map "\t" 'message-tab)
(define-key message-mode-map "\M-;" 'comment-region)
- (define-key message-mode-map "\C-x\C-s" 'message-save-drafts)
(define-key message-mode-map "\C-xk" 'message-mimic-kill-buffer))
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
`("Message"
- ["Sort Headers" message-sort-headers t]
["Yank Original" message-yank-original t]
["Fill Yanked Message" message-fill-yanked-message t]
["Insert Signature" message-insert-signature t]
["Caesar (rot13) Message" message-caesar-buffer-body t]
- ["Caesar (rot13) Region" message-caesar-region (mark t)]
- ["Elide Region" message-elide-region (mark t)]
- ["Delete Outside Region" message-delete-not-region (mark t)]
+ ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)]
+ ["Elide Region" message-elide-region
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Replace text in region with an ellipsis"))]
+ ["Delete Outside Region" message-delete-not-region
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Delete all quoted text outside region"))]
["Kill To Signature" message-kill-to-signature t]
["Newline and Reformat" message-newline-and-reformat t]
["Rename buffer" message-rename-buffer t]
- ["Flag As Important" message-insert-importance-high
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Mark this message as important"))]
- ["Flag As Unimportant" message-insert-importance-low
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Mark this message as unimportant"))]
- ["Request Receipt"
- message-insert-disposition-notification-to
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Request a Disposition Notification of this article"))]
["Spellcheck" ispell-message
,@(if (featurep 'xemacs) '(t)
'(:help "Spellcheck this message"))]
,@(if (featurep 'xemacs) '(t)
'(:help "Attach a file at point"))]
"----"
+ ["Insert Region Marked" message-mark-inserted-region
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Mark region with enclosing tags"))]
+ ["Insert File Marked..." message-mark-insert-file
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Insert file at point marked with enclosing tags"))]
+ "----"
["Send Message" message-send-and-exit
,@(if (featurep 'xemacs) '(t)
'(:help "Send this message"))]
["Postpone Message" message-dont-send
,@(if (featurep 'xemacs) '(t)
'(:help "File this draft message and exit"))]
- ["Send at Specific Time" gnus-delay-article
+ ["Send at Specific Time..." gnus-delay-article
,@(if (featurep 'xemacs) '(t)
'(:help "Ask, then arrange to send message at that time"))]
["Kill Message" message-kill-buffer
(easy-menu-define
message-mode-field-menu message-mode-map ""
- '("Field"
+ `("Field"
["Fetch To" message-insert-to t]
["Fetch Newsgroups" message-insert-newsgroups t]
"----"
["To" message-goto-to t]
["From" message-goto-from t]
["Subject" message-goto-subject t]
+ ["Change subject..." message-change-subject t]
["Cc" message-goto-cc t]
+ ["Bcc" message-goto-bcc t]
+ ["Fcc" message-goto-fcc t]
["Reply-To" message-goto-reply-to t]
- ["Mail-Reply-To" message-goto-mail-reply-to t]
- ["Mail-Followup-To" message-goto-mail-followup-to t]
- ["Mail-Copies-To" message-goto-mail-copies-to t]
+ ["Flag As Important" message-insert-importance-high
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Mark this message as important"))]
+ ["Flag As Unimportant" message-insert-importance-low
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Mark this message as unimportant"))]
+ ["Request Receipt"
+ message-insert-disposition-notification-to
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Request a receipt notification"))]
+ "----"
+ ;; (typical) news stuff
["Summary" message-goto-summary t]
["Keywords" message-goto-keywords t]
["Newsgroups" message-goto-newsgroups t]
["Followup-To" message-goto-followup-to t]
- ["Mail-Followup-To" message-goto-mail-followup-to t]
+ ;; ["Followup-To (with note in body)" message-cross-post-followup-to t]
+ ["Crosspost / Followup-To..." message-cross-post-followup-to t]
["Distribution" message-goto-distribution t]
- ["Body" message-goto-body t]
- ["Signature" message-goto-signature t]))
+ ["X-No-Archive:" message-add-archive-header t ]
+ "----"
+ ;; (typical) mailing-lists stuff
+ ["Send to list only" message-to-list-only t]
+ ["Mail-Followup-To" message-goto-mail-followup-to t]
+ ["Mail-Reply-To" message-goto-mail-reply-to t]
+ ["Mail-Copies-To" message-goto-mail-copies-to t]
+ ["Reduce To: to Cc:" message-reduce-to-to-cc t]
+ "----"
+ ["Sort Headers" message-sort-headers t]
+ ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t]
+ ["Goto Body" message-goto-body t]
+ ["Goto Signature" message-goto-signature t]))
(defvar message-tool-bar-map nil)
;; 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'.
- '(field nil read-only nil intangible nil invisible nil
+ '(field nil read-only nil invisible nil intangible nil
mouse-face nil modification-hooks nil insert-in-front-hooks nil
insert-behind-hooks nil point-entered nil point-left nil)
;; Other special properties:
(message-tamago-not-in-use-p begin)
;; Check whether the invisible MIME part is not inserted.
(not (text-property-any begin end 'mime-edit-invisible t)))
- (remove-text-properties begin end message-forbidden-properties)))
+ (while (not (= begin end))
+ (when (not (get-text-property begin 'message-hidden))
+ (remove-text-properties begin (1+ begin)
+ message-forbidden-properties))
+ (incf begin))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To
C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups
C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution
+ C-c C-f C-o move to From (\"Originator\")
C-c C-f C-f move to Followup-To
C-c C-f C-m move to Mail-Followup-To
- C-c C-f C-i cycle through Importance values
C-c C-f c move to Mail-Copies-To
+ C-c C-f C-i cycle through Importance values
+ C-c C-f s change subject and append \"(was: <Old Subject>)\"
+ C-c C-f x crossposting with FollowUp-To header and note in body
+ C-c C-f t replace To: header with contents of Cc: or Bcc:
+ C-c C-f a Insert X-No-Archive: header and a note in the body
C-c C-t `message-insert-to' (add a To header to a news followup)
+C-c C-l `message-to-list-only' (removes all but list address in to/cc)
C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply)
C-c C-b `message-goto-body' (move to beginning of message text).
C-c C-i `message-goto-signature' (move to the beginning of the signature).
C-c C-r `message-caesar-buffer-body' (rot13 the message body).
C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance).
C-c M-n `message-insert-disposition-notification-to' (request receipt).
+C-c M-m `message-mark-inserted-region' (mark region with enclosing tags).
+C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags).
M-RET `message-newline-and-reformat' (break the line and reformat)."
+ (setq local-abbrev-table text-mode-abbrev-table)
(set (make-local-variable 'message-reply-buffer) nil)
(make-local-variable 'message-send-actions)
(make-local-variable 'message-exit-actions)
(setq message-parameter-alist
(copy-sequence message-startup-parameter-alist))
(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)
(if (featurep 'xemacs)
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
(mail-aliases-setup)))
- (message-set-auto-save-file-name)
+ (unless buffer-file-name
+ (message-set-auto-save-file-name))
(set (make-local-variable 'indent-tabs-mode) nil)) ;No tabs for indentation.
(defun message-setup-fill-variables ()
(goto-char (point-max))
nil))
+(defun message-generate-unsubscribed-mail-followup-to (&optional include-cc)
+ "Insert a reasonable MFT header in a post to an unsubscribed list.
+When making original posts to a mailing list you are not subscribed to,
+you have to type in a MFT header by hand. The contents, usually, are
+the addresses of the list and your own address. This function inserts
+such a header automatically. It fetches the contents of the To: header
+in the current mail buffer, and appends the current `user-mail-address'.
+
+If the optional argument INCLUDE-CC is non-nil, the addresses in the
+Cc: header are also put into the MFT."
+
+ (interactive "P")
+ (message-remove-header "Mail-Followup-To")
+ (let* ((cc (and include-cc (message-fetch-field "Cc")))
+ (tos (if cc
+ (concat (message-fetch-field "To") "," cc)
+ (message-fetch-field "To"))))
+ (message-goto-mail-followup-to)
+ (insert (concat tos ", " user-mail-address))))
+
\f
(defun message-insert-to (&optional force)
(or (equal (downcase co) "never")
(equal (downcase co) "nobody")))
(error "The user has requested not to have copies sent via mail")))
- (when (and (message-position-on-field "To")
- (mail-fetch-field "to")
- (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
- (insert ", "))
- (insert (or (message-fetch-reply-field "mail-reply-to")
- (message-fetch-reply-field "reply-to")
- (message-fetch-reply-field "from") "")))
+ (message-carefully-insert-headers
+ (list (cons 'To
+ (or (message-fetch-reply-field "mail-reply-to")
+ (message-fetch-reply-field "reply-to")
+ (message-fetch-reply-field "from")
+ "")))))
+
+(defun message-insert-wide-reply ()
+ "Insert To and Cc headers as if you were doing a wide reply."
+ (interactive)
+ (let ((headers (message-with-reply-buffer
+ (message-get-reply-headers t))))
+ (message-carefully-insert-headers headers)))
+
+(defun message-carefully-insert-headers (headers)
+ (dolist (header headers)
+ (let ((header-name (symbol-name (car header))))
+ (when (and (message-position-on-field header-name)
+ (mail-fetch-field header-name)
+ (not (string-match "\\` *\\'"
+ (mail-fetch-field header-name))))
+ (insert ", "))
+ (insert (cdr header)))))
(defun message-widen-reply ()
"Widen the reply to include maximum recipients."
(delete-region (point) (re-search-forward "[ \t]*"))
(when (and quoted (not bolp))
(insert quoted leading-space)))
+ (undo-boundary)
(if quoted
(let* ((adaptive-fill-regexp
(regexp-quote (concat quoted leading-space)))
;; Insert the signature.
(unless (bolp)
(insert "\n"))
+ (when message-signature-insert-empty-line
+ (insert "\n"))
(insert "\n" message-signature-separator-for-insertion)
(unless (bolp)
(insert "\n"))
(push (pop saved-id) refs-list))
refs-list))
-(defvar gnus-article-copy)
(defun message-yank-original (&optional arg)
"Insert the message being replied to, if any.
Puts point before the text and mark after.
In addition, if `message-yank-add-new-references' is non-nil and this
command is called interactively, new IDs from the yanked article will
-be added to \"References\" field.
-\(See also `message-yank-add-new-references'.)"
+be added to the \"References\" field."
(interactive "P")
- (let ((modified (buffer-modified-p))
- (buffer (message-eval-parameter message-reply-buffer))
- start end refs)
- (when (and buffer
- message-cite-function)
- (delete-windows-on buffer t)
- (insert-buffer buffer) ; mark will be set at the end of article.
- (setq start (point)
- end (mark t))
-
- ;; Add new IDs to References field.
- (when (and message-yank-add-new-references (interactive-p))
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (setq refs (message-list-references
- nil
- (message-fetch-field "References")))
- (widen)
- (narrow-to-region start end)
- (std11-narrow-to-header)
- (when (setq refs (message-list-references
- refs
- (unless (eq message-yank-add-new-references
- 'message-id-only)
- (or (message-fetch-field "References")
- (message-fetch-field "In-Reply-To")))
- (message-fetch-field "Message-ID")))
+ (let ((modified (buffer-modified-p)))
+ (when (let ((buffer (message-eval-parameter message-reply-buffer)))
+ (and buffer
+ message-cite-function
+ (prog1
+ t
+ (delete-windows-on buffer t)
+ ; The mark will be set at the end of the article.
+ (insert-buffer buffer))))
+ ;; Add new IDs to the References field.
+ (when (and message-yank-add-new-references
+ (interactive-p))
+ (let ((start (point))
+ (end (mark t))
+ refs newrefs)
+ (save-excursion
+ (save-restriction
(widen)
- (message-narrow-to-headers)
- (goto-char (point-min))
- (let ((case-fold-search t))
- (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t)
+ (setq refs (message-list-references
+ nil
+ (or (message-make-references)
+ (prog2
+ (message-narrow-to-headers)
+ (message-fetch-field "References")
+ (widen)))))
+ (narrow-to-region start end)
+ (std11-narrow-to-header)
+ (unless (equal (setq newrefs
+ (message-list-references
+ (copy-sequence refs)
+ (unless (eq message-yank-add-new-references
+ 'message-id-only)
+ (or (message-fetch-field "References")
+ (message-fetch-field "In-Reply-To")))
+ (message-fetch-field "Message-ID")))
+ refs)
+ ;; If the References field has been changed, we make it
+ ;; visible in the header.
+ (mail-header-set-message-id message-reply-headers nil)
+ (mail-header-set-references message-reply-headers nil)
+ (widen)
+ (message-narrow-to-headers)
+ (if (let ((case-fold-search t))
+ (re-search-forward "^References:\\([\t ]+.+\n\\)+"
+ nil t))
(replace-match "")
- (goto-char (point-max))))
- (mail-header-format
- (list (or (assq 'References message-header-format-alist)
- '(References . message-fill-references)))
- (list (cons 'References
- (mapconcat 'identity (nreverse refs) " "))))
- (backward-delete-char 1)))))
-
+ (goto-char (point-max)))
+ (mail-header-format
+ (list (or (assq 'References message-header-format-alist)
+ '(References . message-fill-references)))
+ (list (cons 'References (mapconcat 'identity
+ (nreverse newrefs) " "))))
+ (backward-delete-char 1))))))
(unless arg
(if (and message-suspend-font-lock-when-citing
(boundp 'font-lock-mode)
t)))
(defun message-dont-send ()
- "Don't send the message you have been editing."
+ "Don't send the message you have been editing.
+Instead, just auto-save the buffer and then bury it."
(interactive)
- (message-save-drafts)
+ (set-buffer-modified-p t)
+ (save-buffer)
(let ((actions message-postpone-actions)
(frame (selected-frame))
(org-frame message-original-frame))
(success t)
elem sent dont-barf-on-no-method
(message-options message-options))
- (message-options-set-recipient)
- (save-excursion
- (set-buffer message-encoding-buffer)
- (erase-buffer)
- ;; ;; Avoid copying text props (except hard newlines).
- ;; T-gnus change: copy all text props from the editing buffer
- ;; into the encoding buffer.
- (insert-buffer message-edit-buffer)
- (funcall message-encode-function)
- (while (and success
- (setq elem (pop alist)))
- (when (funcall (cadr elem))
- (when (and (or (not (memq (car elem)
- message-sent-message-via))
- (if (or (message-gnksa-enable-p 'multiple-copies)
- (not (eq (car elem) 'news)))
- (y-or-n-p
- (format
- "Already sent message via %s; resend? "
- (car elem)))
- (error "Denied posting -- multiple copies")))
- (setq success (funcall (caddr elem) arg)))
- (setq sent t)))))
- (unless
- (or sent
- (not success)
- (let ((fcc (message-fetch-field "Fcc"))
- (gcc (message-fetch-field "Gcc")))
- (when (or fcc gcc)
- (or (eq message-allow-no-recipients 'always)
+ (unwind-protect
+ (progn
+ (message-options-set-recipient)
+ (save-excursion
+ (set-buffer message-encoding-buffer)
+ (erase-buffer)
+ ;; ;; Avoid copying text props (except hard newlines).
+ ;; T-gnus change: copy all text props from the editing buffer
+ ;; into the encoding buffer.
+ (insert-buffer-substring message-edit-buffer)
+ (funcall message-encode-function)
+ (while (and success
+ (setq elem (pop alist)))
+ (when (funcall (cadr elem))
+ (when (and
+ (or (not (memq (car elem)
+ message-sent-message-via))
+ (not (message-fetch-field "supersedes"))
+ (if (or (message-gnksa-enable-p 'multiple-copies)
+ (not (eq (car elem) 'news)))
+ (y-or-n-p
+ (format
+ "Already sent message via %s; resend? "
+ (car elem)))
+ (error "Denied posting -- multiple copies")))
+ (setq success (funcall (caddr elem) arg)))
+ (setq sent t)))))
+ (unless
+ (or
+ sent
+ (not success)
+ (let ((fcc (message-fetch-field "Fcc"))
+ (gcc (message-fetch-field "Gcc")))
+ (when (or fcc gcc)
+ (or
+ (eq message-allow-no-recipients 'always)
(and (not (eq message-allow-no-recipients 'never))
(setq dont-barf-on-no-method
(gnus-y-or-n-p
(cond ((and fcc gcc) "Fcc and Gcc")
(fcc "Fcc")
(t "Gcc"))))))))))
- (error "No methods specified to send by"))
- (prog1
- (when (or dont-barf-on-no-method
- (and success sent))
- (message-do-fcc)
- (save-excursion
- (run-hooks 'message-sent-hook))
- (message "Sending...done")
- ;; Mark the buffer as unmodified and delete auto-save.
- (set-buffer-modified-p nil)
- (delete-auto-save-file-if-necessary t)
- (message-disassociate-draft)
- ;; Delete other mail buffers and stuff.
- (message-do-send-housekeeping)
- (message-do-actions message-send-actions)
- ;; Return success.
- t)
+ (error "No methods specified to send by"))
+ (when (or dont-barf-on-no-method
+ (and success sent))
+ (message-do-fcc)
+ (save-excursion
+ (run-hooks 'message-sent-hook))
+ (message "Sending...done")
+ ;; Mark the buffer as unmodified and delete auto-save.
+ (set-buffer-modified-p nil)
+ (delete-auto-save-file-if-necessary t)
+ (message-disassociate-draft)
+ ;; Delete other mail buffers and stuff.
+ (message-do-send-housekeeping)
+ (message-do-actions message-send-actions)
+ ;; Return success.
+ t))
(kill-buffer message-encoding-buffer)))))
(defun message-send-via-mail (arg)
(goto-char (point-max))
(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)))))
;; Delete all invisible text except for the mime parts which might
;; be inserted by the MIME-Edit.
(message-check 'invisible-text
'mime-edit-invisible t))
(when (> mime-from mime-to)
(setq hidden-start (or hidden-start mime-to))
- (put-text-property mime-to mime-from 'invisible nil))
+ (add-text-properties mime-to mime-from
+ '(invisible nil face highlight
+ font-lock-face highlight)))
(setq mime-to (or (text-property-not-all mime-from to
'mime-edit-invisible t)
to)))
(when (< mime-to to)
(setq hidden-start (or hidden-start mime-to))
- (put-text-property mime-to to 'invisible nil)))
+ (add-text-properties mime-to to
+ '(invisible nil face highlight
+ font-lock-face highlight))))
(when hidden-start
(goto-char hidden-start)
(set-window-start (selected-window) (gnus-point-at-bol))
(unless (yes-or-no-p
"Invisible text found and made visible; continue posting? ")
- (error "Invisible text found and made visible"))))))
+ (error "Invisible text found and made visible")))))
+ (message-check 'illegible-text
+ (let ((mm-7bit-chars "\x20-\x7f\r\n\t\x7\x8\xb\xc\x1f\x1b")
+ found choice)
+ (message-goto-body)
+ (skip-chars-forward mm-7bit-chars)
+ (while (not (eobp))
+ (when (let ((char (char-after)))
+ (or (< (mm-char-int char) 128)
+ (and (mm-multibyte-p)
+ (memq (char-charset char)
+ '(eight-bit-control eight-bit-graphic
+ control-1)))))
+ (add-text-properties (point) (1+ (point))
+ '(font-lock-face highlight face highlight))
+ (setq found t))
+ (forward-char)
+ (skip-chars-forward mm-7bit-chars))
+ (when found
+ (setq choice
+ (gnus-multiple-choice
+ "Illegible text found. Continue posting?"
+ '((?d "Remove and continue posting")
+ (?r "Replace with dots and continue posting")
+ (?i "Ignore and continue posting")
+ (?e "Continue editing"))))
+ (if (eq choice ?e)
+ (error "Illegible text found"))
+ (message-goto-body)
+ (skip-chars-forward mm-7bit-chars)
+ (while (not (eobp))
+ (when (let ((char (char-after)))
+ (or (< (mm-char-int char) 128)
+ (and (mm-multibyte-p)
+ (memq (char-charset char)
+ '(eight-bit-control eight-bit-graphic
+ control-1)))))
+ (if (eq choice ?i)
+ (remove-text-properties (point) (1+ (point))
+ '(font-lock-face highlight face highlight))
+ (delete-char 1)
+ (when (eq choice ?r)
+ (insert "."))))
+ (forward-char)
+ (skip-chars-forward mm-7bit-chars))))))
(defun message-add-action (action &rest types)
"Add ACTION to be performed when doing an exit of type TYPES."
+ (while types
+ (add-to-list (intern (format "message-%s-actions" (pop types)))
+ action)))
+
+(defun message-delete-action (action &rest types)
+ "Delete ACTION from lists of actions performed when doing an exit of type TYPES."
(let (var)
(while types
(set (setq var (intern (format "message-%s-actions" (pop types))))
- (nconc (symbol-value var) (list action))))))
+ (delq action (symbol-value var))))))
(defun message-do-actions (actions)
"Perform all actions in ACTIONS."
(message-remove-header "Lines")
(goto-char (point-max))
(insert "Mime-Version: 1.0\n")
- (setq header (buffer-substring (point-min) (point-max))))
+ (setq header (buffer-string)))
(goto-char (point-max))
(insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
id n total))
(save-restriction
(message-narrow-to-headers)
;; Generate the Mail-Followup-To header if the header is not there...
- (if (and (or message-subscribed-regexps
- message-subscribed-addresses
- message-subscribed-address-file
- message-subscribed-address-functions)
+ (if (and (message-subscribed-p)
(not (mail-fetch-field "mail-followup-to")))
(setq headers
(cons
- (cons "Mail-Followup-To" (message-make-mft))
+ (cons "Mail-Followup-To" (message-make-mail-followup-to))
message-required-mail-headers))
;; otherwise, delete the MFT header if the field is empty
(when (equal "" (mail-fetch-field "mail-followup-to"))
;; ;; Avoid copying text props (except hard newlines).
;; T-gnus change: copy all text props from the editing buffer
;; into the encoding buffer.
- (insert-buffer message-encoding-buffer)
+ (insert-buffer-substring message-encoding-buffer)
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
;; require one newline at the end.
(or (= (preceding-char) ?\n)
(insert ?\n))
+ (message-cleanup-headers)
(when
(save-restriction
(message-narrow-to-headers)
(and news
(or (message-fetch-field "cc")
+ (message-fetch-field "bcc")
(message-fetch-field "to"))
(let ((ct (mime-read-Content-Type)))
(or (not ct)
" sendmail errors")
0))
resend-to-addresses delimline)
- (let ((case-fold-search t))
- (save-restriction
- (message-narrow-to-headers)
- (setq resend-to-addresses (message-fetch-field "resent-to")))
- ;; Change header-delimiter to be what sendmail expects.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n"))
- (replace-match "\n")
- (backward-char 1)
- (setq delimline (point-marker))
- (run-hooks 'message-send-mail-hook)
- ;; Insert an extra newline if we need it to work around
- ;; Sun's bug that swallows newlines.
- (goto-char (1+ delimline))
- (when (eval message-mailer-swallows-blank-line)
- (newline))
- (when message-interactive
- (save-excursion
- (set-buffer errbuf)
- (erase-buffer))))
- (let ((default-directory "/"))
- (as-binary-process
- (apply 'call-process-region
- (append (list (point-min) (point-max)
- (if (boundp 'sendmail-program)
- sendmail-program
- "/usr/lib/sendmail")
- nil errbuf nil "-oi")
- ;; Always specify who from,
- ;; since some systems have broken sendmails.
- ;; But some systems are more broken with -f, so
- ;; we'll let users override this.
- (if (null message-sendmail-f-is-evil)
- (list "-f" (message-make-address)))
- ;; These mean "report errors by mail"
- ;; and "deliver in background".
- (if (null message-interactive) '("-oem" "-odb"))
- ;; Get the addresses from the message
- ;; unless this is a resend.
- ;; We must not do that for a resend
- ;; because we would find the original addresses.
- ;; For a resend, include the specific addresses.
- (if resend-to-addresses
- (list resend-to-addresses)
- '("-t"))))))
- (when message-interactive
- (save-excursion
- (set-buffer errbuf)
- (goto-char (point-min))
- (while (re-search-forward "\n\n* *" nil t)
- (replace-match "; "))
- (if (not (zerop (buffer-size)))
- (error "Sending...failed to %s"
- (buffer-substring (point-min) (point-max)))))
+ (unwind-protect
+ (progn
+ (let ((case-fold-search t))
+ (save-restriction
+ (message-narrow-to-headers)
+ (setq resend-to-addresses (message-fetch-field "resent-to")))
+ ;; Change header-delimiter to be what sendmail expects.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1)
+ (setq delimline (point-marker))
+ (run-hooks 'message-send-mail-hook)
+ ;; Insert an extra newline if we need it to work around
+ ;; Sun's bug that swallows newlines.
+ (goto-char (1+ delimline))
+ (when (eval message-mailer-swallows-blank-line)
+ (newline))
+ (when message-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (erase-buffer))))
+ (let* ((default-directory "/")
+ (cpr (as-binary-process
+ (apply
+ 'call-process-region
+ (append
+ (list (point-min) (point-max)
+ (if (boundp 'sendmail-program)
+ sendmail-program
+ "/usr/lib/sendmail")
+ nil errbuf nil "-oi")
+ ;; Always specify who from,
+ ;; since some systems have broken sendmails.
+ ;; But some systems are more broken with -f, so
+ ;; we'll let users override this.
+ (if (null message-sendmail-f-is-evil)
+ (list "-f" (message-sendmail-envelope-from)))
+ ;; These mean "report errors by mail"
+ ;; and "deliver in background".
+ (if (null message-interactive) '("-oem" "-odb"))
+ ;; Get the addresses from the message
+ ;; unless this is a resend.
+ ;; We must not do that for a resend
+ ;; because we would find the original addresses.
+ ;; For a resend, include the specific addresses.
+ (if resend-to-addresses
+ (list resend-to-addresses)
+ '("-t")))))))
+ (unless (or (null cpr) (zerop cpr))
+ (error "Sending...failed with exit value %d" cpr)))
+ (when message-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (goto-char (point-min))
+ (while (re-search-forward "\n\n* *" nil t)
+ (replace-match "; "))
+ (if (not (zerop (buffer-size)))
+ (error "Sending...failed to %s"
+ (buffer-string))))))
(when (bufferp errbuf)
(kill-buffer errbuf)))))
;; free for -inject-arguments -- a big win for the user and for us
;; since we don't have to play that double-guessing game and the user
;; gets full control (no gestapo'ish -f's, for instance). --sj
- message-qmail-inject-args))
+ (if (functionp message-qmail-inject-args)
+ (funcall message-qmail-inject-args)
+ message-qmail-inject-args)))
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(0 nil)
(backward-char 1)
(run-hooks 'message-send-mail-hook)
(if recipients
- (static-if (fboundp 'smtp-send-buffer)
- (smtp-send-buffer user-mail-address recipients
- (current-buffer))
- (let ((result (smtp-via-smtp user-mail-address recipients
- (current-buffer))))
- (unless (eq result t)
- (error "Sending failed; %s" result))))
+ (smtp-send-buffer user-mail-address recipients (current-buffer))
(error "Sending failed; no recipients"))))
(defsubst message-maybe-split-and-send-news (method)
nil)
(not (funcall message-send-news-function method)))))
+(defun message-smtpmail-send-it ()
+ "Send the prepared message buffer with `smtpmail-send-it'.
+This only differs from `smtpmail-send-it' that this command evaluates
+`message-send-mail-hook' just before sending a message. It is useful
+if your ISP requires the POP-before-SMTP authentication. See the
+documentation for the function `mail-source-touch-pop'."
+ (run-hooks 'message-send-mail-hook)
+ (smtpmail-send-it))
+
(defun message-canlock-generate ()
"Return a string that is non-trival to guess.
Do not use this for anything important, it is cryptographically weak."
- (sha1 (concat (message-unique-id)
- (format "%x%x%x" (random) (random t) (random))
- (prin1-to-string (recent-keys))
- (prin1-to-string (garbage-collect)))))
+ (let (sha1-maximum-internal-length)
+ (sha1 (concat (message-unique-id)
+ (format "%x%x%x" (random) (random t) (random))
+ (prin1-to-string (recent-keys))
+ (prin1-to-string (garbage-collect))))))
(defun message-canlock-password ()
"The password used by message for cancel locks.
This is the value of `canlock-password', if that option is non-nil.
Otherwise, generate and save a value for `canlock-password' first."
(unless canlock-password
- (customize-save-variable 'canlock-password (message-canlock-generate)))
+ (customize-save-variable 'canlock-password (message-canlock-generate))
+ (setq canlock-password-for-verify canlock-password))
canlock-password)
(defun message-insert-canlock ()
(set-buffer tembuf)
(buffer-disable-undo)
(erase-buffer)
- (insert-buffer message-encoding-buffer)
+ (insert-buffer-substring message-encoding-buffer)
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
(backward-char 1)
(run-hooks 'message-send-news-hook)
(gnus-open-server method)
- (message "Sending news with %s..." (gnus-server-string method))
+ (message "Sending news via %s..." (gnus-server-string method))
(gnus-request-post method)
))
(y-or-n-p
"The control code \"cmsg\" is in the subject. Really post? ")
t))
+ ;; Check long header lines.
+ (message-check 'long-header-lines
+ (let ((start (point))
+ (header nil)
+ (length 0)
+ found)
+ (while (and (not found)
+ (re-search-forward "^\\([^ \t:]+\\): " nil t))
+ (if (> (- (point) (match-beginning 0)) 998)
+ (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? "
+ header length))
+ t)))
;; Check for multiple identical headers.
(message-check 'multiple-headers
(let (found)
;; Check "Shoot me".
(message-check 'shoot
(if (re-search-forward
- "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
+ "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t)
(y-or-n-p "You appear to have a misconfigured system. Really post? ")
t))
;; Check for Approved.
(gnus-groups-from-server method)))
errors)
(while groups
- (unless (or (equal (car groups) "poster")
- (member (car groups) known-groups))
+ (when (and (not (equal (car groups) "poster"))
+ (not (member (car groups) known-groups))
+ (not (member (car groups) errors)))
(push (car groups) errors))
(pop groups))
(cond
(if (= (length errors) 1) "this" "these")
(if (= (length errors) 1) "" "s")
(mapconcat 'identity errors ", ")))))))
+ ;; Check continuation headers.
+ (message-check 'continuation-headers
+ (goto-char (point-min))
+ (let ((do-posting t))
+ (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t)
+ (if (y-or-n-p "Fix continuation lines? ")
+ (progn
+ (goto-char (match-beginning 0))
+ (insert " "))
+ (unless (y-or-n-p "Send anyway? ")
+ (setq do-posting nil))))
+ do-posting))
;; Check the Newsgroups & Followup-To headers for syntax errors.
(message-check 'valid-newsgroups
(let ((case-fold-search t)
(erase-buffer)
(goto-char (point-min))
(set-buffer-multibyte nil)
- (insert-buffer message-encoding-buffer)
+ (insert-buffer-substring message-encoding-buffer)
(goto-char (point-min))
(if (re-search-forward "[^\x00-\x7f]" nil t)
(y-or-n-p
(message-goto-body)
(int-to-string (count-lines (point) (point-max))))))
+(defun message-make-references ()
+ "Return the References header for this message."
+ (when message-reply-headers
+ (let ((message-id (mail-header-message-id message-reply-headers))
+ (references (mail-header-references message-reply-headers))
+ new-references)
+ (if (or references message-id)
+ (concat (or references "") (and references " ")
+ (or message-id ""))
+ nil))))
+
(defun message-make-in-reply-to ()
"Return the In-Reply-To header for this message."
(when message-reply-headers
(let ((from (mail-header-from message-reply-headers))
(date (mail-header-date message-reply-headers))
(msg-id (mail-header-message-id message-reply-headers)))
- (when msg-id
- (concat msg-id
- (when from
- (let ((pair (std11-extract-address-components from)))
- (concat "\n ("
- (or (car pair) (cadr pair))
- "'s message of \""
- (if (or (not date) (string= date ""))
- "(unknown date)" date)
- "\")"))))))))
+ (when from
+ (let ((name (std11-extract-address-components from)))
+ (concat msg-id (if msg-id " (")
+ (or (car name)
+ (nth 1 name))
+ "'s message of \""
+ (if (or (not date) (string= date ""))
+ "(unknown date)" date)
+ "\"" (if msg-id ")")))))))
(defun message-make-distribution ()
"Make a Distribution header."
(defun message-user-mail-address ()
"Return the pertinent part of `user-mail-address'."
- (when user-mail-address
+ (when (and user-mail-address
+ (string-match "@.*\\." user-mail-address))
(if (string-match " " user-mail-address)
(nth 1 (std11-extract-address-components user-mail-address))
user-mail-address)))
+(defun message-sendmail-envelope-from ()
+ "Return the envelope from."
+ (cond ((eq message-sendmail-envelope-from 'header)
+ (nth 1 (mail-extract-address-components
+ (message-fetch-field "from"))))
+ ((stringp message-sendmail-envelope-from)
+ message-sendmail-envelope-from)
+ (t
+ (message-make-address))))
+
(defun message-make-fqdn ()
"Return user's fully qualified domain name."
- (let ((system-name (system-name))
- (user-mail (message-user-mail-address)))
+ (let* ((system-name (system-name))
+ (user-mail (message-user-mail-address))
+ (user-domain
+ (if (and user-mail
+ (string-match "@\\(.*\\)\\'" user-mail))
+ (match-string 1 user-mail))))
(cond
- ((and (string-match "[^.]\\.[^.]" system-name)
+ ((and message-user-fqdn
+ (stringp message-user-fqdn)
+ (string-match message-valid-fqdn-regexp message-user-fqdn)
+ (not (string-match message-bogus-system-names message-user-fqdn)))
+ message-user-fqdn)
+ ;; `message-user-fqdn' seems to be valid
+ ((and (string-match message-valid-fqdn-regexp system-name)
(not (string-match message-bogus-system-names system-name)))
;; `system-name' returned the right result.
system-name)
;; Try `mail-host-address'.
((and (boundp 'mail-host-address)
(stringp mail-host-address)
- (string-match "\\." mail-host-address))
+ (string-match message-valid-fqdn-regexp mail-host-address)
+ (not (string-match message-bogus-system-names mail-host-address)))
mail-host-address)
;; We try `user-mail-address' as a backup.
- ((and user-mail
- (string-match "\\." user-mail)
- (string-match "@\\(.*\\)\\'" user-mail))
- (match-string 1 user-mail))
+ ((and user-domain
+ (stringp user-domain)
+ (string-match message-valid-fqdn-regexp user-domain)
+ (not (string-match message-bogus-system-names user-domain)))
+ user-domain)
;; Default to this bogus thing.
(t
(concat system-name ".i-did-not-set--mail-host-address--so-tickle-me")))))
(or mail-host-address
(message-make-fqdn)))
-(defun message-make-mft ()
- "Return the Mail-Followup-To header."
- (let* ((msg-recipients (message-options-get 'message-recipients))
+(defun message-to-list-only ()
+ "Send a message to the list only.
+Remove all addresses but the list address from To and Cc headers."
+ (interactive)
+ (let ((listaddr (message-make-mail-followup-to t)))
+ (when listaddr
+ (save-excursion
+ (message-remove-header "to")
+ (message-remove-header "cc")
+ (message-position-on-field "To" "X-Draft-From")
+ (insert listaddr)))))
+
+(defun message-make-mail-followup-to (&optional only-show-subscribed)
+ "Return the Mail-Followup-To header.
+If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the
+subscribed address (and not the additional To and Cc header contents)."
+ (let* ((case-fold-search t)
+ (to (message-fetch-field "To"))
+ (cc (message-fetch-field "cc"))
+ (msg-recipients (concat to (and to cc ", ") cc))
(recipients
(mapcar 'mail-strip-quoted-names
(message-tokenize-header msg-recipients)))
(mapcar 'funcall
message-subscribed-address-functions))))
(save-match-data
- (when (eval (apply 'append '(or)
- (mapcar
- (function (lambda (regexp)
- (mapcar
- (function (lambda (recipient)
- `(string-match ,regexp
- ,recipient)))
- recipients)))
- mft-regexps)))
- msg-recipients))))
+ (let ((subscribed-lists nil)
+ (list
+ (loop for recipient in recipients
+ when (loop for regexp in mft-regexps
+ when (string-match regexp recipient) return t)
+ return recipient)))
+ (when list
+ (if only-show-subscribed
+ list
+ msg-recipients))))))
;; Dummy to avoid byte-compile warning.
(defvar mule-version)
(goto-char (point-min))
(let ((case-fold-search t)
user-agent start p end)
- (if (re-search-forward "^User-Agent:[\t ]*" nil t)
+ (if (re-search-forward
+ (concat "^User-Agent:[\t ]*\\("
+ (regexp-quote gnus-product-name)
+ "/[0-9.]+\\([ \t\r\n]*([^)]+)\\)*\\)?[\t ]*")
+ nil t)
(progn
(setq start (match-beginning 0)
p (match-end 0)
(concat message-user-agent " " user-agent))
message-user-agent)))))
+(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)))))))
+
+(defun message-idna-to-ascii-rhs ()
+ "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
+See `message-idna-encode'."
+ (interactive)
+ (when message-use-idna
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head)
+ (message-idna-to-ascii-rhs-1 "From")
+ (message-idna-to-ascii-rhs-1 "To")
+ (message-idna-to-ascii-rhs-1 "Cc")))))
+
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
+ (setq headers (append headers message-required-headers))
(save-restriction
(message-narrow-to-headers)
(let* ((Date (message-make-date))
(Subject nil)
(Newsgroups nil)
(In-Reply-To (message-make-in-reply-to))
+ (References (message-make-references))
(To nil)
(Distribution (message-make-distribution))
(Lines (message-make-lines))
(User-Agent (message-make-user-agent))
(Expires (message-make-expires))
(case-fold-search t)
+ (optionalp nil)
header value elem)
;; First we remove any old generated headers.
(let ((headers message-deletable-headers))
(setq elem (pop headers))
(if (consp elem)
(if (eq (car elem) 'optional)
- (setq header (cdr elem))
+ (setq header (cdr elem)
+ optionalp t)
(setq header (car elem)))
(setq header elem))
(when (or (not (re-search-forward
;; The header was found. We insert a space after the
;; colon, if there is none.
(if (/= (char-after) ? ) (insert " ") (forward-char 1))
- ;; Find out whether the header is empty...
+ ;; Find out whether the header is empty.
(looking-at "[ \t]*\n[^ \t]")))
;; So we find out what value we should insert.
(setq value
(cond
- ((and (consp elem) (eq (car elem) 'optional))
+ ((and (consp elem)
+ (eq (car elem) 'optional))
;; This is an optional header. If the cdr of this
;; is something that is nil, then we do not insert
;; this header.
(setq header (cdr elem))
- (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
- (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
+ (or (and (message-functionp (cdr elem))
+ (funcall (cdr elem)))
+ (and (boundp (cdr elem))
+ (symbol-value (cdr elem)))))
((consp elem)
;; The element is a cons. Either the cdr is a
;; string to be inserted verbatim, or it is a
;; function, and we insert the value returned from
;; this function.
- (or (and (stringp (cdr elem)) (cdr elem))
- (and (fboundp (cdr elem)) (funcall (cdr elem)))))
- ((and (boundp header) (symbol-value header))
+ (or (and (stringp (cdr elem))
+ (cdr elem))
+ (and (message-functionp (cdr elem))
+ (funcall (cdr elem)))))
+ ((and (boundp header)
+ (symbol-value header))
;; The element is a symbol. We insert the value
;; of this symbol, if any.
(symbol-value header))
(progn
;; This header didn't exist, so we insert it.
(goto-char (point-max))
- (insert (if (stringp header) header (symbol-name header))
- ": " value)
- ;; We check whether the value was ended by a
- ;; newline. If now, we insert one.
- (unless (bolp)
- (insert "\n"))
- (forward-line -1))
+ (let ((formatter
+ (cdr (assq header message-header-format-alist))))
+ (if formatter
+ (funcall formatter header value)
+ (insert (if (stringp header)
+ header (symbol-name header))
+ ": " value))
+ ;; We check whether the value was ended by a
+ ;; newline. If now, 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))
- (insert value)
- (when (bolp)
- (delete-char -1)))
+ ;; If the header is optional, and the header was
+ ;; empty, we can't insert it anyway.
+ (unless optionalp
+ (insert value)
+ (when (bolp)
+ (delete-char -1))))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
(beginning-of-line))
(when (or (message-news-p)
(string-match "@.+\\.." secure-sender))
- (insert "Sender: " secure-sender "\n")))))))
+ (insert "Sender: " secure-sender "\n"))))
+ ;; Check for IDNA
+ (message-idna-to-ascii-rhs))))
(defun message-insert-courtesy-copy ()
"Insert a courtesy message in mail copies of combined messages."
(if (consp value) (car value) value))
"\n"))
+(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.
+ (error
+ (split-line))))
+
+
(defun message-fill-header (header value)
(let ((begin (point))
(fill-column 78)
(forward-line 2)))
(sit-for 0)))
+(defcustom message-beginning-of-line t
+ "Whether C-a goes to beginning of header values."
+ :group 'message-buffers
+ :type 'boolean)
+
(defun message-beginning-of-line (&optional n)
"Move point to beginning of header value or to beginning of line."
(interactive "p")
- (if (message-point-in-header-p)
+ (let ((zrs 'zmacs-region-stays))
+ (when (and (interactive-p) (boundp zrs))
+ (set zrs t)))
+ (if (and message-beginning-of-line
+ (message-point-in-header-p))
(let* ((here (point))
(bol (progn (beginning-of-line n) (point)))
(eol (gnus-point-at-eol))
headers)
nil switch-function yank-action actions)))))
+(defun message-headers-to-generate (headers included-headers excluded-headers)
+ "Return a list that includes all headers from HEADERS.
+If INCLUDED-HEADERS is a list, just include those headers. If if is
+t, include all headers. In any case, headers from EXCLUDED-HEADERS
+are not included."
+ (let ((result nil)
+ header-name)
+ (dolist (header headers)
+ (setq header-name (cond
+ ((and (consp header)
+ (eq (car header) 'optional))
+ ;; On the form (optional . Header)
+ (cdr header))
+ ((consp header)
+ ;; On the form (Header . function)
+ (car header))
+ (t
+ ;; Just a Header.
+ header)))
+ (when (and (not (memq header-name excluded-headers))
+ (or (eq included-headers t)
+ (memq header-name included-headers)))
+ (push header result)))
+ (nreverse result)))
+
(defun message-setup-1 (headers &optional replybuffer actions)
(dolist (action actions)
(condition-case nil
(or (bolp) (insert ?\n)))
(when message-generate-headers-first
(message-generate-headers
- (delq 'Lines
- (delq 'Subject
- (copy-sequence message-required-news-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
(message-generate-headers
- (delq 'Lines
- (delq 'Subject
- (copy-sequence message-required-mail-headers))))))
+ (message-headers-to-generate
+ (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-narrow-to-headers)
- (if message-alternative-emails
+ (if (and replybuffer
+ message-alternative-emails)
(message-use-alternative-email-as-from))
(run-hooks 'message-header-setup-hook))
(set-buffer-modified-p nil)
(when message-auto-save-directory
(unless (file-directory-p
(directory-file-name message-auto-save-directory))
- (gnus-make-directory message-auto-save-directory))
+ (make-directory message-auto-save-directory t))
(if (gnus-alive-p)
(setq message-draft-article
(nndraft-request-associate-buffer "drafts"))
(setq buffer-file-name (expand-file-name
(if (memq system-type
'(ms-dos ms-windows windows-nt
- cygwin32 win32 w32
+ cygwin cygwin32 win32 w32
mswindows))
"message"
"*message*")
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
-(defun message-get-reply-headers (wide &optional to-address)
+(defun message-get-reply-headers (wide &optional to-address address-headers)
(let (follow-to mct never-mct to cc author mft recipients)
;; Find all relevant headers we need.
(let ((mrt (when message-use-mail-reply-to
(cond
((not wide)
(setq recipients (concat ", " author)))
+ (address-headers
+ (dolist (header address-headers)
+ (let ((value (message-fetch-field header)))
+ (when value
+ (setq recipients (concat recipients ", " value))))))
((and mft
(string-match "[^ \t,]" mft)
(or (not (eq message-use-mail-followup-to 'ask))
;; Perhaps "Mail-Copies-To: never" removed the only address?
(if (string-equal recipients "")
(setq recipients author))
- ;; Convert string to a list of (("foo@bar" . "Name <foo@bar>") ...).
+ ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...).
(setq recipients
(mapcar
(lambda (addr)
- (cons (mail-strip-quoted-names addr) addr))
+ (cons (downcase (mail-strip-quoted-names addr)) addr))
(message-tokenize-header recipients)))
;; Remove first duplicates. (Why not all duplicates? Is this a bug?)
(let ((s recipients))
(while s
(setq recipients (delq (assoc (car (pop s)) s) recipients))))
+
+ ;; Remove hierarchical lists that are contained within each other,
+ ;; if message-hierarchical-addresses is defined.
+ (when message-hierarchical-addresses
+ (let ((plain-addrs (mapcar 'car recipients))
+ subaddrs recip)
+ (while plain-addrs
+ (setq subaddrs (assoc (car plain-addrs)
+ message-hierarchical-addresses)
+ plain-addrs (cdr plain-addrs))
+ (when subaddrs
+ (setq subaddrs (cdr subaddrs))
+ (while subaddrs
+ (setq recip (assoc (car subaddrs) recipients)
+ subaddrs (cdr subaddrs))
+ (if recip
+ (setq recipients (delq recip recipients))))))))
+
;; Build the header alist. Allow the user to be asked whether
;; or not to reply to all recipients in a wide reply.
(setq follow-to (list (cons 'To (cdr (pop recipients)))))
(when gnus-list-identifiers
(setq subject (message-strip-list-identifiers subject)))
(setq subject (message-make-followup-subject subject))
+ (when message-subject-trailing-was-query
+ (setq subject (message-strip-subject-trailing-was subject)))
(when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
(string-match "<[^>]+>" gnus-warning))
(message-setup
`((Subject . ,subject)
- ,@follow-to
- ,@(if (or references message-id)
- `((References . ,(concat (or references "") (and references " ")
- (or message-id ""))))
- nil))
+ ,@follow-to)
cur)))
;;;###autoload
(if gnus-list-identifiers
(setq subject (message-strip-list-identifiers subject)))
(setq subject (message-make-followup-subject subject))
+ (when message-subject-trailing-was-query
+ (setq subject (message-strip-subject-trailing-was subject)))
(widen))
;; Handle special values of Mail-Copies-To.
(message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
+ (setq message-reply-headers
+ (make-full-mail-header-from-decoded-header
+ 0 subject from date message-id references 0 0 ""))
+
(message-setup
`((Subject . ,subject)
,@follow-to
,@(and mct (list (cons 'Cc mct)))
- ,@(and distribution (list (cons 'Distribution distribution)))
- ,@(if (or references message-id)
- `((References . ,(concat (or references "") (and references " ")
- (or message-id ""))))))
- cur)
-
- (setq message-reply-headers
- (make-full-mail-header-from-decoded-header
- 0 subject from date message-id references 0 0 ""))))
+ ,@(and distribution (list (cons 'Distribution distribution))))
+ cur)))
;;;###autoload
(defun message-cancel-news (&optional arg)
"(nowhere)"))
"] " subject))
+(defun message-forward-subject-name-subject (subject)
+ "Generate a SUBJECT for a forwarded message.
+The form is: [Source] Subject, where if the original message was mail,
+Source is the name of the sender, and if the original message was
+news, Source is the list of newsgroups is was posted to."
+ (concat "["
+ (let ((prefix (message-fetch-field "newsgroups")))
+ (or prefix
+ (and (setq prefix (message-fetch-field "from"))
+ (car (std11-extract-address-components
+ (nnheader-decode-from prefix))))
+ "(nowhere)"))
+ "] " subject))
+
(defun message-forward-subject-fwd (subject)
"Generate a SUBJECT for a forwarded message.
The form is: Fwd: Subject, where Subject is the original subject of
(defun message-forward-make-body (forward-buffer)
;; Put point where we want it before inserting the forwarded
;; message.
+ ;; Note that this function definition for T-gnus is totally different
+ ;; from the original Gnus."
(if message-forward-before-signature
(message-goto-body)
(goto-char (point-max)))
(defun message-forward-rmail-make-body (forward-buffer)
(save-window-excursion
(set-buffer forward-buffer)
- (let (rmail-enable-mime)
- (rmail-toggle-header 0)))
+ ;; 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))
;;;###autoload
;; We first set up a normal mail buffer.
(unless (message-mail-user-agent)
(set-buffer (get-buffer-create " *message resend*"))
- (erase-buffer)
- (let ((message-this-is-mail t)
- ;; avoid to turn-on-mime-edit
- message-setup-hook)
- (message-setup `((To . ,address)))))
+ (erase-buffer))
+ (let ((message-this-is-mail t)
+ message-setup-hook)
+ (message-setup `((To . ,address))))
;; Insert our usual headers.
(message-generate-headers '(From Date To))
(message-narrow-to-headers)
+ ;; Remove X-Draft-From header etc.
+ (message-remove-header message-ignored-mail-headers t)
;; Rename them all to "Resent-*".
+ (goto-char (point-min))
(while (re-search-forward "^[A-Za-z]" nil t)
(forward-char -1)
(insert "Resent-"))
(delete-char -2))))))
(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+(defalias 'message-make-overlay 'make-overlay)
+(defalias 'message-delete-overlay 'delete-overlay)
+(defalias 'message-overlay-put 'overlay-put)
;; Support for toolbar
(eval-when-compile
(defvar tool-bar-map)
(defvar tool-bar-mode))
+(defun message-tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props)
+ ;; We need to make tool bar entries in local keymaps with
+ ;; `tool-bar-local-item-from-menu' in Emacs > 21.3
+ (if (fboundp 'tool-bar-local-item-from-menu)
+ ;; This is for Emacs 21.3
+ (tool-bar-local-item-from-menu command icon in-map from-map props)
+ (tool-bar-add-item-from-menu command icon from-map props)))
+
(defun message-tool-bar-map ()
(or message-tool-bar-map
(setq message-tool-bar-map
- (and (fboundp 'tool-bar-add-item-from-menu)
- tool-bar-mode
- (let ((tool-bar-map (copy-keymap tool-bar-map))
- (load-path (mm-image-load-path)))
- ;; Zap some items which aren't so relevant and take
- ;; up space.
- (dolist (key '(print-buffer kill-buffer save-buffer
- write-file dired open-file))
- (define-key tool-bar-map (vector key) nil))
- (tool-bar-add-item-from-menu
- 'message-send-and-exit "mail_send" message-mode-map)
- (tool-bar-add-item-from-menu
- 'message-kill-buffer "close" message-mode-map)
- (tool-bar-add-item-from-menu
- 'message-dont-send "cancel" message-mode-map)
- (tool-bar-add-item-from-menu
- 'mime-edit-insert-file "attach" message-mode-map)
- (tool-bar-add-item-from-menu
- 'ispell-message "spell" message-mode-map)
- (tool-bar-add-item-from-menu
- 'message-insert-importance-high "important"
- message-mode-map)
- (tool-bar-add-item-from-menu
- 'message-insert-importance-low "unimportant"
- message-mode-map)
- (tool-bar-add-item-from-menu
- 'message-insert-disposition-notification-to "receipt"
- message-mode-map)
- tool-bar-map)))))
+ (and
+ (condition-case nil (require 'tool-bar) (error nil))
+ (fboundp 'tool-bar-add-item-from-menu)
+ tool-bar-mode
+ (let ((tool-bar-map (copy-keymap tool-bar-map))
+ (load-path (mm-image-load-path)))
+ ;; Zap some items which aren't so relevant and take
+ ;; up space.
+ (dolist (key '(print-buffer kill-buffer save-buffer
+ write-file dired open-file))
+ (define-key tool-bar-map (vector key) nil))
+ (message-tool-bar-local-item-from-menu
+ 'message-send-and-exit "mail_send" tool-bar-map message-mode-map)
+ (message-tool-bar-local-item-from-menu
+ 'message-kill-buffer "close" tool-bar-map message-mode-map)
+ (message-tool-bar-local-item-from-menu
+ 'message-dont-send "cancel" tool-bar-map message-mode-map)
+;; (message-tool-bar-local-item-from-menu
+;; 'mime-edit-insert-file "attach"
+;; tool-bar-map mime-edit-mode-map)
+ (message-tool-bar-local-item-from-menu
+ 'ispell-message "spell" tool-bar-map message-mode-map)
+;; (message-tool-bar-local-item-from-menu
+;; 'mime-edit-preview-message "preview"
+;; tool-bar-map mime-edit-mode-map)
+ (message-tool-bar-local-item-from-menu
+ 'message-insert-importance-high "important"
+ tool-bar-map message-mode-map)
+ (message-tool-bar-local-item-from-menu
+ 'message-insert-importance-low "unimportant"
+ tool-bar-map message-mode-map)
+ (message-tool-bar-local-item-from-menu
+ 'message-insert-disposition-notification-to "receipt"
+ tool-bar-map message-mode-map)
+ tool-bar-map)))))
;;; Group name completion.
(defcustom message-completion-alist
(list (cons message-newgroups-header-regexp 'message-expand-group)
- '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name))
+ '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name)
+ '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
+ . message-expand-name)
+ '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):"
+ . message-expand-name))
"Alist of (RE . FUN). Use FUN for completion on header lines matching RE."
:group 'message
:type '(alist :key-type regexp :value-type function))
+(defcustom message-expand-name-function
+ (if (fboundp 'bbdb-complete-name)
+ 'bbdb-complete-name
+ (if (fboundp 'lsdb-complete-name)
+ 'lsdb-complete-name
+ 'expand-abbrev))
+ "*A function called to expand addresses in field body."
+ :group 'message
+ :type 'function)
+
(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."
(delete-region (point) (progn (forward-line 3) (point))))))))))
(defun message-expand-name ()
- (if (fboundp 'bbdb-complete-name)
- (bbdb-complete-name)
- (expand-abbrev)))
+ (funcall message-expand-name-function))
;;; Help stuff.
(if (and (or to cc) bcc) ", ")
(or bcc "")))))))
+(defun message-hide-headers ()
+ "Hide headers based on the `message-hidden-headers' variable."
+ (let ((regexps (if (stringp message-hidden-headers)
+ (list message-hidden-headers)
+ message-hidden-headers))
+ (inhibit-point-motion-hooks t)
+ (after-change-functions nil))
+ (when regexps
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (not (message-hide-header-p regexps))
+ (message-next-header)
+ (let ((begin (point)))
+ (message-next-header)
+ (add-text-properties begin (point)
+ '(intangible t invisible t
+ message-hidden t))))))))))
+
+(defun message-hide-header-p (regexps)
+ (let ((result nil)
+ (reverse nil))
+ (when (eq (car regexps) 'not)
+ (setq reverse t)
+ (pop regexps))
+ (dolist (regexp regexps)
+ (setq result (or result (looking-at regexp))))
+ (if reverse
+ (not result)
+ result)))
+
(when (featurep 'xemacs)
(require 'messagexmas)
(message-xmas-redefine))
-(defun message-save-drafts ()
- "Postponing the message."
- (interactive)
- (message "Saving %s..." buffer-file-name)
- (let ((reply-headers message-reply-headers)
- (buffer (current-buffer)))
- (with-temp-file buffer-file-name
- (insert-buffer buffer)
- (setq message-reply-headers reply-headers)
- (message-generate-headers '((optional . In-Reply-To)))
- (mime-edit-translate-buffer))
- (set-buffer-modified-p nil))
- (message "Saving %s...done" buffer-file-name))
-
(provide 'message)
(run-hooks 'message-load-hook)
projects / elisp / gnus.git- / blobdiff