From ead04a04cd38909d0d40f1ba7885372c9c65ff38 Mon Sep 17 00:00:00 2001 From: Andreas Rottmann Date: Sun, 13 Mar 2011 23:14:10 +0100 Subject: [PATCH] Enhance transcoder-related functionality of `(rnrs io ports)' MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit * module/rnrs/io/ports.scm (transcoder-eol-style) (transcoder-error-handling-mode): Export these. (textual-port?): Implement this procedure and export it. * module/rnrs.scm: Export these here as well. * module/rnrs/io/ports.scm (port-transcoder): Implement this procedure. (binary-port?): Treat only ports without an encoding as binary ports, add docstring. (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'. Signed-off-by: Ludovic Courtès --- module/rnrs.scm | 6 +++-- module/rnrs/io/ports.scm | 42 +++++++++++++++++++++++++------- test-suite/tests/r6rs-ports.test | 32 +++++++++++++++++++++--- 3 files changed, 66 insertions(+), 14 deletions(-) diff --git a/module/rnrs.scm b/module/rnrs.scm index 77090d0e1..9fff820b3 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -162,12 +162,14 @@ 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? port-transcoder - binary-port? transcoded-port port-position set-port-position! + binary-port? textual-port? transcoded-port + port-position set-port-position! port-has-port-position? port-has-set-port-position!? close-port call-with-port open-bytevector-input-port make-custom-binary-input-port get-u8 diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 662db1908..04d167a2c 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 @@ -129,11 +130,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) @@ -190,10 +191,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, +@code{#f} 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) @@ -408,13 +429,16 @@ the characters read." ;;; (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 fe2197fe4..70b5853b2 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)))))) (with-test-prefix "8.2.9 Textual input" -- 2.20.1