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)