Share similar code from IMAIL-YANK-ORIGINAL and SELECT-MESSAGE.

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 88df1376225e81695800f5d89ea948652380afa9..be98e27f60521effc4bd60437ce1984a455ea5e6 100644 (file)
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.179 2000/06/20 19:27:10 cph Exp $
+;;; $Id: imail-top.scm,v 1.180 2000/06/20 19:32:47 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -895,51 +895,6 @@ With prefix argument, prompt even when point is on an attachment."
    (char-set-difference char-set:graphic
                        char-set:mime-attachment-filename-delimiters)))
 \f
-(define (call-with-mime-decoding-output-port encoding port text? generator)
-  (case encoding
-    ((QUOTED-PRINTABLE)
-     (call-with-decode-quoted-printable-output-port port text? generator))
-    ((BASE64)
-     (call-with-decode-base64-output-port port text? generator))
-    (else
-     (generator port))))
-
-(define (call-with-decode-quoted-printable-output-port port text? generator)
-  (let ((port
-        (make-port decode-quoted-printable-port-type
-                   (decode-quoted-printable:initialize port text?))))
-    (let ((v (generator port)))
-      (close-output-port port)
-      v)))
-
-(define decode-quoted-printable-port-type
-  (make-port-type
-   `((WRITE-SUBSTRING
-      ,(lambda (port string start end)
-        (decode-quoted-printable:update (port/state port) string start end)))
-     (CLOSE-OUTPUT
-      ,(lambda (port)
-        (decode-quoted-printable:finalize (port/state port)))))
-   #f))
-
-(define (call-with-decode-base64-output-port port text? generator)
-  (let ((port
-        (make-port decode-base64-port-type
-                   (decode-base64:initialize port text?))))
-    (let ((v (generator port)))
-      (close-output-port port)
-      v)))
-
-(define decode-base64-port-type
-  (make-port-type
-   `((WRITE-SUBSTRING
-      ,(lambda (port string start end)
-        (decode-base64:update (port/state port) string start end)))
-     (CLOSE-OUTPUT
-      ,(lambda (port)
-        (decode-base64:finalize (port/state port)))))
-   #f))
-\f
 ;;;; Sending mail
 
 (define-command imail-mail
@@ -974,13 +929,7 @@ While composing the reply, use \\[mail-yank-original] to yank the
 
 ;; This procedure is invoked by M-x mail-yank-original in Mail mode.
 (define (imail-yank-original buffer left-margin mark)
-  (let ((message (selected-message #t buffer)))
-    (insert-header-fields message #f mark)
-    (if (folder-supports-mime? (selected-folder #t buffer))
-       (insert-mime-message-body message mark #t left-margin)
-       (call-with-auto-wrapped-output-mark mark left-margin
-         (lambda (port)
-           (write-message-body message port))))))
+  (insert-message (selected-message #t buffer) #t left-margin mark))
 \f
 (define-command imail-forward
   "Forward the current message to another user.
@@ -1678,15 +1627,7 @@ Negative argument means search in reverse."
                (if message
                    (begin
                      (store-property! message 'RAW? raw?)
-                     (insert-header-fields message raw? mark)
-                     (cond ((and raw? (not (eq? raw? 'FULL-HEADERS)))
-                            (insert-message-body message mark))
-                           ((folder-supports-mime? folder)
-                            (insert-mime-message-body message mark #f 0))
-                           (else
-                            (call-with-auto-wrapped-output-mark mark 0
-                              (lambda (port)
-                                (write-message-body message port))))))
+                     (insert-message message #f 0 mark))
                    (insert-string "[This folder has no messages in it.]"
                                   mark))))
            (mark-temporary! mark))
@@ -1932,6 +1873,18 @@ Negative argument means search in reverse."
 \f
 ;;;; Message insertion procedures
 
+(define (insert-message message inline-only? left-margin mark)
+  (let ((raw? (get-property message 'RAW? #f)))
+    (insert-header-fields message raw? mark)
+    (cond ((and raw? (not (eq? raw? 'FULL-HEADERS)))
+          (insert-message-body message mark))
+         ((folder-supports-mime? (message-folder message))
+          (insert-mime-message-body message mark inline-only? left-margin))
+         (else
+          (call-with-auto-wrapped-output-mark mark left-margin
+            (lambda (port)
+              (write-message-body message port)))))))
+
 (define (insert-header-fields headers raw? mark)
   (for-each (lambda (header)
              (insert-string (header-field-name header) mark)
@@ -2201,6 +2154,51 @@ Negative argument means search in reverse."
            (loop (make-mark (mark-group start) index) attachments)
            (reverse! attachments))))))
 \f
+(define (call-with-mime-decoding-output-port encoding port text? generator)
+  (case encoding
+    ((QUOTED-PRINTABLE)
+     (call-with-decode-quoted-printable-output-port port text? generator))
+    ((BASE64)
+     (call-with-decode-base64-output-port port text? generator))
+    (else
+     (generator port))))
+
+(define (call-with-decode-quoted-printable-output-port port text? generator)
+  (let ((port
+        (make-port decode-quoted-printable-port-type
+                   (decode-quoted-printable:initialize port text?))))
+    (let ((v (generator port)))
+      (close-output-port port)
+      v)))
+
+(define decode-quoted-printable-port-type
+  (make-port-type
+   `((WRITE-SUBSTRING
+      ,(lambda (port string start end)
+        (decode-quoted-printable:update (port/state port) string start end)))
+     (CLOSE-OUTPUT
+      ,(lambda (port)
+        (decode-quoted-printable:finalize (port/state port)))))
+   #f))
+
+(define (call-with-decode-base64-output-port port text? generator)
+  (let ((port
+        (make-port decode-base64-port-type
+                   (decode-base64:initialize port text?))))
+    (let ((v (generator port)))
+      (close-output-port port)
+      v)))
+
+(define decode-base64-port-type
+  (make-port-type
+   `((WRITE-SUBSTRING
+      ,(lambda (port string start end)
+        (decode-base64:update (port/state port) string start end)))
+     (CLOSE-OUTPUT
+      ,(lambda (port)
+        (decode-base64:finalize (port/state port)))))
+   #f))
+\f
 ;;;; Automatic wrap/fill
 
 (define (call-with-auto-wrapped-output-mark mark left-margin generator)