From: Andreas Rottmann Subject: Enhance transcoder-related functionality of `(rnrs io ports)' * module/rnrs/io/ports.scm (transcoder-eol-style) (transcoder-error-handling-mode): Export these. * module/rnrs.scm: Ditto here. * module/rnrs/io/ports.scm (port-transcoder): Implement this procedure. (binary-port?): Treat only ports without an encoding as binary ports, add docstring. (textual-port?): Implement this procedure. (standard-input-port, standard-output-port, standard-error-port): Ensure these are created without an encoding. (eol-style): Add `none' as enumeration member. (native-eol-style): Switch to `none' from `lf'. * test-suite/tests/r6rs-ports.test (7.2.7 Input ports) (8.2.10 Output ports): Test binary-ness of `standard-input-port', `standard-output-port' and `standard-error-port'. (8.2.6 Input and output ports): Add test for `port-transcoder'. --- module/rnrs.scm | 3 +- module/rnrs/io/ports.scm | 42 +++++++++++++++++++++++++++++-------- test-suite/tests/r6rs-ports.test | 32 ++++++++++++++++++++++++++-- 3 files changed, 64 insertions(+), 13 deletions(-) diff --git a/module/rnrs.scm b/module/rnrs.scm index 476a3ab..58d9638 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -162,7 +162,8 @@ file-options buffer-mode buffer-mode? eol-style native-eol-style error-handling-mode - make-transcoder transcoder-codec native-transcoder + make-transcoder transcoder-codec transcoder-eol-style + transcoder-error-handling-mode native-transcoder latin-1-codec utf-8-codec utf-16-codec eof-object? port? input-port? output-port? eof-object port-eof? diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index b98811a..097c9d3 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -32,13 +32,14 @@ ;; auxiliary types file-options buffer-mode buffer-mode? eol-style native-eol-style error-handling-mode - make-transcoder transcoder-codec native-transcoder + make-transcoder transcoder-codec transcoder-eol-style + transcoder-error-handling-mode native-transcoder latin-1-codec utf-8-codec utf-16-codec ;; input & output ports port? input-port? output-port? port-eof? - port-transcoder binary-port? transcoded-port + port-transcoder binary-port? textual-port? transcoded-port port-position set-port-position! port-has-port-position? port-has-set-port-position!? call-with-port close-port @@ -128,11 +129,11 @@ (enum-set-member? symbol (enum-set-universe (buffer-modes)))) (define-enumeration eol-style - (lf cr crlf nel crnel ls) + (lf cr crlf nel crnel ls none) eol-styles) (define (native-eol-style) - (eol-style lf)) + (eol-style none)) (define-enumeration error-handling-mode (ignore raise replace) @@ -189,10 +190,30 @@ ;;; (define (port-transcoder port) - (error "port transcoders are not supported" port)) + "Return the transcoder object associated with @var{port}, or @code{#f} +if the port has no transcoder." + (cond ((port-encoding port) + => (lambda (encoding) + (make-transcoder + encoding + (native-eol-style) + (case (port-conversion-strategy port) + ((error) 'raise) + ((substitute) 'replace) + (else + (assertion-violation 'port-transcoder + "unsupported error handling mode")))))) + (else + #f))) (define (binary-port? port) - ;; So far, we don't support transcoders other than the binary transcoder. + "Returns @code{#t} if @var{port} does not have an associated encoding, address@hidden otherwise." + (not (port-encoding port))) + +(define (textual-port? port) + "Always returns @var{#t}, as all ports can be used for textual I/O in +Guile." #t) (define (port-eof? port) @@ -396,13 +417,16 @@ return the characters accumulated in that port." ;;; (define (standard-input-port) - (dup->inport 0)) + (with-fluids ((%default-port-encoding #f)) + (dup->inport 0))) (define (standard-output-port) - (dup->outport 1)) + (with-fluids ((%default-port-encoding #f)) + (dup->outport 1))) (define (standard-error-port) - (dup->outport 2)) + (with-fluids ((%default-port-encoding #f)) + (dup->outport 2))) ) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index df056a4..d0f5666 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -397,7 +397,11 @@ (close-port port) (gc) ; Test for marking a closed port. - closed?))) + closed?)) + + (pass-if "standard-input-port is binary" + (with-fluids ((%default-port-encoding "UTF-8")) + (binary-port? (standard-input-port))))) (with-test-prefix "8.2.10 Output ports" @@ -509,7 +513,15 @@ (put-bytevector port source) (and (= sink-pos (bytevector-length source)) (not eof?) - (bytevector=? sink source))))) + (bytevector=? sink source)))) + + (pass-if "standard-output-port is binary" + (with-fluids ((%default-port-encoding "UTF-8")) + (binary-port? (standard-output-port)))) + + (pass-if "standard-error-port is binary" + (with-fluids ((%default-port-encoding "UTF-8")) + (binary-port? (standard-error-port))))) (with-test-prefix "8.2.6 Input and output ports" @@ -565,7 +577,21 @@ (char=? (i/o-encoding-error-char c) #\λ) (bytevector=? (get) (string->utf8 "The letter "))))) (put-string tp "The letter λ cannot be represented in Latin-1.") - #f))))) + #f)))) + + (pass-if "port-transcoder [binary port]" + (not (port-transcoder (open-bytevector-input-port #vu8())))) + + (pass-if "port-transcoder [transcoded port]" + (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo")) + (make-transcoder (utf-8-codec)))) + (t (port-transcoder p))) + (and t + (transcoder-codec t) + (eq? (native-eol-style) + (transcoder-eol-style t)) + (eq? (error-handling-mode replace) + (transcoder-error-handling-mode t)))))) ;;; Local Variables: ;;; mode: scheme -- tg: (9421ef5..) t/rnrs-transcoders (depends on: t/rnrs-io-current-ports)