-;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
+;;; message.el --- composing mail and news messages -*- coding: iso-latin-1 -*-
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
;;; Code:
-(eval-when-compile (require 'cl))
-
+(eval-when-compile
+ (require 'cl)
+ (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
(require 'mailheader)
(require 'nnheader)
-(require 'timezone)
-(require 'easymenu)
-(require 'custom)
-(if (string-match "XEmacs\\|Lucid" emacs-version)
- (require 'mail-abbrevs)
- (require 'mailabbrev))
+;; This is apparently necessary even though things are autoloaded:
+(if (featurep 'xemacs)
+ (require 'mail-abbrevs))
+(require 'mail-parse)
+(require 'mml)
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
(defcustom message-send-rename-function nil
"Function called to rename the buffer after sending it."
:group 'message-buffers
- :type 'function)
+ :type '(choice function (const nil)))
(defcustom message-fcc-handler-function 'message-output
"*A function called to save outgoing articles.
(defcustom message-from-style 'default
"*Specifies how \"From\" headers look.
-If `nil', they contain just the return address like:
+If nil, they contain just the return address like:
king@grassland.com
If `parens', they look like:
king@grassland.com (Elvis Parsley)
:group 'message-headers)
(defcustom message-syntax-checks nil
- ; Guess this one shouldn't be easy to customize...
+ ;; 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
`(signature . disabled)' to this list.
Don't touch this variable unless you really know what you're doing.
-Checks include subject-cmsg multiple-headers sendsys message-id from
-long-lines control-chars size new-text redirected-followup signature
-approved sender empty empty-headers message-id from subject
-shorten-followup-to existing-newsgroups buffer-file-name unchanged."
- :group 'message-news)
+Checks include `subject-cmsg', `multiple-headers', `sendsys',
+`message-id', `from', `long-lines', `control-chars', `size',
+`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'."
+ :group 'message-news
+ :type '(repeat sexp)) ; Fixme: improve this
(defcustom message-required-news-headers
'(From Newsgroups Subject Date Message-ID
(optional . Organization) Lines
- (optional . X-Newsreader))
+ (optional . User-Agent))
"*Headers to be generated or prompted for when posting an article.
RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
Message-ID. Organization, Lines, In-Reply-To, Expires, and
-X-Newsreader are optional. If don't you want message to insert some
+User-Agent are optional. If don't you want message to insert some
header, remove it from this list."
:group 'message-news
:group 'message-headers
(defcustom message-required-mail-headers
'(From Subject Date (optional . In-Reply-To) Message-ID Lines
- (optional . X-Mailer))
+ (optional . User-Agent))
"*Headers to be generated or prompted for when mailing a message.
RFC822 required that From, Date, To, Subject and Message-ID be
-included. Organization, Lines and X-Mailer are optional."
+included. Organization, Lines and User-Agent are optional."
:group 'message-mail
:group 'message-headers
:type '(repeat sexp))
:type 'sexp)
(defcustom message-ignored-news-headers
- "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:"
+ "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:"
"*Regexp of headers to be removed unconditionally before posting."
:group 'message-news
:group 'message-headers
:type 'regexp)
-(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:"
+(defcustom message-ignored-mail-headers
+ "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:"
"*Regexp of headers to be removed unconditionally before mailing."
:group 'message-mail
: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:\\|^X-Trace:\\|^X-Complaints-To:"
+(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:"
"*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."
:type 'regexp
:group 'message-various)
-(defcustom message-elide-elipsis "\n[...]\n\n"
+(defcustom message-elide-ellipsis "\n[...]\n\n"
"*The string which is inserted for elided text."
:type 'string
:group 'message-various)
:group 'message-mail
:type 'boolean)
-(defcustom message-generate-new-buffers t
- "*Non-nil means that a new message buffer will be created whenever `message-setup' is called.
+(defcustom message-generate-new-buffers 'unique
+ "*Non-nil means create a new message buffer whenever `message-setup' is called.
If this is a function, call that function with three parameters: The type,
the to address and the group name. (Any of these may be nil.) The function
should return the new buffer name."
:group 'message-buffers
:type '(choice (const :tag "off" nil)
- (const :tag "on" t)
+ (const :tag "unique" unique)
+ (const :tag "unsent" unsent)
(function fun)))
(defcustom message-kill-buffer-on-exit nil
:group 'message-buffers
:type 'boolean)
-(defvar gnus-local-organization)
+(eval-when-compile
+ (defvar gnus-local-organization))
(defcustom message-user-organization
(or (and (boundp 'gnus-local-organization)
(stringp gnus-local-organization)
:type 'file
:group 'message-headers)
-(defcustom message-forward-start-separator
- "------- Start of forwarded message -------\n"
- "*Delimiter inserted before forwarded messages."
- :group 'message-forwarding
- :type 'string)
-
-(defcustom message-forward-end-separator
- "------- End of forwarded message -------\n"
- "*Delimiter inserted after forwarded messages."
- :group 'message-forwarding
- :type 'string)
-
-(defcustom message-signature-before-forwarded-message t
- "*If non-nil, put the signature before any included forwarded message."
- :group 'message-forwarding
- :type 'boolean)
-
-(defcustom message-included-forward-headers
- "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:"
- "*Regexp matching headers to be included in forwarded messages."
- :group 'message-forwarding
- :type 'regexp)
-
-(defcustom message-make-forward-subject-function
+(defcustom message-make-forward-subject-function
'message-forward-subject-author-subject
- "*A list of functions that are called to generate a subject header for forwarded messages.
+ "*List of functions called to generate subject headers for forwarded messages.
The subject generated by the previous function is passed into each
successive function.
The provided functions are:
-* message-forward-subject-author-subject (Source of article (author or
+* `message-forward-subject-author-subject' (Source of article (author or
newsgroup)), in brackets followed by the subject
-* message-forward-subject-fwd (Subject of article with 'Fwd:' prepended
+* `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended
to it."
- :group 'message-forwarding
- :type '(radio (function-item message-forward-subject-author-subject)
- (function-item message-forward-subject-fwd)))
+ :group 'message-forwarding
+ :type '(radio (function-item message-forward-subject-author-subject)
+ (function-item message-forward-subject-fwd)
+ (repeat :tag "List of functions" function)))
+
+(defcustom message-forward-as-mime t
+ "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message."
+ :version "21.1"
+ :group 'message-forwarding
+ :type 'boolean)
+
+(defcustom message-forward-show-mml t
+ "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged."
+ :version "21.1"
+ :group 'message-forwarding
+ :type 'boolean)
+
+(defcustom message-forward-before-signature t
+ "*If non-nil, put forwarded message before signature, else after."
+ :group 'message-forwarding
+ :type 'boolean)
(defcustom message-wash-forwarded-subjects nil
"*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward."
:group 'message-forwarding
:type 'boolean)
-(defcustom message-ignored-resent-headers "^Return-receipt"
+(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"
"*All headers that match this regexp will be deleted when resending a message."
:group 'message-interface
:type 'regexp)
+(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
+ "*All headers that match this regexp will be deleted when forwarding a message."
+ :version "21.1"
+ :group 'message-forwarding
+ :type '(choice (const :tag "None" nil)
+ regexp))
+
(defcustom message-ignored-cited-headers "."
"*Delete these headers from the messages you yank."
:group 'message-insertion
:type 'regexp)
-(defcustom message-cancel-message "I am canceling my own article."
+(defcustom message-cite-prefix-regexp
+ (if (string-match "[[:digit:]]" "1") ;; support POSIX?
+ "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>»|:}+]\\)+"
+ ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
+ "\\([ \t]*\\(\\w\\|[-_.]\\)+>+\\|[ \t]*[]>»|:}+]\\)+")
+ "*Regexp matching the longest possible citation prefix on a line."
+ :group 'message-insertion
+ :type 'regexp)
+
+(defcustom message-cancel-message "I am canceling my own article.\n"
"Message to be inserted in the cancel message."
:group 'message-interface
:type 'string)
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'.
-Legal values include `message-send-mail-with-sendmail' (the default),
-`message-send-mail-with-mh', `message-send-mail-with-qmail' and
-`smtpmail-send-it'."
+Valid values include `message-send-mail-with-sendmail' (the default),
+`message-send-mail-with-mh', `message-send-mail-with-qmail',
+`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 smtpmail-send-it)
+ (function-item feedmail-send-it)
(function :tag "Other"))
:group 'message-sending
:group 'message-mail)
:type 'function)
(defcustom message-reply-to-function nil
- "Function that should return a list of headers.
+ "If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
- :type 'function)
+ :type '(choice function (const nil)))
(defcustom message-wide-reply-to-function nil
- "Function that should return a list of headers.
+ "If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
- :type 'function)
+ :type '(choice function (const nil)))
(defcustom message-followup-to-function nil
- "Function that should return a list of headers.
+ "If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
- :type 'function)
+ :type '(choice function (const nil)))
(defcustom message-use-followup-to 'ask
"*Specifies what to do with Followup-To header.
(const use)
(const ask)))
-;; stuff relating to broken sendmail in MMDF
(defcustom message-sendmail-f-is-evil nil
- "*Non-nil means that \"-f username\" should not be added to the sendmail
-command line, because it is even more evil than leaving it out."
+ "*Non-nil means don't add \"-f username\" to the sendmail command line.
+Doing so would be even more evil than leaving it out."
:group 'message-sending
:type 'boolean)
:group 'message-sending
:type '(repeat string))
-(defvar gnus-post-method)
-(defvar gnus-select-method)
+(defvar message-cater-to-broken-inn t
+ "Non-nil means Gnus should not fold the `References' header.
+Folding `References' makes ancient versions of INN create incorrect
+NOV lines.")
+
+(eval-when-compile
+ (defvar gnus-post-method)
+ (defvar gnus-select-method))
(defcustom message-post-method
(cond ((and (boundp 'gnus-post-method)
(listp gnus-post-method)
:type 'sexp)
(defcustom message-generate-headers-first nil
- "*If non-nil, generate all possible headers before composing."
+ "*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.
+
+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)
:group 'message-various
:type 'hook)
+(defcustom message-cancel-hook nil
+ "Hook run when cancelling articles."
+ :group 'message-various
+ :type 'hook)
+
(defcustom message-signature-setup-hook nil
"Normal hook, run each time a new outgoing message is initialized.
It is run after the headers have been inserted and before
:group 'message-various
:type 'hook)
+(defcustom message-minibuffer-local-map
+ (let ((map (make-sparse-keymap 'message-minibuffer-local-map)))
+ (set-keymap-parent map minibuffer-local-map)
+ map)
+ "Keymap for `message-read-from-minibuffer'.")
+
;;;###autoload
(defcustom message-citation-line-function 'message-insert-citation-line
"*Function called to insert the \"Whomever writes:\" line."
;;;###autoload
(defcustom message-yank-prefix "> "
"*Prefix inserted on the lines of yanked messages.
-nil means use indentation."
+Fix `message-cite-prefix-regexp' if it is set to an abnormal value."
:type 'string
:group 'message-insertion)
`message-cite-original-without-signature'.
Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil."
:type '(radio (function-item message-cite-original)
+ (function-item message-cite-original-without-signature)
(function-item sc-cite-original)
(function :tag "Other"))
:group 'message-insertion)
;;;###autoload
(defcustom message-signature-file "~/.signature"
- "*File containing the text inserted at end of message buffer."
- :type 'file
+ "*Name of file containing the text inserted at end of message buffer.
+Ignored if the named file doesn't exist.
+If nil, don't insert a signature."
+ :type '(choice file (const :tags "None" nil))
:group 'message-insertion)
(defcustom message-distribution-function nil
"*Function called to return a Distribution header."
:group 'message-news
:group 'message-headers
- :type 'function)
+ :type '(choice function (const nil)))
(defcustom message-expires 14
"Number of days before your article expires."
(define-widget 'message-header-lines 'text
"All header lines must be LFD terminated."
- :format "%t:%n%v"
+ :format "%{%t%}:%n%v"
:valid-regexp "^\\'"
:error "All header lines must be newline terminated")
:type 'message-header-lines)
(defcustom message-default-news-headers ""
- "*A string of header lines to be inserted in outgoing news
-articles."
+ "*A string of header lines to be inserted in outgoing news articles."
:group 'message-headers
:group 'message-news
:type 'message-header-lines)
:group 'message-sending
:type 'sexp)
-;; Ignore errors in case this is used in Emacs 19.
-;; Don't use ignore-errors because this is copied into loaddefs.el.
;;;###autoload
-(condition-case nil
- (define-mail-user-agent 'message-user-agent
- 'message-mail 'message-send-and-exit
- 'message-kill-buffer 'message-send-hook)
- (error nil))
+(define-mail-user-agent 'message-user-agent
+ 'message-mail 'message-send-and-exit
+ 'message-kill-buffer 'message-send-hook)
(defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
"If non-nil, delete the deletable headers before feeding to mh.")
PREDICATE returns non-nil. FUNCTION is called with one parameter --
the prefix.")
-(defvar message-mail-alias-type 'abbrev
+(defcustom message-mail-alias-type 'abbrev
"*What alias expansion type to use in Message buffers.
The default is `abbrev', which uses mailabbrev. nil switches
-mail aliases off.")
+mail aliases off."
+ :group 'message
+ :link '(custom-manual "(message)Mail Aliases")
+ :type '(choice (const :tag "Use Mailabbrev" abbrev)
+ (const :tag "No expansion" nil)))
+
+(defcustom message-auto-save-directory
+ (file-name-as-directory (nnheader-concat message-directory "drafts"))
+ "*Directory where Message auto-saves buffers if Gnus isn't running.
+If nil, Message won't auto-save."
+ :group 'message-buffers
+ :type '(choice directory (const :tag "Don't auto-save" nil)))
-(defcustom message-autosave-directory
- (nnheader-concat message-directory "drafts/")
- "*Directory where Message autosaves buffers if Gnus isn't running.
-If nil, Message won't autosave."
+(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 'directory)
+ :type '(choice (const :tag "unique" unique)
+ (const :tag "unsent" unsent)))
+
+(defcustom message-default-charset
+ (and (not (mm-multibyte-p)) 'iso-8859-1)
+ "Default charset used in non-MULE Emacsen.
+If nil, you might be asked to input the charset."
+ :version "21.1"
+ :group 'message
+ :type 'symbol)
+
+(defcustom message-dont-reply-to-names
+ (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
+ "*A regexp specifying names to prune when doing wide replies.
+A value of nil means exclude your own name only."
+ :version "21.1"
+ :group 'message
+ :type '(choice (const :tag "Yourself" nil)
+ regexp))
+
+(defvar message-shoot-gnksa-feet nil
+ "*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
+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.
+
+(defsubst message-gnksa-enable-p (feature)
+ (or (not (listp message-shoot-gnksa-feet))
+ (memq feature message-shoot-gnksa-feet)))
;;; Internal variables.
;;; Well, not really internal.
(defvar message-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?% ". " table)
+ (modify-syntax-entry ?> ". " table)
+ (modify-syntax-entry ?< ". " table)
table)
"Syntax table used while in Message mode.")
(defvar message-mode-abbrev-table text-mode-abbrev-table
"Abbrev table used in Message mode buffers.
Defaults to `text-mode-abbrev-table'.")
-(defgroup message-headers nil
- "Message headers."
- :link '(custom-manual "(message)Variables")
- :group 'message)
(defface message-header-to-face
'((((class color)
"Face used for displaying cited text names."
:group 'message-faces)
+(defface message-mml-face
+ '((((class color)
+ (background dark))
+ (:foreground "ForestGreen"))
+ (((class color)
+ (background light))
+ (:foreground "ForestGreen"))
+ (t
+ (:bold t)))
+ "Face used for displaying MML."
+ :group 'message-faces)
+
(defvar message-font-lock-keywords
- (let* ((cite-prefix "A-Za-z")
- (cite-suffix (concat cite-prefix "0-9_.@-"))
- (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)"))
+ (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
`((,(concat "^\\([Tt]o:\\)" content)
(1 'message-header-name-face)
(2 'message-header-to-face nil t))
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1 'message-separator-face))
nil)
- (,(concat "^[ \t]*"
- "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
- "[:>|}].*")
- (0 'message-cited-text-face))))
+ (,(concat "^\\(" message-cite-prefix-regexp "\\).*")
+ (0 'message-cited-text-face))
+ ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>"
+ (0 'message-mml-face))))
"Additional expressions to highlight in Message mode.")
;; XEmacs does it like this. For Emacs, we have to set the
(defvar message-send-coding-system 'binary
"Coding system to encode outgoing mail.")
+(defvar message-draft-coding-system
+ mm-auto-save-coding-system
+ "Coding system to compose mail.")
+
+(defcustom message-send-mail-partially-limit 1000000
+ "The limitation of messages sent as message/partial.
+The lower bound of message size in characters, beyond which the message
+should be sent in several parts. If it is nil, the size is unlimited."
+ :version "21.1"
+ :group 'message-buffers
+ :type '(choice (const :tag "unlimited" nil)
+ (integer 1000000)))
+
+(defcustom message-alternative-emails nil
+ "A regexp to match the alternative email addresses.
+The first matched address (not primary one) is used in the From field."
+ :group 'message-headers
+ :type '(choice (const :tag "Always use primary" nil)
+ regexp))
+
+(defcustom message-mail-user-agent nil
+ "Like `mail-user-agent'.
+Except if it is nil, use Gnus native MUA; if it is t, use
+`mail-user-agent'."
+ :type '(radio (const :tag "Gnus native"
+ :format "%t\n"
+ nil)
+ (const :tag "`mail-user-agent'"
+ :format "%t\n"
+ t)
+ (function-item :tag "Default Emacs mail"
+ :format "%t\n"
+ sendmail-user-agent)
+ (function-item :tag "Emacs interface to MH"
+ :format "%t\n"
+ mh-e-user-agent)
+ (function :tag "Other"))
+ :version "21.1"
+ :group 'message)
+
;;; Internal variables.
+(defvar message-sending-message "Sending...")
(defvar message-buffer-list nil)
(defvar message-this-is-news nil)
(defvar message-this-is-mail nil)
(defvar message-draft-article nil)
+(defvar message-mime-part nil)
+(defvar message-posting-charset nil)
;; Byte-compiler warning
-(defvar gnus-active-hashtb)
-(defvar gnus-read-active-file)
+(eval-when-compile
+ (defvar gnus-active-hashtb)
+ (defvar gnus-read-active-file))
;;; Regexp matching the delimiter of messages in UNIX mail format
;;; (UNIX From lines), minus the initial ^. It should be a copy
"\\([^\0-\b\n-\r\^?].*\\)? "
;; The time the message was sent.
- "\\([^\0-\r \^?]+\\) +" ; day of the week
- "\\([^\0-\r \^?]+\\) +" ; month
- "\\([0-3]?[0-9]\\) +" ; day of month
- "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
+ "\\([^\0-\r \^?]+\\) +" ; day of the week
+ "\\([^\0-\r \^?]+\\) +" ; month
+ "\\([0-3]?[0-9]\\) +" ; day of month
+ "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
;; Perhaps a time zone, specified by an abbreviation, or by a
;; numeric offset.
"^ *---+ +Original message +---+ *$\\|"
"^ *--+ +begin message +--+ *$\\|"
"^ *---+ +Original message follows +---+ *$\\|"
+ "^ *---+ +Undelivered message follows +---+ *$\\|"
"^|? *---+ +Message text follows: +---+ *|?$")
"A regexp that matches the separator before the text of a failed message.")
(Expires)
(Message-ID)
(References . message-shorten-references)
- (X-Mailer)
- (X-Newsreader))
+ (User-Agent))
"Alist used for formatting headers.")
+(defvar message-options nil
+ "Some saved answers when sending message.")
+
(eval-and-compile
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
(autoload 'mh-send-letter "mh-comp")
(autoload 'gnus-point-at-eol "gnus-util")
(autoload 'gnus-point-at-bol "gnus-util")
- (autoload 'gnus-output-to-mail "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-request-post "gnus-int")
(autoload 'gnus-alive-p "gnus-util")
- (autoload 'rmail-output "rmail"))
+ (autoload 'gnus-server-string "gnus")
+ (autoload 'gnus-group-name-charset "gnus-group")
+ (autoload 'rmail-output "rmailout"))
\f
;;;
(defmacro message-y-or-n-p (question show &rest text)
- "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW"
+ "Ask QUESTION, displaying remaining args in a temporary buffer if SHOW."
`(message-talkative-question 'y-or-n-p ,question ,show ,@text))
-;; Delete the current line (and the next N lines.);
(defmacro message-delete-line (&optional n)
+ "Delete the current line (and the next N lines)."
`(delete-region (progn (beginning-of-line) (point))
(progn (forward-line ,(or n 1)) (point))))
+(defun message-unquote-tokens (elems)
+ "Remove double quotes (\") from strings in list ELEMS."
+ (mapcar (lambda (item)
+ (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)
+ (setq item (concat (match-string 1 item)
+ (match-string 2 item))))
+ item)
+ elems))
+
(defun message-tokenize-header (header &optional separator)
"Split HEADER into a list of header elements.
-\",\" is used as the separator."
+SEPARATOR is a string of characters to be used as separators. \",\"
+is used by default."
(if (not header)
nil
(let ((regexp (format "[%s]+" (or separator ",")))
(not paren))))
(push (buffer-substring beg (point)) elems)
(setq beg (match-end 0)))
- ((= (following-char) ?\")
+ ((eq (char-after) ?\")
(setq quoted (not quoted)))
- ((and (= (following-char) ?\()
+ ((and (eq (char-after) ?\()
(not quoted))
(setq paren t))
- ((and (= (following-char) ?\))
+ ((and (eq (char-after) ?\))
(not quoted))
(setq paren nil))))
- (nreverse elems)))))
+ (nreverse elems)))))
(defun message-mail-file-mbox-p (file)
"Say whether FILE looks like a Unix mbox file."
(when (and (file-exists-p file)
(file-readable-p file)
(file-regular-p file))
- (nnheader-temp-write nil
+ (with-temp-buffer
(nnheader-insert-file-contents file)
(goto-char (point-min))
(looking-at message-unix-mail-delimiter))))
(defun message-fetch-field (header &optional not-all)
"The same as `mail-fetch-field', only remove all newlines."
(let* ((inhibit-point-motion-hooks t)
+ (case-fold-search t)
(value (mail-fetch-field header nil (not not-all))))
(when value
- (nnheader-replace-chars-in-string value ?\n ? ))))
+ (while (string-match "\n[\t ]+" value)
+ (setq value (replace-match " " t t value)))
+ (set-text-properties 0 (length value) nil value)
+ value)))
+
+(defun message-narrow-to-field ()
+ "Narrow the buffer to the header on the current line."
+ (beginning-of-line)
+ (narrow-to-region
+ (point)
+ (progn
+ (forward-line 1)
+ (if (re-search-forward "^[^ \n\t]" nil t)
+ (progn
+ (beginning-of-line)
+ (point))
+ (point-max))))
+ (goto-char (point-min)))
(defun message-add-header (&rest headers)
"Add the HEADERS to the message header, skipping those already present."
(unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers))
(error "Invalid header `%s'" (car headers)))
(setq hclean (match-string 1 (car headers)))
- (save-restriction
- (message-narrow-to-headers)
- (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
- (insert (car headers) ?\n))))
+ (save-restriction
+ (message-narrow-to-headers)
+ (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
+ (goto-char (point-max))
+ (if (string-match "\n$" (car headers))
+ (insert (car headers))
+ (insert (car headers) ?\n)))))
(setq headers (cdr headers))))
+
(defun message-fetch-reply-field (header)
- "Fetch FIELD from the message we're replying to."
+ "Fetch field HEADER from the message we're replying to."
(when (and message-reply-buffer
(buffer-name message-reply-buffer))
(save-excursion
(erase-buffer))
(set-buffer (get-buffer-create " *message work*"))
(kill-all-local-variables)
- (buffer-disable-undo (current-buffer))))
+ (mm-enable-multibyte)))
(defun message-functionp (form)
"Return non-nil if FORM is funcallable."
(and (listp form) (eq (car form) 'lambda))
(byte-code-function-p form)))
+(defun message-strip-list-identifiers (subject)
+ "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT."
+ (require 'gnus-sum) ; for gnus-list-identifiers
+ (let ((regexp (if (stringp gnus-list-identifiers)
+ gnus-list-identifiers
+ (mapconcat 'identity gnus-list-identifiers " *\\|"))))
+ (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
+ " *\\)\\)+\\(Re: +\\)?\\)") subject)
+ (concat (substring subject 0 (match-beginning 1))
+ (or (match-string 3 subject)
+ (match-string 5 subject))
+ (substring subject
+ (match-end 1)))
+ subject)))
+
(defun message-strip-subject-re (subject)
- "Remove \"Re:\" from subject lines."
+ "Remove \"Re:\" from subject lines in string SUBJECT."
(if (string-match message-subject-re-regexp subject)
(substring subject (match-end 0))
subject))
(defun message-remove-header (header &optional is-regexp first reverse)
"Remove HEADER in the narrowed buffer.
-If REGEXP, HEADER is a regular expression.
+If IS-REGEXP, HEADER is a regular expression.
If FIRST, only remove the first instance of the header.
Return the number of headers removed."
(goto-char (point-min))
(forward-line 1)
(if (re-search-forward "^[^ \t]" nil t)
(goto-char (match-beginning 0))
- (point-max))))
+ (goto-char (point-max)))))
number))
+(defun message-remove-first-header (header)
+ "Remove the first instance of HEADER if there is more than one."
+ (let ((count 0)
+ (regexp (concat "^" (regexp-quote header) ":")))
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (incf count)))
+ (while (> count 1)
+ (message-remove-header header nil t)
+ (decf count))))
+
(defun message-narrow-to-headers ()
"Narrow the buffer to the head of the message."
(widen)
(point-max)))
(goto-char (point-min)))
-(defun message-narrow-to-head ()
- "Narrow the buffer to the head of the message."
- (widen)
+(defun message-narrow-to-head-1 ()
+ "Like `message-narrow-to-head'. Don't widen."
(narrow-to-region
(goto-char (point-min))
(if (search-forward "\n\n" nil 1)
(point-max)))
(goto-char (point-min)))
+(defun message-narrow-to-head ()
+ "Narrow the buffer to the head of the message.
+Point is left at the beginning of the narrowed-to region."
+ (widen)
+ (message-narrow-to-head-1))
+
+(defun message-narrow-to-headers-or-head ()
+ "Narrow the buffer to the head of the message."
+ (widen)
+ (narrow-to-region
+ (goto-char (point-min))
+ (cond
+ ((re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+ (match-beginning 0))
+ ((search-forward "\n\n" nil t)
+ (1- (point)))
+ (t
+ (point-max))))
+ (goto-char (point-min)))
+
(defun message-news-p ()
"Say whether the current buffer contains a news message."
(and (not message-this-is-mail)
(defun message-sort-headers-1 ()
"Sort the buffer as headers using `message-rank' text props."
(goto-char (point-min))
+ (require 'sort)
(sort-subr
nil 'message-next-header
(lambda ()
(defvar message-mode-map nil)
(unless message-mode-map
- (setq message-mode-map (copy-keymap text-mode-map))
+ (setq message-mode-map (make-keymap))
+ (set-keymap-parent message-mode-map text-mode-map)
(define-key message-mode-map "\C-c?" 'describe-mode)
(define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
(define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
(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-q" 'message-fill-yanked-message)
(define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
+ (define-key message-mode-map "\C-c\M-h" 'message-insert-headers)
(define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
(define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
(define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
(define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
+ ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
+
+ (define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
- (define-key message-mode-map "\t" 'message-tab))
+ (define-key message-mode-map "\t" 'message-tab)
+ (define-key message-mode-map "\M-;" 'comment-region))
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
- '("Message"
+ `("Message"
["Sort Headers" message-sort-headers t]
["Yank Original" message-yank-original t]
["Fill Yanked Message" message-fill-yanked-message t]
["Kill To Signature" message-kill-to-signature t]
["Newline and Reformat" message-newline-and-reformat t]
["Rename buffer" message-rename-buffer t]
- ["Spellcheck" ispell-message t]
+ ["Spellcheck" ispell-message
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Spellcheck this message"))]
+ ["Attach file as MIME" mml-attach-file
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Attach a file at point"))]
"----"
- ["Send Message" message-send-and-exit t]
- ["Abort Message" message-dont-send t]
- ["Kill Message" message-kill-buffer t]))
+ ["Send Message" message-send-and-exit
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Send this message"))]
+ ["Abort Message" message-dont-send
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "File this draft message and exit"))]
+ ["Kill Message" message-kill-buffer
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Delete this message without sending"))]))
(easy-menu-define
message-mode-field-menu message-mode-map ""
["Body" message-goto-body t]
["Signature" message-goto-signature t]))
-(defvar facemenu-add-face-function)
-(defvar facemenu-remove-face-function)
+(defvar message-tool-bar-map nil)
+
+(eval-when-compile
+ (defvar facemenu-add-face-function)
+ (defvar facemenu-remove-face-function))
;;;###autoload
(defun message-mode ()
"Major mode for editing mail and news to be sent.
-Like Text Mode but with these additional commands:
-C-c C-s message-send (send the message) C-c C-c message-send-and-exit
+Like Text Mode but with these additional commands:\\<message-mode-map>
+C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit'
+C-c C-d Postpone sending the message C-c C-k Kill the message
C-c C-f move to a header field (and create it if there isn't):
C-c C-f C-t move to To C-c C-f C-s move to Subject
C-c C-f C-c move to Cc C-c C-f C-b move to Bcc
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-f move to Followup-To
-C-c C-t message-insert-to (add a To header to a news followup)
-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-w message-insert-signature (insert `message-signature-file' file).
-C-c C-y message-yank-original (insert current message, if any).
-C-c C-q message-fill-yanked-message (fill what was yanked).
-C-c C-e message-elide-region (elide the text between point and mark).
-C-c C-z message-kill-to-signature (kill the text up to the signature).
-C-c C-r message-caesar-buffer-body (rot13 the message body)."
+C-c C-t `message-insert-to' (add a To header to a news followup)
+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-w `message-insert-signature' (insert `message-signature-file' file).
+C-c C-y `message-yank-original' (insert current message, if any).
+C-c C-q `message-fill-yanked-message' (fill what was yanked).
+C-c C-e `message-elide-region' (elide the text between point and mark).
+C-c C-v `message-delete-not-region' (remove the text outside the region).
+C-c C-z `message-kill-to-signature' (kill the text up to the signature).
+C-c C-r `message-caesar-buffer-body' (rot13 the message body).
+C-c C-a `mml-attach-file' (attach a file as MIME).
+M-RET `message-newline-and-reformat' (break the line and reformat)."
(interactive)
+ (if (local-variable-p 'mml-buffer-list (current-buffer))
+ (mml-destroy-buffers))
(kill-all-local-variables)
- (make-local-variable 'message-reply-buffer)
- (setq message-reply-buffer nil)
- (make-local-variable 'message-send-actions)
- (make-local-variable 'message-exit-actions)
+ (set (make-local-variable 'message-reply-buffer) nil)
+ (make-local-variable 'message-send-actions)
+ (make-local-variable 'message-exit-actions)
(make-local-variable 'message-kill-actions)
(make-local-variable 'message-postpone-actions)
(make-local-variable 'message-draft-article)
(error "Face %s not configured for %s mode" face mode-name)))
"")
facemenu-remove-face-function t)
- (make-local-variable 'paragraph-separate)
- (make-local-variable 'paragraph-start)
- ;; `-- ' precedes the signature. `-----' appears at the start of the
- ;; lines that delimit forwarded messages.
- ;; Lines containing just >= 3 dashes, perhaps after whitespace,
- ;; are also sometimes used and should be separators.
- (setq paragraph-start
- (concat (regexp-quote mail-header-separator)
- "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|"
- "-- $\\|---+$\\|"
- page-delimiter
- ;;!!! Uhm... shurely this can't be right?
- "[> " (regexp-quote message-yank-prefix) "]+$"))
- (setq paragraph-separate paragraph-start)
(make-local-variable 'message-reply-headers)
(setq message-reply-headers nil)
(make-local-variable 'message-newsreader)
(make-local-variable 'message-mailer)
(make-local-variable 'message-post-method)
- (make-local-variable 'message-sent-message-via)
- (setq message-sent-message-via nil)
- (make-local-variable 'message-checksum)
- (setq message-checksum nil)
- ;;(when (fboundp 'mail-hist-define-keys)
- ;; (mail-hist-define-keys))
- (when (string-match "XEmacs\\|Lucid" emacs-version)
- (message-setup-toolbar))
+ (set (make-local-variable 'message-sent-message-via) nil)
+ (set (make-local-variable 'message-checksum) nil)
+ (set (make-local-variable 'message-mime-part) 0)
+ (message-setup-fill-variables)
+ ;; Allow using comment commands to add/remove quoting.
+ (set (make-local-variable 'comment-start) message-yank-prefix)
+ (if (featurep 'xemacs)
+ (message-setup-toolbar)
+ (set (make-local-variable 'font-lock-defaults)
+ '(message-font-lock-keywords t))
+ (if (boundp 'tool-bar-map)
+ (set (make-local-variable 'tool-bar-map) (message-tool-bar-map))))
(easy-menu-add message-mode-menu message-mode-map)
(easy-menu-add message-mode-field-menu message-mode-map)
;; Allow mail alias things.
(mail-abbrevs-setup)
(mail-aliases-setup)))
(message-set-auto-save-file-name)
- (unless (string-match "XEmacs" emacs-version)
- (set (make-local-variable 'font-lock-defaults)
- '(message-font-lock-keywords t)))
+ (mm-enable-multibyte)
+ (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
+ (setq indent-tabs-mode nil)
+ (mml-mode)
+ (run-hooks 'text-mode-hook 'message-mode-hook))
+
+(defun message-setup-fill-variables ()
+ "Setup message fill variables."
+ (set (make-local-variable 'fill-paragraph-function)
+ 'message-fill-paragraph)
+ (make-local-variable 'paragraph-separate)
+ (make-local-variable 'paragraph-start)
(make-local-variable 'adaptive-fill-regexp)
- (setq adaptive-fill-regexp
- (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp))
(unless (boundp 'adaptive-fill-first-line-regexp)
(setq adaptive-fill-first-line-regexp nil))
(make-local-variable 'adaptive-fill-first-line-regexp)
- (setq adaptive-fill-first-line-regexp
- (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|"
- adaptive-fill-first-line-regexp))
- (run-hooks 'text-mode-hook 'message-mode-hook))
+ (make-local-variable 'auto-fill-inhibit-regexp)
+ (let ((quote-prefix-regexp
+ ;; User should change message-cite-prefix-regexp if
+ ;; message-yank-prefix is set to an abnormal value.
+ (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
+ (setq paragraph-start
+ (concat
+ (regexp-quote mail-header-separator) "$\\|"
+ "[ \t]*$\\|" ; blank lines
+ "-- $\\|" ; signature delimiter
+ "---+$\\|" ; delimiters for forwarded messages
+ page-delimiter "$\\|" ; spoiler warnings
+ ".*wrote:$\\|" ; attribution lines
+ quote-prefix-regexp "$")) ; empty lines in quoted text
+ (setq paragraph-separate paragraph-start)
+ (setq adaptive-fill-regexp
+ (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
+ (setq adaptive-fill-first-line-regexp
+ (concat quote-prefix-regexp "\\|"
+ adaptive-fill-first-line-regexp))
+ (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")))
\f
(interactive)
(message-position-on-field "Summary" "Subject"))
-(defun message-goto-body ()
+(defun message-goto-body (&optional interactivep)
"Move point to the beginning of the message body."
- (interactive)
- (if (looking-at "[ \t]*\n") (expand-abbrev))
+ (interactive (list t))
+ (when (and interactivep
+ (looking-at "[ \t]*\n"))
+ (expand-abbrev))
(goto-char (point-min))
- (search-forward (concat "\n" mail-header-separator "\n") nil t))
+ (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
+ (search-forward "\n\n" nil t)))
(defun message-goto-eoh ()
"Move point to the end of the headers."
(interactive)
(message-goto-body)
- (forward-line -2))
+ (forward-line -1))
(defun message-goto-signature ()
"Move point to the beginning of the message signature.
(let ((co (message-fetch-reply-field "mail-copies-to")))
(when (and (null force)
co
- (equal (downcase co) "never"))
+ (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 "reply-to")
+ (insert (or (message-fetch-reply-field "mail-reply-to")
+ (message-fetch-reply-field "reply-to")
(message-fetch-reply-field "from") "")))
+(defun message-widen-reply ()
+ "Widen the reply to include maximum recipients."
+ (interactive)
+ (let ((follow-to
+ (and message-reply-buffer
+ (buffer-name message-reply-buffer)
+ (save-excursion
+ (set-buffer message-reply-buffer)
+ (message-get-reply-headers t)))))
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (dolist (elem follow-to)
+ (message-remove-header (symbol-name (car elem)))
+ (goto-char (point-min))
+ (insert (symbol-name (car elem)) ": "
+ (cdr elem) "\n"))))))
+
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
(interactive)
;;; Various commands
(defun message-delete-not-region (beg end)
- "Delete everything in the body of the current message that is outside of the region."
+ "Delete everything in the body of the current message outside of the region."
(interactive "r")
(save-excursion
(goto-char end)
(unless (bolp)
(insert "\n"))))
-(defun message-newline-and-reformat ()
- "Insert four newlines, and then reformat if inside quoted text."
- (interactive)
- (let ((point (point))
- quoted)
- (save-excursion
- (beginning-of-line)
- (setq quoted (looking-at (regexp-quote message-yank-prefix))))
- (insert "\n\n\n\n")
- (when quoted
- (insert message-yank-prefix))
- (fill-paragraph nil)
+(defun message-newline-and-reformat (&optional arg not-break)
+ "Insert four newlines, and then reformat if inside quoted text.
+Prefix arg means justify as well."
+ (interactive (list (if current-prefix-arg 'full)))
+ (let (quoted point beg end leading-space bolp)
+ (setq point (point))
+ (beginning-of-line)
+ (setq beg (point))
+ (setq bolp (= beg point))
+ ;; Find first line of the paragraph.
+ (if not-break
+ (while (and (not (eobp))
+ (not (looking-at message-cite-prefix-regexp))
+ (looking-at paragraph-start))
+ (forward-line 1)))
+ ;; Find the prefix
+ (when (looking-at message-cite-prefix-regexp)
+ (setq quoted (match-string 0))
+ (goto-char (match-end 0))
+ (looking-at "[ \t]*")
+ (setq leading-space (match-string 0)))
+ (if (and quoted
+ (not not-break)
+ (not bolp)
+ (< (- point beg) (length quoted)))
+ ;; break inside the cite prefix.
+ (setq quoted nil
+ end nil))
+ (if quoted
+ (progn
+ (forward-line 1)
+ (while (and (not (eobp))
+ (not (looking-at paragraph-separate))
+ (looking-at message-cite-prefix-regexp)
+ (equal quoted (match-string 0)))
+ (goto-char (match-end 0))
+ (looking-at "[ \t]*")
+ (if (> (length leading-space) (length (match-string 0)))
+ (setq leading-space (match-string 0)))
+ (forward-line 1))
+ (setq end (point))
+ (goto-char beg)
+ (while (and (if (bobp) nil (forward-line -1) t)
+ (not (looking-at paragraph-start))
+ (looking-at message-cite-prefix-regexp)
+ (equal quoted (match-string 0)))
+ (setq beg (point))
+ (goto-char (match-end 0))
+ (looking-at "[ \t]*")
+ (if (> (length leading-space) (length (match-string 0)))
+ (setq leading-space (match-string 0)))))
+ (while (and (not (eobp))
+ (not (looking-at paragraph-separate))
+ (not (looking-at message-cite-prefix-regexp)))
+ (forward-line 1))
+ (setq end (point))
+ (goto-char beg)
+ (while (and (if (bobp) nil (forward-line -1) t)
+ (not (looking-at paragraph-start))
+ (not (looking-at message-cite-prefix-regexp)))
+ (setq beg (point))))
(goto-char point)
- (forward-line 2)))
+ (save-restriction
+ (narrow-to-region beg end)
+ (if not-break
+ (setq point nil)
+ (if bolp
+ (insert "\n")
+ (insert "\n\n"))
+ (setq point (point))
+ (insert "\n\n")
+ (delete-region (point) (re-search-forward "[ \t]*"))
+ (when (and quoted (not bolp))
+ (insert quoted leading-space)))
+ (if quoted
+ (let* ((adaptive-fill-regexp
+ (regexp-quote (concat quoted leading-space)))
+ (adaptive-fill-first-line-regexp
+ adaptive-fill-regexp ))
+ (fill-paragraph arg))
+ (fill-paragraph arg))
+ (if point (goto-char point)))))
+
+(defun message-fill-paragraph (&optional arg)
+ "Like `fill-paragraph'."
+ (interactive (list (if current-prefix-arg 'full)))
+ (message-newline-and-reformat arg t)
+ t)
(defun message-insert-signature (&optional force)
- "Insert a signature. See documentation for the `message-signature' variable."
+ "Insert a signature. See documentation for variable `message-signature'."
(interactive (list 0))
(let* ((signature
(cond
(eq force 0))
(save-excursion
(goto-char (point-max))
- (not (re-search-backward
- message-signature-separator nil t))))
+ (not (re-search-backward message-signature-separator nil t))))
((and (null message-signature)
force)
t)
(or (bolp) (insert "\n")))))
(defun message-elide-region (b e)
- "Elide the text between point and mark.
-An ellipsis (from `message-elide-elipsis') will be inserted where the
+ "Elide the text in the region.
+An ellipsis (from `message-elide-ellipsis') will be inserted where the
text was killed."
(interactive "r")
(kill-region b e)
- (unless (bolp)
- (insert "\n"))
- (insert message-elide-elipsis))
+ (insert message-elide-ellipsis))
(defvar message-caesar-translation-table nil)
(defun message-caesar-region (b e &optional n)
- "Caesar rotation of region by N, default 13, for decrypting netnews."
+ "Caesar rotate region B to E by N, default 13, for decrypting netnews."
(interactive
(list
(min (point) (or (mark t) (point)))
;; We build the table, if necessary.
(when (or (not message-caesar-translation-table)
(/= (aref message-caesar-translation-table ?a) (+ ?a n)))
- (setq message-caesar-translation-table
- (message-make-caesar-translation-table n)))
- ;; Then we translate the region. Do it this way to retain
- ;; text properties.
- (while (< b e)
- (subst-char-in-region
- b (1+ b) (char-after b)
- (aref message-caesar-translation-table (char-after b)))
- (incf b))))
+ (setq message-caesar-translation-table
+ (message-make-caesar-translation-table n)))
+ (translate-region b e message-caesar-translation-table)))
(defun message-make-caesar-translation-table (n)
"Create a rot table with offset N."
(substring table (+ ?a 26) 255))))
(defun message-caesar-buffer-body (&optional rotnum)
- "Caesar rotates all letters in the current buffer by 13 places.
-Used to encode/decode possiblyun offensive messages (commonly in net.jokes).
+ "Caesar rotate all letters in the current buffer by 13 places.
+Used to encode/decode possibly offensive messages (commonly in rec.humor).
With prefix arg, specifies the number of places to rotate each letter forward.
Mail and USENET news headers are not rotated."
(interactive (if current-prefix-arg
(save-restriction
(when (message-goto-body)
(narrow-to-region (point) (point-max)))
- (let ((body (buffer-substring (point-min) (point-max))))
- (unless (equal 0 (call-process-region
- (point-min) (point-max) program t t))
- (insert body)
- (message "%s failed." program))))))
+ (shell-command-on-region
+ (point-min) (point-max) program nil t))))
(defun message-rename-buffer (&optional enter-string)
"Rename the *message* buffer to \"*message* RECIPIENT\".
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n") nil t)
(let ((fill-prefix message-yank-prefix))
- (fill-individual-paragraphs (point) (point-max) justifyp t))))
+ (fill-individual-paragraphs (point) (point-max) justifyp))))
(defun message-indent-citation ()
"Modify text just inserted from a message to be cited.
message-cite-function)
(delete-windows-on message-reply-buffer t)
(insert-buffer message-reply-buffer)
- (funcall message-cite-function)
+ (unless arg
+ (funcall message-cite-function))
(message-exchange-point-and-mark)
(unless (bolp)
(insert ?\n))
(unless modified
(setq message-checksum (message-checksum))))))
+(defun message-yank-buffer (buffer)
+ "Insert BUFFER into the current buffer and quote it."
+ (interactive "bYank buffer: ")
+ (let ((message-reply-buffer buffer))
+ (save-window-excursion
+ (message-yank-original))))
+
+(defun message-buffers ()
+ "Return a list of active message buffers."
+ (let (buffers)
+ (save-excursion
+ (dolist (buffer (buffer-list t))
+ (set-buffer buffer)
+ (when (and (eq major-mode 'message-mode)
+ (null message-sent-message-via))
+ (push (buffer-name buffer) buffers))))
+ (nreverse buffers)))
+
(defun message-cite-original-without-signature ()
"Cite function in the standard Message manner."
(let ((start (point))
(if (listp message-indent-citation-function)
message-indent-citation-function
(list message-indent-citation-function)))))
+ (mml-quote-region start end)
+ ;; Allow undoing.
+ (undo-boundary)
(goto-char end)
- (when (re-search-backward "^-- $" start t)
+ (when (re-search-backward message-signature-separator start t)
;; Also peel off any blank lines before the signature.
(forward-line -1)
(while (looking-at "^[ \t]*$")
(forward-line -1))
(forward-line 1)
- (delete-region (point) end))
+ (delete-region (point) end)
+ (unless (search-backward "\n\n" start t)
+ ;; Insert a blank line if it is peeled off.
+ (insert "\n")))
(goto-char start)
(while functions
(funcall (pop functions)))
(insert "\n"))
(funcall message-citation-line-function))))
-(defvar mail-citation-hook) ;Compiler directive
+(eval-when-compile (defvar mail-citation-hook)) ;Compiler directive
(defun message-cite-original ()
"Cite function in the standard Message manner."
(if (and (boundp 'mail-citation-hook)
mail-citation-hook)
(run-hooks 'mail-citation-hook)
(let ((start (point))
+ (end (mark t))
(functions
(when message-indent-citation-function
(if (listp message-indent-citation-function)
message-indent-citation-function
(list message-indent-citation-function)))))
+ (mml-quote-region start end)
(goto-char start)
(while functions
(funcall (pop functions)))
(funcall message-citation-line-function)))))
(defun message-insert-citation-line ()
- "Function that inserts a simple citation line."
+ "Insert a simple citation line."
(when message-reply-headers
(insert (mail-header-from message-reply-headers) " writes:\n\n")))
(bury-buffer buf)
(when (eq buf (current-buffer))
(message-bury buf)))
- (message-do-actions actions))))
+ (message-do-actions actions)
+ t)))
(defun message-dont-send ()
"Don't send the message you have been editing."
(message-do-actions actions))))
(defun message-bury (buffer)
- "Bury this mail buffer."
+ "Bury this mail BUFFER."
(let ((newbuf (other-buffer buffer)))
(bury-buffer buffer)
(if (and (fboundp 'frame-parameters)
(defun message-send (&optional arg)
"Send the message in the current buffer.
-If `message-interactive' is non-nil, wait for success indication
-or error messages, and inform user.
-Otherwise any failure is reported in a message back to
-the user from the mailer."
+If `message-interactive' is non-nil, wait for success indication or
+error messages, and inform user.
+Otherwise any failure is reported in a message back to the user from
+the mailer.
+The usage of ARG is defined by the instance that called Message.
+It should typically alter the sending method in some way or other."
(interactive "P")
- ;; Disabled test.
- (when (or (buffer-modified-p)
- (message-check-element 'unchanged)
- (y-or-n-p "No changes in the buffer; really send? "))
- ;; Make it possible to undo the coming changes.
- (undo-boundary)
- (let ((inhibit-read-only t))
- (put-text-property (point-min) (point-max) 'read-only nil))
- (message-fix-before-sending)
- (run-hooks 'message-send-hook)
- (message "Sending...")
- (let ((alist message-send-method-alist)
- (success t)
- elem sent)
- (while (and success
- (setq elem (pop alist)))
- (when (and (or (not (funcall (cadr elem)))
- (and (or (not (memq (car elem)
- message-sent-message-via))
- (y-or-n-p
- (format
- "Already sent message via %s; resend? "
- (car elem))))
- (setq success (funcall (caddr elem) arg)))))
- (setq sent t)))
- (when (and success sent)
- (message-do-fcc)
- ;;(when (fboundp 'mail-hist-put-headers-into-history)
- ;; (mail-hist-put-headers-into-history))
- (run-hooks 'message-sent-hook)
- (message "Sending...done")
- ;; Mark the buffer as unmodified and delete autosave.
- (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))))
+ ;; Make it possible to undo the coming changes.
+ (undo-boundary)
+ (let ((inhibit-read-only t))
+ (put-text-property (point-min) (point-max) 'read-only nil))
+ (message-fix-before-sending)
+ (run-hooks 'message-send-hook)
+ (message message-sending-message)
+ (let ((alist message-send-method-alist)
+ (success t)
+ elem sent
+ (message-options message-options))
+ (message-options-set-recipient)
+ (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))
+ (error "No methods specified to send by"))
+ (when (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)))
(defun message-send-via-mail (arg)
"Send the current message via mail."
"Send the current message via news."
(funcall message-send-news-function arg))
+(defmacro message-check (type &rest forms)
+ "Eval FORMS if TYPE is to be checked."
+ `(or (message-check-element ,type)
+ (save-excursion
+ ,@forms)))
+
+(put 'message-check 'lisp-indent-function 1)
+(put 'message-check 'edebug-form-spec '(form body))
+
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
;; Make sure there's a newline at the end of the message.
(unless (bolp)
(insert "\n"))
;; Delete all invisible text.
- (when (text-property-any (point-min) (point-max) 'invisible t)
- (put-text-property (point-min) (point-max) 'invisible nil)
- (unless (yes-or-no-p "Invisible text found and made visible; continue posting?")
- (error "Invisible text found and made visible"))))
+ (message-check 'invisible-text
+ (when (text-property-any (point-min) (point-max) 'invisible t)
+ (put-text-property (point-min) (point-max) 'invisible nil)
+ (unless (yes-or-no-p
+ "Invisible text found and made visible; continue posting? ")
+ (error "Invisible text found and made visible")))))
(defun message-add-action (action &rest types)
"Add ACTION to be performed when doing an exit of type TYPES."
(eval (car actions)))))
(pop actions)))
+(defun message-send-mail-partially ()
+ "Send mail as message/partial."
+ ;; replace the header delimiter with a blank line
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (run-hooks 'message-send-mail-hook)
+ (let ((p (goto-char (point-min)))
+ (tembuf (message-generate-new-buffer-clone-locals " message temp"))
+ (curbuf (current-buffer))
+ (id (message-make-message-id)) (n 1)
+ plist total header required-mail-headers)
+ (while (not (eobp))
+ (if (< (point-max) (+ p message-send-mail-partially-limit))
+ (goto-char (point-max))
+ (goto-char (+ p message-send-mail-partially-limit))
+ (beginning-of-line)
+ (if (<= (point) p) (forward-line 1))) ;; In case of bad message.
+ (push p plist)
+ (setq p (point)))
+ (setq total (length plist))
+ (push (point-max) plist)
+ (setq plist (nreverse plist))
+ (unwind-protect
+ (save-excursion
+ (setq p (pop plist))
+ (while plist
+ (set-buffer curbuf)
+ (copy-to-buffer tembuf p (car plist))
+ (set-buffer tembuf)
+ (goto-char (point-min))
+ (if header
+ (progn
+ (goto-char (point-min))
+ (narrow-to-region (point) (point))
+ (insert header))
+ (message-goto-eoh)
+ (setq header (buffer-substring (point-min) (point)))
+ (goto-char (point-min))
+ (narrow-to-region (point) (point))
+ (insert header)
+ (message-remove-header "Mime-Version")
+ (message-remove-header "Content-Type")
+ (message-remove-header "Content-Transfer-Encoding")
+ (message-remove-header "Message-ID")
+ (message-remove-header "Lines")
+ (goto-char (point-max))
+ (insert "Mime-Version: 1.0\n")
+ (setq header (buffer-substring (point-min) (point-max))))
+ (goto-char (point-max))
+ (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n"
+ id n total))
+ (let ((mail-header-separator ""))
+ (when (memq 'Message-ID message-required-mail-headers)
+ (insert "Message-ID: " (message-make-message-id) "\n"))
+ (when (memq 'Lines message-required-mail-headers)
+ (let ((mail-header-separator ""))
+ (insert "Lines: " (message-make-lines) "\n")))
+ (message-goto-subject)
+ (end-of-line)
+ (insert (format " (%d/%d)" n total))
+ (goto-char (point-max))
+ (insert "\n")
+ (widen)
+ (mm-with-unibyte-current-buffer
+ (funcall message-send-mail-function)))
+ (setq n (+ n 1))
+ (setq p (pop plist))
+ (erase-buffer)))
+ (kill-buffer tembuf))))
+
(defun message-send-mail (&optional arg)
(require 'mail-utils)
- (let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
- (case-fold-search nil)
- (news (message-news-p))
- (mailbuf (current-buffer)))
+ (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
+ (case-fold-search nil)
+ (news (message-news-p))
+ (mailbuf (current-buffer))
+ (message-this-is-mail t)
+ (message-posting-charset
+ (if (fboundp 'gnus-setup-posting-charset)
+ (gnus-setup-posting-charset nil)
+ message-posting-charset)))
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(set-buffer tembuf)
(erase-buffer)
;; Avoid copying text props.
- (insert (format
- "%s" (save-excursion
- (set-buffer mailbuf)
- (buffer-string))))
+ (insert (with-current-buffer mailbuf
+ (buffer-substring-no-properties (point-min) (point-max))))
;; Remove some headers.
+ (message-encode-message-body)
(save-restriction
(message-narrow-to-headers)
+ ;; We (re)generate the Lines header.
+ (when (memq 'Lines message-required-mail-headers)
+ (message-generate-headers '(Lines)))
;; Remove some headers.
- (message-remove-header message-ignored-mail-headers t))
+ (message-remove-header message-ignored-mail-headers t)
+ (let ((mail-parse-charset message-default-charset))
+ (mail-encode-encoded-word-buffer)))
(goto-char (point-max))
;; require one newline at the end.
(or (= (preceding-char) ?\n)
(insert ?\n))
- (when (and news
+ (when
+ (save-restriction
+ (message-narrow-to-headers)
+ (and news
(or (message-fetch-field "cc")
- (message-fetch-field "to")))
+ (message-fetch-field "to"))
+ (let ((content-type (message-fetch-field "content-type")))
+ (or
+ (not content-type)
+ (string= "text/plain"
+ (car
+ (mail-header-parse-content-type
+ content-type)))))))
(message-insert-courtesy-copy))
- (funcall message-send-mail-function))
+ (if (or (not message-send-mail-partially-limit)
+ (< (point-max) message-send-mail-partially-limit)
+ (not (y-or-n-p "Message exceeds message-send-mail-partially-limit, send in parts? ")))
+ (mm-with-unibyte-current-buffer
+ (message "Sending via mail...")
+ (funcall message-send-mail-function))
+ (message-send-mail-partially)))
(kill-buffer tembuf))
(set-buffer mailbuf)
(push 'mail message-sent-message-via)))
(defun message-send-mail-with-sendmail ()
"Send off the prepared buffer with sendmail."
(let ((errbuf (if message-interactive
- (generate-new-buffer " sendmail errors")
+ (message-generate-new-buffer-clone-locals
+ " sendmail errors")
0))
resend-to-addresses delimline)
(let ((case-fold-search t))
;; But some systems are more broken with -f, so
;; we'll let users override this.
(if (null message-sendmail-f-is-evil)
- (list "-f" (user-login-name)))
+ (list "-f" (message-make-address)))
;; These mean "report errors by mail"
;; and "deliver in background".
(if (null message-interactive) '("-oem" "-odb"))
(mh-send-letter)))
(defun message-send-news (&optional arg)
- (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
- (case-fold-search nil)
- (method (if (message-functionp message-post-method)
- (funcall message-post-method arg)
- message-post-method))
- (messbuf (current-buffer))
- (message-syntax-checks
- (if arg
- (cons '(existing-newsgroups . disabled)
- message-syntax-checks)
- message-syntax-checks))
- result)
- (save-restriction
- (message-narrow-to-headers)
- ;; Insert some headers.
- (message-generate-headers message-required-news-headers)
- ;; Let the user do all of the above.
- (run-hooks 'message-header-hook))
- (message-cleanup-headers)
- (if (not (message-check-news-syntax))
- (progn
- ;;(message "Posting not performed")
- nil)
- (unwind-protect
- (save-excursion
- (set-buffer tembuf)
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- ;; Avoid copying text props.
- (insert (format
- "%s" (save-excursion
- (set-buffer messbuf)
- (buffer-string))))
- ;; Remove some headers.
- (save-restriction
- (message-narrow-to-headers)
+ (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
+ (case-fold-search nil)
+ (method (if (message-functionp message-post-method)
+ (funcall message-post-method arg)
+ message-post-method))
+ (group-name-charset (gnus-group-name-charset method ""))
+ (rfc2047-header-encoding-alist
+ (if group-name-charset
+ (cons (cons "Newsgroups" group-name-charset)
+ rfc2047-header-encoding-alist)
+ rfc2047-header-encoding-alist))
+ (messbuf (current-buffer))
+ (message-syntax-checks
+ (if arg
+ (cons '(existing-newsgroups . disabled)
+ message-syntax-checks)
+ message-syntax-checks))
+ (message-this-is-news t)
+ (message-posting-charset (gnus-setup-posting-charset
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-fetch-field "Newsgroups"))))
+ result)
+ (if (not (message-check-news-body-syntax))
+ nil
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; Insert some headers.
+ (message-generate-headers message-required-news-headers)
+ ;; Let the user do all of the above.
+ (run-hooks 'message-header-hook))
+ (when group-name-charset
+ (setq message-syntax-checks
+ (cons '(valid-newsgroups . disabled)
+ message-syntax-checks)))
+ (message-cleanup-headers)
+ (if (not (message-check-news-syntax))
+ nil
+ (unwind-protect
+ (save-excursion
+ (set-buffer tembuf)
+ (buffer-disable-undo)
+ (erase-buffer)
+ ;; Avoid copying text props.
+ (insert (with-current-buffer messbuf
+ (buffer-substring-no-properties
+ (point-min) (point-max))))
+ (message-encode-message-body)
;; Remove some headers.
- (message-remove-header message-ignored-news-headers t))
- (goto-char (point-max))
- ;; require one newline at the end.
- (or (= (preceding-char) ?\n)
- (insert ?\n))
- (let ((case-fold-search t))
- ;; Remove the delimiter.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n"))
- (replace-match "\n")
- (backward-char 1))
- (run-hooks 'message-send-news-hook)
- ;;(require (car method))
- ;;(funcall (intern (format "%s-open-server" (car method)))
- ;;(cadr method) (cddr method))
- ;;(setq result
- ;; (funcall (intern (format "%s-request-post" (car method)))
- ;; (cadr method)))
- (gnus-open-server method)
- (setq result (gnus-request-post method)))
- (kill-buffer tembuf))
- (set-buffer messbuf)
- (if result
- (push 'news message-sent-message-via)
- (message "Couldn't send message via news: %s"
- (nnheader-get-report (car method)))
- nil))))
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; We (re)generate the Lines header.
+ (when (memq 'Lines message-required-mail-headers)
+ (message-generate-headers '(Lines)))
+ ;; Remove some headers.
+ (message-remove-header message-ignored-news-headers t)
+ (let ((mail-parse-charset message-default-charset))
+ (mail-encode-encoded-word-buffer)))
+ (goto-char (point-max))
+ ;; require one newline at the end.
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ (let ((case-fold-search t))
+ ;; Remove the delimiter.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1))
+ (run-hooks 'message-send-news-hook)
+ (gnus-open-server method)
+ (message "Sending news with %s..." (gnus-server-string method))
+ (setq result (let ((mail-header-separator ""))
+ (gnus-request-post method))))
+ (kill-buffer tembuf))
+ (set-buffer messbuf)
+ (if result
+ (push 'news message-sent-message-via)
+ (message "Couldn't send message via news: %s"
+ (nnheader-get-report (car method)))
+ nil)))))
;;;
;;; Header generation & syntax checking.
;;;
-(defmacro message-check (type &rest forms)
- "Eval FORMS if TYPE is to be checked."
- `(or (message-check-element ,type)
- (save-excursion
- ,@forms)))
-
-(put 'message-check 'lisp-indent-function 1)
-(put 'message-check 'edebug-form-spec '(form body))
-
(defun message-check-element (type)
- "Returns non-nil if this type is not to be checked."
+ "Return non-nil if this TYPE is not to be checked."
(if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
t
(let ((able (assq type message-syntax-checks)))
(save-excursion
(save-restriction
(widen)
- (and
- ;; We narrow to the headers and check them first.
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (message-check-news-header-syntax)))
- ;; Check the body.
- (message-check-news-body-syntax)))))
+ ;; We narrow to the headers and check them first.
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-check-news-header-syntax))))))
(defun message-check-news-header-syntax ()
(and
+ ;; Check Newsgroups header.
+ (message-check 'newsgroups
+ (let ((group (message-fetch-field "newsgroups")))
+ (or
+ (and group
+ (not (string-match "\\`[ \t]*\\'" group)))
+ (ignore
+ (message
+ "The newsgroups field is empty or missing. Posting is denied.")))))
;; Check the Subject header.
(message-check 'subject
(let* ((case-fold-search t)
(hashtb (and (boundp 'gnus-active-hashtb)
gnus-active-hashtb))
errors)
- (if (or (not hashtb)
- (not (boundp 'gnus-read-active-file))
- (not gnus-read-active-file)
- (eq gnus-read-active-file 'some))
- t
- (while groups
- (when (and (not (boundp (intern (car groups) hashtb)))
- (not (equal (car groups) "poster")))
- (push (car groups) errors))
- (pop groups))
- (if (not errors)
- t
- (y-or-n-p
- (format
- "Really post to %s unknown group%s: %s "
- (if (= (length errors) 1) "this" "these")
- (if (= (length errors) 1) "" "s")
- (mapconcat 'identity errors ", ")))))))
- ;; Check the Newsgroups & Followup-To headers for syntax errors.
- (message-check 'valid-newsgroups
- (let ((case-fold-search t)
- (headers '("Newsgroups" "Followup-To"))
- header error)
- (while (and headers (not error))
- (when (setq header (mail-fetch-field (car headers)))
- (if (or
- (not
- (string-match
- "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
- header))
- (memq
- nil (mapcar
- (lambda (g)
- (not (string-match "\\.\\'\\|\\.\\." g)))
- (message-tokenize-header header ","))))
- (setq error t)))
- (unless error
- (pop headers)))
- (if (not error)
- t
+ (while groups
+ (when (and (not (boundp (intern (car groups) hashtb)))
+ (not (equal (car groups) "poster")))
+ (push (car groups) errors))
+ (pop groups))
+ (cond
+ ;; Gnus is not running.
+ ((or (not hashtb)
+ (not (boundp 'gnus-read-active-file)))
+ t)
+ ;; We don't have all the group names.
+ ((and (or (not gnus-read-active-file)
+ (eq gnus-read-active-file 'some))
+ errors)
(y-or-n-p
- (format "The %s header looks odd: \"%s\". Really post? "
- (car headers) header)))))
- (message-check 'repeated-newsgroups
- (let ((case-fold-search t)
- (headers '("Newsgroups" "Followup-To"))
- header error groups group)
- (while (and headers
- (not error))
- (when (setq header (mail-fetch-field (pop headers)))
- (setq groups (message-tokenize-header header ","))
- (while (setq group (pop groups))
- (when (member group groups)
- (setq error group
- groups nil)))))
- (if (not error)
- t
+ (format
+ "Really post to %s possibly unknown group%s: %s? "
+ (if (= (length errors) 1) "this" "these")
+ (if (= (length errors) 1) "" "s")
+ (mapconcat 'identity errors ", "))))
+ ;; There were no errors.
+ ((not errors)
+ t)
+ ;; There are unknown groups.
+ (t
(y-or-n-p
- (format "Group %s is repeated in headers. Really post? " error)))))
- ;; Check the From header.
- (message-check 'from
- (let* ((case-fold-search t)
- (from (message-fetch-field "from"))
- (ad (nth 1 (mail-extract-address-components from))))
- (cond
- ((not from)
- (message "There is no From line. Posting is denied.")
- nil)
- ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi
- (string-match "\\.\\." ad) ;larsi@ifi..uio
- (string-match "@\\." ad) ;larsi@.ifi.uio
- (string-match "\\.$" ad) ;larsi@ifi.uio.
- (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
- (string-match "(.*).*(.*)" from)) ;(lars) (lars)
- (message
- "Denied posting -- the From looks strange: \"%s\"." from)
- nil)
- (t t))))))
+ (format
+ "Really post to %s unknown group%s: %s? "
+ (if (= (length errors) 1) "this" "these")
+ (if (= (length errors) 1) "" "s")
+ (mapconcat 'identity errors ", ")))))))
+ ;; Check the Newsgroups & Followup-To headers for syntax errors.
+ (message-check 'valid-newsgroups
+ (let ((case-fold-search t)
+ (headers '("Newsgroups" "Followup-To"))
+ header error)
+ (while (and headers (not error))
+ (when (setq header (mail-fetch-field (car headers)))
+ (if (or
+ (not
+ (string-match
+ "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
+ header))
+ (memq
+ nil (mapcar
+ (lambda (g)
+ (not (string-match "\\.\\'\\|\\.\\." g)))
+ (message-tokenize-header header ","))))
+ (setq error t)))
+ (unless error
+ (pop headers)))
+ (if (not error)
+ t
+ (y-or-n-p
+ (format "The %s header looks odd: \"%s\". Really post? "
+ (car headers) header)))))
+ (message-check 'repeated-newsgroups
+ (let ((case-fold-search t)
+ (headers '("Newsgroups" "Followup-To"))
+ header error groups group)
+ (while (and headers
+ (not error))
+ (when (setq header (mail-fetch-field (pop headers)))
+ (setq groups (message-tokenize-header header ","))
+ (while (setq group (pop groups))
+ (when (member group groups)
+ (setq error group
+ groups nil)))))
+ (if (not error)
+ t
+ (y-or-n-p
+ (format "Group %s is repeated in headers. Really post? " error)))))
+ ;; Check the From header.
+ (message-check 'from
+ (let* ((case-fold-search t)
+ (from (message-fetch-field "from"))
+ ad)
+ (cond
+ ((not from)
+ (message "There is no From line. Posting is denied.")
+ nil)
+ ((or (not (string-match
+ "@[^\\.]*\\."
+ (setq ad (nth 1 (mail-extract-address-components
+ from))))) ;larsi@ifi
+ (string-match "\\.\\." ad) ;larsi@ifi..uio
+ (string-match "@\\." ad) ;larsi@.ifi.uio
+ (string-match "\\.$" ad) ;larsi@ifi.uio.
+ (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
+ (string-match "(.*).*(.*)" from)) ;(lars) (lars)
+ (message
+ "Denied posting -- the From looks strange: \"%s\"." from)
+ nil)
+ (t t))))))
(defun message-check-news-body-syntax ()
(and
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
(while (and
- (progn
- (end-of-line)
- (< (current-column) 80))
+ (or (looking-at
+ "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)")
+ (let ((p (point)))
+ (end-of-line)
+ (< (- (point) p) 80)))
(zerop (forward-line 1))))
(or (bolp)
(eobp)
(re-search-backward message-signature-separator nil t)
(beginning-of-line)
(or (re-search-backward "[^ \n\t]" b t)
- (y-or-n-p "Empty article. Really post? "))))
+ (if (message-gnksa-enable-p 'empty-article)
+ (y-or-n-p "Empty article. Really post? ")
+ (message "Denied posting -- Empty article.")
+ nil))))
;; Check for control characters.
(message-check 'control-chars
- (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
+ (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
(y-or-n-p
"The article contains control characters. Really post? ")
t))
(or
(not message-checksum)
(not (eq (message-checksum) message-checksum))
- (y-or-n-p
- "It looks like no new text has been added. Really post? ")))
+ (if (message-gnksa-enable-p 'quoted-text-only)
+ (y-or-n-p
+ "It looks like no new text has been added. Really post? ")
+ (message "Denied posting -- no new text has been added.")
+ nil)))
;; Check the length of the signature.
(message-check 'signature
(goto-char (point-max))
- (if (or (not (re-search-backward message-signature-separator nil t))
- (search-forward message-forward-end-separator nil t))
- t
- (if (> (count-lines (point) (point-max)) 5)
- (y-or-n-p
- (format
- "Your .sig is %d lines; it should be max 4. Really post? "
- (1- (count-lines (point) (point-max)))))
- t)))))
+ (if (> (count-lines (point) (point-max)) 5)
+ (y-or-n-p
+ (format
+ "Your .sig is %d lines; it should be max 4. Really post? "
+ (1- (count-lines (point) (point-max)))))
+ t))
+ ;; Ensure that text follows last quoted portion.
+ (message-check 'quoting-style
+ (goto-char (point-max))
+ (let ((no-problem t))
+ (when (search-backward-regexp "^>[^\n]*\n" nil t)
+ (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t)))
+ (if no-problem
+ t
+ (if (message-gnksa-enable-p 'quoted-text-only)
+ (y-or-n-p "Your text should follow quoted text. Really post? ")
+ ;; Ensure that
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (if (search-forward-regexp "^[ \t]*[^>\n]" nil t)
+ (y-or-n-p "Your text should follow quoted text. Really post? ")
+ (message "Denied posting -- only quoted text.")
+ nil)))))))
(defun message-checksum ()
"Return a \"checksum\" for the current buffer."
(while (not (eobp))
(when (not (looking-at "[ \t\n]"))
(setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
- (following-char))))
+ (char-after))))
(forward-char 1)))
sum))
list file)
(save-excursion
(set-buffer (get-buffer-create " *message temp*"))
- (buffer-disable-undo (current-buffer))
(erase-buffer)
(insert-buffer-substring buf)
(save-restriction
(while (setq file (message-fetch-field "fcc"))
(push file list)
(message-remove-header "fcc" nil t)))
+ (message-encode-message-body)
+ (save-restriction
+ (message-narrow-to-headers)
+ (let ((mail-parse-charset message-default-charset)
+ (rfc2047-header-encoding-alist
+ (cons '("Newsgroups" . default)
+ rfc2047-header-encoding-alist)))
+ (mail-encode-encoded-word-buffer)))
(goto-char (point-min))
- (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
- (replace-match "" t t)
+ (when (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$")
+ nil t)
+ (replace-match "" t t ))
;; Process FCC operations.
(while list
(setq file (pop list))
(rmail-output file 1 nil t)
(let ((mail-use-rfc822 t))
(rmail-output file 1 t t))))))
-
(kill-buffer (current-buffer)))))
(defun message-output (filename)
- "Append this article to Unix/babyl mail file.."
+ "Append this article to Unix/babyl mail file FILENAME."
(if (and (file-readable-p filename)
(mail-file-babyl-p filename))
(gnus-output-to-rmail filename t)
(when (re-search-forward ",+$" nil t)
(replace-match "" t t))))))
-(defun message-make-date ()
- "Make a valid data header."
- (let ((now (current-time)))
- (timezone-make-date-arpa-standard
- (current-time-string now) (current-time-zone now))))
+(defun message-make-date (&optional now)
+ "Make a valid data header.
+If NOW, use that time instead."
+ (let* ((now (or now (current-time)))
+ (zone (nth 8 (decode-time now)))
+ (sign "+"))
+ (when (< zone 0)
+ (setq sign "-")
+ (setq zone (- zone)))
+ (concat
+ (format-time-string "%d" now)
+ ;; The month name of the %b spec is locale-specific. Pfff.
+ (format " %s "
+ (capitalize (car (rassoc (nth 4 (decode-time now))
+ parse-time-months))))
+ (format-time-string "%Y %H:%M:%S " now)
+ ;; We do all of this because XEmacs doesn't have the %z spec.
+ (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
(defun message-make-message-id ()
"Make a unique Message-ID."
(mail-header-references message-reply-headers)
(mail-header-subject message-reply-headers)
psubject
- (mail-header-subject message-reply-headers)
(not (string=
(message-strip-subject-re
(mail-header-subject message-reply-headers))
"Make an Organization header."
(let* ((organization
(when message-user-organization
- (if (message-functionp message-user-organization)
- (funcall message-user-organization)
- message-user-organization))))
+ (if (message-functionp message-user-organization)
+ (funcall message-user-organization)
+ message-user-organization))))
(save-excursion
(message-set-work-buffer)
(cond ((stringp organization)
(save-excursion
(save-restriction
(widen)
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1)
+ (message-goto-body)
(int-to-string (count-lines (point) (point-max))))))
(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)))
+ (date (mail-header-date message-reply-headers))
+ (msg-id (mail-header-message-id message-reply-headers)))
(when from
(let ((stop-pos
(string-match " *at \\| *@ \\| *(\\| *<" from)))
- (concat (if (and stop-pos
+ (concat msg-id (if msg-id " (")
+ (if (and stop-pos
(not (zerop stop-pos)))
(substring from 0 stop-pos) from)
"'s message of \""
(if (or (not date) (string= date ""))
"(unknown date)" date)
- "\""))))))
+ "\"" (if msg-id ")")))))))
(defun message-make-distribution ()
"Make a Distribution header."
;; Add the future to current.
(setcar current (+ (car current) (round (/ future (expt 2 16)))))
(setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
- ;; Return the date in the future in UT.
- (timezone-make-date-arpa-standard
- (current-time-string current) (current-time-zone current) '(0 "UT"))))
+ (message-make-date current)))
(defun message-make-path ()
"Return uucp path."
(To nil)
(Distribution (message-make-distribution))
(Lines (message-make-lines))
- (X-Newsreader message-newsreader)
- (X-Mailer (and (not (message-fetch-field "X-Newsreader"))
- message-mailer))
+ (User-Agent message-newsreader)
(Expires (message-make-expires))
(case-fold-search t)
header value elem)
(progn
;; The header was found. We insert a space after the
;; colon, if there is none.
- (if (/= (following-char) ? ) (insert " ") (forward-char 1))
+ (if (/= (char-after) ? ) (insert " ") (forward-char 1))
;; Find out whether the header is empty...
- (looking-at "[ \t]*$")))
+ (looking-at "[ \t]*\n[^ \t]")))
;; So we find out what value we should insert.
(setq value
(cond
;; The element is a symbol. We insert the value
;; of this symbol, if any.
(symbol-value header))
- (t
+ ((not (message-check-element header))
;; We couldn't generate a value for this header,
;; so we just ask the user.
(read-from-minibuffer
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward "^,\"" (point-max))
- (if (or (= (following-char) ?,)
+ (if (or (eq (char-after) ?,)
(eobp))
(when (not quoted)
(if (and (> (current-column) 78)
(defun message-fill-header (header value)
(let ((begin (point))
- (fill-column 990)
+ (fill-column 78)
(fill-prefix "\t"))
(insert (capitalize (symbol-name header))
": "
(replace-match " " t t))
(goto-char (point-max)))))
+(defun message-shorten-1 (list cut surplus)
+ "Cut SURPLUS elements out of LIST, beginning with CUTth one."
+ (setcdr (nthcdr (- cut 2) list)
+ (nthcdr (+ (- cut 2) surplus 1) list)))
+
(defun message-shorten-references (header references)
- "Limit REFERENCES to be shorter than 988 characters."
- (let ((max 988)
- (cut 4)
+ "Trim REFERENCES to be less than 31 Message-ID long, and fold them.
+If folding is disallowed, also check that the REFERENCES are less
+than 988 characters long, and if they are not, trim them until they are."
+ (let ((maxcount 31)
+ (count 0)
+ (cut 6)
refs)
- (nnheader-temp-write nil
+ (with-temp-buffer
(insert references)
(goto-char (point-min))
+ ;; Cons a list of valid references.
(while (re-search-forward "<[^>]+>" nil t)
(push (match-string 0) refs))
- (setq refs (nreverse refs))
- (while (> (length (mapconcat 'identity refs " ")) max)
- (when (< (length refs) (1+ cut))
- (decf cut))
- (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs)))))
- (insert (capitalize (symbol-name header)) ": "
- (mapconcat 'identity refs " ") "\n")))
+ (setq refs (nreverse refs)
+ count (length refs)))
+
+ ;; If the list has more than MAXCOUNT elements, trim it by
+ ;; removing the CUTth element and the required number of
+ ;; elements that follow.
+ (when (> count maxcount)
+ (let ((surplus (- count maxcount)))
+ (message-shorten-1 refs cut surplus)
+ (decf count surplus)))
+
+ ;; If folding is disallowed, make sure the total length (including
+ ;; the spaces between) will be less than MAXSIZE characters.
+ ;;
+ ;; Only disallow folding for News messages. At this point the headers
+ ;; have not been generated, thus we use message-this-is-news directly.
+ (when (and message-this-is-news message-cater-to-broken-inn)
+ (let ((maxsize 988)
+ (totalsize (+ (apply #'+ (mapcar #'length refs))
+ (1- count)))
+ (surplus 0)
+ (ptr (nthcdr (1- cut) refs)))
+ ;; Decide how many elements to cut off...
+ (while (> totalsize maxsize)
+ (decf totalsize (1+ (length (car ptr))))
+ (incf surplus)
+ (setq ptr (cdr ptr)))
+ ;; ...and do it.
+ (when (> surplus 0)
+ (message-shorten-1 refs cut surplus))))
+
+ ;; Finally, collect the references back into a string and insert
+ ;; it into the buffer.
+ (let ((refstring (mapconcat #'identity refs " ")))
+ (if (and message-this-is-news message-cater-to-broken-inn)
+ (insert (capitalize (symbol-name header)) ": "
+ refstring "\n")
+ (message-fill-header header refstring)))))
(defun message-position-point ()
"Move point to where the user probably wants to find it."
(search-backward ":" )
(widen)
(forward-char 1)
- (if (= (following-char) ? )
+ (if (eq (char-after) ? )
(forward-char 1)
(insert " ")))
(t
(defun message-buffer-name (type &optional to group)
"Return a new (unique) buffer name based on TYPE and TO."
(cond
+ ;; Generate a new buffer name The Message Way.
+ ((eq message-generate-new-buffers 'unique)
+ (generate-new-buffer-name
+ (concat "*" type
+ (if to
+ (concat " to "
+ (or (car (mail-extract-address-components to))
+ to) "")
+ "")
+ (if (and group (not (string= group ""))) (concat " on " group) "")
+ "*")))
;; Check whether `message-generate-new-buffers' is a function,
;; and if so, call it.
((message-functionp message-generate-new-buffers)
(funcall message-generate-new-buffers type to group))
- ;; Generate a new buffer name The Message Way.
- (message-generate-new-buffers
+ ((eq message-generate-new-buffers 'unsent)
(generate-new-buffer-name
- (concat "*" type
+ (concat "*unsent " type
(if to
(concat " to "
(or (car (mail-extract-address-components to))
;; Rename the buffer.
(if message-send-rename-function
(funcall message-send-rename-function)
- (when (string-match "\\`\\*" (buffer-name))
- (rename-buffer
- (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
+ (when (string-match "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*"
+ (buffer-name))
+ (let ((name (match-string 2 (buffer-name)))
+ to group)
+ (if (not (or (string-equal name "mail")
+ (string-equal name "news")))
+ (setq name (concat "*sent " name "*"))
+ (setq to (message-fetch-field "to"))
+ (setq group (message-fetch-field "newsgroups"))
+ (setq name
+ (cond
+ (to (concat "*sent mail to "
+ (or (car (mail-extract-address-components to))
+ to) "*"))
+ ((and group (not (string= group "")))
+ (concat "*sent news on " group "*"))
+ (t "*sent mail*"))))
+ (unless (string-equal name (buffer-name))
+ (rename-buffer name t)))))
;; Push the current buffer onto the list.
(when message-max-buffers
(setq message-buffer-list
(nconc message-buffer-list (list (current-buffer))))))
-(defvar mc-modes-alist)
-(defun message-setup (headers &optional replybuffer actions)
- (when (and (boundp 'mc-modes-alist)
- (not (assq 'message-mode mc-modes-alist)))
- (push '(message-mode (encrypt . mc-encrypt-message)
- (sign . mc-sign-message))
- mc-modes-alist))
+(defun message-mail-user-agent ()
+ (let ((mua (cond
+ ((not message-mail-user-agent) nil)
+ ((eq message-mail-user-agent t) mail-user-agent)
+ (t message-mail-user-agent))))
+ (if (memq mua '(message-user-agent gnus-user-agent))
+ nil
+ mua)))
+
+(defun message-setup (headers &optional replybuffer actions switch-function)
+ (let ((mua (message-mail-user-agent))
+ subject to field yank-action)
+ (if (not (and message-this-is-mail mua))
+ (message-setup-1 headers replybuffer actions)
+ (if replybuffer
+ (setq yank-action (list 'insert-buffer replybuffer)))
+ (setq headers (copy-sequence headers))
+ (setq field (assq 'Subject headers))
+ (when field
+ (setq subject (cdr field))
+ (setq headers (delq field headers)))
+ (setq field (assq 'To headers))
+ (when field
+ (setq to (cdr field))
+ (setq headers (delq field headers)))
+ (let ((mail-user-agent mua))
+ (compose-mail to subject
+ (mapcar (lambda (item)
+ (cons
+ (format "%s" (car item))
+ (cdr item)))
+ headers)
+ nil switch-function yank-action actions)))))
+
+;;;(defvar mc-modes-alist)
+(defun message-setup-1 (headers &optional replybuffer actions)
+;;; (when (and (boundp 'mc-modes-alist)
+;;; (not (assq 'message-mode mc-modes-alist)))
+;;; (push '(message-mode (encrypt . mc-encrypt-message)
+;;; (sign . mc-sign-message))
+;;; mc-modes-alist))
(when actions
(setq message-send-actions actions))
(setq message-reply-buffer replybuffer)
(message-insert-signature)
(save-restriction
(message-narrow-to-headers)
+ (if message-alternative-emails
+ (message-use-alternative-email-as-from))
(run-hooks 'message-header-setup-hook))
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
(defun message-set-auto-save-file-name ()
"Associate the message buffer with a file in the drafts directory."
- (when message-autosave-directory
+ (when message-auto-save-directory
+ (unless (file-directory-p
+ (directory-file-name message-auto-save-directory))
+ (gnus-make-directory message-auto-save-directory))
(if (gnus-alive-p)
(setq message-draft-article
(nndraft-request-associate-buffer "drafts"))
- (setq buffer-file-name (expand-file-name "*message*"
- message-autosave-directory))
+ (setq buffer-file-name (expand-file-name
+ (if (eq system-type 'windows-nt)
+ "message"
+ "*message*")
+ message-auto-save-directory))
(setq buffer-auto-save-file-name (make-auto-save-file-name)))
- (clear-visited-file-modtime)))
+ (clear-visited-file-modtime)
+ (setq buffer-file-coding-system message-draft-coding-system)))
(defun message-disassociate-draft ()
"Disassociate the message buffer from the drafts directory."
(nndraft-request-expire-articles
(list message-draft-article) "drafts" nil t)))
+(defun message-insert-headers ()
+ "Generate the headers for the article."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (when (message-news-p)
+ (message-generate-headers
+ (delq 'Lines
+ (delq 'Subject
+ (copy-sequence message-required-news-headers)))))
+ (when (message-mail-p)
+ (message-generate-headers
+ (delq 'Lines
+ (delq 'Subject
+ (copy-sequence message-required-mail-headers))))))))
+
\f
;;;
"Start editing a mail message to be sent.
OTHER-HEADERS is an alist of header/value pairs."
(interactive)
- (let ((message-this-is-mail t))
- (message-pop-to-buffer (message-buffer-name "mail" to))
+ (let ((message-this-is-mail t) replybuffer)
+ (unless (message-mail-user-agent)
+ (message-pop-to-buffer (message-buffer-name "mail" to)))
+ ;; FIXME: message-mail should do something if YANK-ACTION is not
+ ;; insert-buffer.
+ (and (consp yank-action) (eq (car yank-action) 'insert-buffer)
+ (setq replybuffer (nth 1 yank-action)))
(message-setup
(nconc
`((To . ,(or to "")) (Subject . ,(or subject "")))
- (when other-headers other-headers)))))
+ (when other-headers other-headers))
+ replybuffer)
+ ;; FIXME: Should return nil if failure.
+ t))
;;;###autoload
(defun message-news (&optional newsgroups subject)
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
+(defun message-get-reply-headers (wide &optional to-address)
+ (let (follow-to mct never-mct from to cc reply-to mrt mft ccalist)
+ ;; Find all relevant headers we need.
+ (setq from (message-fetch-field "from")
+ to (message-fetch-field "to")
+ cc (message-fetch-field "cc")
+ mct (message-fetch-field "mail-copies-to")
+ reply-to (message-fetch-field "reply-to")
+ mrt (message-fetch-field "mail-reply-to")
+ mft (and message-use-followup-to
+ (message-fetch-field "mail-followup-to")))
+
+ ;; Handle special values of Mail-Copies-To.
+ (when mct
+ (cond ((or (equal (downcase mct) "never")
+ (equal (downcase mct) "nobody"))
+ (setq never-mct t)
+ (setq mct nil))
+ ((or (equal (downcase mct) "always")
+ (equal (downcase mct) "poster"))
+ (setq mct (or mrt reply-to from)))))
+
+ (if (and (not mft)
+ (or (not wide)
+ to-address))
+ (progn
+ (setq follow-to (list (cons 'To (or to-address mrt reply-to from))))
+ (when (and (and wide mct)
+ (not (member (cons 'To mct) follow-to)))
+ (push (cons 'Cc mct) follow-to)))
+ (let (ccalist)
+ (save-excursion
+ (message-set-work-buffer)
+ (if (and mft
+ message-use-followup-to
+ (or (not (eq message-use-followup-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Mail-Followup-To? ") t "\
+You should normally obey the Mail-Followup-To: header. In this
+article, it has the value of
+
+" mft "
+
+which directs your response to " (if (string-match "," mft)
+ "the specified addresses"
+ "that address only") ".
+
+If a message is posted to several mailing lists, Mail-Followup-To is
+often used to direct the following discussion to one list only,
+because discussions that are spread over several lists tend to be
+fragmented and very difficult to follow.
+
+Also, some source/announcement lists are not indented for discussion;
+responses here are directed to other addresses.")))
+ (insert mft)
+ (unless never-mct
+ (insert (or mrt reply-to from "")))
+ (insert (if to (concat (if (bolp) "" ", ") to "") ""))
+ (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
+ (insert (if cc (concat (if (bolp) "" ", ") cc) "")))
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+" nil t)
+ (replace-match " " t t))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
+ (insert (prog1 (rmail-dont-reply-to (buffer-string))
+ (erase-buffer))))
+ (goto-char (point-min))
+ ;; Perhaps "Mail-Copies-To: never" removed the only address?
+ (when (eobp)
+ (insert (or mrt reply-to from "")))
+ (setq ccalist
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (message-tokenize-header (buffer-string))))
+ (let ((s ccalist))
+ (while s
+ (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
+ (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
+ (when ccalist
+ (let ((ccs (cons 'Cc (mapconcat
+ (lambda (addr) (cdr addr)) ccalist ", "))))
+ (when (string-match "^ +" (cdr ccs))
+ (setcdr ccs (substring (cdr ccs) (match-end 0))))
+ (push ccs follow-to)))))
+ follow-to))
+
+
;;;###autoload
(defun message-reply (&optional to-address wide)
"Start editing a reply to the article in the current buffer."
(interactive)
+ (require 'gnus-sum) ; for gnus-list-identifiers
(let ((cur (current-buffer))
from subject date reply-to to cc
references message-id follow-to
(inhibit-point-motion-hooks t)
- mct never-mct gnus-warning)
+ (message-this-is-mail t)
+ gnus-warning)
(save-restriction
- (message-narrow-to-head)
+ (message-narrow-to-head-1)
;; Allow customizations to have their say.
(if (not wide)
;; This is a regular reply.
- (if (message-functionp message-reply-to-function)
- (setq follow-to (funcall message-reply-to-function)))
- ;; This is a followup.
- (if (message-functionp message-wide-reply-to-function)
+ (when (message-functionp message-reply-to-function)
(save-excursion
- (setq follow-to
- (funcall message-wide-reply-to-function)))))
- ;; Find all relevant headers we need.
- (setq from (message-fetch-field "from")
- date (message-fetch-field "date")
- subject (or (message-fetch-field "subject") "none")
- to (message-fetch-field "to")
- cc (message-fetch-field "cc")
- mct (message-fetch-field "mail-copies-to")
- reply-to (message-fetch-field "reply-to")
+ (setq follow-to (funcall message-reply-to-function))))
+ ;; This is a followup.
+ (when (message-functionp message-wide-reply-to-function)
+ (save-excursion
+ (setq follow-to
+ (funcall message-wide-reply-to-function)))))
+ (setq message-id (message-fetch-field "message-id" t)
references (message-fetch-field "references")
- message-id (message-fetch-field "message-id" t))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
- (when (string-match message-subject-re-regexp subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
+ date (message-fetch-field "date")
+ from (message-fetch-field "from")
+ subject (or (message-fetch-field "subject") "none"))
+ (when gnus-list-identifiers
+ (setq subject (message-strip-list-identifiers subject)))
+ (setq subject (concat "Re: " (message-strip-subject-re subject)))
- (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
- ;; Handle special values of Mail-Copies-To.
- (when mct
- (cond ((equal (downcase mct) "never")
- (setq never-mct t)
- (setq mct nil))
- ((equal (downcase mct) "always")
- (setq mct (or reply-to from)))))
-
- (unless follow-to
- (if (or (not wide)
- to-address)
- (progn
- (setq follow-to (list (cons 'To (or to-address reply-to from))))
- (when (and wide mct)
- (push (cons 'Cc mct) follow-to)))
- (let (ccalist)
- (save-excursion
- (message-set-work-buffer)
- (unless never-mct
- (insert (or reply-to from "")))
- (insert (if to (concat (if (bolp) "" ", ") to "") ""))
- (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
- (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+" nil t)
- (replace-match " " t t))
- ;; Remove addresses that match `rmail-dont-reply-to-names'.
- (insert (prog1 (rmail-dont-reply-to (buffer-string))
- (erase-buffer)))
- (goto-char (point-min))
- ;; Perhaps Mail-Copies-To: never removed the only address?
- (when (eobp)
- (insert (or reply-to from "")))
- (setq ccalist
- (mapcar
- (lambda (addr)
- (cons (mail-strip-quoted-names addr) addr))
- (message-tokenize-header (buffer-string))))
- (let ((s ccalist))
- (while s
- (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
- (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
- (when ccalist
- (let ((ccs (cons 'Cc (mapconcat
- (lambda (addr) (cdr addr)) ccalist ", "))))
- (when (string-match "^ +" (cdr ccs))
- (setcdr ccs (substring (cdr ccs) (match-end 0))))
- (push ccs follow-to))))))
- (widen))
+ (unless follow-to
+ (setq follow-to (message-get-reply-headers wide to-address))))
- (message-pop-to-buffer (message-buffer-name
- (if wide "wide reply" "reply") from
- (if wide to-address nil)))
+ (unless (message-mail-user-agent)
+ (message-pop-to-buffer
+ (message-buffer-name
+ (if wide "wide reply" "reply") from
+ (if wide to-address nil))))
(setq message-reply-headers
(vector 0 subject from date message-id references 0 0 ""))
"Follow up to the message in the current buffer.
If TO-NEWSGROUPS, use that as the new Newsgroups line."
(interactive)
+ (require 'gnus-sum) ; for gnus-list-identifiers
(let ((cur (current-buffer))
- from subject date reply-to mct
+ from subject date reply-to mrt mct
references message-id follow-to
(inhibit-point-motion-hooks t)
(message-this-is-news t)
newsgroups (message-fetch-field "newsgroups")
posted-to (message-fetch-field "posted-to")
reply-to (message-fetch-field "reply-to")
+ mrt (message-fetch-field "mail-reply-to")
distribution (message-fetch-field "distribution")
mct (message-fetch-field "mail-copies-to"))
(when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
(let ((case-fold-search t))
(string-match "world" distribution)))
(setq distribution nil))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
- (when (string-match message-subject-re-regexp subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
+ (if gnus-list-identifiers
+ (setq subject (message-strip-list-identifiers subject)))
+ (setq subject (concat "Re: " (message-strip-subject-re subject)))
(widen))
(message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
does not read the newsgroup, so he wouldn't see any replies sent to it."))
(progn
(setq message-this-is-news nil)
- (cons 'To (or reply-to from "")))
+ (cons 'To (or mrt reply-to from "")))
(cons 'Newsgroups newsgroups)))
(t
(if (or (equal followup-to newsgroups)
`((References . ,(concat (or references "") (and references " ")
(or message-id "")))))
,@(when (and mct
- (not (equal (downcase mct) "never")))
- (list (cons 'Cc (if (equal (downcase mct) "always")
- (or reply-to from "")
+ (not (or (equal (downcase mct) "never")
+ (equal (downcase mct) "nobody"))))
+ (list (cons 'Cc (if (or (equal (downcase mct) "always")
+ (equal (downcase mct) "poster"))
+ (or mrt reply-to from "")
mct)))))
cur)
;;;###autoload
-(defun message-cancel-news ()
- "Cancel an article you posted."
- (interactive)
+(defun message-cancel-news (&optional arg)
+ "Cancel an article you posted.
+If ARG, allow editing of the cancellation message."
+ (interactive "P")
(unless (message-news-p)
(error "This is not a news article; canceling is impossible"))
- (when (yes-or-no-p "Do you really want to cancel this article? ")
- (let (from newsgroups message-id distribution buf sender)
- (save-excursion
- ;; Get header info. from original article.
- (save-restriction
- (message-narrow-to-head)
- (setq from (message-fetch-field "from")
- sender (message-fetch-field "sender")
- newsgroups (message-fetch-field "newsgroups")
- message-id (message-fetch-field "message-id" t)
- distribution (message-fetch-field "distribution")))
- ;; Make sure that this article was written by the user.
- (unless (or (and sender
- (string-equal
- (downcase sender)
- (downcase (message-make-sender))))
- (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
- (error "This article is not yours"))
+ (let (from newsgroups message-id distribution buf sender)
+ (save-excursion
+ ;; Get header info from original article.
+ (save-restriction
+ (message-narrow-to-head-1)
+ (setq from (message-fetch-field "from")
+ sender (message-fetch-field "sender")
+ newsgroups (message-fetch-field "newsgroups")
+ message-id (message-fetch-field "message-id" t)
+ distribution (message-fetch-field "distribution")))
+ ;; Make sure that this article was written by the user.
+ (unless (or (message-gnksa-enable-p 'cancel-messages)
+ (and sender
+ (string-equal
+ (downcase sender)
+ (downcase (message-make-sender))))
+ (string-equal
+ (downcase (cadr (mail-extract-address-components from)))
+ (downcase (cadr (mail-extract-address-components
+ (message-make-from))))))
+ (error "This article is not yours"))
+ (when (yes-or-no-p "Do you really want to cancel this article? ")
;; Make control message.
- (setq buf (set-buffer (get-buffer-create " *message cancel*")))
- (buffer-disable-undo (current-buffer))
+ (if arg
+ (message-news)
+ (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
(erase-buffer)
(insert "Newsgroups: " newsgroups "\n"
- "From: " (message-make-from) "\n"
+ "From: " from "\n"
"Subject: cmsg cancel " message-id "\n"
"Control: cancel " message-id "\n"
(if distribution
"")
mail-header-separator "\n"
message-cancel-message)
- (message "Canceling your article...")
- (if (let ((message-syntax-checks
- 'dont-check-for-anything-just-trust-me))
- (funcall message-send-news-function))
- (message "Canceling your article...done"))
- (kill-buffer buf)))))
+ (run-hooks 'message-cancel-hook)
+ (unless arg
+ (message "Canceling your article...")
+ (if (let ((message-syntax-checks
+ 'dont-check-for-anything-just-trust-me))
+ (funcall message-send-news-function))
+ (message "Canceling your article...done"))
+ (kill-buffer buf))))))
;;;###autoload
(defun message-supersede ()
(sender (message-fetch-field "sender"))
(from (message-fetch-field "from")))
;; Check whether the user owns the article that is to be superseded.
- (unless (or (and sender
+ (unless (or (message-gnksa-enable-p 'cancel-messages)
+ (and sender
(string-equal
(downcase sender)
(downcase (message-make-sender))))
;; Get a normal message buffer.
(message-pop-to-buffer (message-buffer-name "supersede"))
(insert-buffer-substring cur)
- (message-narrow-to-head)
+ (mime-to-mml)
+ (message-narrow-to-head-1)
;; Remove unwanted headers.
(when message-ignored-supersedes-headers
(message-remove-header message-ignored-supersedes-headers t))
(cond ((save-window-excursion
(if (not (eq system-type 'vax-vms))
(with-output-to-temp-buffer "*Directory*"
+ (with-current-buffer standard-output
+ (fundamental-mode)) ; for Emacs 20.4+
(buffer-disable-undo standard-output)
(let ((default-directory "/"))
(call-process
;;; Washing Subject:
(defun message-wash-subject (subject)
- "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc."
- (nnheader-temp-write nil
+ "Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT.
+Previous forwarders, replyers, etc. may add it."
+ (with-temp-buffer
(insert-string subject)
(goto-char (point-min))
;; strip Re/Fwd stuff off the beginning
(replace-match ""))
(buffer-string)))
-
+
;;; Forwarding messages.
+(defvar message-forward-decoded-p nil
+ "Non-nil means the original message is decoded.")
+
(defun message-forward-subject-author-subject (subject)
- "Generate a subject for a forwarded message.
+ "Generate a SUBJECT for a forwarded message.
The form is: [Source] Subject, where if the original message was mail,
Source is the sender, and if the original message was news, Source is
the list of newsgroups is was posted to."
(concat "["
- (or (message-fetch-field
- (if (message-news-p) "newsgroups" "from"))
- "(nowhere)")
+ (let ((prefix
+ (or (message-fetch-field
+ (if (message-news-p) "newsgroups" "from"))
+ "(nowhere)")))
+ (if message-forward-decoded-p
+ prefix
+ (mail-decode-encoded-word-string prefix)))
"] " subject))
(defun message-forward-subject-fwd (subject)
- "Generate a subject for a forwarded message.
+ "Generate a SUBJECT for a forwarded message.
The form is: Fwd: Subject, where Subject is the original subject of
the message."
(concat "Fwd: " subject))
"Return a Subject header suitable for the message in the current buffer."
(save-excursion
(save-restriction
- (current-buffer)
- (message-narrow-to-head)
+ (message-narrow-to-head-1)
(let ((funcs message-make-forward-subject-function)
- (subject (if message-wash-forwarded-subjects
- (message-wash-subject
- (or (message-fetch-field "Subject") ""))
- (or (message-fetch-field "Subject") ""))))
+ (subject (message-fetch-field "Subject")))
+ (setq subject
+ (if subject
+ (if message-forward-decoded-p
+ subject
+ (mail-decode-encoded-word-string subject))
+ ""))
+ (if message-wash-forwarded-subjects
+ (setq subject (message-wash-subject subject)))
;; Make sure funcs is a list.
(and funcs
(not (listp funcs))
(setq funcs (cdr funcs)))
subject))))
+(eval-when-compile
+ (defvar gnus-article-decoded-p))
+
;;;###autoload
-(defun message-forward (&optional news)
+(defun message-forward (&optional news digest)
"Forward the current message via mail.
-Optional NEWS will use news to forward instead of mail."
+Optional NEWS will use news to forward instead of mail.
+Optional DIGEST will use digest to forward."
(interactive "P")
- (let ((cur (current-buffer))
- (subject (message-make-forward-subject))
- art-beg)
- (if news (message-news nil subject) (message-mail nil subject))
+ (let* ((cur (current-buffer))
+ (message-forward-decoded-p
+ (if (local-variable-p 'gnus-article-decoded-p (current-buffer))
+ gnus-article-decoded-p ;; In an article buffer.
+ message-forward-decoded-p))
+ (subject (message-make-forward-subject))
+ art-beg)
+ (if news
+ (message-news nil subject)
+ (message-mail nil subject))
;; Put point where we want it before inserting the forwarded
;; message.
- (if message-signature-before-forwarded-message
- (goto-char (point-max))
- (message-goto-body))
- ;; Make sure we're at the start of the line.
- (unless (eolp)
- (insert "\n"))
- ;; Narrow to the area we are to insert.
- (narrow-to-region (point) (point))
- ;; Insert the separators and the forwarded buffer.
- (insert message-forward-start-separator)
- (setq art-beg (point))
- (insert-buffer-substring cur)
- (goto-char (point-max))
- (insert message-forward-end-separator)
- (set-text-properties (point-min) (point-max) nil)
- ;; Remove all unwanted headers.
- (goto-char art-beg)
- (narrow-to-region (point) (if (search-forward "\n\n" nil t)
- (1- (point))
- (point)))
- (goto-char (point-min))
- (message-remove-header message-included-forward-headers t nil t)
- (widen)
+ (if message-forward-before-signature
+ (message-goto-body)
+ (goto-char (point-max)))
+ (if message-forward-as-mime
+ (if digest
+ (insert "\n<#multipart type=digest>\n")
+ (if message-forward-show-mml
+ (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
+ (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))
+ (insert "\n-------------------- Start of forwarded message --------------------\n"))
+ (let ((b (point)) e)
+ (if digest
+ (if message-forward-as-mime
+ (insert-buffer-substring cur)
+ (mml-insert-buffer cur))
+ (if (and message-forward-show-mml
+ (not message-forward-decoded-p))
+ (insert
+ (with-temp-buffer
+ (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode
+ (insert
+ (with-current-buffer cur
+ (mm-string-as-unibyte (buffer-string))))
+ (mm-enable-multibyte-mule4)
+ (mime-to-mml)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (buffer-string)))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mml-insert-buffer cur)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (goto-char (point-max)))))
+ (setq e (point))
+ (if message-forward-as-mime
+ (if digest
+ (insert "<#/multipart>\n")
+ (if message-forward-show-mml
+ (insert "<#/mml>\n")
+ (insert "<#/part>\n")))
+ (insert "\n-------------------- End of forwarded message --------------------\n"))
+ (if (and digest message-forward-as-mime)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (delete-region (point-min) (point-max)))
+ (when (and (not current-prefix-arg)
+ message-forward-ignored-headers)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (message-remove-header message-forward-ignored-headers t)))))
(message-position-point)))
;;;###autoload
(defun message-resend (address)
"Resend the current article to ADDRESS."
- (interactive "sResend message to: ")
+ (interactive
+ (list (message-read-from-minibuffer "Resend message to: ")))
(message "Resending message to %s..." address)
(save-excursion
(let ((cur (current-buffer))
beg)
;; We first set up a normal mail buffer.
- (set-buffer (get-buffer-create " *message resend*"))
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (message-setup `((To . ,address)))
+ (unless (message-mail-user-agent)
+ (set-buffer (get-buffer-create " *message resend*"))
+ (erase-buffer))
+ (let ((message-this-is-mail t))
+ (message-setup `((To . ,address))))
;; Insert our usual headers.
(message-generate-headers '(From Date To))
(message-narrow-to-headers)
(when (looking-at "From ")
(replace-match "X-From-Line: "))
;; Send it.
- (message-send-mail)
+ (let ((message-inhibit-body-encoding t)
+ message-required-mail-headers)
+ (message-send-mail))
(kill-buffer (current-buffer)))
(message "Resending message to %s...done" address)))
;;;###autoload
(defun message-bounce ()
"Re-mail the current message.
-This only makes sense if the current message is a bounce message than
+This only makes sense if the current message is a bounce message that
contains some mail you have written which has been bounced back to
you."
(interactive)
- (let ((cur (current-buffer))
+ (let ((handles (mm-dissect-buffer t))
boundary)
(message-pop-to-buffer (message-buffer-name "bounce"))
- (insert-buffer-substring cur)
- (undo-boundary)
- (message-narrow-to-head)
- (if (and (message-fetch-field "Mime-Version")
- (setq boundary (message-fetch-field "Content-Type")))
- (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
- (setq boundary (concat (match-string 1 boundary) " *\n"
- "Content-Type: message/rfc822"))
- (setq boundary nil)))
- (widen)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
- (or (and boundary
- (re-search-forward boundary nil t)
- (forward-line 2))
- (and (re-search-forward message-unsent-separator nil t)
- (forward-line 1))
- (re-search-forward "^Return-Path:.*\n" nil t))
- ;; We remove everything before the bounced mail.
- (delete-region
- (point-min)
- (if (re-search-forward "^[^ \n\t]+:" nil t)
- (match-beginning 0)
- (point)))
+ (if (stringp (car handles))
+ ;; This is a MIME bounce.
+ (mm-insert-part (car (last handles)))
+ ;; This is a non-MIME bounce, so we try to remove things
+ ;; manually.
+ (mm-insert-part handles)
+ (undo-boundary)
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (or (and (re-search-forward message-unsent-separator nil t)
+ (forward-line 1))
+ (re-search-forward "^Return-Path:.*\n" nil t))
+ ;; We remove everything before the bounced mail.
+ (delete-region
+ (point-min)
+ (if (re-search-forward "^[^ \n\t]+:" nil t)
+ (match-beginning 0)
+ (point))))
+ (mm-enable-multibyte)
+ (mime-to-mml)
(save-restriction
- (message-narrow-to-head)
+ (message-narrow-to-head-1)
(message-remove-header message-ignored-bounced-headers t)
(goto-char (point-max))
(insert mail-header-separator))
(defun message-mail-other-window (&optional to subject)
"Like `message-mail' command, but display mail buffer in another window."
(interactive)
- (let ((pop-up-windows t)
- (special-display-buffer-names nil)
- (special-display-regexps nil)
- (same-window-buffer-names nil)
- (same-window-regexps nil))
- (message-pop-to-buffer (message-buffer-name "mail" to)))
+ (unless (message-mail-user-agent)
+ (let ((pop-up-windows t)
+ (special-display-buffer-names nil)
+ (special-display-regexps nil)
+ (same-window-buffer-names nil)
+ (same-window-regexps nil))
+ (message-pop-to-buffer (message-buffer-name "mail" to))))
(let ((message-this-is-mail t))
- (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
+ (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
+ nil nil 'switch-to-buffer-other-window)))
;;;###autoload
(defun message-mail-other-frame (&optional to subject)
"Like `message-mail' command, but display mail buffer in another frame."
(interactive)
- (let ((pop-up-frames t)
- (special-display-buffer-names nil)
- (special-display-regexps nil)
- (same-window-buffer-names nil)
- (same-window-regexps nil))
- (message-pop-to-buffer (message-buffer-name "mail" to)))
+ (unless (message-mail-user-agent)
+ (let ((pop-up-frames t)
+ (special-display-buffer-names nil)
+ (special-display-regexps nil)
+ (same-window-buffer-names nil)
+ (same-window-regexps nil))
+ (message-pop-to-buffer (message-buffer-name "mail" to))))
(let ((message-this-is-mail t))
- (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
+ (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
+ nil nil 'switch-to-buffer-other-frame)))
;;;###autoload
(defun message-news-other-window (&optional newsgroups subject)
(goto-char (min start end))
(while (< (point) end1)
(or (looking-at "[_\^@- ]")
- (insert (following-char) "\b"))
+ (insert (char-after) "\b"))
(forward-char 1)))))
;;;###autoload
(move-marker end1 (max start end))
(goto-char (min start end))
(while (re-search-forward "\b" end1 t)
- (if (eq (following-char) (char-after (- (point) 2)))
+ (if (eq (char-after) (char-after (- (point) 2)))
(delete-char -2))))))
(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
;; Support for toolbar
-(when (string-match "XEmacs\\|Lucid" emacs-version)
- (require 'messagexmas))
+(eval-when-compile
+ (defvar tool-bar-map)
+ (defvar tool-bar-mode))
+
+(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
+ 'mml-attach-file "attach" message-mode-map)
+ (tool-bar-add-item-from-menu
+ 'ispell-message "spell" message-mode-map)
+ tool-bar-map)))))
;;; Group name completion.
(message-expand-group)
(tab-to-tab-stop)))
-(defvar gnus-active-hashtb)
(defun message-expand-group ()
"Expand the group name under point."
(let* ((b (save-excursion
(message "No matching groups")
(save-selected-window
(pop-to-buffer "*Completions*")
- (buffer-disable-undo (current-buffer))
+ (buffer-disable-undo)
(let ((buffer-read-only nil))
(erase-buffer)
(let ((standard-output (current-buffer)))
(save-excursion
(with-output-to-temp-buffer " *MESSAGE information message*"
(set-buffer " *MESSAGE information message*")
+ (fundamental-mode) ; for Emacs 20.4+
(mapcar 'princ text)
(goto-char (point-min))))
(funcall ask question))
(list list))))
(defun message-generate-new-buffer-clone-locals (name &optional varstr)
- "Create and return a buffer with a name based on NAME using generate-new-buffer.
+ "Create and return a buffer with name based on NAME using `generate-new-buffer.'
Then clone the local variables and values from the old buffer to the
new one, cloning only the locals having a substring matching the
regexp varstr."
(let ((oldbuf (current-buffer)))
(save-excursion
(set-buffer (generate-new-buffer name))
- (message-clone-locals oldbuf)
+ (message-clone-locals oldbuf varstr)
(current-buffer))))
-(defun message-clone-locals (buffer)
+(defun message-clone-locals (buffer &optional varstr)
"Clone the local variables from BUFFER to the current buffer."
(let ((locals (save-excursion
(set-buffer buffer)
(buffer-local-variables)))
- (regexp "^gnus\\|^nn\\|^message"))
+ (regexp "^gnus\\|^nn\\|^message\\|^user-mail-address"))
(mapcar
(lambda (local)
(when (and (consp local)
(car local)
- (string-match regexp (symbol-name (car local))))
+ (string-match regexp (symbol-name (car local)))
+ (or (null varstr)
+ (string-match varstr (symbol-name (car local)))))
(ignore-errors
(set (make-local-variable (car local))
(cdr local)))))
;;; Miscellaneous functions
-;; stolen (and renamed) from nnheader.el
-(defun message-replace-chars-in-string (string from to)
- "Replace characters in STRING from FROM to TO."
- (let ((string (substring string 0)) ;Copy string.
- (len (length string))
- (idx 0))
- ;; Replace all occurrences of FROM with TO.
- (while (< idx len)
- (when (= (aref string idx) from)
- (aset string idx to))
- (setq idx (1+ idx)))
- string))
+(defsubst message-replace-chars-in-string (string from to)
+ (mm-subst-char-in-string from to string))
-(run-hooks 'message-load-hook)
+;;;
+;;; MIME functions
+;;;
+
+(defvar message-inhibit-body-encoding nil)
+
+(defun message-encode-message-body ()
+ (unless message-inhibit-body-encoding
+ (let ((mail-parse-charset (or mail-parse-charset
+ message-default-charset))
+ (case-fold-search t)
+ lines content-type-p)
+ (message-goto-body)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (let ((new (mml-generate-mime)))
+ (when new
+ (delete-region (point-min) (point-max))
+ (insert new)
+ (goto-char (point-min))
+ (if (eq (aref new 0) ?\n)
+ (delete-char 1)
+ (search-forward "\n\n")
+ (setq lines (buffer-substring (point-min) (1- (point))))
+ (delete-region (point-min) (point))))))
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-remove-header "Mime-Version")
+ (goto-char (point-max))
+ (insert "MIME-Version: 1.0\n")
+ (when lines
+ (insert lines))
+ (setq content-type-p
+ (or mml-boundary
+ (re-search-backward "^Content-Type:" nil t))))
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-remove-first-header "Content-Type")
+ (message-remove-first-header "Content-Transfer-Encoding"))
+ ;; We always make sure that the message has a Content-Type header.
+ ;; This is because some broken MTAs and MUAs get awfully confused
+ ;; when confronted with a message with a MIME-Version header and
+ ;; without a Content-Type header. For instance, Solaris'
+ ;; /usr/bin/mail.
+ (unless content-type-p
+ (goto-char (point-min))
+ (re-search-forward "^MIME-Version:")
+ (forward-line 1)
+ (insert "Content-Type: text/plain; charset=us-ascii\n")))))
+
+(defun message-read-from-minibuffer (prompt)
+ "Read from the minibuffer while providing abbrev expansion."
+ (if (fboundp 'mail-abbrevs-setup)
+ (let ((mail-abbrev-mode-regexp "")
+ (minibuffer-setup-hook 'mail-abbrevs-setup)
+ (minibuffer-local-map message-minibuffer-local-map))
+ (read-from-minibuffer prompt))
+ (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
+ (minibuffer-local-map message-minibuffer-local-map))
+ (read-string prompt))))
+
+(defun message-use-alternative-email-as-from ()
+ (require 'mail-utils)
+ (let* ((fields '("To" "Cc"))
+ (emails
+ (split-string
+ (mail-strip-quoted-names
+ (mapconcat 'message-fetch-reply-field fields ","))
+ "[ \f\t\n\r\v,]+"))
+ email)
+ (while emails
+ (if (string-match message-alternative-emails (car emails))
+ (setq email (car emails)
+ emails nil))
+ (pop emails))
+ (unless (or (not email) (equal email user-mail-address))
+ (goto-char (point-max))
+ (insert "From: " email "\n"))))
+
+(defun message-options-get (symbol)
+ (cdr (assq symbol message-options)))
+
+(defun message-options-set (symbol value)
+ (let ((the-cons (assq symbol message-options)))
+ (if the-cons
+ (if value
+ (setcdr the-cons value)
+ (setq message-options (delq the-cons message-options)))
+ (and value
+ (push (cons symbol value) message-options))))
+ value)
+
+(defun message-options-set-recipient ()
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-options-set 'message-sender
+ (mail-strip-quoted-names
+ (message-fetch-field "from")))
+ (message-options-set 'message-recipients
+ (mail-strip-quoted-names
+ (concat
+ (or (message-fetch-field "to") "") ", "
+ (or (message-fetch-field "cc") "") ", "
+ (or (message-fetch-field "bcc") ""))))))
+
+(when (featurep 'xemacs)
+ (require 'messagexmas)
+ (message-xmas-redefine))
(provide 'message)
+(run-hooks 'message-load-hook)
+
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
;;; message.el ends here
projects / elisp / gnus.git- / blobdiff