diff options
author | Andreas Rottmann <a.rottmann@gmx.at> | 2011-05-14 19:29:26 +0200 |
---|---|---|
committer | Andreas Rottmann <a.rottmann@gmx.at> | 2011-05-14 19:29:26 +0200 |
commit | b6a66c21fc3791bb5ea50f6e7a0ccc2e8f55e27a (patch) | |
tree | 6bdcb9bcd01bbc0fc2fbca5aaa2b0ef0bff79022 | |
parent | 2002f1f84797c2c46d0634eabd5ac5fd61e13d73 (diff) | |
download | guile-b6a66c21fc3791bb5ea50f6e7a0ccc2e8f55e27a.tar.gz |
Improve R6RS conformance wrt. conditions in the I/O libraries
* 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'.
-rw-r--r-- | module/rnrs/io/ports.scm | 78 | ||||
-rw-r--r-- | test-suite/tests/r6rs-ports.test | 136 |
2 files changed, 186 insertions, 28 deletions
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 3dbaa039b..4ae01be68 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -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))) ;;; diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 06431bb76..7a382b75b 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -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 |