From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.devel Subject: =?UTF-8?q?=5BPATCH=5D=20Add=20missing=20R6RS=20=60open-file-input/output-port=27=20procedure?= Date: Mon, 12 Nov 2012 20:48:59 +0100 Message-ID: <1352749739-24082-1-git-send-email-a.rottmann@gmx.at> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Trace: ger.gmane.org 1352750993 915 80.91.229.3 (12 Nov 2012 20:09:53 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 12 Nov 2012 20:09:53 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon Nov 12 21:10:04 2012 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1TY0KU-0001Ba-R3 for guile-devel@m.gmane.org; Mon, 12 Nov 2012 21:09:59 +0100 Original-Received: from localhost ([::1]:54893 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TY0KL-0003kT-1w for guile-devel@m.gmane.org; Mon, 12 Nov 2012 15:09:49 -0500 Original-Received: from eggs.gnu.org ([208.118.235.92]:60312) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TY00l-000666-1k for guile-devel@gnu.org; Mon, 12 Nov 2012 14:49:38 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1TY00h-0003GO-TP for guile-devel@gnu.org; Mon, 12 Nov 2012 14:49:34 -0500 Original-Received: from mailout-de.gmx.net ([213.165.64.22]:35766) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1TY00h-0003Eu-Ip for guile-devel@gnu.org; Mon, 12 Nov 2012 14:49:31 -0500 Original-Received: (qmail invoked by alias); 12 Nov 2012 19:49:29 -0000 Original-Received: from 91-119-177-155.dynamic.xdsl-line.inode.at (EHLO cubox.home.rotty.xx.vu) [91.119.177.155] by mail.gmx.net (mp032) with SMTP; 12 Nov 2012 20:49:29 +0100 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX18EFvxF/EsEDgf67DIswLW/uie+RPx5FzRj9O0N5z PaqDDdjYMkTkiR Original-Received: from delenn.home.rotty.xx.vu (delenn.home.rotty.xx.vu [IPv6:fdfb:599d:f328:2::6e]) by cubox.home.rotty.xx.vu (Postfix) with ESMTP id 87DDD16008C; Mon, 12 Nov 2012 20:49:20 +0100 (CET) Original-Received: by delenn.home.rotty.xx.vu (Postfix, from userid 1000) id 4C52832002C; Mon, 12 Nov 2012 20:49:20 +0100 (CET) X-Mailer: git-send-email 1.7.10.4 X-Y-GMX-Trusted: 0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 213.165.64.22 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:15162 Archived-At: * 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'. --- module/rnrs.scm | 2 +- module/rnrs/io/ports.scm | 70 +++++++++++++++++---------- test-suite/tests/r6rs-ports.test | 98 +++++++++++++++++++++----------------- 3 files changed, 100 insertions(+), 70 deletions(-) diff --git a/module/rnrs.scm b/module/rnrs.scm index 9fff820..a132c53 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -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 diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index fddb491..7c17b0c 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -64,7 +64,10 @@ call-with-string-output-port make-custom-textual-output-port flush-output-port - + + ;; input/output ports + open-file-input/output-port + ;; binary output put-u8 put-bytevector @@ -305,19 +308,46 @@ read from/written to in @var{port}." (with-fluids ((%default-port-encoding "UTF-8")) (open-input-string str))) -(define* (open-file-input-port filename - #:optional - (file-options (file-options)) - (buffer-mode (buffer-mode block)) - maybe-transcoder) +(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 O_RDONLY)))))) - (cond (maybe-transcoder - (set-port-encoding! port (transcoder-codec maybe-transcoder)))) + (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)) + 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 as a string, and a thunk to retrieve the characters associated with that port." @@ -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, diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 46da67f..ed49598 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -316,24 +316,27 @@ (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))))))) - - (delete-file filename)) + (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)) + +(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))))) -(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))))) +(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) + (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-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" + + (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) -- 1.7.10.4