summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--test-suite/tests/ports.test151
1 files changed, 77 insertions, 74 deletions
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 9d3000cc1..1f0e9b0cf 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -462,80 +462,79 @@
(= (port-line p) 0)
(= (port-column p) 0))))
- (pass-if "read-char, wrong encoding, error"
- (let ((p (open-bytevector-input-port #vu8(255 65 66 67))))
- (catch 'decoding-error
- (lambda ()
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'error)
- (read-char p)
- #f)
- (lambda (key subr message err port)
- (and (eq? port p)
-
- ;; PORT should point past the error.
- (equal? '(#\A #\B #\C)
- (list (read-char port)
- (read-char port)
- (read-char port)))
-
- (eof-object? (read-char port)))))))
-
- (pass-if "read-char, wrong encoding, escape"
- ;; `escape' should behave exactly like `error'.
- (let ((p (open-bytevector-input-port #vu8(255 65 66 67))))
- (catch 'decoding-error
- (lambda ()
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'escape)
- (read-char p)
- #f)
- (lambda (key subr message err port)
- (and (eq? port p)
-
- ;; PORT should point past the error.
- (equal? '(#\A #\B #\C)
- (list (read-char port)
- (read-char port)
- (read-char port)))
-
- (eof-object? (read-char port)))))))
-
- (pass-if "read-char, wrong encoding, substitute"
- (let ((p (open-bytevector-input-port #vu8(255 206 187 206 188))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'substitute)
- (equal? (list (read-char p) (read-char p) (read-char p))
- '(#\? #\λ #\μ))))
-
- (pass-if "peek-char, wrong encoding, error"
- (let-syntax ((decoding-error?
- (syntax-rules ()
- ((_ port exp)
- (catch 'decoding-error
- (lambda ()
- (pk 'exp exp)
- #f)
- (lambda (key subr message errno p)
- (eq? p port)))))))
- (let ((p (open-bytevector-input-port #vu8(255 65 66 67))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'error)
-
- ;; `peek-char' should repeatedly raise an error.
- (and (decoding-error? p (peek-char p))
- (decoding-error? p (peek-char p))
- (decoding-error? p (peek-char p))
-
- ;; Move past the error.
- (decoding-error? p (read-char p))
-
- ;; Finish happily.
- (equal? '(#\A #\B #\C)
- (list (read-char p)
- (read-char p)
- (read-char p)))
- (eof-object? (read-char p)))))))
+ ;; Mini DSL to test decoding error handling.
+ (letrec-syntax ((decoding-error?
+ (syntax-rules ()
+ ((_ port exp)
+ (catch 'decoding-error
+ (lambda ()
+ (pk 'exp exp)
+ #f)
+ (lambda (key subr message errno p)
+ (and (eq? p port)
+ (not (= 0 errno))))))))
+ (make-check
+ (syntax-rules (-> error eof)
+ ((_ port (proc -> error))
+ (decoding-error? port (proc port)))
+ ((_ port (proc -> eof))
+ (eof-object? (proc port)))
+ ((_ port (proc -> char))
+ (eq? (proc port) char))))
+ (make-checks
+ (syntax-rules ()
+ ((_ port check ...)
+ (and (make-check port check) ...))))
+ (test-decoding-error
+ (syntax-rules (tests)
+ ((_ sequence encoding strategy (tests checks ...))
+ (pass-if (format #f "test-decoding-error: ~s ~s ~s ~s"
+ (caar '(checks ...))
+ 'sequence encoding strategy)
+ (let ((p (open-bytevector-input-port
+ (u8-list->bytevector 'sequence))))
+ (set-port-encoding! p encoding)
+ (set-port-conversion-strategy! p strategy)
+ (make-checks p checks ...)))))))
+
+ (test-decoding-error (255 65 66 67) "UTF-8" 'error
+ (tests
+ (read-char -> error)
+ (read-char -> #\A)
+ (read-char -> #\B)
+ (read-char -> #\C)
+ (read-char -> eof)))
+
+ (test-decoding-error (255 65 66 67) "UTF-8" 'escape
+ ;; `escape' should behave exactly like `error'.
+ (tests
+ (read-char -> error)
+ (read-char -> #\A)
+ (read-char -> #\B)
+ (read-char -> #\C)
+ (read-char -> eof)))
+
+ (test-decoding-error (255 206 187 206 188) "UTF-8" 'substitute
+ (tests
+ (read-char -> #\?)
+ (read-char -> #\λ)
+ (read-char -> #\μ)
+ (read-char -> eof)))
+
+ (test-decoding-error (255 65 66 67) "UTF-8" 'error
+ (tests
+ ;; `peek-char' should repeatedly raise an error.
+ (peek-char -> error)
+ (peek-char -> error)
+ (peek-char -> error)
+
+ ;; Move past the error.
+ (read-char -> error)
+
+ (read-char -> #\A)
+ (read-char -> #\B)
+ (read-char -> #\C)
+ (read-char -> eof)))))
(with-test-prefix "call-with-output-string"
@@ -994,3 +993,7 @@
'("read" "read-char" "read-line")))
(delete-file (test-file))
+
+;;; Local Variables:
+;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
+;;; End: