Synch up with main trunk, and prepare the release 2.12.0.

[elisp/wanderlust.git] / wl / wl-mime.el

diff --git a/wl/wl-mime.el b/wl/wl-mime.el
index 8e79c5e..1606ee0 100644 (file)
--- a/wl/wl-mime.el
+++ b/wl/wl-mime.el
@@ -66,12 +66,51 @@ has Non-nil value\)"
          (set-buffer message-buffer)
          (save-restriction
            (widen)
-           (if (wl-region-exists-p)
-               (wl-mime-preview-follow-current-region)
-             (mime-preview-follow-current-entity))))
+           (cond
+            ((wl-region-exists-p)
+             (wl-mime-preview-follow-current-region))
+            ((not (wl-message-mime-analysis-p
+                   (wl-message-buffer-display-type)))
+             (wl-mime-preview-follow-no-mime
+              (wl-message-buffer-display-type)))
+            (t
+             (mime-preview-follow-current-entity)))))
       (error "No message."))))
 
 ;; modified mime-preview-follow-current-entity from mime-view.el
+(defun wl-mime-preview-follow-no-mime (display-type)
+  "Write follow message to current message, without mime.
+It calls following-method selected from variable
+`mime-preview-following-method-alist'."
+  (interactive)
+  (let* ((mode (mime-preview-original-major-mode 'recursive))
+        (new-name (format "%s-no-mime" (buffer-name)))
+        new-buf min beg end
+        (entity (get-text-property (point-min) 'elmo-as-is-entity))
+        (the-buf (current-buffer))
+        fields)
+    (save-excursion
+      (goto-char (point-min))
+      (setq min (point-min)
+           beg (re-search-forward "^$" nil t)
+           end (point-max)))
+    (save-excursion
+      (set-buffer (setq new-buf (get-buffer-create new-name)))
+      (erase-buffer)
+      (insert-buffer-substring the-buf beg end)
+      (goto-char (point-min))
+      ;; Insert all headers.
+      (let ((elmo-mime-display-header-analysis
+            (wl-message-mime-analysis-p display-type 'header)))
+       (elmo-mime-insert-sorted-header entity))
+      (let ((f (cdr (assq mode mime-preview-following-method-alist))))
+       (if (functionp f)
+           (funcall f new-buf)
+         (message
+          "Sorry, following method for %s is not implemented yet."
+          mode))))))
+
+;; modified mime-preview-follow-current-entity from mime-view.el
 (defun wl-mime-preview-follow-current-region ()
   "Write follow message to current region.
 It calls following-method selected from variable
@@ -94,7 +133,8 @@ It calls following-method selected from variable
        (insert-buffer-substring the-buf r-beg r-end)
        (goto-char (point-min))
        (let ((current-entity
-              (if (and (eq (mime-entity-media-type entity) 'message)
+              (if (and entity
+                       (eq (mime-entity-media-type entity) 'message)
                        (eq (mime-entity-media-subtype entity) 'rfc822))
                   (car (mime-entity-children entity))
                 entity)))
@@ -107,8 +147,7 @@ It calls following-method selected from variable
                        (mime-insert-header current-entity fields)
                        t))
            (setq fields (std11-collect-field-names)
-                 current-entity (mime-entity-parent current-entity))
-           ))
+                 current-entity (mime-entity-parent current-entity))))
        (let ((rest mime-view-following-required-fields-list)
              field-name ret)
          (while rest
@@ -126,19 +165,14 @@ It calls following-method selected from variable
                                                   entity field-name))))
                        (setq entity (mime-entity-parent entity)))))
                  (if ret
-                     (insert (concat field-name ": " ret "\n"))
-                   )))
-           (setq rest (cdr rest))
-           ))
-       )
+                     (insert (concat field-name ": " ret "\n")))))
+           (setq rest (cdr rest)))))
       (let ((f (cdr (assq mode mime-preview-following-method-alist))))
        (if (functionp f)
            (funcall f new-buf)
          (message
           "Sorry, following method for %s is not implemented yet."
-          mode)
-         ))
-      )))
+          mode))))))
 
 (defalias 'wl-draft-enclose-digest-region 'mime-edit-enclose-digest-region)
 
@@ -185,6 +219,19 @@ It calls following-method selected from variable
          ((boundp attr)
           (symbol-value attr)))))
 
+(defun wl-mime-quit-preview ()
+  "Quitting method for mime-view."
+  (let* ((temp (and (boundp 'mime-edit-temp-message-buffer) ;; for SEMI <= 1.14.6
+                   mime-edit-temp-message-buffer))
+        (window (selected-window))
+        buf)
+    (mime-preview-kill-buffer)
+    (set-buffer temp)
+    (setq buf mime-edit-buffer)
+    (kill-buffer temp)
+    (select-window window)
+    (switch-to-buffer buf)))
+
 (defun wl-draft-preview-message ()
   "Preview editing message."
   (interactive)
@@ -227,11 +274,14 @@ It calls following-method selected from variable
                   (signal (car err) (cdr err)))))))
           mime-edit-translate-buffer-hook)))
     (mime-edit-preview-message)
+    (make-local-variable 'mime-preview-quitting-method-alist)
+    (setq mime-preview-quitting-method-alist
+         '((mime-temp-message-mode . wl-mime-quit-preview)))
     (let ((buffer-read-only nil))
       (when wl-highlight-body-too
        (wl-highlight-body))
       (run-hooks 'wl-draft-preview-message-hook))
-    (make-local-variable 'kill-buffer-hook)
+    (make-local-hook 'kill-buffer-hook)
     (add-hook 'kill-buffer-hook
              (lambda ()
                (when (get-buffer-window
@@ -241,7 +291,8 @@ It calls following-method selected from variable
                  (delete-window))
                (when (get-buffer wl-draft-preview-attributes-buffer-name)
                  (kill-buffer (get-buffer
-                               wl-draft-preview-attributes-buffer-name)))))
+                               wl-draft-preview-attributes-buffer-name))))
+             nil t)
     (if (not wl-draft-preview-attributes)
        (message (concat "Recipients: "
                         (cdr (assq 'recipients attribute-list))))
@@ -641,7 +692,7 @@ With ARG, ask destination folder."
     (mime-decrypt-application/pgp-encrypted entity situation)
     (setq wl-message-buffer-cur-summary-buffer summary-buffer)
     (setq wl-message-buffer-original-buffer original-buffer)))
-   
+
 
 ;;; Setup methods.
 (defun wl-mime-setup ()