From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 27 Dec 2015 00:01:53 +0000 (+0000)
Subject: Don't let mime decoding errors crash imail.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~24
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1c0d9617c2ddc58869065ca8d442effb338a0fd7;p=mit-scheme.git

Don't let mime decoding errors crash imail.
---

diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm
index 58369c9c9..2bf590ed5 100644
--- a/src/imail/imail-mime.scm
+++ b/src/imail/imail-mime.scm
@@ -563,7 +563,9 @@ USA.
            (lambda (output-port)
              (call-with-mime-decoding-output-port encoding output-port #t
                (lambda (output-port)
-                 (write-substring string start end output-port)))))))))
+                 (with-mime-best-effort
+                  (lambda ()
+                    (write-substring string start end output-port)))))))))))
 
 (define (mime:get-boundary parameters)
   (let ((parameter (assq 'BOUNDARY parameters)))
@@ -783,7 +785,7 @@ USA.
                         decode:initialize decode:finalize decode:update
                         make-port call-with-port))
   name)
-
+
 (define (define-identity-mime-encoding name)
   (hash-table/put! mime-encodings
                    name
@@ -822,6 +824,15 @@ USA.
                                    'CALL-WITH-MIME-DECODING-OUTPUT-PORT)
           encoding)))
    port text? generator))
+
+(define (with-mime-best-effort thunk)
+  (call-with-current-continuation
+   (lambda (exit)
+     (bind-condition-handler (list condition-type:decode-mime)
+         (lambda (condition)
+           condition
+           (exit unspecific))
+       thunk))))
 
 (define-identity-mime-encoding '7BIT)
 (define-identity-mime-encoding '8BIT)
diff --git a/src/imail/imail-top.scm b/src/imail/imail-top.scm
index 5941c8ca5..b5f20d655 100644
--- a/src/imail/imail-top.scm
+++ b/src/imail/imail-top.scm
@@ -1109,7 +1109,9 @@ With prefix argument, prompt even when point is on an attachment."
 	      port
 	      text?
 	      (lambda (port)
-		(write-mime-body body port)))))))))
+		(with-mime-best-effort
+		 (lambda ()
+		   (write-mime-body body port)))))))))))
 
 (define (filter-mime-attachment-filename filename)
   (let ((filename
@@ -2563,7 +2565,9 @@ WARNING: With a prefix argument, this command may take a very long
       port
       #t
       (lambda (port)
-	(write-mime-body body port))))))
+	(with-mime-best-effort
+	 (lambda ()
+	   (write-mime-body body port))))))))
 
 (define-method insert-mime-body-inline*
     (entity (body <mime-body-message>) selector context mark)