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