(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
"*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
(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.")
;;; 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
(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)
"Alist used for formatting headers.")
(eval-and-compile
- (autoload 'message-setup-toolbar "message-xmas"))
+ (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-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)
(define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
- (define-key message-mode-map "\C-c\C-p" 'message-dont-send))
+ (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]
- ["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]
+ ["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]
"----"
["Sort Headers" message-sort-headers t]
["Yank Original" message-yank-original t]
["Fill Yanked Message" message-fill-yanked-message t]
- ;; ["Insert Signature" news-reply-signature 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]
"----"
- ["Post Message" message-send-and-exit 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 ()
"Major mode for editing mail and news to be sent.
(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)
(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.
+; ;; 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))
+; (skip-chars-backward " \t\n")
+; (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))
(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)))))
+
(defun message-fill-yanked-message (&optional justifyp)
"Fill the paragraphs of a message yanked into this one.
Numeric argument means justify as well."
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))
(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))
(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-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)
(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.
(let ((message-deletable-headers
(if news nil message-deletable-headers)))
(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.
- (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)))))))
- (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)
(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))
+ (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)
(or
(message-check-element 'subject-cmsg)
(save-excursion
- (if (string-match "^cmsg " (mail-fetch-field "subject"))
+ (if (string-match "^cmsg " (message-fetch-field "subject"))
(y-or-n-p
"The control code \"cmsg \" is in the subject. Really post? ")
t)))
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"))
+ (let ((newsgroups (message-fetch-field "newsgroups"))
+ (followup-to (message-fetch-field "followup-to"))
to)
(when (and newsgroups (string-match "," newsgroups)
(not followup-to)
(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
(or (message-check-element 'message-id)
(save-excursion
(let* ((case-fold-search t)
- (message-id (mail-fetch-field "message-id")))
+ (message-id (message-fetch-field "message-id")))
(or (not message-id)
(and (string-match "@" message-id)
(string-match "@[^\\.]*\\." message-id))
(message-check-element 'subject)
(save-excursion
(let* ((case-fold-search t)
- (subject (mail-fetch-field "subject")))
+ (subject (message-fetch-field "subject")))
(or
(and subject
(not (string-match "\\`[ \t]*\\'" subject)))
(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 (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))))))))
+ (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
;; Check whether any new text has been added.
(or (message-check-element 'new-text)
(not message-checksum)
- (not (eq (message-checksum) 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 (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))))))
+ (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))))))
(defun message-check-element (type)
"Returns non-nil if this type is not to be checked."
(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))
(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)
(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)
(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)
+ (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)
(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
(delq 'Lines
(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
(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 "")))))
(let ((cur (current-buffer))
from subject date reply-to to cc
references message-id follow-to
+ (inhibit-point-motion-hooks t)
mct never-mct gnus-warning)
(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")
- 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]*[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 ""))
(let ((cur (current-buffer))
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 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
;; 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")))
+ (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 (mail-strip-quoted-names from))
+ (downcase (cadr (mail-extract-address-components from)))
(downcase (message-make-address)))
(error "This article is not yours"))
;; Make control message.
(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
(interactive)
(let ((cur (current-buffer))
boundary)
- (message-pop-to-buffer "*mail message*")
+ (message-pop-to-buffer (message-buffer-name "bounce"))
(insert-buffer-substring cur)
(undo-boundary)
(message-narrow-to-head)
- (if (and (mail-fetch-field "Mime-Version")
- (setq boundary (mail-fetch-field "Content-Type")))
+ (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"))
;; 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 'message-xmas))
+ (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 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.
+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)