1 ;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*-
3 ;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 ;;; Author: Ludovic Courtès <ludo@gnu.org>
23 ;;; The I/O port API of the R6RS is provided by this module. In many areas
24 ;;; it complements or refines Guile's own historical port API. For instance,
25 ;;; it allows for binary I/O with bytevectors.
29 (library (rnrs io ports (6))
30 (export eof-object eof-object?
33 file-options buffer-mode buffer-mode?
34 eol-style native-eol-style error-handling-mode
35 make-transcoder transcoder-codec transcoder-eol-style
36 transcoder-error-handling-mode native-transcoder
37 latin-1-codec utf-8-codec utf-16-codec
39 ;; input & output ports
40 port? input-port? output-port?
42 port-transcoder binary-port? textual-port? transcoded-port
43 port-position set-port-position!
44 port-has-port-position? port-has-set-port-position!?
45 call-with-port close-port
48 open-bytevector-input-port
49 open-string-input-port
51 make-custom-binary-input-port
55 get-bytevector-n get-bytevector-n!
56 get-bytevector-some get-bytevector-all
59 open-bytevector-output-port
60 open-string-output-port
62 make-custom-binary-output-port
63 call-with-bytevector-output-port
64 call-with-string-output-port
65 make-custom-textual-output-port
69 open-file-input/output-port
75 get-char get-datum get-line get-string-all get-string-n get-string-n!
79 put-char put-datum put-string
82 standard-input-port standard-output-port standard-error-port
83 current-input-port current-output-port current-error-port
86 &i/o i/o-error? make-i/o-error
87 &i/o-read i/o-read-error? make-i/o-read-error
88 &i/o-write i/o-write-error? make-i/o-write-error
89 &i/o-invalid-position i/o-invalid-position-error?
90 make-i/o-invalid-position-error
91 &i/o-filename i/o-filename-error? make-i/o-filename-error
93 &i/o-file-protection i/o-file-protection-error?
94 make-i/o-file-protection-error
95 &i/o-file-is-read-only i/o-file-is-read-only-error?
96 make-i/o-file-is-read-only-error
97 &i/o-file-already-exists i/o-file-already-exists-error?
98 make-i/o-file-already-exists-error
99 &i/o-file-does-not-exist i/o-file-does-not-exist-error?
100 make-i/o-file-does-not-exist-error
101 &i/o-port i/o-port-error? make-i/o-port-error
103 &i/o-decoding-error i/o-decoding-error?
104 make-i/o-decoding-error
105 &i/o-encoding-error i/o-encoding-error?
106 make-i/o-encoding-error i/o-encoding-error-char)
107 (import (ice-9 binary-ports)
108 (only (rnrs base) assertion-violation)
110 (rnrs records syntactic)
113 (rnrs files) ;for the condition types
116 (except (guile) raise display)
117 (prefix (only (guile) display)
126 (define-enumeration file-option
127 (no-create no-fail no-truncate)
130 (define-enumeration buffer-mode
134 (define (buffer-mode? symbol)
135 (enum-set-member? symbol (enum-set-universe (buffer-modes))))
137 (define-enumeration eol-style
138 (lf cr crlf nel crnel ls none)
141 (define (native-eol-style)
144 (define-enumeration error-handling-mode
145 (ignore raise replace)
146 error-handling-modes)
148 (define-record-type (transcoder %make-transcoder transcoder?)
149 (fields codec eol-style error-handling-mode))
151 (define* (make-transcoder codec
153 (eol-style (native-eol-style))
154 (handling-mode (error-handling-mode replace)))
155 (%make-transcoder codec eol-style handling-mode))
157 (define (native-transcoder)
158 (make-transcoder (or (fluid-ref %default-port-encoding)
161 (define (latin-1-codec)
164 (define (utf-8-codec)
167 (define (utf-16-codec)
175 (define (with-i/o-filename-conditions filename thunk)
176 (with-throw-handler 'system-error
179 (let ((errno (system-error-errno args)))
180 (let ((construct-condition
181 (cond ((= errno EACCES)
182 make-i/o-file-protection-error)
184 make-i/o-file-already-exists-error)
186 make-i/o-file-does-not-exist-error)
188 make-i/o-file-is-read-only-error)
190 make-i/o-filename-error))))
191 (raise (construct-condition filename)))))))
193 (define (with-i/o-port-error port make-primary-condition thunk)
194 (with-throw-handler 'system-error
197 (let ((errno (system-error-errno args)))
198 (if (memv errno (list EIO EFBIG ENOSPC EPIPE))
199 (raise (condition (make-primary-condition)
200 (make-i/o-port-error port)))
201 (apply throw args))))))
203 (define-syntax with-textual-output-conditions
205 ((_ port body0 body ...)
206 (with-i/o-port-error port make-i/o-write-error
207 (lambda () (with-i/o-encoding-error body0 body ...))))))
209 (define-syntax with-textual-input-conditions
211 ((_ port body0 body ...)
212 (with-i/o-port-error port make-i/o-read-error
213 (lambda () (with-i/o-decoding-error body0 body ...))))))
217 ;;; Input and output ports.
220 (define (port-transcoder port)
221 "Return the transcoder object associated with @var{port}, or @code{#f}
222 if the port has no transcoder."
223 (and (textual-port? port)
224 ;; All textual ports have transcoders.
228 (case (port-conversion-strategy port)
230 ((substitute) 'replace)
232 (assertion-violation 'port-transcoder
233 "unsupported error handling mode"))))))
235 (define (binary-port? port)
236 "Always returns @code{#t}, as all ports can be used for binary I/O in
238 (equal? (port-encoding port) "ISO-8859-1"))
240 (define (textual-port? port)
241 "Always returns @code{#t}, as all ports can be used for textual I/O in
245 (define (port-eof? port)
246 (eof-object? (if (binary-port? port)
248 (lookahead-char port))))
250 (define (transcoded-port port transcoder)
251 "Return a new textual port based on @var{port}, using
252 @var{transcoder} to encode and decode data written to or
253 read from its underlying binary port @var{port}."
254 ;; Hackily get at %make-transcoded-port.
255 (let ((result ((@@ (ice-9 binary-ports) %make-transcoded-port) port)))
256 (set-port-encoding! result (transcoder-codec transcoder))
257 (case (transcoder-error-handling-mode transcoder)
259 (set-port-conversion-strategy! result 'error))
261 (set-port-conversion-strategy! result 'substitute))
263 (error "unsupported error handling mode"
264 (transcoder-error-handling-mode transcoder))))
267 (define (port-position port)
268 "Return the offset (an integer) indicating where the next octet will be
269 read from/written to in @var{port}."
271 ;; FIXME: We should raise an `&assertion' error when not supported.
272 (seek port 0 SEEK_CUR))
274 (define (set-port-position! port offset)
275 "Set the position where the next octet will be read from/written to
278 ;; FIXME: We should raise an `&assertion' error when not supported.
279 (seek port offset SEEK_SET))
281 (define (port-has-port-position? port)
282 "Return @code{#t} is @var{port} supports @code{port-position}."
283 (and (false-if-exception (port-position port)) #t))
285 (define (port-has-set-port-position!? port)
286 "Return @code{#t} is @var{port} supports @code{set-port-position!}."
287 (and (false-if-exception (set-port-position! port (port-position port)))
290 (define (call-with-port port proc)
291 "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
292 @var{proc}. Return the return values of @var{proc}."
294 (lambda () (proc port))
297 (apply values vals))))
299 (define* (call-with-bytevector-output-port proc #:optional (transcoder #f))
300 (receive (port extract) (open-bytevector-output-port transcoder)
301 (call-with-port port proc)
304 (define (open-string-input-port str)
305 "Open an input port that will read from @var{str}."
306 (open-input-string str))
308 (define (r6rs-open filename mode buffer-mode transcoder)
309 (let ((port (with-i/o-filename-conditions filename
311 (with-fluids ((%default-port-encoding #f))
312 (open filename mode))))))
314 (set-port-encoding! port (transcoder-codec transcoder))))
317 (define (file-options->mode file-options base-mode)
319 (if (enum-set-member? 'no-create file-options)
322 (if (enum-set-member? 'no-truncate file-options)
325 (if (enum-set-member? 'no-fail file-options)
329 (define* (open-file-input-port filename
331 (file-options (file-options))
332 (buffer-mode (buffer-mode block))
334 "Return an input port for reading from @var{filename}."
335 (r6rs-open filename O_RDONLY buffer-mode transcoder))
337 (define* (open-file-input/output-port filename
339 (file-options (file-options))
340 (buffer-mode (buffer-mode block))
342 "Return a port for reading from and writing to @var{filename}."
344 (file-options->mode file-options O_RDWR)
348 (define (open-string-output-port)
349 "Return two values: an output port that will collect characters written to it
350 as a string, and a thunk to retrieve the characters associated with that port."
351 (let ((port (open-output-string)))
353 (lambda () (get-output-string port)))))
355 (define* (open-file-output-port filename
357 (file-options (file-options))
358 (buffer-mode (buffer-mode block))
360 "Return an output port for writing to @var{filename}."
362 (file-options->mode file-options O_WRONLY)
366 (define (call-with-string-output-port proc)
367 "Call @var{proc}, passing it a string output port. When @var{proc} returns,
368 return the characters accumulated in that port."
369 (let ((port (open-output-string)))
371 (get-output-string port)))
373 (define (make-custom-textual-output-port id
378 (make-soft-port (vector (lambda (c) (write! (string c) 0 1))
379 (lambda (s) (write! s 0 (string-length s)))
385 (define (flush-output-port port)
393 (define-condition-type &i/o-encoding &i/o-port
394 make-i/o-encoding-error i/o-encoding-error?
395 (char i/o-encoding-error-char))
397 (define-syntax with-i/o-encoding-error
399 "Convert Guile throws to `encoding-error' to `&i/o-encoding-error'."
401 ;; XXX: This is heavyweight for small functions like `put-char'.
402 (with-throw-handler 'encoding-error
405 (lambda (key subr message errno port chr)
406 (raise (make-i/o-encoding-error port chr)))))))
408 (define (put-char port char)
409 (with-textual-output-conditions port (write-char char port)))
411 (define (put-datum port datum)
412 (with-textual-output-conditions port (write datum port)))
414 (define* (put-string port s #:optional start count)
415 (with-textual-output-conditions port
416 (cond ((not (string? s))
417 (assertion-violation 'put-string "expected string" s))
419 (display (substring/shared s start (+ start count)) port))
421 (display (substring/shared s start (string-length s)) port))
425 ;; Defined here to be able to make use of `with-i/o-encoding-error', but
426 ;; not exported from here, but from `(rnrs io simple)'.
427 (define* (display object #:optional (port (current-output-port)))
428 (with-textual-output-conditions port (guile:display object port)))
435 (define-condition-type &i/o-decoding &i/o-port
436 make-i/o-decoding-error i/o-decoding-error?)
438 (define-syntax with-i/o-decoding-error
440 "Convert Guile throws to `decoding-error' to `&i/o-decoding-error'."
442 ;; XXX: This is heavyweight for small functions like `get-char' and
444 (with-throw-handler 'decoding-error
447 (lambda (key subr message errno port)
448 (raise (make-i/o-decoding-error port)))))))
450 (define (get-char port)
451 (with-textual-input-conditions port (read-char port)))
453 (define (get-datum port)
454 (with-textual-input-conditions port (read port)))
456 (define (get-line port)
457 (with-textual-input-conditions port (read-line port 'trim)))
459 (define (get-string-all port)
460 (with-textual-input-conditions port (read-string port)))
462 (define (get-string-n port count)
463 "Read up to @var{count} characters from @var{port}.
464 If no characters could be read before encountering the end of file,
465 return the end-of-file object, otherwise return a string containing
466 the characters read."
467 (let* ((s (make-string count))
468 (rv (get-string-n! port s 0 count)))
469 (cond ((eof-object? rv) rv)
471 (else (substring/shared s 0 rv)))))
473 (define (lookahead-char port)
474 (with-textual-input-conditions port (peek-char port)))
481 (define (standard-input-port)
482 (with-fluids ((%default-port-encoding #f))
485 (define (standard-output-port)
486 (with-fluids ((%default-port-encoding #f))
489 (define (standard-error-port)
490 (with-fluids ((%default-port-encoding #f))
495 ;;; ports.scm ends here