mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 14:21:10 +02:00
rnrs io ports: fix port encoding when opening file ports
* module/rnrs/io/ports.scm (open-file-input-port) (open-file-output-port): Ensure the resulting ports are binary when no transcoder is specified. * test-suite/tests/r6rs-ports.test: Remove superfluous global change of `%default-port-encoding' and accompanying comment. ("7.2.7 Input Ports"): Add test ensuring `open-file-input-port' opens a binary port when no transcoder is specified. ("8.2.10 Output ports"): Strengthen existing `open-file-output-port' binary-ness test by setting `%default-port-encoding' to "UTF-8".
This commit is contained in:
parent
dfc4d56df1
commit
0687e826a1
2 changed files with 28 additions and 13 deletions
|
@ -311,7 +311,9 @@ read from/written to in @var{port}."
|
||||||
(buffer-mode (buffer-mode block))
|
(buffer-mode (buffer-mode block))
|
||||||
maybe-transcoder)
|
maybe-transcoder)
|
||||||
(let ((port (with-i/o-filename-conditions filename
|
(let ((port (with-i/o-filename-conditions filename
|
||||||
(lambda () (open filename O_RDONLY)))))
|
(lambda ()
|
||||||
|
(with-fluids ((%default-port-encoding #f))
|
||||||
|
(open filename O_RDONLY))))))
|
||||||
(cond (maybe-transcoder
|
(cond (maybe-transcoder
|
||||||
(set-port-encoding! port (transcoder-codec maybe-transcoder))))
|
(set-port-encoding! port (transcoder-codec maybe-transcoder))))
|
||||||
port))
|
port))
|
||||||
|
@ -340,7 +342,9 @@ as a string, and a thunk to retrieve the characters associated with that port."
|
||||||
0
|
0
|
||||||
O_EXCL)))
|
O_EXCL)))
|
||||||
(port (with-i/o-filename-conditions filename
|
(port (with-i/o-filename-conditions filename
|
||||||
(lambda () (open filename flags)))))
|
(lambda ()
|
||||||
|
(with-fluids ((%default-port-encoding #f))
|
||||||
|
(open filename flags))))))
|
||||||
(cond (maybe-transcoder
|
(cond (maybe-transcoder
|
||||||
(set-port-encoding! port (transcoder-codec maybe-transcoder))))
|
(set-port-encoding! port (transcoder-codec maybe-transcoder))))
|
||||||
port))
|
port))
|
||||||
|
|
|
@ -27,12 +27,6 @@
|
||||||
#:use-module (rnrs exceptions)
|
#:use-module (rnrs exceptions)
|
||||||
#:use-module (rnrs bytevectors))
|
#:use-module (rnrs bytevectors))
|
||||||
|
|
||||||
;;; All these tests assume Guile 1.8's port system, where characters are
|
|
||||||
;;; treated as octets.
|
|
||||||
|
|
||||||
;; Set the default encoding of future ports to be Latin-1.
|
|
||||||
(fluid-set! %default-port-encoding #f)
|
|
||||||
|
|
||||||
(define-syntax pass-if-condition
|
(define-syntax pass-if-condition
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ name predicate body0 body ...)
|
((_ name predicate body0 body ...)
|
||||||
|
@ -322,6 +316,22 @@
|
||||||
|
|
||||||
(with-test-prefix "7.2.7 Input Ports"
|
(with-test-prefix "7.2.7 Input Ports"
|
||||||
|
|
||||||
|
(let ((filename (test-file))
|
||||||
|
(contents (string->utf8 "GNU λ")))
|
||||||
|
|
||||||
|
;; Create file
|
||||||
|
(call-with-output-file filename
|
||||||
|
(lambda (port) (put-bytevector port contents)))
|
||||||
|
|
||||||
|
(pass-if "open-file-input-port [opens binary port]"
|
||||||
|
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||||
|
(call-with-port (open-file-input-port filename)
|
||||||
|
(lambda (port)
|
||||||
|
(and (binary-port? port)
|
||||||
|
(bytevector=? contents (get-bytevector-all port)))))))
|
||||||
|
|
||||||
|
(delete-file filename))
|
||||||
|
|
||||||
;; This section appears here so that it can use the binary input
|
;; This section appears here so that it can use the binary input
|
||||||
;; primitives.
|
;; primitives.
|
||||||
|
|
||||||
|
@ -469,11 +479,12 @@
|
||||||
(with-test-prefix "8.2.10 Output ports"
|
(with-test-prefix "8.2.10 Output ports"
|
||||||
|
|
||||||
(let ((filename (test-file)))
|
(let ((filename (test-file)))
|
||||||
(pass-if "open-file-output-port [opens binary port]"
|
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||||
(call-with-port (open-file-output-port filename)
|
(pass-if "open-file-output-port [opens binary port]"
|
||||||
(lambda (port)
|
(call-with-port (open-file-output-port filename)
|
||||||
(put-bytevector port '#vu8(1 2 3))
|
(lambda (port)
|
||||||
(binary-port? port))))
|
(put-bytevector port '#vu8(1 2 3))
|
||||||
|
(binary-port? port)))))
|
||||||
|
|
||||||
(pass-if-condition "open-file-output-port [exception: already-exists]"
|
(pass-if-condition "open-file-output-port [exception: already-exists]"
|
||||||
i/o-file-already-exists-error?
|
i/o-file-already-exists-error?
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue