Commit | Line | Data |
---|---|---|
bce5cb56 | 1 | ;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*- |
1ee2c72e | 2 | |
5a35d42a | 3 | ;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. |
1ee2c72e LC |
4 | ;;;; |
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 | |
83ba2d37 | 8 | ;;;; version 3 of the License, or (at your option) any later version. |
1ee2c72e LC |
9 | ;;;; |
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. | |
14 | ;;;; | |
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 | |
18 | ||
bce5cb56 | 19 | ;;; Author: Ludovic Courtès <ludo@gnu.org> |
1ee2c72e LC |
20 | |
21 | ;;; Commentary: | |
22 | ;;; | |
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. | |
26 | ;;; | |
27 | ;;; Code: | |
28 | ||
baa5705c AR |
29 | (library (rnrs io ports (6)) |
30 | (export eof-object eof-object? | |
31 | ||
a5484153 AR |
32 | ;; auxiliary types |
33 | file-options buffer-mode buffer-mode? | |
34 | eol-style native-eol-style error-handling-mode | |
ead04a04 AR |
35 | make-transcoder transcoder-codec transcoder-eol-style |
36 | transcoder-error-handling-mode native-transcoder | |
a5484153 AR |
37 | latin-1-codec utf-8-codec utf-16-codec |
38 | ||
baa5705c AR |
39 | ;; input & output ports |
40 | port? input-port? output-port? | |
b04f841d | 41 | port-eof? |
ead04a04 | 42 | port-transcoder binary-port? textual-port? transcoded-port |
baa5705c AR |
43 | port-position set-port-position! |
44 | port-has-port-position? port-has-set-port-position!? | |
a5484153 | 45 | call-with-port close-port |
baa5705c AR |
46 | |
47 | ;; input ports | |
48 | open-bytevector-input-port | |
49 | open-string-input-port | |
a5484153 | 50 | open-file-input-port |
baa5705c AR |
51 | make-custom-binary-input-port |
52 | ||
53 | ;; binary input | |
54 | get-u8 lookahead-u8 | |
55 | get-bytevector-n get-bytevector-n! | |
56 | get-bytevector-some get-bytevector-all | |
57 | ||
58 | ;; output ports | |
59 | open-bytevector-output-port | |
60 | open-string-output-port | |
a5484153 | 61 | open-file-output-port |
baa5705c | 62 | make-custom-binary-output-port |
a5484153 AR |
63 | call-with-bytevector-output-port |
64 | call-with-string-output-port | |
65 | make-custom-textual-output-port | |
66 | flush-output-port | |
3ae5a02f AR |
67 | |
68 | ;; input/output ports | |
69 | open-file-input/output-port | |
70 | ||
baa5705c | 71 | ;; binary output |
a5484153 AR |
72 | put-u8 put-bytevector |
73 | ||
74 | ;; textual input | |
a6c377f7 AR |
75 | get-char get-datum get-line get-string-all get-string-n get-string-n! |
76 | lookahead-char | |
77 | ||
a5484153 AR |
78 | ;; textual output |
79 | put-char put-datum put-string | |
80 | ||
81 | ;; standard ports | |
82 | standard-input-port standard-output-port standard-error-port | |
74571cfd | 83 | current-input-port current-output-port current-error-port |
a5484153 AR |
84 | |
85 | ;; condition types | |
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 | |
92 | i/o-error-filename | |
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 | |
b1e76e8f LC |
102 | i/o-error-port |
103 | &i/o-decoding-error i/o-decoding-error? | |
eed98cbc LC |
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) | |
dd0d987f AW |
107 | (import (ice-9 binary-ports) |
108 | (only (rnrs base) assertion-violation) | |
a5484153 AR |
109 | (rnrs enums) |
110 | (rnrs records syntactic) | |
111 | (rnrs exceptions) | |
112 | (rnrs conditions) | |
113 | (rnrs files) ;for the condition types | |
114 | (srfi srfi-8) | |
115 | (ice-9 rdelim) | |
2252321b AR |
116 | (except (guile) raise display) |
117 | (prefix (only (guile) display) | |
118 | guile:)) | |
1ee2c72e | 119 | |
1ee2c72e LC |
120 | |
121 | \f | |
a5484153 AR |
122 | ;;; |
123 | ;;; Auxiliary types | |
124 | ;;; | |
125 | ||
126 | (define-enumeration file-option | |
127 | (no-create no-fail no-truncate) | |
128 | file-options) | |
129 | ||
130 | (define-enumeration buffer-mode | |
131 | (none line block) | |
132 | buffer-modes) | |
133 | ||
134 | (define (buffer-mode? symbol) | |
135 | (enum-set-member? symbol (enum-set-universe (buffer-modes)))) | |
136 | ||
137 | (define-enumeration eol-style | |
ead04a04 | 138 | (lf cr crlf nel crnel ls none) |
a5484153 AR |
139 | eol-styles) |
140 | ||
141 | (define (native-eol-style) | |
ead04a04 | 142 | (eol-style none)) |
a5484153 AR |
143 | |
144 | (define-enumeration error-handling-mode | |
145 | (ignore raise replace) | |
146 | error-handling-modes) | |
147 | ||
148 | (define-record-type (transcoder %make-transcoder transcoder?) | |
149 | (fields codec eol-style error-handling-mode)) | |
150 | ||
151 | (define* (make-transcoder codec | |
152 | #:optional | |
153 | (eol-style (native-eol-style)) | |
154 | (handling-mode (error-handling-mode replace))) | |
155 | (%make-transcoder codec eol-style handling-mode)) | |
156 | ||
157 | (define (native-transcoder) | |
158 | (make-transcoder (or (fluid-ref %default-port-encoding) | |
159 | (latin-1-codec)))) | |
160 | ||
161 | (define (latin-1-codec) | |
162 | "ISO-8859-1") | |
163 | ||
164 | (define (utf-8-codec) | |
165 | "UTF-8") | |
166 | ||
167 | (define (utf-16-codec) | |
168 | "UTF-16") | |
169 | ||
170 | \f | |
171 | ;;; | |
172 | ;;; Internal helpers | |
173 | ;;; | |
174 | ||
175 | (define (with-i/o-filename-conditions filename thunk) | |
b6a66c21 AR |
176 | (with-throw-handler 'system-error |
177 | thunk | |
178 | (lambda args | |
179 | (let ((errno (system-error-errno args))) | |
180 | (let ((construct-condition | |
181 | (cond ((= errno EACCES) | |
182 | make-i/o-file-protection-error) | |
183 | ((= errno EEXIST) | |
184 | make-i/o-file-already-exists-error) | |
185 | ((= errno ENOENT) | |
186 | make-i/o-file-does-not-exist-error) | |
187 | ((= errno EROFS) | |
188 | make-i/o-file-is-read-only-error) | |
189 | (else | |
190 | make-i/o-filename-error)))) | |
191 | (raise (construct-condition filename))))))) | |
192 | ||
193 | (define (with-i/o-port-error port make-primary-condition thunk) | |
194 | (with-throw-handler 'system-error | |
195 | thunk | |
196 | (lambda args | |
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)))))) | |
202 | ||
203 | (define-syntax with-textual-output-conditions | |
204 | (syntax-rules () | |
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 ...)))))) | |
208 | ||
209 | (define-syntax with-textual-input-conditions | |
210 | (syntax-rules () | |
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 ...)))))) | |
a5484153 AR |
214 | |
215 | \f | |
1ee2c72e LC |
216 | ;;; |
217 | ;;; Input and output ports. | |
218 | ;;; | |
219 | ||
220 | (define (port-transcoder port) | |
ead04a04 AR |
221 | "Return the transcoder object associated with @var{port}, or @code{#f} |
222 | if the port has no transcoder." | |
e2551947 AW |
223 | (and (textual-port? port) |
224 | ;; All textual ports have transcoders. | |
225 | (make-transcoder | |
226 | (port-encoding port) | |
227 | (native-eol-style) | |
228 | (case (port-conversion-strategy port) | |
229 | ((error) 'raise) | |
230 | ((substitute) 'replace) | |
231 | (else | |
232 | (assertion-violation 'port-transcoder | |
233 | "unsupported error handling mode")))))) | |
1ee2c72e LC |
234 | |
235 | (define (binary-port? port) | |
e2551947 AW |
236 | "Always returns @code{#t}, as all ports can be used for binary I/O in |
237 | Guile." | |
238 | (equal? (port-encoding port) "ISO-8859-1")) | |
ead04a04 AR |
239 | |
240 | (define (textual-port? port) | |
91a214eb | 241 | "Always returns @code{#t}, as all ports can be used for textual I/O in |
ead04a04 | 242 | Guile." |
1ee2c72e LC |
243 | #t) |
244 | ||
b04f841d AW |
245 | (define (port-eof? port) |
246 | (eof-object? (if (binary-port? port) | |
247 | (lookahead-u8 port) | |
248 | (lookahead-char port)))) | |
249 | ||
1044537d AR |
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}." | |
dd0d987f AW |
254 | ;; Hackily get at %make-transcoded-port. |
255 | (let ((result ((@@ (ice-9 binary-ports) %make-transcoded-port) port))) | |
1044537d | 256 | (set-port-encoding! result (transcoder-codec transcoder)) |
d4b81637 LC |
257 | (case (transcoder-error-handling-mode transcoder) |
258 | ((raise) | |
259 | (set-port-conversion-strategy! result 'error)) | |
260 | ((replace) | |
261 | (set-port-conversion-strategy! result 'substitute)) | |
262 | (else | |
263 | (error "unsupported error handling mode" | |
264 | (transcoder-error-handling-mode transcoder)))) | |
1044537d | 265 | result)) |
1ee2c72e LC |
266 | |
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}." | |
270 | ||
271 | ;; FIXME: We should raise an `&assertion' error when not supported. | |
272 | (seek port 0 SEEK_CUR)) | |
273 | ||
274 | (define (set-port-position! port offset) | |
275 | "Set the position where the next octet will be read from/written to | |
276 | @var{port}." | |
277 | ||
278 | ;; FIXME: We should raise an `&assertion' error when not supported. | |
279 | (seek port offset SEEK_SET)) | |
280 | ||
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)) | |
284 | ||
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))) | |
288 | #t)) | |
289 | ||
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}." | |
a5484153 AR |
293 | (call-with-values |
294 | (lambda () (proc port)) | |
295 | (lambda vals | |
296 | (close-port port) | |
297 | (apply values vals)))) | |
298 | ||
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) | |
302 | (extract))) | |
1ee2c72e | 303 | |
c3993330 AW |
304 | (define (open-string-input-port str) |
305 | "Open an input port that will read from @var{str}." | |
6dce942c | 306 | (open-input-string str)) |
c3993330 | 307 | |
3ae5a02f | 308 | (define (r6rs-open filename mode buffer-mode transcoder) |
a5484153 | 309 | (let ((port (with-i/o-filename-conditions filename |
0687e826 AR |
310 | (lambda () |
311 | (with-fluids ((%default-port-encoding #f)) | |
3ae5a02f AR |
312 | (open filename mode)))))) |
313 | (cond (transcoder | |
314 | (set-port-encoding! port (transcoder-codec transcoder)))) | |
a5484153 AR |
315 | port)) |
316 | ||
3ae5a02f AR |
317 | (define (file-options->mode file-options base-mode) |
318 | (logior base-mode | |
319 | (if (enum-set-member? 'no-create file-options) | |
320 | 0 | |
321 | O_CREAT) | |
322 | (if (enum-set-member? 'no-truncate file-options) | |
323 | 0 | |
324 | O_TRUNC) | |
325 | (if (enum-set-member? 'no-fail file-options) | |
326 | 0 | |
327 | O_EXCL))) | |
328 | ||
329 | (define* (open-file-input-port filename | |
330 | #:optional | |
331 | (file-options (file-options)) | |
332 | (buffer-mode (buffer-mode block)) | |
333 | transcoder) | |
334 | "Return an input port for reading from @var{filename}." | |
335 | (r6rs-open filename O_RDONLY buffer-mode transcoder)) | |
336 | ||
337 | (define* (open-file-input/output-port filename | |
338 | #:optional | |
339 | (file-options (file-options)) | |
340 | (buffer-mode (buffer-mode block)) | |
341 | transcoder) | |
342 | "Return a port for reading from and writing to @var{filename}." | |
343 | (r6rs-open filename | |
344 | (file-options->mode file-options O_RDWR) | |
345 | buffer-mode | |
346 | transcoder)) | |
347 | ||
c3993330 AW |
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." | |
6dce942c | 351 | (let ((port (open-output-string))) |
c3993330 AW |
352 | (values port |
353 | (lambda () (get-output-string port))))) | |
354 | ||
a5484153 AR |
355 | (define* (open-file-output-port filename |
356 | #:optional | |
357 | (file-options (file-options)) | |
358 | (buffer-mode (buffer-mode block)) | |
359 | maybe-transcoder) | |
3ae5a02f AR |
360 | "Return an output port for writing to @var{filename}." |
361 | (r6rs-open filename | |
362 | (file-options->mode file-options O_WRONLY) | |
363 | buffer-mode | |
364 | maybe-transcoder)) | |
a5484153 AR |
365 | |
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))) | |
370 | (proc port) | |
371 | (get-output-string port))) | |
372 | ||
373 | (define (make-custom-textual-output-port id | |
374 | write! | |
375 | get-position | |
376 | set-position! | |
377 | close) | |
378 | (make-soft-port (vector (lambda (c) (write! (string c) 0 1)) | |
379 | (lambda (s) (write! s 0 (string-length s))) | |
380 | #f ;flush | |
381 | #f ;read character | |
382 | close) | |
383 | "w")) | |
384 | ||
385 | (define (flush-output-port port) | |
386 | (force-output port)) | |
387 | ||
eed98cbc LC |
388 | \f |
389 | ;;; | |
390 | ;;; Textual output. | |
391 | ;;; | |
392 | ||
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)) | |
396 | ||
397 | (define-syntax with-i/o-encoding-error | |
398 | (syntax-rules () | |
399 | "Convert Guile throws to `encoding-error' to `&i/o-encoding-error'." | |
400 | ((_ body ...) | |
401 | ;; XXX: This is heavyweight for small functions like `put-char'. | |
402 | (with-throw-handler 'encoding-error | |
403 | (lambda () | |
404 | (begin body ...)) | |
405 | (lambda (key subr message errno port chr) | |
406 | (raise (make-i/o-encoding-error port chr))))))) | |
407 | ||
a5484153 | 408 | (define (put-char port char) |
b6a66c21 | 409 | (with-textual-output-conditions port (write-char char port))) |
a5484153 AR |
410 | |
411 | (define (put-datum port datum) | |
b6a66c21 | 412 | (with-textual-output-conditions port (write datum port))) |
a5484153 AR |
413 | |
414 | (define* (put-string port s #:optional start count) | |
b6a66c21 | 415 | (with-textual-output-conditions port |
eed98cbc LC |
416 | (cond ((not (string? s)) |
417 | (assertion-violation 'put-string "expected string" s)) | |
418 | ((and start count) | |
419 | (display (substring/shared s start (+ start count)) port)) | |
420 | (start | |
421 | (display (substring/shared s start (string-length s)) port)) | |
422 | (else | |
423 | (display s port))))) | |
a5484153 | 424 | |
2252321b AR |
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))) | |
b6a66c21 | 428 | (with-textual-output-conditions port (guile:display object port))) |
2252321b | 429 | |
b1e76e8f LC |
430 | \f |
431 | ;;; | |
432 | ;;; Textual input. | |
433 | ;;; | |
434 | ||
435 | (define-condition-type &i/o-decoding &i/o-port | |
436 | make-i/o-decoding-error i/o-decoding-error?) | |
437 | ||
438 | (define-syntax with-i/o-decoding-error | |
439 | (syntax-rules () | |
440 | "Convert Guile throws to `decoding-error' to `&i/o-decoding-error'." | |
441 | ((_ body ...) | |
442 | ;; XXX: This is heavyweight for small functions like `get-char' and | |
443 | ;; `lookahead-char'. | |
444 | (with-throw-handler 'decoding-error | |
445 | (lambda () | |
446 | (begin body ...)) | |
447 | (lambda (key subr message errno port) | |
448 | (raise (make-i/o-decoding-error port))))))) | |
449 | ||
a5484153 | 450 | (define (get-char port) |
b6a66c21 | 451 | (with-textual-input-conditions port (read-char port))) |
a5484153 AR |
452 | |
453 | (define (get-datum port) | |
b6a66c21 | 454 | (with-textual-input-conditions port (read port))) |
a5484153 AR |
455 | |
456 | (define (get-line port) | |
b6a66c21 | 457 | (with-textual-input-conditions port (read-line port 'trim))) |
a5484153 AR |
458 | |
459 | (define (get-string-all port) | |
5a35d42a | 460 | (with-textual-input-conditions port (read-string port))) |
a5484153 | 461 | |
a6c377f7 AR |
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) | |
470 | ((= rv count) s) | |
471 | (else (substring/shared s 0 rv))))) | |
472 | ||
a5484153 | 473 | (define (lookahead-char port) |
b6a66c21 | 474 | (with-textual-input-conditions port (peek-char port))) |
a5484153 AR |
475 | |
476 | \f | |
b1e76e8f LC |
477 | ;;; |
478 | ;;; Standard ports. | |
479 | ;;; | |
480 | ||
a5484153 | 481 | (define (standard-input-port) |
ead04a04 AR |
482 | (with-fluids ((%default-port-encoding #f)) |
483 | (dup->inport 0))) | |
a5484153 AR |
484 | |
485 | (define (standard-output-port) | |
ead04a04 AR |
486 | (with-fluids ((%default-port-encoding #f)) |
487 | (dup->outport 1))) | |
a5484153 AR |
488 | |
489 | (define (standard-error-port) | |
ead04a04 AR |
490 | (with-fluids ((%default-port-encoding #f)) |
491 | (dup->outport 2))) | |
a5484153 | 492 | |
baa5705c AR |
493 | ) |
494 | ||
1ee2c72e | 495 | ;;; ports.scm ends here |