Commit | Line | Data |
---|---|---|
bce5cb56 | 1 | ;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*- |
1ee2c72e | 2 | |
b04f841d | 3 | ;;;; Copyright (C) 2009, 2010, 2011 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 | |
67 | ||
baa5705c | 68 | ;; binary output |
a5484153 AR |
69 | put-u8 put-bytevector |
70 | ||
71 | ;; textual input | |
a6c377f7 AR |
72 | get-char get-datum get-line get-string-all get-string-n get-string-n! |
73 | lookahead-char | |
74 | ||
a5484153 AR |
75 | ;; textual output |
76 | put-char put-datum put-string | |
77 | ||
78 | ;; standard ports | |
79 | standard-input-port standard-output-port standard-error-port | |
74571cfd | 80 | current-input-port current-output-port current-error-port |
a5484153 AR |
81 | |
82 | ;; condition types | |
83 | &i/o i/o-error? make-i/o-error | |
84 | &i/o-read i/o-read-error? make-i/o-read-error | |
85 | &i/o-write i/o-write-error? make-i/o-write-error | |
86 | &i/o-invalid-position i/o-invalid-position-error? | |
87 | make-i/o-invalid-position-error | |
88 | &i/o-filename i/o-filename-error? make-i/o-filename-error | |
89 | i/o-error-filename | |
90 | &i/o-file-protection i/o-file-protection-error? | |
91 | make-i/o-file-protection-error | |
92 | &i/o-file-is-read-only i/o-file-is-read-only-error? | |
93 | make-i/o-file-is-read-only-error | |
94 | &i/o-file-already-exists i/o-file-already-exists-error? | |
95 | make-i/o-file-already-exists-error | |
96 | &i/o-file-does-not-exist i/o-file-does-not-exist-error? | |
97 | make-i/o-file-does-not-exist-error | |
98 | &i/o-port i/o-port-error? make-i/o-port-error | |
b1e76e8f LC |
99 | i/o-error-port |
100 | &i/o-decoding-error i/o-decoding-error? | |
eed98cbc LC |
101 | make-i/o-decoding-error |
102 | &i/o-encoding-error i/o-encoding-error? | |
103 | make-i/o-encoding-error i/o-encoding-error-char) | |
dd0d987f AW |
104 | (import (ice-9 binary-ports) |
105 | (only (rnrs base) assertion-violation) | |
a5484153 AR |
106 | (rnrs enums) |
107 | (rnrs records syntactic) | |
108 | (rnrs exceptions) | |
109 | (rnrs conditions) | |
110 | (rnrs files) ;for the condition types | |
111 | (srfi srfi-8) | |
112 | (ice-9 rdelim) | |
2252321b AR |
113 | (except (guile) raise display) |
114 | (prefix (only (guile) display) | |
115 | guile:)) | |
1ee2c72e | 116 | |
1ee2c72e LC |
117 | |
118 | \f | |
a5484153 AR |
119 | ;;; |
120 | ;;; Auxiliary types | |
121 | ;;; | |
122 | ||
123 | (define-enumeration file-option | |
124 | (no-create no-fail no-truncate) | |
125 | file-options) | |
126 | ||
127 | (define-enumeration buffer-mode | |
128 | (none line block) | |
129 | buffer-modes) | |
130 | ||
131 | (define (buffer-mode? symbol) | |
132 | (enum-set-member? symbol (enum-set-universe (buffer-modes)))) | |
133 | ||
134 | (define-enumeration eol-style | |
ead04a04 | 135 | (lf cr crlf nel crnel ls none) |
a5484153 AR |
136 | eol-styles) |
137 | ||
138 | (define (native-eol-style) | |
ead04a04 | 139 | (eol-style none)) |
a5484153 AR |
140 | |
141 | (define-enumeration error-handling-mode | |
142 | (ignore raise replace) | |
143 | error-handling-modes) | |
144 | ||
145 | (define-record-type (transcoder %make-transcoder transcoder?) | |
146 | (fields codec eol-style error-handling-mode)) | |
147 | ||
148 | (define* (make-transcoder codec | |
149 | #:optional | |
150 | (eol-style (native-eol-style)) | |
151 | (handling-mode (error-handling-mode replace))) | |
152 | (%make-transcoder codec eol-style handling-mode)) | |
153 | ||
154 | (define (native-transcoder) | |
155 | (make-transcoder (or (fluid-ref %default-port-encoding) | |
156 | (latin-1-codec)))) | |
157 | ||
158 | (define (latin-1-codec) | |
159 | "ISO-8859-1") | |
160 | ||
161 | (define (utf-8-codec) | |
162 | "UTF-8") | |
163 | ||
164 | (define (utf-16-codec) | |
165 | "UTF-16") | |
166 | ||
167 | \f | |
168 | ;;; | |
169 | ;;; Internal helpers | |
170 | ;;; | |
171 | ||
172 | (define (with-i/o-filename-conditions filename thunk) | |
173 | (catch 'system-error | |
174 | thunk | |
175 | (lambda args | |
176 | (let ((errno (system-error-errno args))) | |
177 | (let ((construct-condition | |
178 | (cond ((= errno EACCES) | |
179 | make-i/o-file-protection-error) | |
180 | ((= errno EEXIST) | |
181 | make-i/o-file-already-exists-error) | |
182 | ((= errno ENOENT) | |
183 | make-i/o-file-does-not-exist-error) | |
184 | ((= errno EROFS) | |
185 | make-i/o-file-is-read-only-error) | |
186 | (else | |
187 | make-i/o-filename-error)))) | |
188 | (raise (construct-condition filename))))))) | |
189 | ||
190 | \f | |
1ee2c72e LC |
191 | ;;; |
192 | ;;; Input and output ports. | |
193 | ;;; | |
194 | ||
195 | (define (port-transcoder port) | |
ead04a04 AR |
196 | "Return the transcoder object associated with @var{port}, or @code{#f} |
197 | if the port has no transcoder." | |
198 | (cond ((port-encoding port) | |
199 | => (lambda (encoding) | |
200 | (make-transcoder | |
201 | encoding | |
202 | (native-eol-style) | |
203 | (case (port-conversion-strategy port) | |
204 | ((error) 'raise) | |
205 | ((substitute) 'replace) | |
206 | (else | |
207 | (assertion-violation 'port-transcoder | |
208 | "unsupported error handling mode")))))) | |
209 | (else | |
210 | #f))) | |
1ee2c72e LC |
211 | |
212 | (define (binary-port? port) | |
ead04a04 AR |
213 | "Returns @code{#t} if @var{port} does not have an associated encoding, |
214 | @code{#f} otherwise." | |
215 | (not (port-encoding port))) | |
216 | ||
217 | (define (textual-port? port) | |
218 | "Always returns @var{#t}, as all ports can be used for textual I/O in | |
219 | Guile." | |
1ee2c72e LC |
220 | #t) |
221 | ||
b04f841d AW |
222 | (define (port-eof? port) |
223 | (eof-object? (if (binary-port? port) | |
224 | (lookahead-u8 port) | |
225 | (lookahead-char port)))) | |
226 | ||
1044537d AR |
227 | (define (transcoded-port port transcoder) |
228 | "Return a new textual port based on @var{port}, using | |
229 | @var{transcoder} to encode and decode data written to or | |
230 | read from its underlying binary port @var{port}." | |
dd0d987f AW |
231 | ;; Hackily get at %make-transcoded-port. |
232 | (let ((result ((@@ (ice-9 binary-ports) %make-transcoded-port) port))) | |
1044537d | 233 | (set-port-encoding! result (transcoder-codec transcoder)) |
d4b81637 LC |
234 | (case (transcoder-error-handling-mode transcoder) |
235 | ((raise) | |
236 | (set-port-conversion-strategy! result 'error)) | |
237 | ((replace) | |
238 | (set-port-conversion-strategy! result 'substitute)) | |
239 | (else | |
240 | (error "unsupported error handling mode" | |
241 | (transcoder-error-handling-mode transcoder)))) | |
1044537d | 242 | result)) |
1ee2c72e LC |
243 | |
244 | (define (port-position port) | |
245 | "Return the offset (an integer) indicating where the next octet will be | |
246 | read from/written to in @var{port}." | |
247 | ||
248 | ;; FIXME: We should raise an `&assertion' error when not supported. | |
249 | (seek port 0 SEEK_CUR)) | |
250 | ||
251 | (define (set-port-position! port offset) | |
252 | "Set the position where the next octet will be read from/written to | |
253 | @var{port}." | |
254 | ||
255 | ;; FIXME: We should raise an `&assertion' error when not supported. | |
256 | (seek port offset SEEK_SET)) | |
257 | ||
258 | (define (port-has-port-position? port) | |
259 | "Return @code{#t} is @var{port} supports @code{port-position}." | |
260 | (and (false-if-exception (port-position port)) #t)) | |
261 | ||
262 | (define (port-has-set-port-position!? port) | |
263 | "Return @code{#t} is @var{port} supports @code{set-port-position!}." | |
264 | (and (false-if-exception (set-port-position! port (port-position port))) | |
265 | #t)) | |
266 | ||
267 | (define (call-with-port port proc) | |
268 | "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of | |
269 | @var{proc}. Return the return values of @var{proc}." | |
a5484153 AR |
270 | (call-with-values |
271 | (lambda () (proc port)) | |
272 | (lambda vals | |
273 | (close-port port) | |
274 | (apply values vals)))) | |
275 | ||
276 | (define* (call-with-bytevector-output-port proc #:optional (transcoder #f)) | |
277 | (receive (port extract) (open-bytevector-output-port transcoder) | |
278 | (call-with-port port proc) | |
279 | (extract))) | |
1ee2c72e | 280 | |
c3993330 AW |
281 | (define (open-string-input-port str) |
282 | "Open an input port that will read from @var{str}." | |
73b03e98 AW |
283 | (with-fluids ((%default-port-encoding "UTF-8")) |
284 | (open-input-string str))) | |
c3993330 | 285 | |
a5484153 AR |
286 | (define* (open-file-input-port filename |
287 | #:optional | |
288 | (file-options (file-options)) | |
289 | (buffer-mode (buffer-mode block)) | |
290 | maybe-transcoder) | |
291 | (let ((port (with-i/o-filename-conditions filename | |
292 | (lambda () (open filename O_RDONLY))))) | |
293 | (cond (maybe-transcoder | |
294 | (set-port-encoding! port (transcoder-codec maybe-transcoder)))) | |
295 | port)) | |
296 | ||
c3993330 AW |
297 | (define (open-string-output-port) |
298 | "Return two values: an output port that will collect characters written to it | |
299 | as a string, and a thunk to retrieve the characters associated with that port." | |
73b03e98 AW |
300 | (let ((port (with-fluids ((%default-port-encoding "UTF-8")) |
301 | (open-output-string)))) | |
c3993330 AW |
302 | (values port |
303 | (lambda () (get-output-string port))))) | |
304 | ||
a5484153 AR |
305 | (define* (open-file-output-port filename |
306 | #:optional | |
307 | (file-options (file-options)) | |
308 | (buffer-mode (buffer-mode block)) | |
309 | maybe-transcoder) | |
310 | (let* ((flags (logior O_WRONLY | |
311 | (if (enum-set-member? 'no-create file-options) | |
312 | 0 | |
313 | O_CREAT) | |
314 | (if (enum-set-member? 'no-truncate file-options) | |
315 | 0 | |
316 | O_TRUNC))) | |
317 | (port (with-i/o-filename-conditions filename | |
318 | (lambda () (open filename flags))))) | |
319 | (cond (maybe-transcoder | |
320 | (set-port-encoding! port (transcoder-codec maybe-transcoder)))) | |
321 | port)) | |
322 | ||
323 | (define (call-with-string-output-port proc) | |
324 | "Call @var{proc}, passing it a string output port. When @var{proc} returns, | |
325 | return the characters accumulated in that port." | |
326 | (let ((port (open-output-string))) | |
327 | (proc port) | |
328 | (get-output-string port))) | |
329 | ||
330 | (define (make-custom-textual-output-port id | |
331 | write! | |
332 | get-position | |
333 | set-position! | |
334 | close) | |
335 | (make-soft-port (vector (lambda (c) (write! (string c) 0 1)) | |
336 | (lambda (s) (write! s 0 (string-length s))) | |
337 | #f ;flush | |
338 | #f ;read character | |
339 | close) | |
340 | "w")) | |
341 | ||
342 | (define (flush-output-port port) | |
343 | (force-output port)) | |
344 | ||
eed98cbc LC |
345 | \f |
346 | ;;; | |
347 | ;;; Textual output. | |
348 | ;;; | |
349 | ||
350 | (define-condition-type &i/o-encoding &i/o-port | |
351 | make-i/o-encoding-error i/o-encoding-error? | |
352 | (char i/o-encoding-error-char)) | |
353 | ||
354 | (define-syntax with-i/o-encoding-error | |
355 | (syntax-rules () | |
356 | "Convert Guile throws to `encoding-error' to `&i/o-encoding-error'." | |
357 | ((_ body ...) | |
358 | ;; XXX: This is heavyweight for small functions like `put-char'. | |
359 | (with-throw-handler 'encoding-error | |
360 | (lambda () | |
361 | (begin body ...)) | |
362 | (lambda (key subr message errno port chr) | |
363 | (raise (make-i/o-encoding-error port chr))))))) | |
364 | ||
a5484153 | 365 | (define (put-char port char) |
eed98cbc | 366 | (with-i/o-encoding-error (write-char char port))) |
a5484153 AR |
367 | |
368 | (define (put-datum port datum) | |
eed98cbc | 369 | (with-i/o-encoding-error (write datum port))) |
a5484153 AR |
370 | |
371 | (define* (put-string port s #:optional start count) | |
eed98cbc LC |
372 | (with-i/o-encoding-error |
373 | (cond ((not (string? s)) | |
374 | (assertion-violation 'put-string "expected string" s)) | |
375 | ((and start count) | |
376 | (display (substring/shared s start (+ start count)) port)) | |
377 | (start | |
378 | (display (substring/shared s start (string-length s)) port)) | |
379 | (else | |
380 | (display s port))))) | |
a5484153 | 381 | |
2252321b AR |
382 | ;; Defined here to be able to make use of `with-i/o-encoding-error', but |
383 | ;; not exported from here, but from `(rnrs io simple)'. | |
384 | (define* (display object #:optional (port (current-output-port))) | |
385 | (with-i/o-encoding-error | |
386 | (guile:display object port))) | |
387 | ||
b1e76e8f LC |
388 | \f |
389 | ;;; | |
390 | ;;; Textual input. | |
391 | ;;; | |
392 | ||
393 | (define-condition-type &i/o-decoding &i/o-port | |
394 | make-i/o-decoding-error i/o-decoding-error?) | |
395 | ||
396 | (define-syntax with-i/o-decoding-error | |
397 | (syntax-rules () | |
398 | "Convert Guile throws to `decoding-error' to `&i/o-decoding-error'." | |
399 | ((_ body ...) | |
400 | ;; XXX: This is heavyweight for small functions like `get-char' and | |
401 | ;; `lookahead-char'. | |
402 | (with-throw-handler 'decoding-error | |
403 | (lambda () | |
404 | (begin body ...)) | |
405 | (lambda (key subr message errno port) | |
406 | (raise (make-i/o-decoding-error port))))))) | |
407 | ||
a5484153 | 408 | (define (get-char port) |
b1e76e8f | 409 | (with-i/o-decoding-error (read-char port))) |
a5484153 AR |
410 | |
411 | (define (get-datum port) | |
b1e76e8f | 412 | (with-i/o-decoding-error (read port))) |
a5484153 AR |
413 | |
414 | (define (get-line port) | |
b1e76e8f | 415 | (with-i/o-decoding-error (read-line port 'trim))) |
a5484153 AR |
416 | |
417 | (define (get-string-all port) | |
b1e76e8f | 418 | (with-i/o-decoding-error (read-delimited "" port 'concat))) |
a5484153 | 419 | |
a6c377f7 AR |
420 | (define (get-string-n port count) |
421 | "Read up to @var{count} characters from @var{port}. | |
422 | If no characters could be read before encountering the end of file, | |
423 | return the end-of-file object, otherwise return a string containing | |
424 | the characters read." | |
425 | (let* ((s (make-string count)) | |
426 | (rv (get-string-n! port s 0 count))) | |
427 | (cond ((eof-object? rv) rv) | |
428 | ((= rv count) s) | |
429 | (else (substring/shared s 0 rv))))) | |
430 | ||
a5484153 | 431 | (define (lookahead-char port) |
b1e76e8f | 432 | (with-i/o-decoding-error (peek-char port))) |
a5484153 AR |
433 | |
434 | \f | |
b1e76e8f LC |
435 | ;;; |
436 | ;;; Standard ports. | |
437 | ;;; | |
438 | ||
a5484153 | 439 | (define (standard-input-port) |
ead04a04 AR |
440 | (with-fluids ((%default-port-encoding #f)) |
441 | (dup->inport 0))) | |
a5484153 AR |
442 | |
443 | (define (standard-output-port) | |
ead04a04 AR |
444 | (with-fluids ((%default-port-encoding #f)) |
445 | (dup->outport 1))) | |
a5484153 AR |
446 | |
447 | (define (standard-error-port) | |
ead04a04 AR |
448 | (with-fluids ((%default-port-encoding #f)) |
449 | (dup->outport 2))) | |
a5484153 | 450 | |
baa5705c AR |
451 | ) |
452 | ||
1ee2c72e | 453 | ;;; ports.scm ends here |