2001-10-30 04:00:00 ShengHuo ZHU <zsh@cs.rochester.edu>
[gnus] / lisp / message.el
index 997f783..18d54f6 100644 (file)
@@ -40,6 +40,7 @@
     (require 'mail-abbrevs))
 (require 'mail-parse)
 (require 'mml)
+(require 'rfc822)
 
 (defgroup message '((user-mail-address custom-variable)
                    (user-full-name custom-variable))
@@ -190,7 +191,7 @@ header, remove it from this list."
   '(From Subject Date (optional . In-Reply-To) Message-ID Lines
         (optional . User-Agent))
   "*Headers to be generated or prompted for when mailing a message.
-RFC822 required that From, Date, To, Subject and Message-ID be
+It is recommended that From, Date, To, Subject and Message-ID be
 included.  Organization, Lines and User-Agent are optional."
   :group 'message-mail
   :group 'message-headers
@@ -1114,6 +1115,9 @@ no, only reply back to the author."
 (defvar message-send-mail-real-function nil
   "Internal send mail function.")
 
+(defvar message-bogus-system-names "^localhost\\."
+  "The regexp of bogus system names.")
+
 (eval-and-compile
   (autoload 'message-setup-toolbar "messagexmas")
   (autoload 'mh-new-draft-name "mh-comp")
@@ -1130,6 +1134,8 @@ no, only reply back to the author."
   (autoload 'gnus-alive-p "gnus-util")
   (autoload 'gnus-server-string "gnus")
   (autoload 'gnus-group-name-charset "gnus-group")
+  (autoload 'gnus-group-name-decode "gnus-group")
+  (autoload 'gnus-groups-from-server "gnus")
   (autoload 'rmail-output "rmailout"))
 
 \f
@@ -1483,6 +1489,7 @@ Point is left at the beginning of the narrowed-to region."
   (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 "\C-c\n" 'gnus-delay-article)
 
   (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
   (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
@@ -1512,16 +1519,16 @@ Point is left at the beginning of the narrowed-to region."
     ["Spellcheck" ispell-message
      ,@(if (featurep 'xemacs) '(t)
         '(:help "Spellcheck this message"))]
-    ["Attach file as MIME" mml-attach-file
-     ,@(if (featurep 'xemacs) '(t)
-        '(:help "Attach a file at point"))]
     "----"
     ["Send Message" message-send-and-exit
      ,@(if (featurep 'xemacs) '(t)
         '(:help "Send this message"))]
-    ["Abort Message" message-dont-send
+    ["Postpone Message" message-dont-send
      ,@(if (featurep 'xemacs) '(t)
         '(:help "File this draft message and exit"))]
+    ["Send at Specific Time" gnus-delay-article
+     ,@(if (featurep 'xemacs) '(t)
+        '(:help "Ask, then arrange to send message at that time"))]
     ["Kill Message" message-kill-buffer
      ,@(if (featurep 'xemacs) '(t)
         '(:help "Delete this message without sending"))]))
@@ -1629,7 +1636,6 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
   (unless (boundp 'adaptive-fill-first-line-regexp)
     (setq adaptive-fill-first-line-regexp nil))
   (make-local-variable 'adaptive-fill-first-line-regexp)
-  (make-local-variable 'auto-fill-inhibit-regexp)
   (let ((quote-prefix-regexp
         ;; User should change message-cite-prefix-regexp if
         ;; message-yank-prefix is set to an abnormal value.
@@ -1648,8 +1654,19 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
          (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
     (setq adaptive-fill-first-line-regexp
          (concat quote-prefix-regexp "\\|"
-                 adaptive-fill-first-line-regexp))
-    (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")))
+                 adaptive-fill-first-line-regexp)))
+  (make-local-variable 'auto-fill-inhibit-regexp)
+  ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
+  (setq auto-fill-inhibit-regexp nil)
+  (make-local-variable 'normal-auto-fill-function)
+  (setq normal-auto-fill-function 'message-do-auto-fill)
+  ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'.
+  ;; In that case, ensure that it uses the right function.  The real
+  ;; solution would be not to use `define-derived-mode', and run
+  ;; `text-mode-hook' ourself at the end of the mode.
+  ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19.
+  (when auto-fill-function
+    (setq auto-fill-function normal-auto-fill-function)))
 
 \f
 
@@ -1921,6 +1938,17 @@ Prefix arg means justify as well."
     (message-newline-and-reformat arg t)
     t))
 
+(defun message-do-auto-fill ()
+  "Like `do-auto-fill', but don't fill in message header."
+  (when (> (point) (save-excursion 
+                    (goto-char (point-min))
+                    (if (re-search-forward
+                         (concat "^" (regexp-quote mail-header-separator)
+                                 "\n") nil t)
+                        (match-beginning 0)
+                      (point-max))))
+    (do-auto-fill)))
+
 (defun message-insert-signature (&optional force)
   "Insert a signature.  See documentation for variable `message-signature'."
   (interactive (list 0))
@@ -2100,31 +2128,11 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
        (indent-rigidly start (mark t) message-indentation-spaces)
       (save-excursion
        (goto-char start)
-       (let (last-line)
-         ;; `last-line' describes the contents of the last line
-         ;; encountered in the loop below. nil means "empty line",
-         ;; spaces "line consisting entirely of whitespace",
-         ;; right-angle "line starts with >", quoted "quote character
-         ;; at the beginning of the line", text "the remaining cases".
-         (while (< (point) (mark t))
-           (cond
-            ((eolp) 
+       (while (< (point) (mark t))
+         (if (or (looking-at ">") (looking-at "^$"))
              (insert message-yank-cited-prefix)
-             (setq last-line nil))
-            ((looking-at ">")
-             (if (memq last-line '(nil spaces right-angle quoted))
-                 (progn
-                   (insert message-yank-cited-prefix)
-                   (setq last-line 'quoted))
-               (insert message-yank-prefix)
-               (setq last-line 'right-angle)))
-            ((looking-at "\\s-+$")
-             (insert message-yank-prefix)
-             (setq last-line 'spaces))
-            (t
-             (insert message-yank-prefix)
-             (setq last-line 'text)))
-           (forward-line 1)))))
+           (insert message-yank-prefix))
+         (forward-line 1))))
     (goto-char start)))
 
 (defun message-yank-original (&optional arg)
@@ -2482,19 +2490,17 @@ It should typically alter the sending method in some way or other."
              (insert "Mime-Version: 1.0\n")
              (setq header (buffer-substring (point-min) (point-max))))
            (goto-char (point-max))
-           (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n"
+           (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
                            id n total))
+           (forward-char -1)
            (let ((mail-header-separator ""))
              (when (memq 'Message-ID message-required-mail-headers)
                (insert "Message-ID: " (message-make-message-id) "\n"))
              (when (memq 'Lines message-required-mail-headers)
-               (let ((mail-header-separator ""))
-                 (insert "Lines: " (message-make-lines) "\n")))
+               (insert "Lines: " (message-make-lines) "\n"))
              (message-goto-subject)
              (end-of-line)
              (insert (format " (%d/%d)" n total))
-             (goto-char (point-max))
-             (insert "\n")
              (widen)
              (mm-with-unibyte-current-buffer
                (funcall (or message-send-mail-real-function
@@ -2702,23 +2708,36 @@ to find out how to use this."
         (method (if (message-functionp message-post-method)
                     (funcall message-post-method arg)
                   message-post-method))
-        (group-name-charset (gnus-group-name-charset method ""))
+        (newsgroups-field (save-restriction
+                           (message-narrow-to-headers-or-head)
+                           (message-fetch-field "Newsgroups")))
+        (followup-field (save-restriction
+                          (message-narrow-to-headers-or-head)
+                          (message-fetch-field "Followup-To")))
+        ;; BUG: We really need to get the charset for each name in the
+        ;; Newsgroups and Followup-To lines to allow crossposting
+        ;; between group namess with incompatible character sets.
+        ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
+        (group-field-charset
+         (gnus-group-name-charset method newsgroups-field))
+        (followup-field-charset 
+         (gnus-group-name-charset method (or followup-field "")))
         (rfc2047-header-encoding-alist
-         (if group-name-charset
-             (cons (cons "Newsgroups" group-name-charset)
-                   rfc2047-header-encoding-alist)
-           rfc2047-header-encoding-alist))
+         (append (when group-field-charset
+                   (list (cons "Newsgroups" group-field-charset)))
+                 (when followup-field-charset
+                   (list (cons "Followup-To" followup-field-charset)))
+                 rfc2047-header-encoding-alist))
         (messbuf (current-buffer))
         (message-syntax-checks
-         (if arg
+         (if (and arg
+                  (listp message-syntax-checks))
              (cons '(existing-newsgroups . disabled)
                    message-syntax-checks)
            message-syntax-checks))
         (message-this-is-news t)
-        (message-posting-charset (gnus-setup-posting-charset
-                                  (save-restriction
-                                    (message-narrow-to-headers-or-head)
-                                    (message-fetch-field "Newsgroups"))))
+        (message-posting-charset
+         (gnus-setup-posting-charset newsgroups-field))
         result)
     (if (not (message-check-news-body-syntax))
        nil
@@ -2728,7 +2747,10 @@ to find out how to use this."
        (message-generate-headers message-required-news-headers)
        ;; Let the user do all of the above.
        (run-hooks 'message-header-hook))
-      (when group-name-charset
+      ;; Note: This check will be disabled by the ".*" default value for
+      ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07.
+      (when (and group-field-charset
+                (listp message-syntax-checks))
        (setq message-syntax-checks
              (cons '(valid-newsgroups . disabled)
                    message-syntax-checks)))
@@ -2910,12 +2932,26 @@ to find out how to use this."
                     (if followup-to
                         (concat newsgroups "," followup-to)
                       newsgroups)))
+           (post-method (if (message-functionp message-post-method)
+                            (funcall message-post-method)
+                          message-post-method))
+           ;; KLUDGE to handle nnvirtual groups.  Doing this right
+           ;; would probably involve a new nnoo function.
+           ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17.
+           (method (if (and (consp post-method) 
+                            (eq (car post-method) 'nnvirtual)
+                            gnus-message-group-art)
+                       (let ((group (car (nnvirtual-find-group-art
+                                          (car gnus-message-group-art)
+                                          (cdr gnus-message-group-art)))))
+                         (gnus-find-method-for-group group))
+                     post-method))
            (known-groups
-            (mapcar (lambda (n) (gnus-group-real-name n))
-                    (gnus-groups-from-server
-                     (if (message-functionp message-post-method)
-                         (funcall message-post-method)
-                       message-post-method))))
+            (mapcar (lambda (n)
+                      (gnus-group-name-decode 
+                       (gnus-group-real-name n)
+                       (gnus-group-name-charset method n)))
+                    (gnus-groups-from-server method)))
            errors)
        (while groups
         (unless (or (equal (car groups) "poster")
@@ -3011,6 +3047,14 @@ to find out how to use this."
         (message
          "Denied posting -- the From looks strange: \"%s\"." from)
         nil)
+       ((let ((addresses (rfc822-addresses from)))
+          (while (and addresses
+                      (not (eq (string-to-char (car addresses)) ?\()))
+            (setq addresses (cdr addresses)))
+          addresses)
+        (message
+         "Denied posting -- bad From address: \"%s\"." from)
+        nil)
        (t t))))
    ;; Check the Reply-To header.
    (message-check 'reply-to
@@ -3464,7 +3508,8 @@ give as trustworthy answer as possible."
   (let ((system-name (system-name))
        (user-mail (message-user-mail-address)))
     (cond
-     ((string-match "[^.]\\.[^.]" system-name)
+     ((and (string-match "[^.]\\.[^.]" system-name)
+          (not (string-match message-bogus-system-names system-name)))
       ;; `system-name' returned the right result.
       system-name)
      ;; Try `mail-host-address'.
@@ -4043,14 +4088,15 @@ OTHER-HEADERS is an alist of header/value pairs."
                     (Subject . ,(or subject ""))))))
 
 (defun message-get-reply-headers (wide &optional to-address)
-  (let (follow-to mct never-mct from to cc reply-to mrt mft ccalist)
+  (let (follow-to mct never-mct to cc author mft recipients)
     ;; Find all relevant headers we need.
-    (setq from (message-fetch-field "from")
-         to (message-fetch-field "to")
+    (setq to (message-fetch-field "to")
          cc (message-fetch-field "cc")
          mct (message-fetch-field "mail-copies-to")
-         reply-to (message-fetch-field "reply-to")
-         mrt (message-fetch-field "mail-reply-to")
+         author (or (message-fetch-field "mail-reply-to")
+                    (message-fetch-field "reply-to")
+                    (message-fetch-field "from")
+                    "")
          mft (and message-use-mail-followup-to
                   (message-fetch-field "mail-followup-to")))
 
@@ -4062,24 +4108,17 @@ OTHER-HEADERS is an alist of header/value pairs."
             (setq mct nil))
            ((or (equal (downcase mct) "always")
                 (equal (downcase mct) "poster"))
-            (setq mct (or mrt reply-to from)))))
+            (setq mct author))))
 
-    (if (and (not mft)
-            (or (not wide)
-                to-address))
-       (progn
-         (setq follow-to (list (cons 'To (or to-address mrt reply-to from))))
-         (when (and (and wide mct)
-                    (not (member (cons 'To mct) follow-to)))
-           (push (cons 'Cc mct) follow-to)))
-      (let (ccalist)
-       (save-excursion
-         (message-set-work-buffer)
-         (if (and mft
-                  wide
-                  (or (not (eq message-use-mail-followup-to 'ask))
-                      (message-y-or-n-p
-                       (concat "Obey Mail-Followup-To? ") t "\
+    (save-match-data
+      ;; Build (textual) list of new recipient addresses.
+      (cond
+       ((not wide)
+       (setq recipients (concat ", " author)))
+       ((and mft
+            (string-match "[^ \t,]" mft)
+            (or (not (eq message-use-mail-followup-to 'ask))
+                (message-y-or-n-p "Obey Mail-Followup-To? " t "\
 You should normally obey the Mail-Followup-To: header.  In this
 article, it has the value of
 
@@ -4100,46 +4139,50 @@ fragmented and very difficult to follow.
 
 Also, some source/announcement lists are not intended for discussion;
 responses here are directed to other addresses.")))
-             (insert mft)
-           (unless never-mct
-             (insert (or mrt reply-to from "")))
-           (insert (if to (concat (if (bolp) "" ", ") to "") ""))
-           (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
-           (insert (if cc (concat (if (bolp) "" ", ") cc) "")))
-         (goto-char (point-min))
-         (while (re-search-forward "[ \t]+" nil t)
-           (replace-match " " t t))
-         ;; Remove addresses that match `rmail-dont-reply-to-names'.
-         (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
-           (insert (prog1 (rmail-dont-reply-to (buffer-string))
-                     (erase-buffer))))
-         (goto-char (point-min))
-         ;; Perhaps "Mail-Copies-To: never" removed the only address?
-         (when (eobp)
-           (insert (or mrt reply-to from "")))
-         (setq ccalist
-               (mapcar
-                (lambda (addr)
-                  (cons (mail-strip-quoted-names addr) addr))
-                (message-tokenize-header (buffer-string))))
-         (let ((s ccalist))
-           (while s
-             (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
-       (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
-       (when ccalist
-         (let ((ccs (cons 'Cc (mapconcat
-                               (lambda (addr) (cdr addr)) ccalist ", "))))
-           (when (string-match "^ +" (cdr ccs))
-             (setcdr ccs (substring (cdr ccs) (match-end 0))))
-           (push ccs follow-to)))
-       ;; Allow the user to be asked whether or not to reply to all
-       ;; recipients in a wide reply.
-       (if (and ccalist wide message-wide-reply-confirm-recipients
-                (not (y-or-n-p "Reply to all recipients? ")))
-           (setq follow-to (delq (assoc 'Cc follow-to) follow-to)))))
+       (setq recipients (concat ", " mft)))
+       (to-address
+       (setq recipients (concat ", " to-address))
+       ;; If the author explicitly asked for a copy, we don't deny it to them.
+       (if mct (setq recipients (concat recipients ", " mct))))
+       (t
+       (setq recipients (if never-mct "" (concat ", " author)))
+       (if to  (setq recipients (concat recipients ", " to)))
+       (if cc  (setq recipients (concat recipients ", " cc)))
+       (if mct (setq recipients (concat recipients ", " mct)))))
+      ;; Strip the leading ", ".
+      (setq recipients (substring recipients 2))
+      ;; Squeeze whitespace.
+      (while (string-match "[ \t][ \t]+" recipients)
+       (setq recipients (replace-match " " t t recipients)))
+      ;; Remove addresses that match `rmail-dont-reply-to-names'.
+      (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
+       (setq recipients (rmail-dont-reply-to recipients)))
+      ;; Perhaps "Mail-Copies-To: never" removed the only address?
+      (if (string-equal recipients "")
+         (setq recipients author))
+      ;; Convert string to a list of (("foo@bar" . "Name <foo@bar>") ...).
+      (setq recipients
+           (mapcar
+            (lambda (addr)
+              (cons (mail-strip-quoted-names addr) addr))
+            (message-tokenize-header recipients)))
+      ;; Remove first duplicates.  (Why not all duplicates?  Is this a bug?)
+      (let ((s recipients))
+       (while s
+         (setq recipients (delq (assoc (car (pop s)) s) recipients))))
+      ;; Build the header alist.  Allow the user to be asked whether
+      ;; or not to reply to all recipients in a wide reply.
+      (setq follow-to (list (cons 'To (cdr (pop recipients)))))
+      (when (and recipients
+                (or (not message-wide-reply-confirm-recipients)
+                    (y-or-n-p "Reply to all recipients? ")))
+       (setq recipients (mapconcat
+                         (lambda (addr) (cdr addr)) recipients ", "))
+       (if (string-match "^ +" recipients)
+           (setq recipients (substring recipients (match-end 0))))
+       (push (cons 'Cc recipients) follow-to)))
     follow-to))
 
-
 ;;;###autoload
 (defun message-reply (&optional to-address wide)
   "Start editing a reply to the article in the current buffer."
@@ -4335,15 +4378,36 @@ If ARG, allow editing of the cancellation message."
              message-id (message-fetch-field "message-id" t)
              distribution (message-fetch-field "distribution")))
       ;; Make sure that this article was written by the user.
-      (unless (or (message-gnksa-enable-p 'cancel-messages)
-                 (and sender
-                      (string-equal
-                       (downcase sender)
-                       (downcase (message-make-sender))))
-                 (string-equal
-                  (downcase (cadr (mail-extract-address-components from)))
-                  (downcase (cadr (mail-extract-address-components
-                                   (message-make-from))))))
+      (unless (or
+              ;; Canlock-logic as suggested by Per Abrahamsen
+              ;; <abraham@dina.kvl.dk>
+              ;;
+              ;; IF article has cancel-lock THEN
+              ;;   IF we can load canlock THEN
+              ;;      IF we can verify it THEN
+              ;;         issue cancel
+              ;;      ELSE
+              ;;         error: cancellock: article is not yours
+              ;;   ELSE
+              ;;      error: message is cancel locked
+              ;; ELSE
+              ;;   Use old rules, comparing sender...
+              (if (message-fetch-field "Cancel-Lock")
+                  (if (ignore-errors (require 'canlock))
+                      (if (null (canlock-verify))
+                          t
+                        (error "Failed to verify Cancel-lock: This article is not yours"))
+                    (error "This article is cancel locked, the `canlock.el' library is required."))
+                nil)
+              (message-gnksa-enable-p 'cancel-messages)
+              (and sender
+                   (string-equal
+                    (downcase sender)
+                    (downcase (message-make-sender))))
+              (string-equal
+               (downcase (cadr (mail-extract-address-components from)))
+               (downcase (cadr (mail-extract-address-components
+                                (message-make-from))))))
        (error "This article is not yours"))
       (when (yes-or-no-p "Do you really want to cancel this article? ")
        ;; Make control message.
@@ -4471,8 +4535,8 @@ Source is the sender, and if the original message was news, Source is
 the list of newsgroups is was posted to."
   (concat "["
          (let ((prefix
-                (or (message-fetch-field
-                     (if (message-news-p) "newsgroups" "from"))
+                (or (message-fetch-field "newsgroups")
+                    (message-fetch-field "from")
                     "(nowhere)")))
            (if message-forward-decoded-p
                prefix
@@ -4515,6 +4579,7 @@ the message."
 (eval-when-compile
   (defvar gnus-article-decoded-p))
 
+
 ;;;###autoload
 (defun message-forward (&optional news digest)
   "Forward the current message via mail.
@@ -4526,35 +4591,38 @@ Optional DIGEST will use digest to forward."
          (if (local-variable-p 'gnus-article-decoded-p (current-buffer))
              gnus-article-decoded-p ;; In an article buffer.
            message-forward-decoded-p))
-        (subject (message-make-forward-subject))
-        art-beg)
+        (subject (message-make-forward-subject)))
     (if news
        (message-news nil subject)
       (message-mail nil subject))
-    ;; Put point where we want it before inserting the forwarded
-    ;; message.
-    (if message-forward-before-signature
-       (message-goto-body)
-      (goto-char (point-max)))
-    (if message-forward-as-mime
-       (if digest
-           (insert "\n<#multipart type=digest>\n")
-         (if message-forward-show-mml
-             (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
-           (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))
-      (insert "\n-------------------- Start of forwarded message --------------------\n"))
-    (let ((b (point)) e)
+    (message-forward-make-body cur digest)))
+
+;;;###autoload
+(defun message-forward-make-body (forward-buffer &optional digest)
+  ;; Put point where we want it before inserting the forwarded
+  ;; message.
+  (if message-forward-before-signature
+      (message-goto-body)
+    (goto-char (point-max)))
+  (if message-forward-as-mime
       (if digest
-         (if message-forward-as-mime
-             (insert-buffer-substring cur)
-           (mml-insert-buffer cur))
-       (if (and message-forward-show-mml
-                (not message-forward-decoded-p))
-           (insert
-            (with-temp-buffer
-              (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode
+         (insert "\n<#multipart type=digest>\n")
+       (if message-forward-show-mml
+           (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
+         (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))
+    (insert "\n-------------------- Start of forwarded message --------------------\n"))
+  (let ((b (point)) e)
+    (if digest
+       (if message-forward-as-mime
+           (insert-buffer-substring forward-buffer)
+         (mml-insert-buffer forward-buffer))
+      (if (and message-forward-show-mml
+              (not message-forward-decoded-p))
+         (insert
+          (with-temp-buffer
+            (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode
               (insert
-               (with-current-buffer cur
+               (with-current-buffer forward-buffer
                  (mm-string-as-unibyte (buffer-string))))
               (mm-enable-multibyte-mule4)
               (mime-to-mml)
@@ -4562,37 +4630,51 @@ Optional DIGEST will use digest to forward."
               (when (looking-at "From ")
                 (replace-match "X-From-Line: "))
               (buffer-string)))
-         (save-restriction
-           (narrow-to-region (point) (point))
-           (mml-insert-buffer cur)
-           (goto-char (point-min))
-           (when (looking-at "From ")
-             (replace-match "X-From-Line: "))
-           (goto-char (point-max)))))
-      (setq e (point))
-      (if message-forward-as-mime
-         (if digest
-             (insert "<#/multipart>\n")
-           (if message-forward-show-mml
-               (insert "<#/mml>\n")
-             (insert "<#/part>\n")))
-       (insert "\n-------------------- End of forwarded message --------------------\n"))
-      (if (and digest message-forward-as-mime)
-         (save-restriction
-           (narrow-to-region b e)
-           (goto-char b)
-           (narrow-to-region (point)
-                             (or (search-forward "\n\n" nil t) (point)))
-           (delete-region (point-min) (point-max)))
-       (when (and (not current-prefix-arg)
-                  message-forward-ignored-headers)
-         (save-restriction
-           (narrow-to-region b e)
-           (goto-char b)
-           (narrow-to-region (point)
-                             (or (search-forward "\n\n" nil t) (point)))
-           (message-remove-header message-forward-ignored-headers t)))))
-    (message-position-point)))
+       (save-restriction
+         (narrow-to-region (point) (point))
+         (mml-insert-buffer forward-buffer)
+         (goto-char (point-min))
+         (when (looking-at "From ")
+           (replace-match "X-From-Line: "))
+         (goto-char (point-max)))))
+    (setq e (point))
+    (if message-forward-as-mime
+       (if digest
+           (insert "<#/multipart>\n")
+         (if message-forward-show-mml
+             (insert "<#/mml>\n")
+           (insert "<#/part>\n")))
+      (insert "\n-------------------- End of forwarded message --------------------\n"))
+    (if (and digest message-forward-as-mime)
+       (save-restriction
+         (narrow-to-region b e)
+         (goto-char b)
+         (narrow-to-region (point)
+                           (or (search-forward "\n\n" nil t) (point)))
+         (delete-region (point-min) (point-max)))
+      (when (and (not current-prefix-arg)
+                message-forward-ignored-headers)
+       (save-restriction
+         (narrow-to-region b e)
+         (goto-char b)
+         (narrow-to-region (point)
+                           (or (search-forward "\n\n" nil t) (point)))
+         (message-remove-header message-forward-ignored-headers t)))))
+  (message-position-point))
+
+;;;###autoload
+(defun message-forward-rmail-make-body (forward-buffer)
+  (with-current-buffer forward-buffer
+    (rmail-toggle-header 0))
+  (message-forward-make-body forward-buffer))
+
+;;;###autoload
+(defun message-insinuate-rmail ()
+  "Let RMAIL uses message to forward."
+  (interactive)
+  (setq rmail-enable-mime-composing t)
+  (setq rmail-insert-mime-forwarded-message-function 
+       'message-forward-rmail-make-body))
 
 ;;;###autoload
 (defun message-resend (address)
@@ -4822,6 +4904,9 @@ which specify the range to operate on."
        '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name))
   "Alist of (RE . FUN).  Use FUN for completion on header lines matching RE.")
 
+(defvar message-tab-body-function 'indent-relative
+  "*Function to execute when `message-tab' (TAB) is executed in the body.")
+
 (defun message-tab ()
   "Complete names according to `message-completion-alist'.
 Do an `indent-relative' if not in those headers."
@@ -4831,7 +4916,7 @@ Do an `indent-relative' if not in those headers."
                (let ((mail-abbrev-mode-regexp (caar alist)))
                  (not (mail-abbrev-in-expansion-header-p))))
       (setq alist (cdr alist)))
-    (funcall (or (cdar alist) 'indent-relative))))
+    (funcall (or (cdar alist) message-tab-body-function))))
 
 (defun message-expand-group ()
   "Expand the group name under point."