Support for `article editing' and `re-sending bounced mail' with MIME-Edit.

See ChangeLog for more details.

diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el
index 7c455a2..247338f 100644 (file)
--- a/lisp/gnus-art.el
+++ b/lisp/gnus-art.el
@@ -3,6 +3,7 @@
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;     Katsumi Yamaoka  <yamaoka@jpl.org>
 ;; Keywords: mail, news, MIME
 
 ;; This file is part of GNU Emacs.
@@ -1999,6 +2000,38 @@ commands:
     (mime-maybe-hide-echo-buffer))
   (gnus-run-hooks 'gnus-mime-article-prepare-hook))
 
+(defun gnus-article-make-full-mail-header (&optional number charset)
+  "Create a new mail header structure in a raw article buffer."
+  (unless (and number charset)
+    (save-current-buffer
+      (set-buffer gnus-summary-buffer)
+      (unless number
+       (setq number (or (cdr gnus-article-current) 0)))
+      (unless charset
+       (setq charset (or default-mime-charset 'x-ctext)))))
+  (goto-char (point-min))
+  (let ((header-end (if (search-forward "\n\n" nil t)
+                       (1- (point))
+                     (goto-char (point-max))))
+       (chars (- (point-max) (point)))
+       (lines (count-lines (point) (point-max)))
+       (default-mime-charset charset)
+       xref)
+    (narrow-to-region (point-min) header-end)
+    (setq xref (std11-fetch-field "xref"))
+    (prog1
+       (make-full-mail-header
+        number
+        (std11-fetch-field "subject")
+        (std11-fetch-field "from")
+        (std11-fetch-field "date")
+        (std11-fetch-field "message-id")
+        (std11-fetch-field "references")
+        chars
+        lines
+        (when xref (concat "Xref: " xref)))
+      (widen))))
+
 (defun gnus-article-prepare (article &optional all-headers header)
   "Prepare ARTICLE in article mode buffer.
 ARTICLE should either be an article number or a Message-ID.
@@ -2092,25 +2125,7 @@ If ALL-HEADERS is non-nil, no headers are hidden."
                      (or all-headers gnus-show-all-headers))))
            (when (or (numberp article)
                      (stringp article))
-             ;; Hooks for getting information from the article.
-             ;; This hook must be called before being narrowed.
-             (let ((method
-                    (if gnus-show-mime
-                        (progn
-                          (mime-parse-buffer)
-                          (if (or (not gnus-strict-mime)
-                                  (mime-fetch-field "MIME-Version"))
-                              gnus-article-display-method-for-mime
-                            gnus-article-display-method-for-encoded-word))
-                      gnus-article-display-method-for-traditional)))
-               (gnus-run-hooks 'gnus-tmp-internal-hook)
-               (gnus-run-hooks 'gnus-article-prepare-hook)
-               ;; Display message.
-               (funcall method)
-               ;; Associate this article with the current summary buffer.
-               (setq gnus-article-current-summary summary-buffer)
-               ;; Perform the article display hooks.
-               (gnus-run-hooks 'gnus-article-display-hook))
+             (gnus-article-prepare-display)
              ;; Do page break.
              (goto-char (point-min))
              (setq gnus-page-broken
@@ -2124,6 +2139,26 @@ If ALL-HEADERS is non-nil, no headers are hidden."
            (set-window-point (get-buffer-window (current-buffer)) (point))
            t))))))
 
+(defun gnus-article-prepare-display ()
+  "Make the current buffer look like a nice article."
+  (let ((method
+        (if gnus-show-mime
+            (progn
+              (mime-parse-buffer)
+              (if (or (not gnus-strict-mime)
+                      (mime-fetch-field "MIME-Version"))
+                  gnus-article-display-method-for-mime
+                gnus-article-display-method-for-encoded-word))
+          gnus-article-display-method-for-traditional)))
+    (gnus-run-hooks 'gnus-tmp-internal-hook)
+    (gnus-run-hooks 'gnus-article-prepare-hook)
+    ;; Display message.
+    (funcall method)
+    ;; Associate this article with the current summary buffer.
+    (setq gnus-article-current-summary (current-buffer))
+    ;; Perform the article display hooks.
+    (gnus-run-hooks 'gnus-article-display-hook)))
+
 (defun gnus-article-wash-status ()
   "Return a string which display status of article washing."
   (save-excursion
@@ -2553,6 +2588,12 @@ If given a prefix, show the hidden text instead."
   :group 'gnus-article-various
   :type 'hook)
 
+(defcustom gnus-article-edit-article-setup-function
+  'gnus-article-mime-edit-article-setup
+  "Function called to setup an editing article buffer."
+  :group 'gnus-article-various
+  :type 'function)
+
 (defvar gnus-article-edit-done-function nil)
 
 (defvar gnus-article-edit-mode-map nil)
@@ -2610,6 +2651,8 @@ groups."
     (gnus-configure-windows 'edit-article)
     (setq gnus-article-edit-done-function exit-func)
     (setq gnus-prev-winconf winconf)
+    (when gnus-article-edit-article-setup-function
+      (funcall gnus-article-edit-article-setup-function))
     (gnus-message 6 "C-c C-c to end edits")))
 
 (defun gnus-article-edit-done (&optional arg)
@@ -2640,6 +2683,8 @@ groups."
   (let ((func gnus-article-edit-done-function)
        (buf (current-buffer))
        (start (window-start)))
+    (remove-hook 'gnus-article-mode-hook
+                'gnus-article-mime-edit-article-unwind)
     (gnus-article-edit-exit)
     (save-excursion
       (set-buffer buf)
@@ -2691,6 +2736,86 @@ groups."
       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
 
 ;;;
+;;; Article editing with MIME-Edit
+;;;
+
+(defcustom gnus-article-mime-edit-article-setup-hook nil
+  "Hook run after setting up a MIME editing article buffer."
+  :group 'gnus-article-various
+  :type 'hook)
+
+(defun gnus-article-mime-edit-article-unwind ()
+  "Unwind `gnus-article-buffer' if article editing was given up."
+  (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
+  (when mime-edit-mode-flag
+    (mime-edit-exit 'nomime 'no-error)
+    (message ""))
+  (when (featurep 'font-lock)
+    (setq font-lock-defaults nil)
+    (font-lock-mode 0)))
+
+(defun gnus-article-mime-edit-article-setup ()
+  "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
+after replacing with the original article."
+  (setq gnus-show-mime t)
+  (setq gnus-article-edit-done-function
+       `(lambda (&rest args)
+          (when mime-edit-mode-flag
+            (mime-edit-exit)
+            (message ""))
+          (goto-char (point-min))
+          (let (case-fold-search)
+            (when (re-search-forward
+                   (format "^%s$" (regexp-quote mail-header-separator))
+                   nil t)
+              (replace-match "")))
+          (when (featurep 'font-lock)
+            (setq font-lock-defaults nil)
+            (font-lock-mode 0))
+          (apply ,gnus-article-edit-done-function args)
+          (set-buffer gnus-original-article-buffer)
+          (erase-buffer)
+          (insert-buffer gnus-article-buffer)
+          (setq gnus-current-headers (gnus-article-make-full-mail-header))
+          (gnus-article-prepare-display)))
+  (define-key (current-local-map) "\C-c\C-k" 'gnus-article-mime-edit-exit)
+  (erase-buffer)
+  (insert-buffer gnus-original-article-buffer)
+  (mime-edit-again)
+  (when (featurep 'font-lock)
+    (set (make-local-variable 'font-lock-defaults)
+        '(message-font-lock-keywords t))
+    (font-lock-set-defaults)
+    (turn-on-font-lock))
+  (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
+  (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
+
+(defun gnus-article-mime-edit-exit ()
+  "Exit the article MIME editing without updating."
+  (interactive)
+  (let ((winconf gnus-prev-winconf)
+       buf)
+    (when mime-edit-mode-flag
+      (mime-edit-exit)
+      (message ""))
+    (goto-char (point-min))
+    (let (case-fold-search)
+      (when (re-search-forward
+            (format "^%s$" (regexp-quote mail-header-separator)) nil t)
+       (replace-match "")))
+    (when (featurep 'font-lock)
+      (setq font-lock-defaults nil)
+      (font-lock-mode 0))
+    ;; We remove all text props from the article buffer.
+    (setq buf (format "%s" (buffer-string)))
+    (set-buffer (get-buffer-create gnus-original-article-buffer))
+    (erase-buffer)
+    (insert buf)
+    (setq gnus-current-headers (gnus-article-make-full-mail-header))
+    (gnus-article-prepare-display)
+    (set-window-configuration winconf)))
+
+;;;
 ;;; Article highlights
 ;;;
 

diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el
index d6e62bf..9af23d9 100644 (file)
--- a/lisp/gnus-msg.el
+++ b/lisp/gnus-msg.el
@@ -948,14 +948,15 @@ this is a reply."
   (interactive "P")
   (gnus-summary-select-article t)
   (set-buffer gnus-original-article-buffer)
-  (gnus-setup-message 'compose-bounce
-    (let* ((references (mail-fetch-field "references"))
-          (parent (and references (gnus-parent-id references))))
-      (message-bounce)
-      ;; If there are references, we fetch the article we answered to.
-      (and fetch parent
-          (gnus-summary-refer-article parent)
-          (gnus-summary-show-all-headers)))))
+  (let (gnus-message-setup-hook)
+    (gnus-setup-message 'compose-bounce
+      (let* ((references (mail-fetch-field "references"))
+            (parent (and references (gnus-parent-id references))))
+       (message-bounce)
+       ;; If there are references, we fetch the article we answered to.
+       (and fetch parent
+            (gnus-summary-refer-article parent)
+            (gnus-summary-show-all-headers))))))
 
 ;;; Gcc handling.
 

diff --git a/lisp/message.el b/lisp/message.el
index 738e4a3..e09f367 100644 (file)
--- a/lisp/message.el
+++ b/lisp/message.el
@@ -157,6 +157,11 @@ If this variable is nil, no such courtesy message will be added."
   :group 'message-interface
   :type 'regexp)
 
+(defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit
+  "Function to setup a re-sending bounced message."
+  :group 'message-sending
+  :type 'function)
+
 ;;;###autoload
 (defcustom message-from-style 'default
   "*Specifies how \"From\" headers look.
@@ -483,6 +488,12 @@ the signature is inserted."
   :group 'message-various
   :type 'hook)
 
+(defcustom message-bounce-setup-hook nil
+  "Normal hook, run each time a a re-sending bounced message is initialized.
+The function `message-bounce' runs this hook."
+  :group 'message-various
+  :type 'hook)
+
 (defcustom message-mode-hook nil
   "Hook run in message mode buffers."
   :group 'message-various
@@ -4100,6 +4111,13 @@ Optional NEWS will use news to forward instead of mail."
       (kill-buffer (current-buffer)))
     (message "Resending message to %s...done" address)))
 
+(defun message-bounce-setup-for-mime-edit ()
+  (goto-char (point-min))
+  (when (search-forward (concat "\n" mail-header-separator "\n") nil t)
+    (replace-match "\n\n"))
+  (set (make-local-variable 'message-setup-hook) nil)
+  (mime-edit-again))
+
 ;;;###autoload
 (defun message-bounce ()
   "Re-mail the current message.
@@ -4139,6 +4157,9 @@ you."
       (message-remove-header message-ignored-bounced-headers t)
       (goto-char (point-max))
       (insert mail-header-separator))
+    (when message-bounce-setup-function
+      (funcall message-bounce-setup-function))
+    (run-hooks 'message-bounce-setup-hook)
     (message-position-point)))
 
 ;;;