(eval-when-compile
(require 'cl))
-(require 'mail-header)
+(require 'mailheader)
+(require 'rmail)
(require 'nnheader)
(require 'timezone)
+(require 'easymenu)
+(if (string-match "XEmacs\\|Lucid" emacs-version)
+ (require 'mail-abbrevs)
+ (require 'mailabbrev))
+
+(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.")
+
+(defvar message-send-rename-function nil
+ "Function called to rename the buffer after sending it.")
;;;###autoload
(defvar message-fcc-handler-function 'rmail-output
If this variable is nil, no such courtesy message will be added.")
;;;###autoload
-(defvar message-ignored-bounced-headers "^\\(Received\\):"
+(defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
"*Regexp that matches headers to be removed in resent bounced mail.")
;;;###autoload
`parens' if `angles' would need quoting and `parens' would not.")
;;;###autoload
-(defvar message-syntax-checks
- '(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)
- "In non-nil, message will attempt to run some checks on outgoing posts.
-If this variable is t, message will check everything it can. If it is
-a list, then those elements in that list will be checked.")
+(defvar message-syntax-checks nil
+ "Controls what syntax checks should not be performed on outgoing posts.
+To disable checking of long signatures, for instance, add
+ `(signature . disabled)' to this list.
+
+Don't touch this variable unless you really know what you're doing.
+
+Checks include subject-cmsg multiple-headers sendsys message-id from
+long-lines control-chars size new-text redirected-followup signature
+approved sender empty empty-headers message-id from subject.")
;;;###autoload
(defvar message-required-news-headers
"*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:"
+(defvar 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.")
nil means let mailer mail back a message to report errors.")
;;;###autoload
-(defvar message-generate-new-buffers nil
- "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.")
+(defvar 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.")
;;;###autoload
(defvar message-kill-buffer-on-exit nil
"*Non-nil means that the message buffer will be killed after sending a message.")
(defvar gnus-local-organization)
-;;;###autoload
(defvar message-user-organization
(or (and (boundp 'gnus-local-organization)
gnus-local-organization)
(defvar message-user-organization-file "/usr/lib/news/organization"
"*Local news organization file.")
-;;;###autoload
-(defvar message-autosave-directory "~/Mail/drafts/"
+(defvar message-autosave-directory "~/"
+ ; (concat (file-name-as-directory message-directory) "drafts/")
"*Directory where message autosaves buffers.
If nil, message won't autosave.")
;; Useful to set in site-init.el
;;;###autoload
-(defvar message-send-mail-function 'message-send-mail
+(defvar 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'.")
+variable `mail-header-separator'.
+
+Legal values include `message-send-mail-with-mh' and
+`message-send-mail-with-sendmail', which is the default.")
;;;###autoload
(defvar 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 `message-header-separator'.")
+variable `mail-header-separator'.")
;;;###autoload
(defvar message-reply-to-function nil
- "Function that should return a list of headers.")
+ "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.")
;;;###autoload
(defvar message-wide-reply-to-function nil
- "Function that should return a list of headers.")
+ "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.")
;;;###autoload
(defvar message-followup-to-function nil
- "Function that should return a list of headers.")
+ "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.")
;;;###autoload
(defvar message-use-followup-to 'ask
(defvar gnus-select-method)
;;;###autoload
(defvar message-post-method
- (cond ((boundp 'gnus-post-method)
+ (cond ((and (boundp 'gnus-post-method)
+ gnus-post-method)
gnus-post-method)
((boundp 'gnus-select-method)
gnus-select-method)
(defvar message-generate-headers-first nil
"*If non-nil, generate all possible headers before composing.")
-;;;###autoload
-(defvar message-header-separator "--text follows this line--"
- "*Line used to separate headers from text in messages being composed.")
-
(defvar message-setup-hook nil
"Normal hook, run each time a new outgoing message is initialized.
The function `message-setup' runs this hook.")
+(defvar 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.")
(defvar message-checksum nil)
(defvar message-send-actions nil
"A list of actions to be performed upon successful sending of a message.")
+(defvar message-exit-actions nil
+ "A list of actions to be performed upon exiting after sending a message.")
+(defvar message-kill-actions nil
+ "A list of actions to be performed before killing a message buffer.")
+(defvar message-postpone-actions nil
+ "A list of actions to be performed after postponing a message.")
;;;###autoload
(defvar message-default-headers nil
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'.")
+
(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)
- '("^B?CC:\\|^Reply-To:" . font-lock-keyword-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) "\\)$")
;;; Internal variables.
+(defvar message-buffer-list nil)
+
+;;; Regexp matching the delimiter of messages in UNIX mail format
+;;; (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\\)?"
+ "\\|[-+]?[0-9][0-9][0-9][0-9]"
+ "\\|"
+ "\\) *")))
+ (concat
+ "From "
+
+ ;; Username, perhaps with a quoted section that can contain spaces.
+ "\\("
+ "[^ \n]*"
+ "\\(\\|\".*\"[^ \n]*\\)"
+ "\\|<[^<>\n]+>"
+ "\\) ?"
+
+ ;; The time the message was sent.
+ "\\([^ \n]*\\) *" ; day of the week
+ "\\([^ ]*\\) *" ; month
+ "\\([0-9]*\\) *" ; day of month
+ "\\([0-9:]*\\) *" ; time of day
+
+ ;; Perhaps a time zone, specified by an abbreviation, or by a
+ ;; numeric offset.
+ time-zone-regexp
+
+ ;; The year.
+ " [0-9][0-9]\\([0-9]*\\) *"
+
+ ;; On some systems the time zone can appear after the year, too.
+ time-zone-regexp
+
+ ;; Old uucp cruft.
+ "\\(remote from .*\\)?"
+
+ "\n")))
+
+(defvar message-unsent-separator
+ (concat "^ *---+ +Unsent message follows +---+ *$\\|"
+ "^ *---+ +Returned message +---+ *$\\|"
+ "^Start of returned message$\\|"
+ "^ *---+ +Original message +---+ *$\\|"
+ "^ *--+ +begin message +--+ *$\\|"
+ "^ *---+ +Original message follows +---+ *$\\|"
+ "^|? *---+ +Message text follows: +---+ *|?$")
+ "A regexp that matches the separator before the text of a failed message.")
+
(defvar message-header-format-alist
`((Newsgroups)
- (To . message-fill-header)
- (Cc . message-fill-header)
+ (To . message-fill-address)
+ (Cc . message-fill-address)
(Subject)
(In-Reply-To)
(Fcc)
(X-Newsreader))
"Alist used for formatting headers.")
+(eval-and-compile
+ (autoload 'message-setup-toolbar "messagexmas")
+ (autoload 'mh-send-letter "mh-comp"))
+
\f
;;;
(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)))
+ (let ((regexp (format "[%s]+" (or separator ",")))
+ (beg 1)
+ (first t)
+ quoted elems)
+ (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))))
+ (push (buffer-substring beg (point)) elems)
+ (setq beg (match-end 0)))
+ ((= (following-char) ?\")
+ (setq quoted (not quoted)))))
+ (nreverse elems))))
+
+(defun message-fetch-field (header)
+ "The same as `mail-fetch-field', only remove all newlines."
+ (let ((value (mail-fetch-field header)))
+ (when value
+ (nnheader-replace-chars-in-string value ?\n ? ))))
(defun message-fetch-reply-field (header)
"Fetch FIELD from the message we're replying to."
(buffer-name message-reply-buffer))
(save-excursion
(set-buffer message-reply-buffer)
- (mail-fetch-field header))))
+ (message-fetch-field header))))
(defun message-set-work-buffer ()
(if (get-buffer " *message work*")
(save-excursion
(save-restriction
(message-narrow-to-headers)
- (mail-fetch-field "newsgroups"))))
+ (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 (mail-fetch-field "to")
- (mail-fetch-field "cc")
- (mail-fetch-field "bcc")))))
+ (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."
(let ((max (1+ (length message-header-format-alist)))
rank)
(message-narrow-to-headers)
- (while (re-search-forward "^[^ ]+:" nil t)
+ (while (re-search-forward "^[^ \n]+:" nil t)
(put-text-property
(match-beginning 0) (1+ (match-beginning 0))
'message-rank
(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-r" 'message-caesar-buffer-body)
+ (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
+ (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
(define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
- (define-key message-mode-map "\C-c\C-s" 'message-send))
-
-(defun message-make-menu-bar ()
- (unless (boundp 'message-menu)
- (easy-menu-define
- message-menu message-mode-map ""
- '("Message"
- ["Fill Citation" message-fill-yanked-message t]))))
+ (define-key message-mode-map "\C-c\C-s" 'message-send)
+ (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 "\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]))
+
+(defvar facemenu-add-face-function)
+(defvar facemenu-remove-face-function)
;;;###autoload
(defun message-mode ()
(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-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)
+ ;; Allow mail alias things.
+ (if (fboundp 'mail-abbrevs-setup)
+ (mail-abbrevs-setup)
+ (funcall (intern "mail-aliases-setup")))
(run-hooks 'text-mode-hook 'message-mode-hook))
\f
(defun message-goto-body ()
"Move point to the beginning of the message body."
(interactive)
+ (if (looking-at "[ \t]*\n") (expand-abbrev))
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n") nil t))
(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")
+ (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))
+ (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)
(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")
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n-- \n")
(if (eq signature t)
(insert-file-contents message-signature-file)
(insert signature))
(narrow-to-region (point) (point-max)))
(message-caesar-region (point-min) (point-max) rotnum))))
+(defun message-rename-buffer (&optional enter-string)
+ "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)
+ (search-forward mail-header-separator nil 'end))
+ (let* ((mail-to (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)) ", ...")
+ mail-to))
+ (name-default (concat "*message* " mail-trimmed-to))
+ (name (if enter-string
+ (read-string "New buffer name: " name-default)
+ name-default)))
+ (rename-buffer name t)
+ (setq buffer-auto-save-file-name
+ (format "%s%s"
+ (file-name-as-directory message-autosave-directory)
+ (file-name-nondirectory buffer-auto-save-file-name)))))))
+
(defun message-fill-yanked-message (&optional justifyp)
"Fill the paragraphs of a message yanked into this one.
Numeric argument means justify as well."
(save-excursion
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n") nil t)
- (fill-individual-paragraphs (point)
- (point-max)
- justifyp
- t)))
+ (let ((fill-prefix message-yank-prefix))
+ (fill-individual-paragraphs (point) (point-max) justifyp t))))
(defun message-indent-citation ()
"Modify text just inserted from a message to be cited.
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 ()
(let ((start (point))
(defun message-send-and-exit (&optional arg)
"Send message like `message-send', then, if no errors, exit from mail buffer."
(interactive "P")
- (let ((buf (current-buffer)))
+ (let ((buf (current-buffer))
+ (actions message-exit-actions))
(when (and (message-send arg)
(buffer-name buf))
(if message-kill-buffer-on-exit
(kill-buffer buf)
(bury-buffer buf)
(when (eq buf (current-buffer))
- (message-bury buf))))))
+ (message-bury buf)))
+ (message-do-actions actions))))
(defun message-dont-send ()
"Don't send the message you have been editing."
(interactive)
- (message-bury (current-buffer)))
+ (message-bury (current-buffer))
+ (message-do-actions message-postpone-actions))
+
+(defun message-kill-buffer ()
+ "Kill the current buffer."
+ (interactive)
+ (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 'mail message-sent-message-via))
(y-or-n-p
"Already sent message via mail; resend? "))
- (funcall message-send-mail-function arg))))
+ (message-send-mail arg))))
(message-do-fcc)
- (when (fboundp 'mail-hist-put-headers-into-history)
- (mail-hist-put-headers-into-history))
+ ;;(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))
- ;; Now perform actions on successful sending.
- (let ((actions message-send-actions))
- (while actions
- (condition-case nil
- (apply (caar actions) (cdar actions))
- (error))
- (pop actions)))
+ ;; Delete other mail buffers and stuff.
+ (message-do-send-housekeeping)
+ (message-do-actions message-send-actions)
;; Return success.
t)))
+(defun message-fix-before-sending ()
+ "Do various things to make the message nice before sending it."
+ ;; Make sure there's a newline at the end of the message.
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n")))
+
+(defun message-add-action (action &rest types)
+ "Add ACTION to be performed when doing an exit of type TYPES."
+ (let (var)
+ (while types
+ (set (setq var (intern (format "message-%s-actions" (pop types))))
+ (nconc (symbol-value var) (list action))))))
+
+(defun message-do-actions (actions)
+ "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))
+ (pop actions)))
+
(defun message-send-mail (&optional arg)
(require 'mail-utils)
- (let ((errbuf (if message-interactive
- (generate-new-buffer " sendmail errors")
- 0))
- (tembuf (generate-new-buffer " message temp"))
+ (let ((tembuf (generate-new-buffer " message temp"))
(case-fold-search nil)
(news (message-news-p))
- resend-to-addresses delimline
(mailbuf (current-buffer)))
(save-restriction
(message-narrow-to-headers)
- (setq resend-to-addresses (mail-fetch-field "resent-to"))
;; Insert some headers.
- (message-generate-headers message-required-mail-headers)
+ (let ((message-deletable-headers
+ (if news nil message-deletable-headers)))
+ (message-generate-headers message-required-mail-headers))
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
(unwind-protect
(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)
(or (= (preceding-char) ?\n)
(insert ?\n))
(when (and news
- (or (mail-fetch-field "cc")
- (mail-fetch-field "to")))
+ (or (message-fetch-field "cc")
+ (message-fetch-field "to")))
(message-insert-courtesy-copy))
- (let ((case-fold-search t))
- ;; Change header-delimiter to be what sendmail expects.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n"))
- (replace-match "\n")
- (backward-char 1)
- (setq delimline (point-marker))
- ;; Insert an extra newline if we need it to work around
- ;; Sun's bug that swallows newlines.
- (goto-char (1+ delimline))
- (when (eval message-mailer-swallows-blank-line)
- (newline))
- (when message-interactive
- (save-excursion
- (set-buffer errbuf)
- (erase-buffer))))
- (let ((default-directory "/"))
- (apply 'call-process-region
- (append (list (point-min) (point-max)
- (if (boundp 'sendmail-program)
- sendmail-program
- "/usr/lib/sendmail")
- nil errbuf nil "-oi")
- ;; Always specify who from,
- ;; since some systems have broken sendmails.
- (list "-f" (user-login-name))
- ;; These mean "report errors by mail"
- ;; and "deliver in background".
- (if (null message-interactive) '("-oem" "-odb"))
- ;; Get the addresses from the message
- ;; unless this is a resend.
- ;; We must not do that for a resend
- ;; because we would find the original addresses.
- ;; For a resend, include the specific addresses.
- (or resend-to-addresses
- '("-t")))))
- (when message-interactive
- (save-excursion
- (set-buffer errbuf)
- (goto-char (point-min))
- (while (re-search-forward "\n\n* *" nil t)
- (replace-match "; "))
- (if (not (zerop (buffer-size)))
- (error "Sending...failed to %s"
- (buffer-substring (point-min) (point-max)))))))
- (kill-buffer tembuf)
- (when (bufferp errbuf)
- (kill-buffer errbuf)))
+ (funcall message-send-mail-function))
+ (kill-buffer tembuf))
(set-buffer mailbuf)
(push 'mail message-sent-message-via)))
+(defun message-send-mail-with-sendmail ()
+ "Send off the prepared buffer with sendmail."
+ (let ((errbuf (if message-interactive
+ (generate-new-buffer " sendmail errors")
+ 0))
+ resend-to-addresses delimline)
+ (let ((case-fold-search t))
+ (save-restriction
+ (message-narrow-to-headers)
+ (setq resend-to-addresses (message-fetch-field "resent-to")))
+ ;; Change header-delimiter to be what sendmail expects.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1)
+ (setq delimline (point-marker))
+ ;; Insert an extra newline if we need it to work around
+ ;; Sun's bug that swallows newlines.
+ (goto-char (1+ delimline))
+ (when (eval message-mailer-swallows-blank-line)
+ (newline))
+ (when message-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (erase-buffer))))
+ (let ((default-directory "/"))
+ (apply 'call-process-region
+ (append (list (point-min) (point-max)
+ (if (boundp 'sendmail-program)
+ sendmail-program
+ "/usr/lib/sendmail")
+ nil errbuf nil "-oi")
+ ;; Always specify who from,
+ ;; since some systems have broken sendmails.
+ (list "-f" (user-login-name))
+ ;; These mean "report errors by mail"
+ ;; and "deliver in background".
+ (if (null message-interactive) '("-oem" "-odb"))
+ ;; Get the addresses from the message
+ ;; unless this is a resend.
+ ;; We must not do that for a resend
+ ;; because we would find the original addresses.
+ ;; For a resend, include the specific addresses.
+ (if resend-to-addresses
+ (list resend-to-addresses)
+ '("-t")))))
+ (when message-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (goto-char (point-min))
+ (while (re-search-forward "\n\n* *" nil t)
+ (replace-match "; "))
+ (if (not (zerop (buffer-size)))
+ (error "Sending...failed to %s"
+ (buffer-substring (point-min) (point-max)))))
+ (when (bufferp errbuf)
+ (kill-buffer errbuf)))))
+
+(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)
+ "msg."))))
+ (setq buffer-file-name name)
+ (mh-send-letter)
+ (condition-case ()
+ (delete-file name)
+ (error nil))))
+
(defun message-send-news (&optional arg)
(let ((tembuf (generate-new-buffer " *message temp*"))
(case-fold-search nil)
(method (if (message-functionp message-post-method)
(funcall message-post-method arg)
message-post-method))
- (messbuf (current-buffer)))
+ (messbuf (current-buffer))
+ (message-syntax-checks
+ (if arg
+ (cons '(existing-newsgroups . disabled)
+ message-syntax-checks)
+ message-syntax-checks))
+ result)
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(message-generate-headers message-required-news-headers)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
+ (message-cleanup-headers)
(when (message-check-news-syntax)
(unwind-protect
(save-excursion
(set-buffer tembuf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
- (insert-buffer-substring messbuf)
+ ;; Avoid copying text props.
+ (insert (format
+ "%s" (save-excursion
+ (set-buffer messbuf)
+ (buffer-string))))
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
(require (car method))
(funcall (intern (format "%s-open-server" (car method)))
(cadr method) (cddr method))
- (funcall (intern (format "%s-request-post"
- (car method)))))
+ (setq result
+ (funcall (intern (format "%s-request-post" (car method))))))
(kill-buffer tembuf))
(set-buffer messbuf)
- (push 'news message-sent-message-via))))
+ (if result
+ (push 'news message-sent-message-via)
+ (message "Couldn't send message via news: %s"
+ (nnheader-get-report (car method)))
+ nil))))
;;;
;;; Header generation & syntax checking.
(defun message-check-news-syntax ()
"Check the syntax of the message."
- (or
- (not message-syntax-checks)
- (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 " (mail-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 (mail-fetch-field "newsgroups"))
- (followup-to (mail-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"))))
-
- ;; 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 (mail-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 (mail-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 From header.
- (or (message-check-element 'from)
- (save-excursion
- (let* ((case-fold-search t)
- (from (mail-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)
- (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)
- (or (re-search-forward "[^ \n\t]" nil 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)
+ (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 "Shoot me".
+ (or (message-check-element 'shoot)
+ (save-excursion
+ (if (re-search-forward
+ "Message-ID.*.i-have-a-misconfigured-system-so-shoot-me"
+ nil t)
+ (y-or-n-p
+ "You appear to have a misconfigured system. Really post? ")
+ 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
+ (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)
+ (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)))
+ (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.
+ (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 (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.
+ (or
+ (message-check-element 'signature)
+ (progn
+ (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 "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 (not (re-search-backward "^-- $" 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)))))))
-
-;; Returns non-nil if this type is not to be checked.
+ (format
+ "Your .sig is %d lines; it should be max 4. Really post? "
+ (count-lines (point) (point-max))))
+ t))))))
+
(defun message-check-element (type)
- (not
- (or (not message-syntax-checks)
- (if (listp message-syntax-checks)
- (memq type message-syntax-checks)
- t))))
+ "Returns non-nil if this type is not to be checked."
+ (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
+ t
+ (let ((able (assq type message-syntax-checks)))
+ (and (consp able)
+ (eq (cdr able) 'disabled)))))
(defun message-checksum ()
"Return a \"checksum\" for the current buffer."
(let ((sum 0))
(save-excursion
+ (goto-char (point-min))
+ (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))
(insert-buffer-substring buf)
(save-restriction
(message-narrow-to-headers)
- (while (setq file (mail-fetch-field "fcc"))
+ (while (setq file (message-fetch-field "fcc"))
(push file list)
(message-remove-header "fcc" nil t)))
(goto-char (point-min))
- (re-search-forward (concat "^" mail-header-separator "$"))
+ (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
(replace-match "" t t)
;; Process FCC operations.
(while list
(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))
(defun message-make-message-id ()
"Make a unique Message-ID."
(concat "<" (message-unique-id)
- (let ((psubject (save-excursion (mail-fetch-field "subject"))))
+ (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)
(mail-header-subject message-reply-headers))
(message-strip-subject-re psubject))))
"_-_" ""))
- "@" (message-make-fqdm) ">"))
+ "@" (message-make-fqdn) ">"))
(defvar message-unique-id-char nil)
message-user-organization)))))
(save-excursion
(message-set-work-buffer)
- (cond ((stringp message-user-organization)
- (insert message-user-organization))
- ((and (eq t message-user-organization)
+ (cond ((stringp organization)
+ (insert organization))
+ ((and (eq t organization)
message-user-organization-file
(file-exists-p message-user-organization-file))
(insert-file-contents message-user-organization-file)))
(defun message-make-from ()
"Make a From header."
(let* ((login (message-make-address))
- (fullname (user-full-name)))
+ (fullname
+ (or (and (boundp 'user-full-name)
+ user-full-name)
+ (user-full-name))))
(when (string= fullname "&")
(setq fullname (user-login-name)))
(save-excursion
(when user-mail-address
(nth 1 (mail-extract-address-components user-mail-address))))
-(defun message-make-fqdm ()
+(defun message-make-fqdn ()
"Return user's fully qualified domain name."
- (let ((system-name (system-name)))
+ (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")))))
(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.
(Distribution (message-make-distribution))
(Lines (message-make-lines))
(X-Newsreader message-newsreader)
- (X-Mailer (and (not (mail-fetch-field "X-Newsreader"))
+ (X-Mailer (and (not (message-fetch-field "X-Newsreader"))
message-mailer))
(Expires (message-make-expires))
(case-fold-search t)
(point) (match-end 0)
'(message-deletable t face italic) (current-buffer)))))))
;; Insert new Sender if the From is strange.
- (let ((from (mail-fetch-field "from"))
- (sender (mail-fetch-field "sender"))
+ (let ((from (message-fetch-field "from"))
+ (sender (message-fetch-field "sender"))
(secure-sender (message-make-sender)))
(when (and from
(not (message-check-element 'sender))
(save-excursion
(save-restriction
(message-narrow-to-headers)
- (let ((newsgroups (mail-fetch-field "newsgroups")))
+ (let ((newsgroups (message-fetch-field "newsgroups")))
(when newsgroups
(goto-char (point-max))
(insert "Posted-To: " newsgroups "\n"))))
;;; Setting up a message buffer
;;;
+(defun message-fill-address (header value)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")
+ (narrow-to-region (point-min) (1- (point-max)))
+ (let (quoted last)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward "^,\"" (point-max))
+ (if (or (= (following-char) ?,)
+ (eobp))
+ (when (not quoted)
+ (if (and (> (current-column) 78)
+ last)
+ (progn
+ (save-excursion
+ (goto-char last)
+ (insert "\n\t"))
+ (setq last (1+ (point))))
+ (setq last (1+ (point)))))
+ (setq quoted (not quoted)))
+ (unless (eobp)
+ (forward-char 1))))
+ (goto-char (point-max))
+ (widen)
+ (forward-line 1)))
+
(defun message-fill-header (header value)
(let ((begin (point))
(fill-column 78)
- (fill-prefix "\t")
- end)
+ (fill-prefix "\t"))
(insert (capitalize (symbol-name header))
": "
(if (consp value) (car value) value)
(forward-line 2)))
(sit-for 0)))
+(defun message-buffer-name (type &optional to group)
+ "Return a new (unique) buffer name based on TYPE and TO."
+ (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."
- (if message-generate-new-buffers
- (set-buffer (pop-to-buffer (generate-new-buffer name)))
- (let ((buffer (get-buffer name)))
- (if (and buffer
- (buffer-name buffer))
- (progn
- (set-buffer (pop-to-buffer buffer))
- (when (and (buffer-modified-p)
- (not (y-or-n-p
- "Message already being composed; erase? ")))
- (error "Message being composed")))
- (set-buffer (pop-to-buffer name)))))
+ (let ((buffer (get-buffer name)))
+ (if (and buffer
+ (buffer-name buffer))
+ (progn
+ (set-buffer (pop-to-buffer buffer))
+ (when (and (buffer-modified-p)
+ (not (y-or-n-p
+ "Message already being composed; erase? ")))
+ (error "Message being composed")))
+ (set-buffer (pop-to-buffer name))))
(erase-buffer)
(message-mode))
+(defun message-do-send-housekeeping ()
+ "Kill old message buffers."
+ ;; We might have sent this buffer already. Delete it from the
+ ;; list of buffers.
+ (setq message-buffer-list (delq (current-buffer) message-buffer-list))
+ (while (and message-max-buffers
+ (>= (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.
+ (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
+ (nconc message-buffer-list (list (current-buffer))))))
+
+(defvar mc-modes-alist)
(defun message-setup (headers &optional replybuffer actions)
- (setq message-send-actions actions)
+ (when (and (boundp 'mc-modes-alist)
+ (not (assq 'message-mode mc-modes-alist)))
+ (push '(message-mode (encrypt . mc-encrypt-message)
+ (sign . mc-sign-message))
+ mc-modes-alist))
+ (when actions
+ (setq message-send-actions actions))
(setq message-reply-buffer replybuffer)
(goto-char (point-min))
;; Insert all the headers.
(pop h))
alist)
headers)
- (forward-line -1)
+ (delete-region (point) (progn (forward-line -1) (point)))
(when message-default-headers
(insert message-default-headers))
- (insert mail-header-separator "\n")
+ (put-text-property
+ (point)
+ (progn
+ (insert mail-header-separator "\n")
+ (1- (point)))
+ 'read-only nil)
(forward-line -1)
(when (message-news-p)
(when message-default-news-headers
(when message-generate-headers-first
(message-generate-headers
(delq 'Lines
- (copy-sequence message-required-news-headers)))))
+ (delq 'Subject
+ (copy-sequence message-required-news-headers))))))
(when (message-mail-p)
(when message-default-mail-headers
(insert message-default-mail-headers))
(when message-generate-headers-first
(message-generate-headers
(delq 'Lines
- (copy-sequence message-required-mail-headers)))))
+ (delq 'Subject
+ (copy-sequence message-required-mail-headers))))))
+ (run-hooks 'message-signature-setup-hook)
(message-insert-signature)
(message-set-auto-save-file-name)
(save-restriction
(message-narrow-to-headers)
(run-hooks 'message-header-setup-hook))
- ;; Allow mail alias things.
- (if (fboundp 'mail-abbrevs-setup)
- (mail-abbrevs-setup)
- (mail-aliases-setup))
(set-buffer-modified-p nil)
(run-hooks 'message-setup-hook)
(message-position-point)
(defun message-mail (&optional to subject)
"Start editing a mail message to be sent."
(interactive)
- (message-pop-to-buffer "*mail message*")
+ (message-pop-to-buffer (message-buffer-name "mail" to))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
;;;###autoload
(defun message-news (&optional newsgroups subject)
"Start editing a news article to be sent."
(interactive)
- (message-pop-to-buffer "*news message*")
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject "")))))
"Start editing a reply to the article in the current buffer."
(interactive)
(let ((cur (current-buffer))
- from subject date reply-to message-of to cc
- references message-id sender follow-to sendto elt new-cc new-to
+ from subject date reply-to to cc
+ references message-id follow-to
+ (inhibit-point-motion-hooks t)
mct never-mct gnus-warning)
(save-restriction
(narrow-to-region
(setq follow-to
(funcall message-wide-reply-to-function)))))
;; Find all relevant headers we need.
- (setq from (mail-fetch-field "from")
- date (mail-fetch-field "date")
- sender (mail-fetch-field "sender")
- subject (or (mail-fetch-field "subject") "none")
- to (mail-fetch-field "to")
- cc (mail-fetch-field "cc")
- mct (mail-fetch-field "mail-copies-to")
- reply-to (unless ignore-reply-to (mail-fetch-field "reply-to"))
- references (mail-fetch-field "references")
- message-id (mail-fetch-field "message-id"))
+ (setq from (message-fetch-field "from")
+ date (message-fetch-field "date")
+ subject (or (message-fetch-field "subject") "none")
+ to (message-fetch-field "to")
+ cc (message-fetch-field "cc")
+ mct (message-fetch-field "mail-copies-to")
+ reply-to (unless ignore-reply-to (message-fetch-field "reply-to"))
+ references (message-fetch-field "references")
+ message-id (message-fetch-field "message-id"))
;; Remove any (buggy) Re:'s that are present and make a
;; proper one.
- (when (string-match "^[ \t]*[Re][Ee]:[ \t]*" subject)
+ (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
(setq subject (substring subject (match-end 0))))
(setq subject (concat "Re: " subject))
- (when (and (setq gnus-warning (mail-fetch-field "gnus-warning"))
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
(string-match "<[^>]+>" gnus-warning))
(setq message-id (match-string 0 gnus-warning)))
(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) ""))
+ (insert (if (bolp) "" ", ") (or to ""))
+ (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
+ (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
;; Remove addresses that match `rmail-dont-reply-to-names'.
(insert (prog1 (rmail-dont-reply-to (buffer-string))
(erase-buffer)))
(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)))))
follow-to)))))
(widen))
- (message-pop-to-buffer "*mail message*")
+ (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
- (References . ,(concat (or references "") (and references " ")
- (or message-id ""))))
+ ,@(if (or references message-id)
+ `((References . ,(concat (or references "") (and references " ")
+ (or message-id ""))))
+ nil))
cur)))
;;;###autoload
(defun message-followup ()
(interactive)
(let ((cur (current-buffer))
- from subject date message-of reply-to mct
- references message-id follow-to sendto elt
+ from subject date reply-to mct
+ references message-id follow-to
+ (inhibit-point-motion-hooks t)
followup-to distribution newsgroups gnus-warning)
(save-restriction
(narrow-to-region
(when (message-functionp message-followup-to-function)
(setq follow-to
(funcall message-followup-to-function)))
- (setq from (mail-fetch-field "from")
- date (mail-fetch-field "date")
- subject (or (mail-fetch-field "subject") "none")
- references (mail-fetch-field "references")
- message-id (mail-fetch-field "message-id")
- followup-to (mail-fetch-field "followup-to")
- newsgroups (mail-fetch-field "newsgroups")
- reply-to (mail-fetch-field "reply-to")
- distribution (mail-fetch-field "distribution")
- mct (mail-fetch-field "mail-copies-to"))
- (when (and (setq gnus-warning (mail-fetch-field "gnus-warning"))
+ (setq from (message-fetch-field "from")
+ date (message-fetch-field "date")
+ subject (or (message-fetch-field "subject") "none")
+ references (message-fetch-field "references")
+ message-id (message-fetch-field "message-id")
+ followup-to (message-fetch-field "followup-to")
+ newsgroups (message-fetch-field "newsgroups")
+ reply-to (message-fetch-field "reply-to")
+ distribution (message-fetch-field "distribution")
+ mct (message-fetch-field "mail-copies-to"))
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
(string-match "<[^>]+>" gnus-warning))
(setq message-id (match-string 0 gnus-warning)))
;; Remove bogus distribution.
(setq distribution nil))
;; Remove any (buggy) Re:'s that are present and make a
;; proper one.
- (when (string-match "^[ \t]*[Re][Ee]:[ \t]*" subject)
+ (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
(setq subject (substring subject (match-end 0))))
(setq subject (concat "Re: " subject))
(widen))
- (message-pop-to-buffer "*news message*")
+ (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
(message-setup
`((Subject . ,subject)
(cond
((equal (downcase followup-to) "poster")
(if (or (eq message-use-followup-to 'use)
- (y-or-n-p "Use Followup-To \"poster\"? "))
+ (message-y-or-n-p "Obey Followup-To: poster? " t "\
+You should normally obey the Followup-To: header.
+
+`Followup-To: poster' sends your response via e-mail instead of news.
+
+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 ""))
(cons 'Newsgroups newsgroups)))
(t
(if (or (equal followup-to newsgroups)
(not (eq message-use-followup-to 'ask))
- (y-or-n-p
- (format "Use Followup-To %s? " followup-to)))
+ (message-y-or-n-p
+ (concat "Obey Followup-To: " followup-to "? ") t "\
+You should normally obey the Followup-To: header.
+
+ `Followup-To: " followup-to "'
+directs your response to " (if (string-match "," followup-to)
+ "the specified newsgroups"
+ "that newsgroup only") ".
+
+If a message is posted to several newsgroups, Followup-To is often
+used to direct the following discussion to one newsgroup only,
+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;
+responses here are directed to other newsgroups."))
(cons 'Newsgroups followup-to)
(cons 'Newsgroups newsgroups))))))
(t
(interactive)
(unless (message-news-p)
(error "This is not a news article; canceling is impossible"))
- (when (yes-or-no-p "Do you really want to cancel this article? "))
- (let (from newsgroups message-id distribution buf)
- (save-excursion
- ;; Get header info. from original article.
- (save-restriction
- (message-narrow-to-head)
- (setq from (mail-fetch-field "from")
- newsgroups (mail-fetch-field "newsgroups")
- message-id (mail-fetch-field "message-id")
- distribution (mail-fetch-field "distribution")))
- ;; Make sure that this article was written by the user.
- (unless (string-equal
- (downcase (mail-strip-quoted-names from))
- (downcase (message-make-address)))
- (error "This article is not yours"))
- ;; Make control message.
- (setq buf (set-buffer (get-buffer-create " *message cancel*")))
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert "Newsgroups: " newsgroups "\n"
- "From: " (message-make-from) "\n"
- "Subject: cmsg cancel " message-id "\n"
- "Control: cancel " message-id "\n"
- (if distribution
- (concat "Distribution: " distribution "\n")
- "")
- mail-header-separator "\n"
- "This is a cancel message from " from ".\n")
- (message "Canceling your article...")
- (let (message-syntax-checks)
- (funcall message-send-news-function))
- (message "Canceling your article...done")
- (kill-buffer buf))))
+ (when (yes-or-no-p "Do you really want to cancel this article? ")
+ (let (from newsgroups message-id distribution buf)
+ (save-excursion
+ ;; Get header info. from original article.
+ (save-restriction
+ (message-narrow-to-head)
+ (setq from (message-fetch-field "from")
+ newsgroups (message-fetch-field "newsgroups")
+ message-id (message-fetch-field "message-id")
+ distribution (message-fetch-field "distribution")))
+ ;; Make sure that this article was written by the user.
+ (unless (string-equal
+ (downcase (cadr (mail-extract-address-components from)))
+ (downcase (message-make-address)))
+ (error "This article is not yours"))
+ ;; Make control message.
+ (setq buf (set-buffer (get-buffer-create " *message cancel*")))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert "Newsgroups: " newsgroups "\n"
+ "From: " (message-make-from) "\n"
+ "Subject: cmsg cancel " message-id "\n"
+ "Control: cancel " message-id "\n"
+ (if distribution
+ (concat "Distribution: " distribution "\n")
+ "")
+ mail-header-separator "\n"
+ "This is a cancel message from " from ".\n")
+ (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")
+ (kill-buffer buf)))))
;;;###autoload
(defun message-supersede ()
(let ((cur (current-buffer)))
;; Check whether the user owns the article that is to be superseded.
(unless (string-equal
- (downcase (mail-strip-quoted-names (mail-fetch-field "from")))
- (downcase (mail-strip-quoted-names (message-make-address))))
+ (downcase (cadr (mail-extract-address-components
+ (message-fetch-field "from"))))
+ (downcase (message-make-address)))
(error "This article is not yours"))
;; Get a normal message buffer.
- (message-pop-to-buffer "*supersede message*")
+ (message-pop-to-buffer (message-buffer-name "supersede"))
(insert-buffer-substring cur)
(message-narrow-to-head)
;; Remove unwanted headers.
(defun message-make-forward-subject ()
"Return a Subject header suitable for the message in the current buffer."
- (concat "[" (mail-fetch-field (if (message-news-p) "newsgroups" "from"))
- "] " (or (mail-fetch-field "Subject") "")))
+ (concat "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from"))
+ "(nowhere)")
+ "] " (or (message-fetch-field "Subject") "")))
;;;###autoload
(defun message-forward (&optional news)
(if message-signature-before-forwarded-message
(goto-char (point-max))
(message-goto-body))
+ ;; Make sure we're at the start of the line.
+ (unless (eolp)
+ (insert "\n"))
;; Narrow to the area we are to insert.
(narrow-to-region (point) (point))
;; Insert the separators and the forwarded buffer.
(beginning-of-line)
(insert "Also-"))
;; Send it.
- (funcall message-send-mail-function)
+ (message-send-mail)
(kill-buffer (current-buffer)))))
;;;###autoload
This only makes sense if the current message is a bounce message than
contains some mail you have written which has been bounced back to
you."
- (interactive "P")
- (let ((cur (current-buffer)))
- (message-pop-to-buffer "*mail message*")
+ (interactive)
+ (let ((cur (current-buffer))
+ boundary)
+ (message-pop-to-buffer (message-buffer-name "bounce"))
(insert-buffer-substring cur)
(undo-boundary)
+ (message-narrow-to-head)
+ (if (and (message-fetch-field "Mime-Version")
+ (setq boundary (message-fetch-field "Content-Type")))
+ (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
+ (setq boundary (concat (match-string 1 boundary) " *\n"
+ "Content-Type: message/rfc822"))
+ (setq boundary nil)))
+ (widen)
(goto-char (point-min))
- (or (and (re-search-forward mail-unsent-separator nil t)
+ (search-forward "\n\n" nil t)
+ (or (and boundary
+ (re-search-forward boundary nil t)
+ (forward-line 2))
+ (and (re-search-forward message-unsent-separator nil t)
(forward-line 1))
(and (search-forward "\n\n" nil t)
(re-search-forward "^Return-Path:.*\n" nil t)))
;; We remove everything before the bounced mail.
(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
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer "*mail message*"))
+ (message-pop-to-buffer (message-buffer-name "mail" to)))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
;;;###autoload
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer "*mail message*"))
+ (message-pop-to-buffer (message-buffer-name "mail" to)))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
;;;###autoload
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer "*news message*"))
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject "")))))
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer "*news message*"))
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject "")))))
(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)
+ (require 'messagexmas))
+
+;;; Group name completion.
+
+(defvar message-newgroups-header-regexp
+ "^\\(Newsgroups\\|Followup-To\\|Posted-To\\):"
+ "Regexp that match headers that lists groups.")
+
+(defun message-tab ()
+ "Expand group names in Newsgroups and Followup-To headers.
+Do a `tab-to-tab-stop' if not in those headers."
+ (interactive)
+ (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
+ (mail-abbrev-in-expansion-header-p))
+ (message-expand-group)
+ (tab-to-tab-stop)))
+
+(defvar gnus-active-hashtb)
+(defun message-expand-group ()
+ (let* ((b (save-excursion (skip-chars-backward "^, :\t\n") (point)))
+ (completion-ignore-case t)
+ (string (buffer-substring b (point)))
+ (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
+ (completions (all-completions string hashtb))
+ (cur (current-buffer))
+ comp)
+ (delete-region b (point))
+ (cond
+ ((= (length completions) 1)
+ (if (string= (car completions) string)
+ (progn
+ (insert string)
+ (message "Only matching group"))
+ (insert (car completions))))
+ ((and (setq comp (try-completion string hashtb))
+ (not (string= comp string)))
+ (insert comp))
+ (t
+ (insert string)
+ (if (not comp)
+ (message "No matching groups")
+ (pop-to-buffer "*Completions*")
+ (buffer-disable-undo (current-buffer))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (display-completion-list (sort completions 'string<)))
+ (goto-char (point-min))
+ (pop-to-buffer cur)))))))
+
+;;; Help stuff.
+
+(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))
+
+(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.
+The following arguments may contain lists of values."
+ (if (and show
+ (setq text (message-flatten-list text)))
+ (save-window-excursion
+ (save-excursion
+ (with-output-to-temp-buffer " *MESSAGE information message*"
+ (set-buffer " *MESSAGE information message*")
+ (mapcar 'princ text)
+ (goto-char (point-min))))
+ (funcall ask question))
+ (funcall ask question)))
+
+(defun message-flatten-list (&rest list)
+ (message-flatten-list-1 list))
+
+(defun message-flatten-list-1 (list)
+ (cond ((consp list)
+ (apply 'append (mapcar 'message-flatten-list-1 list)))
+ (list
+ (list list))))
+
+(run-hooks 'message-load-hook)
+
(provide 'message)
;;; message.el ends here