;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: mail, news
;;; Code:
-(eval-when-compile
- (require 'cl))
+(require 'cl)
(require 'mailheader)
(require 'rmail)
(require 'nnheader)
(require 'timezone)
(require 'easymenu)
+(require 'custom)
(if (string-match "XEmacs\\|Lucid" emacs-version)
(require 'mail-abbrevs)
(require 'mailabbrev))
-;;;###autoload
-(defvar message-directory "~/Mail/"
- "*Directory from which all other mail file variables are derived.")
-
-(defvar message-max-buffers 10
- "*How many buffers to keep before starting to kill them off.")
-
-;;;###autoload
-(defvar message-fcc-handler-function 'rmail-output
+(defgroup message '((user-mail-address custom-variable)
+ (user-full-name custom-variable))
+ "Mail and news message composing."
+ :link '(custom-manual "(message)Top")
+ :group 'mail
+ :group 'news)
+
+(put 'user-mail-address 'custom-type 'string)
+(put 'user-full-name 'custom-type 'string)
+
+(defgroup message-various nil
+ "Various Message Variables"
+ :link '(custom-manual "(message)Various Message Variables")
+ :group 'message)
+
+(defgroup message-buffers nil
+ "Message Buffers"
+ :link '(custom-manual "(message)Message Buffers")
+ :group 'message)
+
+(defgroup message-sending nil
+ "Message Sending"
+ :link '(custom-manual "(message)Sending Variables")
+ :group 'message)
+
+(defgroup message-interface nil
+ "Message Interface"
+ :link '(custom-manual "(message)Interface")
+ :group 'message)
+
+(defgroup message-forwarding nil
+ "Message Forwarding"
+ :link '(custom-manual "(message)Forwarding")
+ :group 'message-interface)
+
+(defgroup message-insertion nil
+ "Message Insertion"
+ :link '(custom-manual "(message)Insertion")
+ :group 'message)
+
+(defgroup message-headers nil
+ "Message Headers"
+ :link '(custom-manual "(message)Message Headers")
+ :group 'message)
+
+(defgroup message-news nil
+ "Composing News Messages"
+ :group 'message)
+
+(defgroup message-mail nil
+ "Composing Mail Messages"
+ :group 'message)
+
+(defgroup message-faces nil
+ "Faces used for message composing."
+ :group 'message
+ :group 'faces)
+
+(defcustom message-directory "~/Mail/"
+ "*Directory from which all other mail file variables are derived."
+ :group 'message-various
+ :type 'directory)
+
+(defcustom message-max-buffers 10
+ "*How many buffers to keep before starting to kill them off."
+ :group 'message-buffers
+ :type 'integer)
+
+(defcustom message-send-rename-function nil
+ "Function called to rename the buffer after sending it."
+ :group 'message-buffers
+ :type 'function)
+
+(defcustom message-fcc-handler-function 'message-output
"*A function called to save outgoing articles.
This function will be called with the name of the file to store the
-article in. The default function is `rmail-output' which saves in Unix
-mailbox format.")
-
-;;;###autoload
-(defvar message-courtesy-message
- "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
+article in. The default function is `message-output' which saves in Unix
+mailbox format."
+ :type '(radio (function-item message-output)
+ (function :tag "Other"))
+ :group 'message-sending)
+
+(defcustom message-courtesy-message
+ "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"
"*This is inserted at the start of a mailed copy of a posted message.
-If this variable is nil, no such courtesy message will be added.")
+If the string contains the format spec \"%s\", the Newsgroups
+the article has been posted to will be inserted there.
+If this variable is nil, no such courtesy message will be added."
+ :group 'message-sending
+ :type 'string)
-;;;###autoload
-(defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
- "*Regexp that matches headers to be removed in resent bounced mail.")
+(defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
+ "*Regexp that matches headers to be removed in resent bounced mail."
+ :group 'message-interface
+ :type 'regexp)
;;;###autoload
-(defvar message-from-style 'default
+(defcustom message-from-style 'default
"*Specifies how \"From\" headers look.
If `nil', they contain just the return address like:
Elvis Parsley <king@grassland.com>
Otherwise, most addresses look like `angles', but they look like
-`parens' if `angles' would need quoting and `parens' would not.")
-
-;;;###autoload
-(defvar message-syntax-checks nil
+`parens' if `angles' would need quoting and `parens' would not."
+ :type '(choice (const :tag "simple" nil)
+ (const parens)
+ (const angles)
+ (const default))
+ :group 'message-headers)
+
+(defcustom message-syntax-checks nil
+ ;; Guess this one shouldn't be easy to customize...
"Controls what syntax checks should not be performed on outgoing posts.
To disable checking of long signatures, for instance, add
`(signature . disabled)' to this list.
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.")
+approved sender empty empty-headers message-id from subject
+shorten-followup-to existing-newsgroups."
+ :group 'message-news)
-;;;###autoload
-(defvar message-required-news-headers
- '(From Newsgroups Subject Date Message-ID
- (optional . Organization) Lines
+(defcustom message-required-news-headers
+ '(From Newsgroups Subject Date Message-ID
+ (optional . Organization) Lines
(optional . X-Newsreader))
- "*Headers to be generated or prompted for when posting an article.
+ "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
-header, remove it from this list.")
+header, remove it from this list."
+ :group 'message-news
+ :group 'message-headers
+ :type '(repeat sexp))
-;;;###autoload
-(defvar message-required-mail-headers
+(defcustom message-required-mail-headers
'(From Subject Date (optional . In-Reply-To) Message-ID Lines
(optional . X-Mailer))
- "*Headers to be generated or prompted for when mailing a message.
+ "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.")
-
-;;;###autoload
-(defvar message-deletable-headers '(Message-ID Date)
- "*Headers to be deleted if they already exist and were generated by message previously.")
-
-;;;###autoload
-(defvar message-ignored-news-headers
- "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:"
- "*Regexp of headers to be removed unconditionally before posting.")
-
-;;;###autoload
-(defvar message-ignored-mail-headers "^Gcc:\\|^Fcc:"
- "*Regexp of headers to be removed unconditionally before mailing.")
-
-;;;###autoload
-(defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:"
+included. Organization, Lines and X-Mailer are optional."
+ :group 'message-mail
+ :group 'message-headers
+ :type '(repeat sexp))
+
+(defcustom message-deletable-headers '(Message-ID Date Lines)
+ "Headers to be deleted if they already exist and were generated by message previously."
+ :group 'message-headers
+ :type 'sexp)
+
+(defcustom message-ignored-news-headers
+ "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:\\|^Resent-Fcc:"
+ "*Regexp of headers to be removed unconditionally before posting."
+ :group 'message-news
+ :group 'message-headers
+ :type 'regexp)
+
+(defcustom message-ignored-mail-headers "^Gcc:\\|^Fcc:\\|^Resent-Fcc:"
+ "*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:\\|Return-Path:\\|^Supersedes:"
"*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.")
-
-;;;###autoload
-(defvar message-signature-separator "^-- *$"
- "Regexp matching the signature separator.")
+any confusion."
+ :group 'message-interface
+ :type 'regexp)
;;;###autoload
-(defvar message-interactive nil
- "Non-nil means when sending a message wait for and display errors.
-nil means let mailer mail back a message to report errors.")
+(defcustom message-signature-separator "^-- *$"
+ "Regexp matching the signature separator."
+ :type 'regexp
+ :group 'message-various)
-;;;###autoload
-(defvar message-generate-new-buffers t
- "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.")
+(defcustom message-elide-elipsis "\n[...]\n\n"
+ "*The string which is inserted for elided text.")
-;;;###autoload
-(defvar message-kill-buffer-on-exit nil
- "*Non-nil means that the message buffer will be killed after sending a message.")
+(defcustom message-interactive nil
+ "Non-nil means when sending a message wait for and display errors.
+nil means let mailer mail back a message to report errors."
+ :group 'message-sending
+ :group 'message-mail
+ :type 'boolean)
+
+(defcustom message-generate-new-buffers t
+ "*Non-nil means that a new message buffer will be created whenever `mail-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)
+ (function fun)))
+
+(defcustom message-kill-buffer-on-exit nil
+ "*Non-nil means that the message buffer will be killed after sending a message."
+ :group 'message-buffers
+ :type 'boolean)
(defvar gnus-local-organization)
-;;;###autoload
-(defvar message-user-organization
+(defcustom message-user-organization
(or (and (boundp 'gnus-local-organization)
+ (stringp gnus-local-organization)
gnus-local-organization)
(getenv "ORGANIZATION")
t)
"*String to be used as an Organization header.
-If t, use `message-user-organization-file'.")
+If t, use `message-user-organization-file'."
+ :group 'message-headers
+ :type '(choice string
+ (const :tag "consult file" t)))
;;;###autoload
-(defvar message-user-organization-file "/usr/lib/news/organization"
- "*Local news organization file.")
+(defcustom message-user-organization-file "/usr/lib/news/organization"
+ "*Local news organization file."
+ :type 'file
+ :group 'message-headers)
-;;;###autoload
-(defvar message-autosave-directory
- (concat (file-name-as-directory message-directory) "drafts/")
+(defcustom message-autosave-directory "~/"
+ ; (concat (file-name-as-directory message-directory) "drafts/")
"*Directory where message autosaves buffers.
-If nil, message won't autosave.")
+If nil, message won't autosave."
+ :group 'message-buffers
+ :type 'directory)
-(defvar message-forward-start-separator
+(defcustom message-forward-start-separator
"------- Start of forwarded message -------\n"
- "*Delimiter inserted before forwarded messages.")
+ "*Delimiter inserted before forwarded messages."
+ :group 'message-forwarding
+ :type 'string)
-(defvar message-forward-end-separator
+(defcustom message-forward-end-separator
"------- End of forwarded message -------\n"
- "*Delimiter inserted after forwarded messages.")
+ "*Delimiter inserted after forwarded messages."
+ :group 'message-forwarding
+ :type 'string)
-;;;###autoload
-(defvar message-signature-before-forwarded-message t
- "*If non-nil, put the signature before any included forwarded message.")
+(defcustom message-signature-before-forwarded-message t
+ "*If non-nil, put the signature before any included forwarded message."
+ :group 'message-forwarding
+ :type 'boolean)
-;;;###autoload
-(defvar message-included-forward-headers
+(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:"
- "*Regexp matching headers to be included in forwarded messages.")
+ "*Regexp matching headers to be included in forwarded messages."
+ :group 'message-forwarding
+ :type 'regexp)
-;;;###autoload
-(defvar message-ignored-resent-headers "^Return-receipt"
- "*All headers that match this regexp will be deleted when resending a message.")
+(defcustom message-ignored-resent-headers "^Return-receipt"
+ "*All headers that match this regexp will be deleted when resending a message."
+ :group 'message-interface
+ :type 'regexp)
-;;;###autoload
-(defvar message-ignored-cited-headers "."
- "Delete these headers from the messages you yank.")
+(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."
+ "Message to be inserted in the cancel message."
+ :group 'message-interface
+ :type 'string)
;; Useful to set in site-init.el
;;;###autoload
-(defvar message-send-mail-function 'message-send-mail-with-sendmail
+(defcustom message-send-mail-function 'message-send-mail-with-sendmail
"Function to call to send the current buffer as mail.
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'.
-Legal values include `message-send-mail-with-mh' and
-`message-send-mail-with-sendmail', which is the default.")
+Legal values include `message-send-mail-with-sendmail' (the default),
+`message-send-mail-with-mh' and `message-send-mail-with-qmail'."
+ :type '(radio (function-item message-send-mail-with-sendmail)
+ (function-item message-send-mail-with-mh)
+ (function-item message-send-mail-with-qmail)
+ (function :tag "Other"))
+ :group 'message-sending
+ :group 'message-mail)
-;;;###autoload
-(defvar message-send-news-function 'message-send-news
+(defcustom message-send-news-function 'message-send-news
"Function to call to send the current buffer as news.
The headers should be delimited by a line whose contents match the
-variable `mail-header-separator'.")
+variable `mail-header-separator'."
+ :group 'message-sending
+ :group 'message-news
+ :type 'function)
-;;;###autoload
-(defvar message-reply-to-function nil
+(defcustom message-reply-to-function 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.")
+and respond with new To and Cc headers."
+ :group 'message-interface
+ :type 'function)
-;;;###autoload
-(defvar message-wide-reply-to-function nil
+(defcustom message-wide-reply-to-function 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.")
+and respond with new To and Cc headers."
+ :group 'message-interface
+ :type 'function)
-;;;###autoload
-(defvar message-followup-to-function nil
+(defcustom message-followup-to-function 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.")
+and respond with new To and Cc headers."
+ :group 'message-interface
+ :type 'function)
-;;;###autoload
-(defvar message-use-followup-to 'ask
+(defcustom message-use-followup-to 'ask
"*Specifies what to do with Followup-To header.
-If nil, ignore the header. If it is t, use its value, but query before
-using the \"poster\" value. If it is the symbol `ask', query the user
-whether to ignore the \"poster\" value. If it is the symbol `use',
-always use the value.")
+If nil, always ignore the header. If it is t, use its value, but
+query before using the \"poster\" value. If it is the symbol `ask',
+always query the user whether to use the value. If it is the symbol
+`use', always use the value."
+ :group 'message-interface
+ :type '(choice (const :tag "ignore" nil)
+ (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."
+ :group 'message-sending
+ :type 'boolean)
+
+;; qmail-related stuff
+(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
+ "Location of the qmail-inject program."
+ :group 'message-sending
+ :type 'file)
+
+(defcustom message-qmail-inject-args nil
+ "Arguments passed to qmail-inject programs.
+This should be a list of strings, one string for each argument.
+
+For e.g., if you wish to set the envelope sender address so that bounces
+go to the right place or to deal with listserv's usage of that address, you
+might set this variable to '(\"-f\" \"you@some.where\")."
+ :group 'message-sending
+ :type '(repeat string))
(defvar gnus-post-method)
(defvar gnus-select-method)
-;;;###autoload
-(defvar message-post-method
+(defcustom message-post-method
(cond ((and (boundp 'gnus-post-method)
gnus-post-method)
gnus-post-method)
((boundp 'gnus-select-method)
gnus-select-method)
(t '(nnspool "")))
- "Method used to post news.")
-
-;;;###autoload
-(defvar message-generate-headers-first nil
- "*If non-nil, generate all possible headers before composing.")
-
-(defvar message-setup-hook nil
+ "Method used to post news."
+ :group 'message-news
+ :group 'message-sending
+ ;; This should be the `gnus-select-method' widget, but that might
+ ;; create a dependence to `gnus.el'.
+ :type 'sexp)
+
+(defcustom message-generate-headers-first nil
+ "*If non-nil, generate all possible headers before composing."
+ :group 'message-headers
+ :type 'boolean)
+
+(defcustom message-setup-hook nil
"Normal hook, run each time a new outgoing message is initialized.
-The function `message-setup' runs this hook.")
+The function `message-setup' runs this hook."
+ :group 'message-various
+ :type 'hook)
-(defvar message-signature-setup-hook nil
+(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
-the signature is inserted.")
-
-(defvar message-mode-hook nil
- "Hook run in message mode buffers.")
-
-(defvar message-header-hook nil
- "Hook run in a message mode buffer narrowed to the headers.")
-
-(defvar message-header-setup-hook nil
- "Hook called narrowed to the headers when setting up a message buffer.")
+It is run after the headers have been inserted and before
+the signature is inserted."
+ :group 'message-various
+ :type 'hook)
+
+(defcustom message-mode-hook nil
+ "Hook run in message mode buffers."
+ :group 'message-various
+ :type 'hook)
+
+(defcustom message-header-hook nil
+ "Hook run in a message mode buffer narrowed to the headers."
+ :group 'message-various
+ :type 'hook)
+
+(defcustom message-header-setup-hook nil
+ "Hook called narrowed to the headers when setting up a message
+buffer."
+ :group 'message-various
+ :type 'hook)
;;;###autoload
-(defvar message-citation-line-function 'message-insert-citation-line
- "*Function called to insert the \"Whomever writes:\" line.")
+(defcustom message-citation-line-function 'message-insert-citation-line
+ "*Function called to insert the \"Whomever writes:\" line."
+ :type 'function
+ :group 'message-insertion)
;;;###autoload
-(defvar message-yank-prefix "> "
+(defcustom message-yank-prefix "> "
"*Prefix inserted on the lines of yanked messages.
-nil means use indentation.")
+nil means use indentation."
+ :type 'string
+ :group 'message-insertion)
-(defvar message-indentation-spaces 3
+(defcustom message-indentation-spaces 3
"*Number of spaces to insert at the beginning of each cited line.
-Used by `message-yank-original' via `message-yank-cite'.")
+Used by `message-yank-original' via `message-yank-cite'."
+ :group 'message-insertion
+ :type 'integer)
;;;###autoload
-(defvar message-cite-function 'message-cite-original
- "*Function for citing an original message.")
+(defcustom message-cite-function
+ (if (and (boundp 'mail-citation-hook)
+ mail-citation-hook)
+ mail-citation-hook
+ 'message-cite-original)
+ "*Function for citing an original message."
+ :type '(radio (function-item message-cite-original)
+ (function-item sc-cite-original)
+ (function :tag "Other"))
+ :group 'message-insertion)
;;;###autoload
-(defvar message-indent-citation-function 'message-indent-citation
+(defcustom message-indent-citation-function 'message-indent-citation
"*Function for modifying a citation just inserted in the mail buffer.
This can also be a list of functions. Each function can find the
citation between (point) and (mark t). And each function should leave
-point and mark around the citation text as modified.")
+point and mark around the citation text as modified."
+ :type 'function
+ :group 'message-insertion)
(defvar message-abbrevs-loaded nil)
;;;###autoload
-(defvar message-signature t
+(defcustom message-signature t
"*String to be inserted at the end of the message buffer.
If t, the `message-signature-file' file will be inserted instead.
If a function, the result from the function will be used instead.
-If a form, the result from the form will be used instead.")
+If a form, the result from the form will be used instead."
+ :type 'sexp
+ :group 'message-insertion)
;;;###autoload
-(defvar message-signature-file "~/.signature"
- "*File containing the text inserted at end of message. buffer.")
-
-(defvar message-distribution-function nil
- "*Function called to return a Distribution header.")
-
-(defvar message-expires 14
- "*Number of days before your article expires.")
-
-(defvar message-user-path nil
+(defcustom message-signature-file "~/.signature"
+ "*File containing the text inserted at end of message buffer."
+ :type 'file
+ :group 'message-insertion)
+
+(defcustom message-distribution-function nil
+ "*Function called to return a Distribution header."
+ :group 'message-news
+ :group 'message-headers
+ :type 'function)
+
+(defcustom message-expires 14
+ "Number of days before your article expires."
+ :group 'message-news
+ :group 'message-headers
+ :link '(custom-manual "(message)News Headers")
+ :type 'integer)
+
+(defcustom message-user-path nil
"If nil, use the NNTP server name in the Path header.
-If stringp, use this; if non-nil, use no host name (user name only).")
+If stringp, use this; if non-nil, use no host name (user name only)."
+ :group 'message-news
+ :group 'message-headers
+ :link '(custom-manual "(message)News Headers")
+ :type '(choice (const :tag "nntp" nil)
+ (string :tag "name")
+ (sexp :tag "none" :format "%t" t)))
(defvar message-reply-buffer nil)
(defvar message-reply-headers nil)
(defvar message-postpone-actions nil
"A list of actions to be performed after postponing a message.")
-;;;###autoload
-(defvar message-default-headers nil
+(defcustom message-default-headers ""
"*A string containing header lines to be inserted in outgoing messages.
It is inserted before you edit the message, so you can edit or delete
-these lines.")
-
-;;;###autoload
-(defvar message-default-mail-headers nil
- "*A string of header lines to be inserted in outgoing mails.")
-
-;;;###autoload
-(defvar message-default-news-headers nil
- "*A string of header lines to be inserted in outgoing news articles.")
+these lines."
+ :group 'message-headers
+ :type 'string)
+
+(defcustom message-default-mail-headers ""
+ "*A string of header lines to be inserted in outgoing mails."
+ :group 'message-headers
+ :group 'message-mail
+ :type 'string)
+
+(defcustom message-default-news-headers ""
+ "*A string of header lines to be inserted in outgoing news
+articles."
+ :group 'message-headers
+ :group 'message-news
+ :type 'string)
;; Note: could use /usr/ucb/mail instead of sendmail;
;; options -t, and -v if not interactive.
-(defvar message-mailer-swallows-blank-line
- (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
+(defcustom message-mailer-swallows-blank-line
+ (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
system-configuration)
(file-readable-p "/etc/sendmail.cf")
(let ((buffer (get-buffer-create " *temp*")))
(re-search-forward "^OR\\>" nil t)))
(kill-buffer buffer))))
;; According to RFC822, "The field-name must be composed of printable
- ;; ASCII characters (i.e. characters that have decimal values between
- ;; 33 and 126, except colon)", i.e. any chars except ctl chars,
+ ;; ASCII characters (i. e., characters that have decimal values between
+ ;; 33 and 126, except colon)", i. e., any chars except ctl chars,
;; space, or colon.
'(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
"Set this non-nil if the system's mailer runs the header and body together.
\(This problem exists on Sunos 4 when sendmail is run in remote mode.)
The value should be an expression to test whether the problem will
-actually occur.")
+actually occur."
+ :group 'message-sending
+ :type 'sexp)
+
+(ignore-errors
+ (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.")
+
+(defvar message-send-method-alist
+ '((news message-news-p message-send-via-news)
+ (mail message-mail-p message-send-via-mail))
+ "Alist of ways to send outgoing messages.
+Each element has the form
-(defvar message-mode-syntax-table
+ \(TYPE PREDICATE FUNCTION)
+
+where TYPE is a symbol that names the method; PREDICATE is a function
+called without any parameters to determine whether the message is
+a message of type TYPE; and FUNCTION is a function to be called if
+PREDICATE returns non-nil. FUNCTION is called with one parameter --
+the prefix.")
+
+(defvar 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.")
+
+;;; Internal variables.
+;;; Well, not really internal.
+
+(defvar message-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-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)
+ (background dark))
+ (:foreground "green2" :bold t))
+ (((class color)
+ (background light))
+ (:foreground "MidnightBlue" :bold t))
+ (t
+ (:bold t :italic t)))
+ "Face used for displaying From headers."
+ :group 'message-faces)
+
+(defface message-header-cc-face
+ '((((class color)
+ (background dark))
+ (:foreground "green4" :bold t))
+ (((class color)
+ (background light))
+ (:foreground "MidnightBlue"))
+ (t
+ (:bold t)))
+ "Face used for displaying Cc headers."
+ :group 'message-faces)
+
+(defface message-header-subject-face
+ '((((class color)
+ (background dark))
+ (:foreground "green3"))
+ (((class color)
+ (background light))
+ (:foreground "navy blue" :bold t))
+ (t
+ (:bold t)))
+ "Face used for displaying subject headers."
+ :group 'message-faces)
+
+(defface message-header-newsgroups-face
+ '((((class color)
+ (background dark))
+ (:foreground "yellow" :bold t :italic t))
+ (((class color)
+ (background light))
+ (:foreground "blue4" :bold t :italic t))
+ (t
+ (:bold t :italic t)))
+ "Face used for displaying newsgroups headers."
+ :group 'message-faces)
+
+(defface message-header-other-face
+ '((((class color)
+ (background dark))
+ (:foreground "red4"))
+ (((class color)
+ (background light))
+ (:foreground "steel blue"))
+ (t
+ (:bold t :italic t)))
+ "Face used for displaying newsgroups headers."
+ :group 'message-faces)
+
+(defface message-header-name-face
+ '((((class color)
+ (background dark))
+ (:foreground "DarkGreen"))
+ (((class color)
+ (background light))
+ (:foreground "cornflower blue"))
+ (t
+ (:bold t)))
+ "Face used for displaying header names."
+ :group 'message-faces)
+
+(defface message-header-xheader-face
+ '((((class color)
+ (background dark))
+ (:foreground "blue"))
+ (((class color)
+ (background light))
+ (:foreground "blue"))
+ (t
+ (:bold t)))
+ "Face used for displaying X-Header headers."
+ :group 'message-faces)
+
+(defface message-separator-face
+ '((((class color)
+ (background dark))
+ (:foreground "blue4"))
+ (((class color)
+ (background light))
+ (:foreground "brown"))
+ (t
+ (:bold t)))
+ "Face used for displaying the separator."
+ :group 'message-faces)
+
+(defface message-cited-text-face
+ '((((class color)
+ (background dark))
+ (:foreground "red"))
+ (((class color)
+ (background light))
+ (:foreground "red"))
+ (t
+ (:bold t)))
+ "Face used for displaying cited text names."
+ :group 'message-faces)
+
(defvar message-font-lock-keywords
- (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")))
- (list '("^To:" . font-lock-function-name-face)
- '("^[GBF]?[Cc][Cc]:\\|^Reply-To:" . font-lock-keyword-face)
- '("^\\(Subject:\\)[ \t]*\\(.+\\)?"
- (1 font-lock-comment-face) (2 font-lock-type-face nil t))
- (list (concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
- 1 'font-lock-comment-face)
- (cons (concat "^[ \t]*"
- "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
- "[>|}].*")
- 'font-lock-reference-face)
- '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*"
- . font-lock-string-face)))
+ (let* ((cite-prefix "A-Za-z")
+ (cite-suffix (concat cite-prefix "0-9_.@-"))
+ (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)"))
+ `((,(concat "^\\([Tt]o:\\)" content)
+ (1 'message-header-name-face)
+ (2 'message-header-to-face nil t))
+ (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)
+ (1 'message-header-name-face)
+ (2 'message-header-cc-face nil t))
+ (,(concat "^\\([Ss]ubject:\\)" content)
+ (1 'message-header-name-face)
+ (2 'message-header-subject-face nil t))
+ (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
+ (1 'message-header-name-face)
+ (2 'message-header-newsgroups-face nil t))
+ (,(concat "^\\([^: \n\t]+:\\)" content)
+ (1 'message-header-name-face)
+ (2 'message-header-other-face nil t))
+ (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
+ (1 'message-header-name-face)
+ (2 'message-header-name-face))
+ (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
+ 1 'message-separator-face)
+ (,(concat "^[ \t]*"
+ "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
+ "[>|}].*")
+ (0 'message-cited-text-face))))
"Additional expressions to highlight in Message mode.")
(defvar message-face-alist
'((bold . bold-region)
(underline . underline-region)
- (default . (lambda (b e)
+ (default . (lambda (b e)
(unbold-region b e)
(ununderline-region b e))))
"Alist of mail and news faces for facemenu.
The cdr of ech entry is a function for applying the face to a region.")
-(defvar message-send-hook nil
- "Hook run before sending messages.")
+(defcustom message-send-hook nil
+ "Hook run before sending messages."
+ :group 'message-various
+ :options '(ispell-message)
+ :type 'hook)
+
+(defcustom message-send-mail-hook nil
+ "Hook run before sending mail messages."
+ :group 'message-various
+ :type 'hook)
-(defvar message-sent-hook nil
- "Hook run after sending messages.")
+(defcustom message-send-news-hook nil
+ "Hook run before sending news messages."
+ :group 'message-various
+ :type 'hook)
+
+(defcustom message-sent-hook nil
+ "Hook run after sending messages."
+ :group 'message-various
+ :type 'hook)
;;; Internal variables.
(defvar message-buffer-list nil)
+(defvar message-this-is-news nil)
+(defvar message-this-is-mail nil)
+
+;; Byte-compiler warning
+(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 ^.
+;;; (UNIX From lines), minus the initial ^.
(defvar message-unix-mail-delimiter
(let ((time-zone-regexp
(concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
"^|? *---+ +Message text follows: +---+ *|?$")
"A regexp that matches the separator before the text of a failed message.")
-(defvar message-header-format-alist
+(defvar message-header-format-alist
`((Newsgroups)
- (To . message-fill-address)
+ (To . message-fill-address)
(Cc . message-fill-address)
(Subject)
(In-Reply-To)
(Lines)
(Expires)
(Message-ID)
- (References . message-fill-header)
+ (References)
(X-Mailer)
(X-Newsreader))
"Alist used for formatting headers.")
(eval-and-compile
(autoload 'message-setup-toolbar "messagexmas")
- (autoload 'mh-send-letter "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 'mail-abbrev-in-expansion-header-p "mailabbrev"))
\f
-;;;
+;;;
;;; Utility functions.
;;;
-(defun message-point-at-bol ()
- "Return point at the beginning of the line."
- (let ((p (point)))
- (beginning-of-line)
- (prog1
- (point)
- (goto-char p))))
-
-(defun message-point-at-eol ()
- "Return point at the end of the line."
- (let ((p (point)))
- (end-of-line)
- (prog1
- (point)
- (goto-char p))))
+(defmacro message-y-or-n-p (question show &rest text)
+ "Ask QUESTION, displaying the rest of the arguments in a temp. 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)
(defun message-tokenize-header (header &optional separator)
"Split HEADER into a list of header elements.
\",\" is used as the separator."
- (let* ((beg 0)
- (separator (or separator ","))
- (regexp
- (format "[ \t]*\\([^%s]+\\)?\\([%s]+\\|\\'\\)" separator separator))
- elems)
- (while (and (string-match regexp header beg)
- (< beg (length header)))
- (when (match-beginning 1)
- (push (match-string 1 header) elems))
- (setq beg (match-end 0)))
- (nreverse elems)))
-
-(defun message-fetch-field (header)
+ (if (not header)
+ nil
+ (let ((regexp (format "[%s]+" (or separator ",")))
+ (beg 1)
+ (first t)
+ quoted elems paren)
+ (save-excursion
+ (message-set-work-buffer)
+ (insert header)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if first
+ (setq first nil)
+ (forward-char 1))
+ (cond ((and (> (point) beg)
+ (or (eobp)
+ (and (looking-at regexp)
+ (not quoted)
+ (not paren))))
+ (push (buffer-substring beg (point)) elems)
+ (setq beg (match-end 0)))
+ ((= (following-char) ?\")
+ (setq quoted (not quoted)))
+ ((and (= (following-char) ?\()
+ (not quoted))
+ (setq paren t))
+ ((and (= (following-char) ?\))
+ (not quoted))
+ (setq paren nil))))
+ (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
+ (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 ((value (mail-fetch-field header)))
+ (let ((value (mail-fetch-field header nil (not not-all))))
(when value
(nnheader-replace-chars-in-string value ?\n ? ))))
+(defun message-add-header (&rest headers)
+ "Add the HEADERS to the message header, skipping those already present."
+ (while headers
+ (let (hclean)
+ (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))))
+ (setq headers (cdr headers))))
+
(defun message-fetch-reply-field (header)
"Fetch FIELD from the message we're replying to."
(when (and message-reply-buffer
(defun message-functionp (form)
"Return non-nil if FORM is funcallable."
(or (and (symbolp form) (fboundp form))
- (and (listp form) (eq (car form) 'lambda))))
+ (and (listp form) (eq (car form) 'lambda))
+ (compiled-function-p form)))
(defun message-strip-subject-re (subject)
"Remove \"Re:\" from subject lines."
(defun message-news-p ()
"Say whether the current buffer contains a news message."
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (message-fetch-field "newsgroups"))))
+ (or message-this-is-news
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "newsgroups")))))
(defun message-mail-p ()
"Say whether the current buffer contains a mail message."
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (or (message-fetch-field "to")
- (message-fetch-field "cc")
- (message-fetch-field "bcc")))))
+ (or message-this-is-mail
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (or (message-fetch-field "to")
+ (message-fetch-field "cc")
+ (message-fetch-field "bcc"))))))
(defun message-next-header ()
"Go to the beginning of the next header."
(not (if (re-search-forward "^[^ \t]" nil t)
(beginning-of-line)
(goto-char (point-max)))))
-
+
(defun message-sort-headers-1 ()
"Sort the buffer as headers using `message-rank' text props."
(goto-char (point-min))
- (sort-subr
- nil 'message-next-header
+ (sort-subr
+ nil 'message-next-header
(lambda ()
(message-next-header)
(unless (bobp)
(forward-char -1)))
(lambda ()
(or (get-text-property (point) 'message-rank)
- 0))))
+ 10000))))
(defun message-sort-headers ()
"Sort the headers of the current message according to `message-header-format-alist'."
(define-key message-mode-map "\C-c\C-t" 'message-insert-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\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\C-k" 'message-kill-buffer)
(define-key message-mode-map "\C-c\C-d" 'message-dont-send)
+ (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
+
(define-key message-mode-map "\t" 'message-tab))
-(easy-menu-define message-mode-menu message-mode-map
- "Message Menu."
- '("Message"
- "Go to Field:"
- "----"
- ["To" message-goto-to t]
- ["Subject" message-goto-subject t]
- ["Cc" message-goto-cc t]
- ["Reply-to" message-goto-reply-to t]
- ["Summary" message-goto-summary t]
- ["Keywords" message-goto-keywords t]
- ["Newsgroups" message-goto-newsgroups t]
- ["Followup-To" message-goto-followup-to t]
- ["Distribution" message-goto-distribution t]
- ["Body" message-goto-body t]
- ["Signature" message-goto-signature t]
- "----"
- "Miscellaneous Commands:"
- "----"
- ["Sort Headers" message-sort-headers t]
- ["Yank Original" message-yank-original t]
- ["Fill Yanked Message" message-fill-yanked-message t]
- ["Insert Signature" message-insert-signature t]
- ["Caesar (rot13) Message" message-caesar-buffer-body t]
- ["Rename buffer" message-rename-buffer t]
- ["Spellcheck" ispell-message t]
- "----"
- ["Send Message" message-send-and-exit t]
- ["Abort Message" message-dont-send t]))
+(easy-menu-define
+ message-mode-menu message-mode-map "Message Menu."
+ '("Message"
+ ["Sort Headers" message-sort-headers t]
+ ["Yank Original" message-yank-original t]
+ ["Fill Yanked Message" message-fill-yanked-message t]
+ ["Insert Signature" message-insert-signature t]
+ ["Caesar (rot13) Message" message-caesar-buffer-body t]
+ ["Caesar (rot13) Region" message-caesar-region (mark t)]
+ ["Elide Region" message-elide-region (mark t)]
+ ["Rename buffer" message-rename-buffer t]
+ ["Spellcheck" ispell-message t]
+ "----"
+ ["Send Message" message-send-and-exit t]
+ ["Abort Message" message-dont-send t]))
+
+(easy-menu-define
+ message-mode-field-menu message-mode-map ""
+ '("Field"
+ ["Fetch To" message-insert-to t]
+ ["Fetch Newsgroups" message-insert-newsgroups t]
+ "----"
+ ["To" message-goto-to t]
+ ["Subject" message-goto-subject t]
+ ["Cc" message-goto-cc t]
+ ["Reply-To" message-goto-reply-to t]
+ ["Summary" message-goto-summary t]
+ ["Keywords" message-goto-keywords t]
+ ["Newsgroups" message-goto-newsgroups t]
+ ["Followup-To" message-goto-followup-to t]
+ ["Distribution" message-goto-distribution t]
+ ["Body" message-goto-body t]
+ ["Signature" message-goto-signature t]))
(defvar facemenu-add-face-function)
(defvar facemenu-remove-face-function)
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-f move to Fcc C-c C-f C-r move to Reply-To
+ C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To
C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups
C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution
- C-c C-f C-o move to Followup-To
+ 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-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-r message-ceasar-buffer-body (rot13 the message body)."
+C-c C-e message-elide-region (elide the text between point and mark).
+C-c C-r message-caesar-buffer-body (rot13 the message body)."
(interactive)
(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)
+ (make-local-variable 'message-send-actions)
+ (make-local-variable 'message-exit-actions)
(make-local-variable 'message-kill-actions)
(make-local-variable 'message-postpone-actions)
(set-syntax-table message-mode-syntax-table)
(use-local-map message-mode-map)
- (setq local-abbrev-table text-mode-abbrev-table)
+ (setq local-abbrev-table message-mode-abbrev-table)
(setq major-mode 'message-mode)
(setq mode-name "Message")
(setq buffer-offer-save t)
(make-local-variable 'paragraph-start)
(setq paragraph-start (concat (regexp-quote mail-header-separator)
"$\\|[ \t]*[-_][-_][-_]+$\\|"
+ "-- $\\|"
paragraph-start))
(setq paragraph-separate (concat (regexp-quote mail-header-separator)
"$\\|[ \t]*[-_][-_][-_]+$\\|"
+ "-- $\\|"
paragraph-separate))
(make-local-variable 'message-reply-headers)
(setq message-reply-headers nil)
(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 (fboundp 'mail-hist-define-keys)
+ ;; (mail-hist-define-keys))
(when (string-match "XEmacs\\|Lucid" emacs-version)
(message-setup-toolbar))
(easy-menu-add message-mode-menu message-mode-map)
+ (easy-menu-add message-mode-field-menu message-mode-map)
;; Allow mail alias things.
- (if (fboundp 'mail-abbrevs-setup)
- (mail-abbrevs-setup)
- (funcall (intern "mail-aliases-setup")))
+ (when (eq message-mail-alias-type 'abbrev)
+ (if (fboundp 'mail-abbrevs-setup)
+ (mail-abbrevs-setup)
+ (funcall (intern "mail-aliases-setup"))))
(run-hooks 'text-mode-hook 'message-mode-hook))
\f
"Move point to the beginning of the message signature."
(interactive)
(goto-char (point-min))
- (or (re-search-forward message-signature-separator nil t)
- (goto-char (point-max))))
+ (if (re-search-forward message-signature-separator nil t)
+ (forward-line 1)
+ (goto-char (point-max))))
\f
-(defun message-insert-to ()
- "Insert a To header that points to the author of the article being replied to."
- (interactive)
- (when (message-position-on-field "To")
+(defun message-insert-to (&optional force)
+ "Insert a To header that points to the author of the article being replied to.
+If the original author requested not to be sent mail, the function signals
+an error.
+With the prefix argument FORCE, insert the header anyway."
+ (interactive "P")
+ (let ((co (message-fetch-reply-field "mail-copies-to")))
+ (when (and (null force)
+ co
+ (equal (downcase co) "never"))
+ (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")
(message-fetch-reply-field "from") "")))
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
(interactive)
- (when (message-position-on-field "Newsgroups")
+ (when (and (message-position-on-field "Newsgroups")
+ (mail-fetch-field "newsgroups")
+ (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
(insert ","))
(insert (or (message-fetch-reply-field "newsgroups") "")))
(defun message-insert-signature (&optional force)
"Insert a signature. See documentation for the `message-signature' variable."
- (interactive (list t))
- (let* ((signature
- (cond ((and (null message-signature)
- force)
- t)
- ((message-functionp message-signature)
- (funcall message-signature))
- ((listp message-signature)
- (eval message-signature))
- (t message-signature)))
+ (interactive (list 0))
+ (let* ((signature
+ (cond
+ ((and (null message-signature)
+ (eq force 0))
+ (save-excursion
+ (goto-char (point-max))
+ (not (re-search-backward
+ message-signature-separator nil t))))
+ ((and (null message-signature)
+ force)
+ t)
+ ((message-functionp message-signature)
+ (funcall message-signature))
+ ((listp message-signature)
+ (eval message-signature))
+ (t message-signature)))
(signature
(cond ((stringp signature)
signature)
(file-exists-p message-signature-file))
signature))))
(when signature
- ;; Remove blank lines at the end of the message.
(goto-char (point-max))
- (skip-chars-backward " \t\n")
- (end-of-line)
- (delete-region (point) (point-max))
;; Insert the signature.
- (insert "\n\n-- \n")
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n-- \n")
(if (eq signature t)
(insert-file-contents message-signature-file)
(insert signature))
(goto-char (point-max))
(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 text was killed."
+ (interactive "r")
+ (kill-region b e)
+ (unless (bolp)
+ (insert "\n"))
+ (insert message-elide-elipsis))
+
(defvar message-caesar-translation-table nil)
(defun message-caesar-region (b e &optional n)
;; We build the table, if necessary.
(when (or (not message-caesar-translation-table)
(/= (aref message-caesar-translation-table ?a) (+ ?a n)))
- (let ((i -1)
- (table (make-string 256 0)))
- (while (< (incf i) 256)
- (aset table i i))
- (setq table
- (concat
- (substring table 0 ?A)
- (substring table (+ ?A n) (+ ?A n (- 26 n)))
- (substring table ?A (+ ?A n))
- (substring table (+ ?A 26) ?a)
- (substring table (+ ?a n) (+ ?a n (- 26 n)))
- (substring table ?a (+ ?a n))
- (substring table (+ ?a 26) 255)))
- (setq message-caesar-translation-table table)))
- ;; Then we translate the region. Do it this way to retain
+ (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
+ (subst-char-in-region
b (1+ b) (char-after b)
(aref message-caesar-translation-table (char-after b)))
(incf b))))
+(defun message-make-caesar-translation-table (n)
+ "Create a rot table with offset N."
+ (let ((i -1)
+ (table (make-string 256 0)))
+ (while (< (incf i) 256)
+ (aset table i i))
+ (concat
+ (substring table 0 ?A)
+ (substring table (+ ?A n) (+ ?A n (- 26 n)))
+ (substring table ?A (+ ?A n))
+ (substring table (+ ?A 26) ?a)
+ (substring table (+ ?a n) (+ ?a n (- 26 n)))
+ (substring table ?a (+ ?a 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 possibly offensive messages (commonly in net.jokes).
(narrow-to-region (point) (point-max)))
(message-caesar-region (point-min) (point-max) rotnum))))
+(defun message-pipe-buffer-body (program)
+ "Pipe the message body in the current buffer through PROGRAM."
+ (save-excursion
+ (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))))))
+
(defun message-rename-buffer (&optional enter-string)
- "Rename the *message* buffer to \"*message* RECIPIENT\".
+ "Rename the *message* buffer to \"*message* RECIPIENT\".
If the function is run with a prefix, it will ask for a new buffer
name, rather than giving an automatic name."
(interactive "Pbuffer name: ")
(save-excursion
(save-restriction
(goto-char (point-min))
- (narrow-to-region (point)
+ (narrow-to-region (point)
(search-forward mail-header-separator nil 'end))
- (let* ((mail-to (if (message-news-p) (message-fetch-field "Newsgroups")
- (message-fetch-field "To")))
+ (let* ((mail-to (or
+ (if (message-news-p) (message-fetch-field "Newsgroups")
+ (message-fetch-field "To"))
+ ""))
(mail-trimmed-to
(if (string-match "," mail-to)
(concat (substring mail-to 0 (match-beginning 0)) ", ...")
(name-default (concat "*message* " mail-trimmed-to))
(name (if enter-string
(read-string "New buffer name: " name-default)
- name-default)))
+ name-default))
+ (default-directory
+ (file-name-as-directory message-autosave-directory)))
(rename-buffer name t)))))
(defun message-fill-yanked-message (&optional justifyp)
(let ((start (point)))
;; Remove unwanted headers.
(when message-ignored-cited-headers
- (save-restriction
- (narrow-to-region
- (goto-char start)
- (if (search-forward "\n\n" nil t)
- (1- (point))
- (point)))
- (message-remove-header message-ignored-cited-headers t)))
+ (let (all-removed)
+ (save-restriction
+ (narrow-to-region
+ (goto-char start)
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point)))
+ (message-remove-header message-ignored-cited-headers t)
+ (when (= (point-min) (point-max))
+ (setq all-removed t))
+ (goto-char (point-max)))
+ (if all-removed
+ (goto-char start)
+ (forward-line 1))))
+ ;; Delete blank lines at the start of the buffer.
+ (while (and (point-min)
+ (eolp)
+ (not (eobp)))
+ (message-delete-line))
+ ;; Delete blank lines at the end of the buffer.
+ (goto-char (point-max))
+ (unless (eolp)
+ (insert "\n"))
+ (while (and (zerop (forward-line -1))
+ (looking-at "$"))
+ (message-delete-line))
;; Do the indentation.
(if (null message-yank-prefix)
(indent-rigidly start (mark t) message-indentation-spaces)
(goto-char start)
(while (< (point) (mark t))
(insert message-yank-prefix)
- (forward-line 1)))
- (goto-char start))))
+ (forward-line 1))))
+ (goto-char start)))
(defun message-yank-original (&optional arg)
"Insert the message being replied to, if any.
Normally indents each nonblank line ARG spaces (default 3). However,
if `message-yank-prefix' is non-nil, insert that prefix on each line.
+This function uses `message-cite-function' to do the actual citing.
+
Just \\[universal-argument] as argument means don't indent, insert no
prefix, and don't delete any headers."
(interactive "P")
(delete-windows-on message-reply-buffer t)
(insert-buffer message-reply-buffer)
(funcall message-cite-function)
- (exchange-point-and-mark)
+ (message-exchange-point-and-mark)
(unless (bolp)
(insert ?\n))
(unless modified
- (setq message-checksum (message-checksum))))))
+ (setq message-checksum (cons (message-checksum) (buffer-size)))))))
-(defun message-cite-original ()
+(defun message-cite-original ()
+ "Cite function in the standard Message manner."
(let ((start (point))
- (functions
+ (functions
(when message-indent-citation-function
(if (listp message-indent-citation-function)
message-indent-citation-function
(narrow-to-region
(goto-char (point-min))
(progn
- (re-search-forward
+ (re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$"))
(match-beginning 0)))
(goto-char (point-min))
(skip-chars-backward "\n")
t)
(while (and afters
- (not (re-search-forward
+ (not (re-search-forward
(concat "^" (regexp-quote (car afters)) ":")
nil t)))
(pop afters))
(save-excursion
(let ((start (point))
mark)
- (if (not (re-search-forward message-signature-separator (mark t) t))
- ;; No signature here, so we just indent the cited text.
+ (if (not (re-search-forward message-signature-separator (mark t) t))
+ ;; No signature here, so we just indent the cited text.
+ (message-indent-citation)
+ ;; Find the last non-empty line.
+ (forward-line -1)
+ (while (looking-at "[ \t]*$")
+ (forward-line -1))
+ (forward-line 1)
+ (setq mark (set-marker (make-marker) (point)))
+ (goto-char start)
(message-indent-citation)
- ;; Find the last non-empty line.
- (forward-line -1)
- (while (looking-at "[ \t]*$")
- (forward-line -1))
- (forward-line 1)
- (setq mark (set-marker (make-marker) (point)))
- (goto-char start)
- (message-indent-citation)
- ;; Enable undoing the deletion.
- (undo-boundary)
- (delete-region mark (mark t))
- (set-marker mark nil)))))
+ ;; Enable undoing the deletion.
+ (undo-boundary)
+ (delete-region mark (mark t))
+ (set-marker mark nil)))))
\f
(defun message-dont-send ()
"Don't send the message you have been editing."
(interactive)
- (message-bury (current-buffer))
- (message-do-actions message-postpone-actions))
+ (let ((actions message-postpone-actions))
+ (message-bury (current-buffer))
+ (message-do-actions actions)))
(defun message-kill-buffer ()
"Kill the current buffer."
(interactive)
- (let ((actions message-kill-actions))
- (kill-buffer (current-buffer))
- (message-do-actions actions)))
+ (when (or (not (buffer-modified-p))
+ (yes-or-no-p "Message modified; kill anyway? "))
+ (let ((actions message-kill-actions))
+ (kill-buffer (current-buffer))
+ (message-do-actions actions))))
(defun message-bury (buffer)
"Bury this mail buffer."
(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...")
- (when (and (or (not (message-news-p))
- (and (or (not (memq 'news message-sent-message-via))
- (y-or-n-p
- "Already sent message via news; resend? "))
- (funcall message-send-news-function arg)))
- (or (not (message-mail-p))
- (and (or (not (memq 'mail message-sent-message-via))
- (y-or-n-p
- "Already sent message via mail; resend? "))
- (message-send-mail arg))))
- (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")
- ;; If buffer has no file, mark it as unmodified and delete autosave.
- (unless buffer-file-name
- (set-buffer-modified-p nil)
- (delete-auto-save-file-if-necessary t))
- ;; Delete other mail buffers and stuff.
- (message-do-send-housekeeping)
- (message-do-actions message-send-actions)
- ;; Return success.
- t)))
+ (let ((alist message-send-method-alist)
+ elem sent)
+ (while (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))))
+ (funcall (caddr elem) arg))))
+ (setq sent t)))
+ (when 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")
+ ;; If buffer has no file, mark it as unmodified and delete autosave.
+ (unless buffer-file-name
+ (set-buffer-modified-p nil)
+ (delete-auto-save-file-if-necessary t))
+ ;; 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."
+ (message-send-mail arg))
+
+(defun message-send-via-news (arg)
+ "Send the current message via news."
+ (funcall message-send-news-function arg))
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
"Perform all actions in ACTIONS."
;; Now perform actions on successful sending.
(while actions
- (condition-case nil
- (cond
- ;; A simple function.
- ((message-functionp (car actions))
- (funcall (car actions)))
- ;; Something to be evaled.
- (t
- (eval (car actions))))
- (error))
+ (ignore-errors
+ (cond
+ ;; A simple function.
+ ((message-functionp (car actions))
+ (funcall (car actions)))
+ ;; Something to be evaled.
+ (t
+ (eval (car actions)))))
(pop actions)))
(defun message-send-mail (&optional arg)
(require 'mail-utils)
- (let ((tembuf (generate-new-buffer " message temp"))
+ (let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
(case-fold-search nil)
(news (message-news-p))
(mailbuf (current-buffer)))
(save-excursion
(set-buffer tembuf)
(erase-buffer)
- (insert-buffer-substring mailbuf)
+ ;; Avoid copying text props.
+ (insert (format
+ "%s" (save-excursion
+ (set-buffer mailbuf)
+ (buffer-string))))
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
(replace-match "\n")
(backward-char 1)
(setq delimline (point-marker))
+ (run-hooks 'message-send-mail-hook)
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
(goto-char (1+ delimline))
nil errbuf nil "-oi")
;; Always specify who from,
;; since some systems have broken sendmails.
- (list "-f" (user-login-name))
+ ;; 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)))
;; These mean "report errors by mail"
;; and "deliver in background".
(if (null message-interactive) '("-oem" "-odb"))
(when (bufferp errbuf)
(kill-buffer errbuf)))))
+(defun message-send-mail-with-qmail ()
+ "Pass the prepared message buffer to qmail-inject.
+Refer to the documentation for the variable `message-send-mail-function'
+to find out how to use this."
+ ;; 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)
+ ;; send the message
+ (case
+ (apply
+ 'call-process-region 1 (point-max) message-qmail-inject-program
+ nil nil nil
+ ;; qmail-inject's default behaviour is to look for addresses on the
+ ;; command line; if there're none, it scans the headers.
+ ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
+ ;;
+ ;; in general, ALL of qmail-inject's defaults are perfect for simply
+ ;; reading a formatted (i. e., at least a To: or Resent-To header)
+ ;; message from stdin.
+ ;;
+ ;; qmail also has the advantage of not having been raped by
+ ;; various vendors, so we don't have to allow for that, either --
+ ;; compare this with message-send-mail-with-sendmail and weep
+ ;; for sendmail's lost innocence.
+ ;;
+ ;; all this is way cool coz it lets us keep the arguments entirely
+ ;; free for -inject-arguments -- a big win for the user and for us
+ ;; since we don't have to play that double-guessing game and the user
+ ;; gets full control (no gestapo'ish -f's, for instance). --sj
+ message-qmail-inject-args)
+ ;; qmail-inject doesn't say anything on it's stdout/stderr,
+ ;; we have to look at the retval instead
+ (0 nil)
+ (1 (error "qmail-inject reported permanent failure."))
+ (111 (error "qmail-inject reported transient failure."))
+ ;; should never happen
+ (t (error "qmail-inject reported unknown failure."))))
+
(defun message-send-mail-with-mh ()
"Send the prepared message buffer with mh."
(let ((mh-previous-window-config nil)
(name (make-temp-name
- (concat (file-name-as-directory message-autosave-directory)
+ (concat (file-name-as-directory
+ (expand-file-name message-autosave-directory))
"msg."))))
(setq buffer-file-name name)
- (mh-send-letter)
- (condition-case ()
- (delete-file name)
- (error nil))))
+ ;; MH wants to generate these headers itself.
+ (when message-mh-deletable-headers
+ (let ((headers message-mh-deletable-headers))
+ (while headers
+ (goto-char (point-min))
+ (and (re-search-forward
+ (concat "^" (symbol-name (car headers)) ": *") nil t)
+ (message-delete-line))
+ (pop headers))))
+ (run-hooks 'message-send-mail-hook)
+ ;; Pass it on to mh.
+ (mh-send-letter)))
(defun message-send-news (&optional arg)
- (let ((tembuf (generate-new-buffer " *message temp*"))
+ (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)
(message-generate-headers message-required-news-headers)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
- (when (message-check-news-syntax)
+ (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)
- (insert-buffer-substring messbuf)
+ (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)
(or (= (preceding-char) ?\n)
(insert ?\n))
(let ((case-fold-search t))
- ;; Remove the delimeter.
+ ;; 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))
;;; Header generation & syntax checking.
;;;
-(defun message-check-news-syntax ()
- "Check the syntax of the message."
- (and
- ;; We narrow to the headers and check them first.
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (and
- ;; Check for commands in Subject.
- (or
- (message-check-element 'subject-cmsg)
- (save-excursion
- (if (string-match "^cmsg " (message-fetch-field "subject"))
- (y-or-n-p
- "The control code \"cmsg \" is in the subject. Really post? ")
- t)))
- ;; Check for multiple identical headers.
- (or (message-check-element 'multiple-headers)
- (save-excursion
- (let (found)
- (while (and (not found)
- (re-search-forward "^[^ \t:]+: " nil t))
- (save-excursion
- (or (re-search-forward
- (concat "^" (setq found
- (buffer-substring
- (match-beginning 0)
- (- (match-end 0) 2))))
- nil t)
- (setq found nil))))
- (if found
- (y-or-n-p
- (format "Multiple %s headers. Really post? " found))
- t))))
- ;; Check for Version and Sendsys.
- (or (message-check-element 'sendsys)
- (save-excursion
- (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
- (y-or-n-p
- (format "The article contains a %s command. Really post? "
- (buffer-substring (match-beginning 0)
- (1- (match-end 0)))))
- t)))
- ;; See whether we can shorten Followup-To.
- (or (message-check-element 'shorten-followup-to)
- (let ((newsgroups (message-fetch-field "newsgroups"))
- (followup-to (message-fetch-field "followup-to"))
- to)
- (when (and newsgroups (string-match "," newsgroups)
- (not followup-to)
- (not
- (zerop
- (length
- (setq to (completing-read
- "Followups to: (default all groups) "
- (mapcar (lambda (g) (list g))
- (cons "poster"
- (message-tokenize-header
- newsgroups)))))))))
- (goto-char (point-min))
- (insert "Followup-To: " to "\n"))
- t))
-
- ;; Check for Approved.
- (or (message-check-element 'approved)
- (save-excursion
- (if (re-search-forward "^Approved:" nil t)
- (y-or-n-p
- "The article contains an Approved header. Really post? ")
- t)))
- ;; Check the Message-Id header.
- (or (message-check-element 'message-id)
- (save-excursion
- (let* ((case-fold-search t)
- (message-id (message-fetch-field "message-id")))
- (or (not message-id)
- (and (string-match "@" message-id)
- (string-match "@[^\\.]*\\." message-id))
- (y-or-n-p
- (format
- "The Message-ID looks strange: \"%s\". Really post? "
- message-id))))))
- ;; Check the Subject header.
- (or
- (message-check-element 'subject)
- (save-excursion
- (let* ((case-fold-search t)
- (subject (message-fetch-field "subject")))
- (or
- (and subject
- (not (string-match "\\`[ \t]*\\'" subject)))
- (progn
- (message
- "The subject field is empty or missing. Posting is denied.")
- nil)))))
- ;; Check the Newsgroups & Followup-To headers.
- (or
- (message-check-element 'existing-newsgroups)
- (let* ((case-fold-search t)
- (newsgroups (message-fetch-field "newsgroups"))
- (followup-to (message-fetch-field "followup-to"))
- (groups (message-tokenize-header
- (if followup-to
- (concat newsgroups "," followup-to)
- newsgroups)))
- (hashtb (and (boundp 'gnus-active-hashtb)
- gnus-active-hashtb))
- errors)
- (if (not hashtb)
- 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.
- (or
- (message-check-element '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)))))
- ;; Check the From header.
- (or
- (message-check-element 'from)
- (save-excursion
- (let* ((case-fold-search t)
- (from (message-fetch-field "from")))
- (cond
- ((not from)
- (message "There is no From line. Posting is denied.")
- nil)
- ((not (string-match "@[^\\.]*\\." from))
- (message
- "Denied posting -- the From looks strange: \"%s\"." from)
- nil)
- ((string-match "@[^@]*@" from)
- (message
- "Denied posting -- two \"@\"'s in the From header: %s." from)
- nil)
- ((string-match "(.*).*(.*)" from)
- (message
- "Denied posting -- the From header looks strange: \"%s\"."
- from)
- nil)
- (t t))))))))
- ;; Check for long lines.
- (or (message-check-element 'long-lines)
+(defmacro message-check (type &rest forms)
+ "Eval FORMS if TYPE is to be checked."
+ `(or (message-check-element ,type)
(save-excursion
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (while (and
- (progn
- (end-of-line)
- (< (current-column) 80))
- (zerop (forward-line 1))))
- (or (bolp)
- (eobp)
- (y-or-n-p
- "You have lines longer than 79 characters. Really post? "))))
- ;; Check whether the article is empty.
- (or (message-check-element 'empty)
- (save-excursion
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1)
- (let ((b (point)))
- (or (re-search-forward message-signature-separator nil t)
- (goto-char (point-max)))
- (beginning-of-line)
- (or (re-search-backward "[^ \n\t]" b t)
- (y-or-n-p "Empty article. Really post? ")))))
- ;; Check for control characters.
- (or (message-check-element 'control-chars)
- (save-excursion
- (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
- (y-or-n-p
- "The article contains control characters. Really post? ")
- t)))
- ;; Check excessive size.
- (or (message-check-element 'size)
- (if (> (buffer-size) 60000)
- (y-or-n-p
- (format "The article is %d octets long. Really post? "
- (buffer-size)))
- t))
- ;; Check whether any new text has been added.
- (or (message-check-element 'new-text)
- (not message-checksum)
- (not (eq (message-checksum) message-checksum))
- (y-or-n-p
- "It looks like no new text has been added. Really post? "))
- ;; Check the length of the signature.
- (or
- (message-check-element 'signature)
- (progn
- (goto-char (point-max))
- (if (or (not (re-search-backward "^-- $" 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? "
- (count-lines (point) (point-max))))
- t))))))
+ ,@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."
(and (consp able)
(eq (cdr able) 'disabled)))))
+(defun message-check-news-syntax ()
+ "Check the syntax of the message."
+ (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)))))
+
+(defun message-check-news-header-syntax ()
+ (and
+ ;; Check the Subject header.
+ (message-check 'subject
+ (let* ((case-fold-search t)
+ (subject (message-fetch-field "subject")))
+ (or
+ (and subject
+ (not (string-match "\\`[ \t]*\\'" subject)))
+ (ignore
+ (message
+ "The subject field is empty or missing. Posting is denied.")))))
+ ;; Check for commands in Subject.
+ (message-check 'subject-cmsg
+ (if (string-match "^cmsg " (message-fetch-field "subject"))
+ (y-or-n-p
+ "The control code \"cmsg\" is in the subject. Really post? ")
+ t))
+ ;; Check for multiple identical headers.
+ (message-check 'multiple-headers
+ (let (found)
+ (while (and (not found)
+ (re-search-forward "^[^ \t:]+: " nil t))
+ (save-excursion
+ (or (re-search-forward
+ (concat "^"
+ (regexp-quote
+ (setq found
+ (buffer-substring
+ (match-beginning 0) (- (match-end 0) 2))))
+ ":")
+ nil t)
+ (setq found nil))))
+ (if found
+ (y-or-n-p (format "Multiple %s headers. Really post? " found))
+ t)))
+ ;; Check for Version and Sendsys.
+ (message-check 'sendsys
+ (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
+ (y-or-n-p
+ (format "The article contains a %s command. Really post? "
+ (buffer-substring (match-beginning 0)
+ (1- (match-end 0)))))
+ t))
+ ;; See whether we can shorten Followup-To.
+ (message-check 'shorten-followup-to
+ (let ((newsgroups (message-fetch-field "newsgroups"))
+ (followup-to (message-fetch-field "followup-to"))
+ to)
+ (when (and newsgroups
+ (string-match "," newsgroups)
+ (not followup-to)
+ (not
+ (zerop
+ (length
+ (setq to (completing-read
+ "Followups to: (default all groups) "
+ (mapcar (lambda (g) (list g))
+ (cons "poster"
+ (message-tokenize-header
+ newsgroups)))))))))
+ (goto-char (point-min))
+ (insert "Followup-To: " to "\n"))
+ t))
+ ;; Check "Shoot me".
+ (message-check 'shoot
+ (if (re-search-forward
+ "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
+ (y-or-n-p "You appear to have a misconfigured system. Really post? ")
+ t))
+ ;; Check for Approved.
+ (message-check 'approved
+ (if (re-search-forward "^Approved:" nil t)
+ (y-or-n-p "The article contains an Approved header. Really post? ")
+ t))
+ ;; Check the Message-ID header.
+ (message-check 'message-id
+ (let* ((case-fold-search t)
+ (message-id (message-fetch-field "message-id" t)))
+ (or (not message-id)
+ (and (string-match "@" message-id)
+ (string-match "@[^\\.]*\\." message-id))
+ (y-or-n-p
+ (format "The Message-ID looks strange: \"%s\". Really post? "
+ message-id)))))
+ ;; Check the Newsgroups & Followup-To headers.
+ (message-check 'existing-newsgroups
+ (let* ((case-fold-search t)
+ (newsgroups (message-fetch-field "newsgroups"))
+ (followup-to (message-fetch-field "followup-to"))
+ (groups (message-tokenize-header
+ (if followup-to
+ (concat newsgroups "," followup-to)
+ newsgroups)))
+ (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
+ (y-or-n-p
+ (format "The %s header looks odd: \"%s\". Really post? "
+ (car headers) header)))))
+ ;; 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))))))
+
+(defun message-check-news-body-syntax ()
+ (and
+ ;; Check for long lines.
+ (message-check 'long-lines
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (while (and
+ (progn
+ (end-of-line)
+ (< (current-column) 80))
+ (zerop (forward-line 1))))
+ (or (bolp)
+ (eobp)
+ (y-or-n-p
+ "You have lines longer than 79 characters. Really post? ")))
+ ;; Check whether the article is empty.
+ (message-check 'empty
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (let ((b (point)))
+ (goto-char (point-max))
+ (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? "))))
+ ;; Check for control characters.
+ (message-check 'control-chars
+ (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
+ (y-or-n-p
+ "The article contains control characters. Really post? ")
+ t))
+ ;; Check excessive size.
+ (message-check 'size
+ (if (> (buffer-size) 60000)
+ (y-or-n-p
+ (format "The article is %d octets long. Really post? "
+ (buffer-size)))
+ t))
+ ;; Check whether any new text has been added.
+ (message-check 'new-text
+ (or
+ (not message-checksum)
+ (not (and (eq (message-checksum) (car message-checksum))
+ (eq (buffer-size) (cdr message-checksum))))
+ (y-or-n-p
+ "It looks like no new text has been added. Really post? ")))
+ ;; 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)))))
+
(defun message-checksum ()
"Return a \"checksum\" for the current buffer."
(let ((sum 0))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$"))
(while (not (eobp))
- (setq sum (logxor sum (following-char)))
+ (when (not (looking-at "[ \t\n]"))
+ (setq sum (logxor (ash sum 1) (following-char))))
(forward-char 1)))
sum))
(if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
;; Pipe the article to the program in question.
(call-process-region (point-min) (point-max) shell-file-name
- nil nil nil "-c" (match-string 1 file))
+ nil nil nil shell-command-switch
+ (match-string 1 file))
;; Save the article.
(setq file (expand-file-name file))
(unless (file-exists-p (file-name-directory file))
(not (eq message-fcc-handler-function 'rmail-output)))
(funcall message-fcc-handler-function file)
(if (and (file-readable-p file) (mail-file-babyl-p file))
- (rmail-output file 1)
+ (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.."
+ (if (and (file-readable-p filename)
+ (mail-file-babyl-p filename))
+ (gnus-output-to-rmail filename t)
+ (gnus-output-to-mail filename t)))
+
(defun message-cleanup-headers ()
"Do various automatic cleanups of the headers."
;; Remove empty lines in the header.
(defun message-make-date ()
"Make a valid data header."
(let ((now (current-time)))
- (timezone-make-date-arpa-standard
+ (timezone-make-date-arpa-standard
(current-time-string now) (current-time-zone now))))
(defun message-make-message-id ()
"Make a unique Message-ID."
- (concat "<" (message-unique-id)
+ (concat "<" (message-unique-id)
(let ((psubject (save-excursion (message-fetch-field "subject"))))
(if (and message-reply-headers
(mail-header-references message-reply-headers)
(mail-header-subject message-reply-headers)
psubject
(mail-header-subject message-reply-headers)
- (not (string=
+ (not (string=
(message-strip-subject-re
(mail-header-subject message-reply-headers))
(message-strip-subject-re psubject))))
"_-_" ""))
- "@" (message-make-fqdm) ">"))
+ "@" (message-make-fqdn) ">"))
(defvar message-unique-id-char nil)
(aset user (match-beginning 0) ?_))
user)
(message-number-base36 (user-uid) -1))
- (message-number-base36 (+ (car tm)
+ (message-number-base36 (+ (car tm)
(lsh (% message-unique-id-char 25) 16)) 4)
(message-number-base36 (+ (nth 1 tm)
(lsh (/ message-unique-id-char 25) 16)) 4)
".fsf")))
(defun message-number-base36 (num len)
- (if (if (< len 0) (<= num 0) (= len 0))
+ (if (if (< len 0)
+ (<= num 0)
+ (= len 0))
""
(concat (message-number-base36 (/ num 36) (1- len))
(char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
(defun message-make-organization ()
"Make an Organization header."
- (let* ((organization
+ (let* ((organization
(or (getenv "ORGANIZATION")
(when message-user-organization
(if (message-functionp message-user-organization)
(save-restriction
(widen)
(goto-char (point-min))
- (re-search-forward
+ (re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$"))
(forward-line 1)
(int-to-string (count-lines (point) (point-max))))))
(let ((from (mail-header-from message-reply-headers))
(date (mail-header-date message-reply-headers)))
(when from
- (let ((stop-pos
+ (let ((stop-pos
(string-match " *at \\| *@ \\| *(\\| *<" from)))
(concat (if stop-pos (substring from 0 stop-pos) from)
- "'s message of "
+ "'s message of "
(if (or (not date) (string= date ""))
"(unknown date)" date)))))))
(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
+ (timezone-make-date-arpa-standard
(current-time-string current) (current-time-zone current) '(0 "UT"))))
(defun message-make-path ()
(defun message-make-from ()
"Make a From header."
- (let* ((login (message-make-address))
- (fullname
+ (let* ((style message-from-style)
+ (login (message-make-address))
+ (fullname
(or (and (boundp 'user-full-name)
user-full-name)
(user-full-name))))
(setq fullname (user-login-name)))
(save-excursion
(message-set-work-buffer)
- (cond
- ((or (null message-from-style)
+ (cond
+ ((or (null style)
(equal fullname ""))
(insert login))
- ((or (eq message-from-style 'angles)
- (and (not (eq message-from-style 'parens))
+ ((or (eq style 'angles)
+ (and (not (eq style 'parens))
;; Use angles if no quoting is needed, or if parens would
;; need quoting too.
(or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
;; ... then undo escaping of matching parentheses,
;; including matching nested parentheses.
(goto-char fullname-start)
- (while (re-search-forward
+ (while (re-search-forward
"\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
- nil 1)
+ nil 1)
(replace-match "\\1(\\3)" t)
(goto-char fullname-start)))
(insert ")")))
(defun message-make-sender ()
"Return the \"real\" user address.
-This function tries to ignore all user modifications, and
+This function tries to ignore all user modifications, and
give as trustworthy answer as possible."
(concat (user-login-name) "@" (system-name)))
(defun message-user-mail-address ()
"Return the pertinent part of `user-mail-address'."
(when user-mail-address
- (nth 1 (mail-extract-address-components user-mail-address))))
+ (if (string-match " " user-mail-address)
+ (nth 1 (mail-extract-address-components user-mail-address))
+ user-mail-address)))
-(defun message-make-fqdm ()
+(defun message-make-fqdn ()
"Return user's fully qualified domain name."
- (let ((system-name (system-name)))
- (cond
+ (let ((system-name (system-name))
+ (user-mail (message-user-mail-address)))
+ (cond
((string-match "[^.]\\.[^.]" system-name)
;; `system-name' returned the right result.
system-name)
- ;; We try `user-mail-address' as a backup.
- ((string-match "@\\(.*\\)\\'" (message-user-mail-address))
- (match-string 1 user-mail-address))
;; Try `mail-host-address'.
((and (boundp 'mail-host-address)
- mail-host-address)
+ (stringp mail-host-address)
+ (string-match "\\." mail-host-address))
mail-host-address)
+ ;; We try `user-mail-address' as a backup.
+ ((and (string-match "\\." user-mail)
+ (string-match "@\\(.*\\)\\'" user-mail))
+ (match-string 1 user-mail))
;; Default to this bogus thing.
(t
- (concat system-name ".i-have-a-misconfigured-system-so-shoot-me")))))
+ (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me")))))
(defun message-make-host-name ()
"Return the name of the host."
- (let ((fqdm (message-make-fqdm)))
- (string-match "^[^.]+\\." fqdm)
- (substring fqdm 0 (1- (match-end 0)))))
+ (let ((fqdn (message-make-fqdn)))
+ (string-match "^[^.]+\\." fqdn)
+ (substring fqdn 0 (1- (match-end 0)))))
(defun message-make-domain ()
"Return the domain name."
(or mail-host-address
- (message-make-fqdm)))
+ (message-make-fqdn)))
(defun message-generate-headers (headers)
"Prepare article HEADERS.
(let ((headers message-deletable-headers))
(while headers
(goto-char (point-min))
- (and (re-search-forward
+ (and (re-search-forward
(concat "^" (symbol-name (car headers)) ": *") nil t)
(get-text-property (1+ (match-beginning 0)) 'message-deletable)
(message-delete-line))
(pop headers)))
;; Go through all the required headers and see if they are in the
- ;; articles already. If they are not, or are empty, they are
+ ;; articles already. If they are not, or are empty, they are
;; inserted automatically - except for Subject, Newsgroups and
- ;; Distribution.
+ ;; Distribution.
(while headers
(goto-char (point-min))
(setq elem (pop headers))
(setq header (cdr elem))
(setq header (car elem)))
(setq header elem))
- (when (or (not (re-search-forward
- (concat "^" (downcase (symbol-name header)) ":")
+ (when (or (not (re-search-forward
+ (concat "^" (downcase (symbol-name header)) ":")
nil t))
(progn
- ;; The header was found. We insert a space after the
+ ;; The header was found. We insert a space after the
;; colon, if there is none.
(if (/= (following-char) ? ) (insert " ") (forward-char 1))
;; Find out whether the header is empty...
(looking-at "[ \t]*$")))
;; So we find out what value we should insert.
(setq value
- (cond
+ (cond
((and (consp elem) (eq (car elem) 'optional))
;; This is an optional header. If the cdr of this
;; is something that is nil, then we do not insert
(read-from-minibuffer
(format "Empty header for %s; enter value: " header)))))
;; Finally insert the header.
- (when (and value
+ (when (and value
(not (equal value "")))
(save-excursion
(if (bolp)
(forward-line -1))
;; The value of this header was empty, so we clear
;; totally and insert the new value.
- (delete-region (point) (message-point-at-eol))
+ (delete-region (point) (gnus-point-at-eol))
(insert value))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
- (add-text-properties
+ (add-text-properties
(point) (match-end 0)
'(message-deletable t face italic) (current-buffer)))))))
- ;; Insert new Sender if the From is strange.
+ ;; Insert new Sender if the From is strange.
(let ((from (message-fetch-field "from"))
(sender (message-fetch-field "sender"))
(secure-sender (message-make-sender)))
- (when (and from
+ (when (and from
(not (message-check-element 'sender))
(not (string=
(downcase
(cadr (mail-extract-address-components from)))
(downcase secure-sender)))
(or (null sender)
- (not
+ (not
(string=
(downcase
(cadr (mail-extract-address-components sender)))
(downcase secure-sender)))))
- (goto-char (point-min))
+ (goto-char (point-min))
;; Rename any old Sender headers to Original-Sender.
- (when (re-search-forward "^Sender:" nil t)
+ (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
(beginning-of-line)
(insert "Original-")
(beginning-of-line))
- (insert "Sender: " secure-sender "\n"))))))
+ (when (or (message-news-p)
+ (string-match "^[^@]@.+\\..+" secure-sender))
+ (insert "Sender: " secure-sender "\n")))))))
(defun message-insert-courtesy-copy ()
"Insert a courtesy message in mail copies of combined messages."
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (let ((newsgroups (message-fetch-field "newsgroups")))
- (when newsgroups
+ (let (newsgroups)
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (when (setq newsgroups (message-fetch-field "newsgroups"))
(goto-char (point-max))
- (insert "Posted-To: " newsgroups "\n"))))
- (forward-line 1)
- (insert message-courtesy-message)))
-
+ (insert "Posted-To: " newsgroups "\n")))
+ (forward-line 1)
+ (when message-courtesy-message
+ (cond
+ ((string-match "%s" message-courtesy-message)
+ (insert (format message-courtesy-message newsgroups)))
+ (t
+ (insert message-courtesy-message)))))))
+
;;;
;;; Setting up a message buffer
;;;
(defun message-position-point ()
"Move point to where the user probably wants to find it."
(message-narrow-to-headers)
- (cond
+ (cond
((re-search-forward "^[^:]+:[ \t]*$" nil t)
(search-backward ":" )
(widen)
(defun message-buffer-name (type &optional to group)
"Return a new (unique) buffer name based on TYPE and TO."
- (if message-generate-new-buffers
- (generate-new-buffer-name
- (concat "*" type
- (if to
- (concat " to "
- (or (car (mail-extract-address-components to))
- to) "")
- "")
- (if group (concat " on " group) "")
- "*"))
- (format "*%s message*" type)))
+ (cond
+ ;; 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
+ (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) "")
+ "*")))
+ ;; Use standard name.
+ (t
+ (format "*%s message*" type))))
(defun message-pop-to-buffer (name)
"Pop to buffer NAME, and warn if it already exists and is modified."
;; We might have sent this buffer already. Delete it from the
;; list of buffers.
(setq message-buffer-list (delq (current-buffer) message-buffer-list))
- (when (and message-max-buffers
- (>= (length message-buffer-list) message-max-buffers))
+ (while (and message-max-buffers
+ message-buffer-list
+ (>= (length message-buffer-list) message-max-buffers))
;; Kill the oldest buffer -- unless it has been changed.
(let ((buffer (pop message-buffer-list)))
(when (and (buffer-name buffer)
(not (buffer-modified-p buffer)))
(kill-buffer buffer))))
;; Rename the buffer.
- (when (string-match "\\`\\*" (buffer-name))
- (rename-buffer
- (concat "*sent " (substring (buffer-name) (match-end 0))) t))
+ (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)))
;; Push the current buffer onto the list.
(when message-max-buffers
- (setq message-buffer-list
+ (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)))
(setq message-reply-buffer replybuffer)
(goto-char (point-min))
;; Insert all the headers.
- (mail-header-format
+ (mail-header-format
(let ((h headers)
(alist message-header-format-alist))
(while h
(pop h))
alist)
headers)
- (forward-line -1)
+ (delete-region (point) (progn (forward-line -1) (point)))
(when message-default-headers
(insert message-default-headers))
(put-text-property
(point)
(progn
(insert mail-header-separator "\n")
- (point))
+ (1- (point)))
'read-only nil)
(forward-line -1)
(when (message-news-p)
(message-narrow-to-headers)
(run-hooks 'message-header-setup-hook))
(set-buffer-modified-p nil)
+ (setq buffer-undo-list nil)
(run-hooks 'message-setup-hook)
(message-position-point)
(undo-boundary))
(unless (file-exists-p message-autosave-directory)
(make-directory message-autosave-directory t))
(let ((name (make-temp-name
- (concat (file-name-as-directory message-autosave-directory)
- "msg."))))
+ (expand-file-name
+ (concat (file-name-as-directory message-autosave-directory)
+ "msg.")))))
(setq buffer-auto-save-file-name
(save-excursion
(prog1
;;;
;;;###autoload
-(defun message-mail (&optional to subject)
+(defun message-mail (&optional to subject
+ other-headers continue switch-function
+ yank-action send-actions)
"Start editing a mail message to be sent."
(interactive)
- (message-pop-to-buffer (message-buffer-name "mail" to))
- (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
+ (let ((message-this-is-mail t))
+ (message-pop-to-buffer (message-buffer-name "mail" to))
+ (message-setup
+ (nconc
+ `((To . ,(or to "")) (Subject . ,(or subject "")))
+ (when other-headers other-headers)))))
;;;###autoload
(defun message-news (&optional newsgroups subject)
"Start editing a news article to be sent."
(interactive)
- (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
- (message-setup `((Newsgroups . ,(or newsgroups ""))
- (Subject . ,(or subject "")))))
+ (let ((message-this-is-news t))
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (Subject . ,(or subject ""))))))
;;;###autoload
(defun message-reply (&optional to-address wide ignore-reply-to)
(interactive)
(let ((cur (current-buffer))
from subject date reply-to to cc
- references message-id follow-to
+ references message-id follow-to
+ (inhibit-point-motion-hooks t)
mct never-mct gnus-warning)
(save-restriction
- (narrow-to-region
- (goto-char (point-min))
- (if (search-forward "\n\n" nil t)
- (1- (point))
- (point-max)))
+ (message-narrow-to-head)
;; Allow customizations to have their say.
(if (not wide)
;; This is a regular reply.
(funcall message-wide-reply-to-function)))))
;; Find all relevant headers we need.
(setq from (message-fetch-field "from")
- date (message-fetch-field "date")
+ 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 (unless ignore-reply-to (message-fetch-field "reply-to"))
references (message-fetch-field "references")
- message-id (message-fetch-field "message-id"))
+ message-id (message-fetch-field "message-id" t))
;; Remove any (buggy) Re:'s that are present and make a
;; proper one.
(when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
(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")
(message-set-work-buffer)
(unless never-mct
(insert (or reply-to from "")))
- (insert
- (if (bolp) "" ", ") (or to "")
- (if mct (concat (if (bolp) "" ", ") mct) "")
- (if cc (concat (if (bolp) "" ", ") cc) ""))
- ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (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))
- (nreverse (mail-parse-comma-list))))
+ (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
- (push (cons 'Cc
- (mapconcat (lambda (addr) (cdr addr)) ccalist ", "))
- follow-to)))))
+ (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))
- (message-pop-to-buffer (message-buffer-name "reply" from))
+ (message-pop-to-buffer (message-buffer-name
+ (if wide "wide reply" "reply") from
+ (if wide to-address nil)))
(setq message-reply-headers
(vector 0 subject from date message-id references 0 0 ""))
(message-setup
`((Subject . ,subject)
- ,@follow-to
+ ,@follow-to
,@(if (or references message-id)
`((References . ,(concat (or references "") (and references " ")
(or message-id ""))))
cur)))
;;;###autoload
-(defun message-wide-reply (&optional to-address)
+(defun message-wide-reply (&optional to-address ignore-reply-to)
+ "Make a \"wide\" reply to the message in the current buffer."
(interactive)
- (message-reply to-address t))
+ (message-reply to-address t ignore-reply-to))
;;;###autoload
-(defun message-followup ()
+(defun message-followup (&optional to-newsgroups)
+ "Follow up to the message in the current buffer.
+If TO-NEWSGROUPS, use that as the new Newsgroups line."
(interactive)
(let ((cur (current-buffer))
from subject date reply-to mct
- references message-id follow-to
- followup-to distribution newsgroups gnus-warning)
+ references message-id follow-to
+ (inhibit-point-motion-hooks t)
+ (message-this-is-news t)
+ followup-to distribution newsgroups gnus-warning posted-to)
(save-restriction
(narrow-to-region
(goto-char (point-min))
(setq follow-to
(funcall message-followup-to-function)))
(setq from (message-fetch-field "from")
- date (message-fetch-field "date")
+ date (message-fetch-field "date")
subject (or (message-fetch-field "subject") "none")
references (message-fetch-field "references")
- message-id (message-fetch-field "message-id")
+ message-id (message-fetch-field "message-id" t)
followup-to (message-fetch-field "followup-to")
newsgroups (message-fetch-field "newsgroups")
+ posted-to (message-fetch-field "posted-to")
reply-to (message-fetch-field "reply-to")
distribution (message-fetch-field "distribution")
mct (message-fetch-field "mail-copies-to"))
(string-match "<[^>]+>" gnus-warning))
(setq message-id (match-string 0 gnus-warning)))
;; Remove bogus distribution.
- (and (stringp distribution)
- (string-match "world" distribution)
- (setq distribution nil))
+ (when (and (stringp distribution)
+ (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 "^[ \t]*[Rr][Ee]:[ \t]*" subject)
(message-setup
`((Subject . ,subject)
- ,@(cond
+ ,@(cond
+ (to-newsgroups
+ (list (cons 'Newsgroups to-newsgroups)))
(follow-to follow-to)
((and followup-to message-use-followup-to)
(list
- (cond
+ (cond
((equal (downcase followup-to) "poster")
(if (or (eq message-use-followup-to 'use)
(message-y-or-n-p "Obey Followup-To: poster? " t "\
A typical situation where `Followup-To: poster' is used is when the poster
does not read the newsgroup, so he wouldn't see any replies sent to it."))
- (cons 'To (or reply-to from ""))
+ (progn
+ (setq message-this-is-news nil)
+ (cons 'To (or reply-to from "")))
(cons 'Newsgroups newsgroups)))
(t
(if (or (equal followup-to newsgroups)
because discussions that are spread over several newsgroup tend to
be fragmented and very difficult to follow.
-Also, some source/announcment newsgroups are not indented for discussion;
+Also, some source/announcement newsgroups are not indented for discussion;
responses here are directed to other newsgroups."))
(cons 'Newsgroups followup-to)
(cons 'Newsgroups newsgroups))))))
+ (posted-to
+ `((Newsgroups . ,posted-to)))
(t
`((Newsgroups . ,newsgroups))))
,@(and distribution (list (cons 'Distribution distribution)))
- (References . ,(concat (or references "") (and references " ")
- (or message-id "")))
+ ,@(if (or references message-id)
+ `((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")
(message-narrow-to-head)
(setq from (message-fetch-field "from")
newsgroups (message-fetch-field "newsgroups")
- message-id (message-fetch-field "message-id")
+ message-id (message-fetch-field "message-id" t)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
(unless (string-equal
(concat "Distribution: " distribution "\n")
"")
mail-header-separator "\n"
- "This is a cancel message from " from ".\n")
+ message-cancel-message)
(message "Canceling your article...")
- (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me))
- (funcall message-send-news-function))
- (message "Canceling your article...done")
+ (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
header line with the old Message-ID."
(interactive)
(let ((cur (current-buffer)))
- ;; Check whether the user owns the article that is to be superseded.
+ ;; Check whether the user owns the article that is to be superseded.
(unless (string-equal
(downcase (cadr (mail-extract-address-components
(message-fetch-field "from"))))
(defun message-make-forward-subject ()
"Return a Subject header suitable for the message in the current buffer."
- (concat "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from"))
- "(nowhere)")
- "] " (or (message-fetch-field "Subject") "")))
+ (save-excursion
+ (save-restriction
+ (current-buffer)
+ (message-narrow-to-head)
+ (concat "[" (or (message-fetch-field
+ (if (message-news-p) "newsgroups" "from"))
+ "(nowhere)")
+ "] " (or (message-fetch-field "Subject") "")))))
;;;###autoload
(defun message-forward (&optional news)
- "Forward the current message via mail.
+ "Forward the current message via mail.
Optional NEWS will use news to forward instead of mail."
(interactive "P")
(let ((cur (current-buffer))
- (subject (message-make-forward-subject)))
+ (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.
+ ;; message.
(if message-signature-before-forwarded-message
(goto-char (point-max))
(message-goto-body))
(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 (point-min))
- (forward-line 1)
+ (goto-char art-beg)
(narrow-to-region (point) (if (search-forward "\n\n" nil t)
(1- (point))
(point)))
(defun message-resend (address)
"Resend the current article to ADDRESS."
(interactive "sResend message to: ")
+ (message "Resending message to %s..." address)
(save-excursion
(let ((cur (current-buffer))
beg)
(while (re-search-backward "^\\(Also-\\)?Resent-" beg t)
(beginning-of-line)
(insert "Also-"))
+ ;; Quote any "From " lines at the beginning.
+ (goto-char beg)
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
;; Send it.
(message-send-mail)
- (kill-buffer (current-buffer)))))
+ (kill-buffer (current-buffer)))
+ (message "Resending message to %s...done" address)))
;;;###autoload
(defun message-bounce ()
(forward-line 2))
(and (re-search-forward message-unsent-separator nil t)
(forward-line 1))
- (and (search-forward "\n\n" nil t)
- (re-search-forward "^Return-Path:.*\n" nil t)))
+ (re-search-forward "^Return-Path:.*\n" nil t))
;; We remove everything before the bounced mail.
- (delete-region
+ (delete-region
(point-min)
- (if (re-search-forward "[^ \t]*:" nil t)
+ (if (re-search-forward "^[^ \n\t]+:" nil t)
(match-beginning 0)
(point)))
(save-restriction
(same-window-buffer-names nil)
(same-window-regexps nil))
(message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
- (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject "")))))
;;;###autoload
(same-window-buffer-names nil)
(same-window-regexps nil))
(message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
- (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject "")))))
;;; underline.el
-;; This code should be moved to underline.el (from which it is stolen).
+;; This code should be moved to underline.el (from which it is stolen).
;;;###autoload
(defun bold-region (start end)
which specify the range to operate on."
(interactive "r")
(save-excursion
- (let ((end1 (make-marker)))
- (move-marker end1 (max start end))
- (goto-char (min start end))
- (while (< (point) end1)
- (or (looking-at "[_\^@- ]")
- (insert (following-char) "\b"))
- (forward-char 1)))))
+ (let ((end1 (make-marker)))
+ (move-marker end1 (max start end))
+ (goto-char (min start end))
+ (while (< (point) end1)
+ (or (looking-at "[_\^@- ]")
+ (insert (following-char) "\b"))
+ (forward-char 1)))))
;;;###autoload
(defun unbold-region (start end)
which specify the range to operate on."
(interactive "r")
(save-excursion
- (let ((end1 (make-marker)))
- (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)))
- (delete-char -2))))))
+ (let ((end1 (make-marker)))
+ (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)))
+ (delete-char -2))))))
+
+(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
;; Support for toolbar
(when (string-match "XEmacs\\|Lucid" emacs-version)
;;; Group name completion.
(defvar message-newgroups-header-regexp
- "^\\(Newsgroups\\|Followup-To\\|Posted-To\\):"
+ "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
"Regexp that match headers that lists groups.")
(defun message-tab ()
(defvar gnus-active-hashtb)
(defun message-expand-group ()
- (let* ((b (save-excursion (skip-chars-backward "^, :\t\n") (point)))
+ (let* ((b (save-excursion
+ (save-restriction
+ (narrow-to-region
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward "^:")
+ (1+ (point)))
+ (point))
+ (skip-chars-backward "^, \t\n") (point))))
(completion-ignore-case t)
(string (buffer-substring b (point)))
(hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
(cur (current-buffer))
comp)
(delete-region b (point))
- (cond
+ (cond
((= (length completions) 1)
(if (string= (car completions) string)
(progn
;;; Help stuff.
-(defmacro message-y-or-n-p (question show &rest text)
- "Ask QUESTION, displaying the rest of the arguments in a temporary buffer."
- `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
-
(defun message-talkative-question (ask question show &rest text)
- "Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW.
+ "Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW.
The following arguments may contain lists of values."
(if (and show
(setq text (message-flatten-list text)))
(funcall ask question))
(funcall ask question)))
-(defun message-flatten-list (&rest list)
- (message-flatten-list-1 list))
+(defun message-flatten-list (list)
+ "Return a new, flat list that contains all elements of LIST.
-(defun message-flatten-list-1 (list)
- (cond ((consp list)
- (apply 'append (mapcar 'message-flatten-list-1 list)))
+\(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
+=> (1 2 3 4 5 6 7)"
+ (cond ((consp list)
+ (apply 'append (mapcar 'message-flatten-list list)))
(list
(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.
+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 ((oldlocals (buffer-local-variables)))
+ (save-excursion
+ (set-buffer (generate-new-buffer name))
+ (mapcar (lambda (dude)
+ (when (and (car dude)
+ (or (not varstr)
+ (string-match varstr (symbol-name (car dude)))))
+ (ignore-errors
+ (set (make-local-variable (car dude))
+ (cdr dude)))))
+ oldlocals)
+ (current-buffer))))
+
(run-hooks 'message-load-hook)
(provide 'message)
projects / gnus / blobdiff