mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Add missing R6RS `open-file-input/output-port' procedure

Browse source 
* module/rnrs/io/port.scm (r6rs-open): New internal helper procedure for
  opening files.
  (open-file-input-port, open-file-output-port): Make use of
  `r6rs-open'.
  (open-file-input/output-port): Implement in terms of `r6rs-open',
  add to exported identifiers list.

* module/rnrs.scm (open-file-input/output-port): Add to exported
  identifiers.

* test-suite/tests/r6rs-ports.test (test-input-file-opener): New
  procedure, collects several tests for opening file input ports.
  ("7.2.7 Input Ports"): Use `test-input-file-opener' for checking
  `open-file-input-port'.
  (test-output-file-opener): New procedure, collects several tests for
  opening file output ports.
  ("8.2.10 Output ports"): Use `test-output-file-opener' for checking
  `open-file-output-port'.
  ("8.2.13 Input/output ports"): New test prefix, making use of both
  `test-input-file-opener' and `test-output-file-opener' to check
  `open-file-input/output-port'.
This commit is contained in:
Andreas Rottmann 2012-11-12 20:47:57 +01:00
parent 5ec8fc2134
commit 3ae5a02f1d
3 changed files with 100 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

2
module/rnrs.scm
View file

@ -180,7 +180,7 @@
call-with-bytevector-output-port
call-with-string-output-port
latin-1-codec utf-8-codec utf-16-codec
open-file-input-port open-file-output-port
open-file-input-port open-file-output-port open-file-input/output-port
make-custom-textual-output-port
call-with-string-output-port
flush-output-port put-string

68
module/rnrs/io/ports.scm
View file

@ -65,6 +65,9 @@
make-custom-textual-output-port
flush-output-port
;; input/output ports
open-file-input/output-port
;; binary output
put-u8 put-bytevector
@ -305,18 +308,45 @@ read from/written to in @var{port}."
(with-fluids ((%default-port-encoding "UTF-8"))
(open-input-string str)))
(define (r6rs-open filename mode buffer-mode transcoder)
(let ((port (with-i/o-filename-conditions filename
(lambda ()
(with-fluids ((%default-port-encoding #f))
(open filename mode))))))
(cond (transcoder
(set-port-encoding! port (transcoder-codec transcoder))))
port))
(define (file-options->mode file-options base-mode)
(logior base-mode
(if (enum-set-member? 'no-create file-options)
0
O_CREAT)
(if (enum-set-member? 'no-truncate file-options)
0
O_TRUNC)
(if (enum-set-member? 'no-fail file-options)
0
O_EXCL)))
(define* (open-file-input-port filename
#:optional
(file-options (file-options))
(buffer-mode (buffer-mode block))
maybe-transcoder)
(let ((port (with-i/o-filename-conditions filename
(lambda ()
(with-fluids ((%default-port-encoding #f))
(open filename O_RDONLY))))))
(cond (maybe-transcoder
(set-port-encoding! port (transcoder-codec maybe-transcoder))))
port))
transcoder)
"Return an input port for reading from @var{filename}."
(r6rs-open filename O_RDONLY buffer-mode transcoder))
(define* (open-file-input/output-port filename
#:optional
(file-options (file-options))
(buffer-mode (buffer-mode block))
transcoder)
"Return a port for reading from and writing to @var{filename}."
(r6rs-open filename
(file-options->mode file-options O_RDWR)
buffer-mode
transcoder))
(define (open-string-output-port)
"Return two values: an output port that will collect characters written to it
@ -331,23 +361,11 @@ as a string, and a thunk to retrieve the characters associated with that port."
(file-options (file-options))
(buffer-mode (buffer-mode block))
maybe-transcoder)
(let* ((flags (logior O_WRONLY
(if (enum-set-member? 'no-create file-options)
0
O_CREAT)
(if (enum-set-member? 'no-truncate file-options)
0
O_TRUNC)
(if (enum-set-member? 'no-fail file-options)
0
O_EXCL)))
(port (with-i/o-filename-conditions filename
(lambda ()
(with-fluids ((%default-port-encoding #f))
(open filename flags))))))
(cond (maybe-transcoder
(set-port-encoding! port (transcoder-codec maybe-transcoder))))
port))
"Return an output port for writing to @var{filename}."
(r6rs-open filename
(file-options->mode file-options O_WRONLY)
buffer-mode
maybe-transcoder))
(define (call-with-string-output-port proc)
"Call @var{proc}, passing it a string output port. When @var{proc} returns,

96
test-suite/tests/r6rs-ports.test
View file

@ -316,23 +316,26 @@
(string? (strerror errno)))))))
(with-test-prefix "7.2.7 Input Ports"
(let ((filename (test-file))
(contents (string->utf8 "GNU λ")))
(define (test-input-file-opener open filename)
(let ((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]"
(pass-if "opens binary input port with correct contents"
(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)))))))
(call-with-port (open-file-input-port filename)
(lambda (port)
(and (binary-port? port)
(input-port? port)
(bytevector=? contents (get-bytevector-all port))))))))
(delete-file filename))
(delete-file filename))
(with-test-prefix "7.2.7 Input Ports"
(with-test-prefix "open-file-input-port"
(test-input-file-opener open-file-input-port (test-file)))
;; This section appears here so that it can use the binary input
;; primitives.
@ -478,39 +481,42 @@
(binary-port? (standard-input-port)))))
(define (test-output-file-opener open filename)
(with-fluids ((%default-port-encoding "UTF-8"))
(pass-if "opens binary output port"
(call-with-port (open filename)
(lambda (port)
(put-bytevector port '#vu8(1 2 3))
(and (binary-port? port)
(output-port? port))))))
(pass-if-condition "exception: already-exists"
i/o-file-already-exists-error?
(open filename))
(pass-if "no-fail no-truncate"
(and
(call-with-port (open filename (file-options no-fail no-truncate))
(lambda (port)
(= 0 (port-position port))))
(= 3 (stat:size (stat filename)))))
(pass-if "no-fail"
(and
(call-with-port (open filename (file-options no-fail))
binary-port?)
(= 0 (stat:size (stat filename)))))
(delete-file filename)
(pass-if-condition "exception: does-not-exist"
i/o-file-does-not-exist-error?
(open filename (file-options no-create))))
(with-test-prefix "8.2.10 Output ports"
(let ((filename (test-file)))
(with-fluids ((%default-port-encoding "UTF-8"))
(pass-if "open-file-output-port [opens binary port]"
(call-with-port (open-file-output-port filename)
(lambda (port)
(put-bytevector port '#vu8(1 2 3))
(binary-port? port)))))
(pass-if-condition "open-file-output-port [exception: already-exists]"
i/o-file-already-exists-error?
(open-file-output-port filename))
(pass-if "open-file-output-port [no-fail no-truncate]"
(and
(call-with-port (open-file-output-port filename
(file-options no-fail no-truncate))
(lambda (port)
(= 0 (port-position port))))
(= 3 (stat:size (stat filename)))))
(pass-if "open-file-output-port [no-fail]"
(and
(call-with-port (open-file-output-port filename (file-options no-fail))
binary-port?)
(= 0 (stat:size (stat filename)))))
(delete-file filename)
(pass-if-condition "open-file-output-port [exception: does-not-exist]"
i/o-file-does-not-exist-error?
(open-file-output-port filename (file-options no-create))))
(with-test-prefix "open-file-output-port"
(test-output-file-opener open-file-output-port (test-file)))
(pass-if "open-bytevector-output-port"
(let-values (((port get-content)
@ -801,6 +807,12 @@
values))
(delete-file filename)))
(with-test-prefix "8.2.13 Input/output ports"
(with-test-prefix "open-file-input/output-port [output]"
(test-output-file-opener open-file-input/output-port (test-file)))
(with-test-prefix "open-file-input/output-port [input]"
(test-input-file-opener open-file-input/output-port (test-file))))
;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'guard 'scheme-indent-function 1)