diff options
-rw-r--r-- | test-suite/tests/ports.test | 151 |
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: |