mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 16:30:19 +02:00
Code Activity

Improve R6RS conformance wrt. conditions in the I/O libraries

Browse source 
* module/rnrs/io/ports.scm (open-file-output-port): Handle `no-fail'
  file option.
  (with-i/o-filename-conditions): Use `with-throw-handler' instead of `catch'.
  (with-i/o-port-error,
  with-textual-output-conditions. with-textual-input-conditions): New
  exception-conversion helpers.
  (put-char, put-datum, put-string, display): Use
  `with-textual-output-conditions' instead of `with-i/o-encoding-error'
  to get proper conditions in case of write errors.
  (get-char, get-datum, get-line, get-string-all, lookahead-char):
  Likewise, for the input case.

* test-suite/tests/r6rs-ports.test (pass-if-condition, test-file,
  make-failing-port): New helpers.
  ("8.2.10 Output ports"): Add some tests for `open-file-output-port'.
  ("8.2.9 Textual Input"): Add tests read error conditions.
  ("8.2.12 Textual Output"): Add tests for write error conditions.
  ("8.3 Simple I/O"): Add tests for conditions, `call-with-input-file'
  and `call-with-output-file'.
This commit is contained in:
Andreas Rottmann 2011-05-14 19:29:26 +02:00
parent 2002f1f847
commit b6a66c21fc
2 changed files with 186 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -170,22 +170,44 @@
;;;
(define (with-i/o-filename-conditions filename thunk)
(catch 'system-error
thunk
(lambda args
(let ((errno (system-error-errno args)))
(let ((construct-condition
(cond ((= errno EACCES)
make-i/o-file-protection-error)
((= errno EEXIST)
make-i/o-file-already-exists-error)
((= errno ENOENT)
make-i/o-file-does-not-exist-error)
((= errno EROFS)
make-i/o-file-is-read-only-error)
(else
make-i/o-filename-error))))
(raise (construct-condition filename)))))))
(with-throw-handler 'system-error
thunk
(lambda args
(let ((errno (system-error-errno args)))
(let ((construct-condition
(cond ((= errno EACCES)
make-i/o-file-protection-error)
((= errno EEXIST)
make-i/o-file-already-exists-error)
((= errno ENOENT)
make-i/o-file-does-not-exist-error)
((= errno EROFS)
make-i/o-file-is-read-only-error)
(else
make-i/o-filename-error))))
(raise (construct-condition filename)))))))
(define (with-i/o-port-error port make-primary-condition thunk)
(with-throw-handler 'system-error
thunk
(lambda args
(let ((errno (system-error-errno args)))
(if (memv errno (list EIO EFBIG ENOSPC EPIPE))
(raise (condition (make-primary-condition)
(make-i/o-port-error port)))
(apply throw args))))))
(define-syntax with-textual-output-conditions
(syntax-rules ()
((_ port body0 body ...)
(with-i/o-port-error port make-i/o-write-error
(lambda () (with-i/o-encoding-error body0 body ...))))))
(define-syntax with-textual-input-conditions
(syntax-rules ()
((_ port body0 body ...)
(with-i/o-port-error port make-i/o-read-error
(lambda () (with-i/o-decoding-error body0 body ...))))))
;;;
@ -313,7 +335,10 @@ as a string, and a thunk to retrieve the characters associated with that port."
O_CREAT)
(if (enum-set-member? 'no-truncate file-options)
0
O_TRUNC)))
O_TRUNC)
(if (enum-set-member? 'no-fail file-options)
0
O_EXCL)))
(port (with-i/o-filename-conditions filename
(lambda () (open filename flags)))))
(cond (maybe-transcoder
@ -363,13 +388,13 @@ return the characters accumulated in that port."
(raise (make-i/o-encoding-error port chr)))))))
(define (put-char port char)
(with-i/o-encoding-error (write-char char port)))
(with-textual-output-conditions port (write-char char port)))
(define (put-datum port datum)
(with-i/o-encoding-error (write datum port)))
(with-textual-output-conditions port (write datum port)))
(define* (put-string port s #:optional start count)
(with-i/o-encoding-error
(with-textual-output-conditions port
(cond ((not (string? s))
(assertion-violation 'put-string "expected string" s))
((and start count)
@ -382,8 +407,7 @@ return the characters accumulated in that port."
;; Defined here to be able to make use of `with-i/o-encoding-error', but
;; not exported from here, but from `(rnrs io simple)'.
(define* (display object #:optional (port (current-output-port)))
(with-i/o-encoding-error
(guile:display object port)))
(with-textual-output-conditions port (guile:display object port)))
;;;
@ -406,16 +430,16 @@ return the characters accumulated in that port."
(raise (make-i/o-decoding-error port)))))))
(define (get-char port)
(with-i/o-decoding-error (read-char port)))
(with-textual-input-conditions port (read-char port)))
(define (get-datum port)
(with-i/o-decoding-error (read port)))
(with-textual-input-conditions port (read port)))
(define (get-line port)
(with-i/o-decoding-error (read-line port 'trim)))
(with-textual-input-conditions port (read-line port 'trim)))
(define (get-string-all port)
(with-i/o-decoding-error (read-delimited "" port 'concat)))
(with-textual-input-conditions port (read-delimited "" port 'concat)))
(define (get-string-n port count)
"Read up to @var{count} characters from @var{port}.
@ -429,7 +453,7 @@ the characters read."
(else (substring/shared s 0 rv)))))
(define (lookahead-char port)
(with-i/o-decoding-error (peek-char port)))
(with-textual-input-conditions port (peek-char port)))
;;;

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

@ -19,9 +19,11 @@
(define-module (test-io-ports)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (rnrs io ports)
#:use-module (rnrs io simple)
#:use-module (rnrs exceptions)
#:use-module (rnrs bytevectors))
@ -31,6 +33,45 @@
;; Set the default encoding of future ports to be Latin-1.
(fluid-set! %default-port-encoding #f)
(define-syntax pass-if-condition
(syntax-rules ()
((_ name predicate body0 body ...)
(let ((cookie (list 'cookie)))
(pass-if name
(eq? cookie (guard (c ((predicate c) cookie))
body0 body ...)))))))
(define (test-file)
(data-file-name "ports-test.tmp"))
;; A input/output port that swallows all output, and produces just
;; spaces on input. Reading and writing beyond `failure-position'
;; produces `system-error' exceptions. Used for testing exception
;; behavior.
(define* (make-failing-port #:optional (failure-position 0))
(define (maybe-fail index errno)
(if (> index failure-position)
(scm-error 'system-error
'failing-port
"I/O beyond failure position" '()
(list errno))))
(let ((read-index 0)
(write-index 0))
(define (write-char chr)
(set! write-index (+ 1 write-index))
(maybe-fail write-index ENOSPC))
(make-soft-port
(vector write-char
(lambda (str) ;; write-string
(for-each write-char (string->list str)))
(lambda () #t) ;; flush-output
(lambda () ;; read-char
(set! read-index (+ read-index 1))
(maybe-fail read-index EIO)
#\space)
(lambda () #t)) ;; close-port
"rw")))
(with-test-prefix "7.2.5 End-of-File Object"
@ -421,6 +462,37 @@
(with-test-prefix "8.2.10 Output ports"
(let ((filename (test-file)))
(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))))
(pass-if "open-bytevector-output-port"
(let-values (((port get-content)
(open-bytevector-output-port #f)))
@ -627,7 +699,69 @@
(let ((port (open-input-string "GNU Guile"))
(s (string-copy "Isn't XXX great?")))
(and (= 3 (get-string-n! port s 6 3))
(string=? s "Isn't GNU great?")))))
(string=? s "Isn't GNU great?"))))
(with-test-prefix "read error"
(pass-if-condition "get-char" i/o-read-error?
(get-char (make-failing-port)))
(pass-if-condition "lookahead-char" i/o-read-error?
(lookahead-char (make-failing-port)))
;; FIXME: these are not yet exception-correct
#|
(pass-if-condition "get-string-n" i/o-read-error?
(get-string-n (make-failing-port) 5))
(pass-if-condition "get-string-n!" i/o-read-error?
(get-string-n! (make-failing-port) (make-string 5) 0 5))
|#
(pass-if-condition "get-string-all" i/o-read-error?
(get-string-all (make-failing-port 100)))
(pass-if-condition "get-line" i/o-read-error?
(get-line (make-failing-port)))
(pass-if-condition "get-datum" i/o-read-error?
(get-datum (make-failing-port)))))
(with-test-prefix "8.2.12 Textual Output"
(with-test-prefix "write error"
(pass-if-condition "put-char" i/o-write-error?
(put-char (make-failing-port) #\G))
(pass-if-condition "put-string" i/o-write-error?
(put-string (make-failing-port) "Hello World!"))
(pass-if-condition "put-datum" i/o-write-error?
(put-datum (make-failing-port) '(hello world!)))))
(with-test-prefix "8.3 Simple I/O"
(with-test-prefix "read error"
(pass-if-condition "read-char" i/o-read-error?
(read-char (make-failing-port)))
(pass-if-condition "peek-char" i/o-read-error?
(peek-char (make-failing-port)))
(pass-if-condition "read" i/o-read-error?
(read (make-failing-port))))
(with-test-prefix "write error"
(pass-if-condition "display" i/o-write-error?
(display "Hi there!" (make-failing-port)))
(pass-if-condition "write" i/o-write-error?
(write '(hi there!) (make-failing-port)))
(pass-if-condition "write-char" i/o-write-error?
(write-char #\G (make-failing-port)))
(pass-if-condition "newline" i/o-write-error?
(newline (make-failing-port))))
(let ((filename (test-file)))
;; ensure the test file exists
(call-with-output-file filename
(lambda (port) (write "foo" port)))
(pass-if "call-with-input-file [port is textual]"
(call-with-input-file filename textual-port?))
(pass-if-condition "call-with-input-file [exception: not-found]"
i/o-file-does-not-exist-error?
(call-with-input-file ",this-is-highly-unlikely-to-exist!"
values))
(pass-if-condition "call-with-output-file [exception: already-exists]"
i/o-file-already-exists-error?
(call-with-output-file filename
values))
(delete-file filename)))
;;; Local Variables:
;;; mode: scheme