From 86dab1d8c36377f713bbba57db6179cfb2f7b722 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sat, 26 Dec 2015 23:57:51 +0000
Subject: [PATCH] Make all mime decoders signal a common condition type.
---
src/runtime/mime-codec.scm | 51 ++++++++++++++++++++++++++++----------
src/runtime/runtime.pkg | 3 +++
2 files changed, 41 insertions(+), 13 deletions(-)
diff --git a/src/runtime/mime-codec.scm b/src/runtime/mime-codec.scm
index a8397b4f0..c090049ea 100644
--- a/src/runtime/mime-codec.scm
+++ b/src/runtime/mime-codec.scm
@@ -46,6 +46,9 @@ USA.
,(lambda (port)
(finalize (port/state port)))))
#f))
+
+(define condition-type:decode-mime
+ (make-condition-type 'DECODE-MIME condition-type:simple-error '() #f))
;;;; Encode quoted-printable
@@ -609,7 +612,7 @@ USA.
unspecific)
(define condition-type:decode-base64
- (make-condition-type 'DECODE-BASE64 condition-type:simple-error '() #f))
+ (make-condition-type 'DECODE-BASE64 condition-type:decode-mime '() #f))
(define error:decode-base64
(let ((signal
@@ -653,9 +656,9 @@ USA.
(let ((state (binhex40-decoding-context/state context)))
(case (binhex40-decoding-context/state context)
((SEEKING-COMMENT)
- (error "Missing BinHex 4.0 initial comment line."))
+ (error:decode-binhex40 "Missing BinHex 4.0 initial comment line."))
((DECODING)
- (error "Missing BinHex 4.0 terminating character."))
+ (error:decode-binhex40 "Missing BinHex 4.0 terminating character."))
((IGNORING)
(close-output-port (binhex40-decoding-context/port context)))
(else
@@ -673,6 +676,17 @@ USA.
(define decode-binhex40-port-type
(make-decoding-port-type decode-binhex40:update decode-binhex40:finalize))
+
+(define condition-type:decode-binhex40
+ (make-condition-type 'DECODE-BINHEX40 condition-type:decode-mime '() #f))
+
+(define error:decode-binhex40
+ (let ((signal
+ (condition-signaller condition-type:decode-binhex40
+ '(MESSAGE IRRITANTS)
+ standard-error-handler)))
+ (lambda (message . irritants)
+ (signal message irritants))))
(define (decode-binhex40-seeking-comment context string start end)
(let loop
@@ -755,8 +769,8 @@ USA.
(let ((digit
(vector-8b-ref binhex40-char-table (vector-8b-ref input index))))
(if (fix:> digit #x40)
- (error "Illegal character in BinHex 4.0 input stream:"
- (string-ref input index)))
+ (error:decode-binhex40 "Illegal character in BinHex 4.0 input stream:"
+ (string-ref input index)))
digit))
(define binhex40-digit-table
@@ -850,7 +864,7 @@ USA.
(CLOSE-OUTPUT
,(lambda (port)
(if (not (eq? (binhex40-decon/state (port/state port)) 'FINISHED))
- (error "Premature EOF in BinHex 4.0 stream.")))))
+ (error:decode-binhex40 "Premature EOF in BinHex 4.0 stream.")))))
#f))
(define (binhex40-decon-reading-header port char)
@@ -930,7 +944,7 @@ USA.
(define (process-line line)
(if (not (fix:> (string-length line) 0))
- (error "Empty line not allowed."))
+ (error:decode-uue "Empty line not allowed."))
(case state
((BEGIN) (process-begin-line line))
((NORMAL) (process-normal-line line))
@@ -940,7 +954,7 @@ USA.
(define (process-begin-line line)
(if (not (re-string-match "^begin +[0-7]+ +.+$" line))
- (error "Malformed \"begin\" line:" line))
+ (error:decode-uue "Malformed \"begin\" line:" line))
(set! state 'NORMAL))
(define (process-normal-line line)
@@ -949,7 +963,7 @@ USA.
(fix:<= n 45)
(fix:>= (fix:- (string-length line) 1)
(fix:* (fix:quotient (fix:+ n 2) 3) 4))))
- (error "Malformed line length:" n))
+ (error:decode-uue "Malformed line length:" n))
(let per-quantum ((i 0) (start 1))
(if (fix:< i n)
(let ((i* (fix:+ i 3)))
@@ -965,17 +979,17 @@ USA.
(define (process-zero-line line)
(let ((n (uudecode-char (string-ref line 0))))
(if (not (fix:= n 0))
- (error "Expected zero-length line:" n)))
+ (error:decode-uue "Expected zero-length line:" n)))
(set! state 'END))
(define (process-end-line line)
(if (not (string=? line "end"))
- (error "Malformed \"end\" line:" line))
+ (error:decode-uue "Malformed \"end\" line:" line))
(set! state 'FINISHED))
(define (finalize)
(if (not (eq? state 'FINISHED))
- (error "Can't finalize unfinished decoding.")))
+ (error:decode-uue "Can't finalize unfinished decoding.")))
(make-uudecode-ctx update finalize)))
@@ -1050,4 +1064,15 @@ USA.
(make-port decode-uue-port-type (decode-uue:initialize port text?)))
(define decode-uue-port-type
- (make-decoding-port-type decode-uue:update decode-uue:finalize))
\ No newline at end of file
+ (make-decoding-port-type decode-uue:update decode-uue:finalize))
+
+(define condition-type:decode-uue
+ (make-condition-type 'DECODE-UUE condition-type:decode-mime '() #f))
+
+(define error:decode-uue
+ (let ((signal
+ (condition-signaller condition-type:decode-uue
+ '(MESSAGE IRRITANTS)
+ standard-error-handler)))
+ (lambda (message . irritants)
+ (signal message irritants))))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2e4db73bf..4871f62b3 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5540,6 +5540,9 @@ USA.
call-with-decode-quoted-printable-output-port
call-with-decode-uue-output-port
condition-type:decode-base64
+ condition-type:decode-binhex40
+ condition-type:decode-mime
+ condition-type:decode-uue
decode-base64:finalize
decode-base64:initialize
decode-base64:update
--
2.25.1