io module tested and debugged
[software/python-on-guile.git] / modules / language / python / module / io.scm
1 (define-module (language python module io)
2 #:use-module (oop pf-objects)
3 #:use-module (system foreign)
4 #:use-module (ice-9 binary-ports)
5 #:use-module (ice-9 textual-ports)
6 #:use-module (ice-9 rdelim)
7
8 #:use-module (language python exceptions)
9 #:use-module (language python def)
10 #:use-module (language python try)
11 #:use-module (language python string)
12 #:use-module (language python list)
13 #:use-module (language python bytes)
14 #:use-module (language python bool)
15
16 #:use-module (language python module errno)
17 #:re-export (BlockingIOError)
18 #:replace (open)
19 #:export (UnsupportedOperation scm-port DEFAULT_BUFFER_SIZE
20 IOBase RawIOBase BufferedIOBase FileIO
21 BytesIO BufferedReader BufferedWriter
22 BufferedRandom TextIOBase TextIOWrapper
23 StringIO))
24
25 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
26
27 (define-syntax-rule (ca code)
28 (catch #t
29 (lambda () code)
30 (lambda x (raise error x))))
31
32 (define-syntax-rule (rm code)
33 (let ((r (ca code)))
34 (if (< r 0)
35 (raise error (errno) ((@ (guile) strerror) (errno)))
36 r)))
37
38 (define F_GETFL 3)
39
40 (define fcntl2 (pointer->procedure int
41 (dynamic-func "fcntl" (dynamic-link))
42 (list int int)))
43 (define fcntl3 (pointer->procedure int
44 (dynamic-func "fcntl" (dynamic-link))
45 (list int int int)))
46
47 (define (get_blocking fd)
48 (let ((fd (if (port? fd) (port->fdes fd) fd)))
49 (if (= (logand O_NONBLOCK (rm (fcntl2 fd F_GETFL))) 0)
50 #f
51 #t)))
52
53 (define (scm-port x)
54 (if (port? x)
55 x
56 (aif it (ref x '_port)
57 it
58 (aif it (ref x 'raw)
59 (scm-port it)
60 (raise ValueError "no port in scm-port")))))
61
62 (define-python-class UnsupportedOperation (OSError ValueError))
63
64 (define DEFAULT_BUFFER_SIZE 4096)
65
66 (define (path-it path)
67 (if (number? path)
68 path
69 (scm-str
70 (aif it (ref path '__fspath__)
71 (it)
72 path))))
73
74 (def (open- path
75 (= mode "r")
76 (= buffering -1 )
77 (= encoding None)
78 (= errors None)
79 (= newline None)
80 (= closefd #t)
81 (= opener None))
82
83 (define modelist (string->list mode))
84 (define path* (path-it path))
85 (define (clean ch l)
86 (filter (lambda (c) (not (eq? ch c))) l))
87
88 (let* ((port (if (number? path)
89 (begin
90 (if (member #\a modelist)
91 (seek path* 0 SEEK_END))
92 (if (member #\x modelist)
93 (error "cannot use mode 'x' for fd input"))
94 (cond
95 ((member #\r modelist)
96 (fdes->inport path*))
97 ((member #\w modelist)
98 (fdes->outport path*))))
99 (begin
100 (if (member #\x modelist)
101 (if (file-exists? path*)
102 (raise OSError "mode='x' and file exists")
103 (set mode (list->string
104 (clean #\x modelist)))))
105 ((@ (guile) open-file) path* mode))))
106
107 (errors (if (bool errors)
108 (scm-str errors)
109 (let ((s (port-conversion-strategy port)))
110 (cond
111 ((eq? s 'error) "strict")
112 ((eq? s 'substitute) "replace")
113 ((eq? s 'escape) "basckslashreplace")))))
114
115 (encoding (if (eq? encoding None)
116 (port-encoding port)
117 encoding)))
118
119
120 ;; encoding
121 (set-port-encoding! port encoding)
122
123 (case buffering
124 ((-1)
125 (setvbuf port 'block DEFAULT_BUFFER_SIZE))
126 ((0)
127 (setvbuf port 'none))
128 ((1)
129 (setvbuf port 'line))
130 (else
131 (setvbuf port 'block buffering)))
132
133 (cond
134 ((equal? errors "strict")
135 (set-port-conversion-strategy! port 'error))
136 ((equal? errors "replace")
137 (set-port-conversion-strategy! port 'substitute))
138 ((equal? errors "basckslashreplace")
139 (set-port-conversion-strategy! port 'escape))
140 (else
141 (set-port-conversion-strategy! port 'escape)))
142
143 port))
144
145
146 (def (open path
147 (= mode "r")
148 (= buffering -1 )
149 (= encoding None)
150 (= errors None)
151 (= newline None)
152 (= closefd #t)
153 (= opener None))
154
155 (let ((F
156 (FileIO (cons
157 (open- path mode buffering encoding errors
158 newline closefd opener)
159 path)
160 mode)))
161 (if (member #\b (string->list mode))
162 F
163 (TextIOWrapper F encoding errors))))
164
165
166 (define-syntax check
167 (syntax-rules ()
168 ((_ (self) . l)
169 (check (self a b) . l))
170
171 ((_ (self port) . l)
172 (check (self port b) . l))
173
174 ((_ (self port it) . l)
175 (let lp ((it self))
176 (aif it2 (ref it 'raw)
177 (lp it2)
178 (begin
179 (if (ref self 'closed)
180 (raise ValueError "IO operation on closed port"))
181 (let ((port (ref it '_port)))
182 . l)))))))
183
184 ;; ABC
185
186
187 (define-python-class IOBase ()
188 (define __init__
189 (lambda (self port)
190 (set self '_port port)
191 (set self 'closed (port-closed? port))))
192
193 (define __getport__
194 (lambda (self)
195 (check (self port)
196 port)))
197
198 (define close
199 (lambda (self)
200 (check (self port it)
201 (close-port port)
202 (set it 'closed #t))))
203
204 (define __enter__
205 (lambda (self)
206 (check (self)
207 self)))
208
209 (define __exit__
210 (lambda (self . x)
211 (check (self)
212 ((ref self 'close)))))
213
214 (define flush
215 (lambda (self)
216 (check (self port)
217 (if ((ref self 'readable)) (drain-input port))
218 (if ((ref self 'writeable)) (force-output port)))))
219
220 (define isatty
221 (lambda (self)
222 (check (self port)
223 (isatty? port))))
224
225 (define __iter__
226 (lambda (self)
227 (check (self)
228 self)))
229
230 (define __next__
231 (lambda (self)
232 (check (self)
233 (raise StopIteration))))
234
235 (define readable
236 (lambda (self)
237 (check (self port)
238 (output-port? port))))
239
240 (define readline
241 (lam (self (= size -1))
242 (check (self)
243 (raise UnsupportedOperation))))
244
245 (define readlines
246 (lam (self (= hint -1))
247 (check (self)
248 (raise UnsupportedOperation))))
249
250 (define seekable
251 (lambda (self)
252 (check (self port)
253 (catch #t
254 (lambda () (seek port 0 SEEK_CUR) #t)
255 (lambda x #f)))))
256
257 (define seek
258 (lambda* (self offset #:optional (whence SEEK_SET))
259 (check (self port)
260 (if (not ((ref self seekable)))
261 (raise (ValueError "Not seekable")))
262 (seek port offset whence))))
263
264
265 (define tell
266 (lambda (self)
267 (check (self port)
268 (ftell port))))
269
270 (define truncate
271 (lam (self (= size None))
272 (check (self port)
273 (if (eq? size None)
274 (truncate-file port)
275 (truncate-file port size)))))
276
277
278 (define writeable
279 (lambda (self)
280 (check (self port)
281 (input-port? port))))
282
283 (define writelines
284 (lambda (self lines)
285 (check (self)
286 (raise UnsupportedOperation))))
287
288 (define __repr__
289 (lambda (self)
290 (let lp ((it self))
291 (aif it2 (ref it 'raw)
292 (lp it2)
293 (let* ((port (ref it '_port ))
294 (cln (ref self '__name__ ))
295 (nm (port-filename port ))
296 (mod (port-mode port )))
297 (format #f "~a ~a : ~a" cln nm mod))))))
298
299 (define __del__
300 (lambda (self)
301 ((ref self 'close)))))
302
303
304
305 (define (wrap x) (if (eof-object? x) #vu8() x))
306 (define (wraps x) (if (eof-object? x) "" x))
307
308
309 (define-python-class RawIOBase (IOBase)
310 (define __next__
311 (lambda (self)
312 (let ((x (read self 1)))
313 (if (= (len x) 0)
314 StopIteration
315 x))))
316
317 (define read
318 (lam (self (= size -1))
319 (check (self port)
320 (bytes
321 (if (< size 0)
322 ((ref self 'readall))
323 (wrap (get-bytevector-n port size)))))))
324
325
326 (define readall
327 (lambda (self)
328 (check (self port)
329 (bytes
330 (wrap (get-bytevector-all port))))))
331
332 (define readinto
333 (lambda (self b)
334 (check (self port)
335 (let* ((n (len b))
336 (b (scm-bytevector b))
337 (m (get-bytevector-n! port b 0 n)))
338 (if (eq? m eof-object)
339 (if (get_blocking (ref self '_port))
340 0
341 None)
342 m)))))
343
344 (define write
345 (lambda (self b)
346 (check (self port)
347 (let ((n (len b))
348 (b (scm-bytevector b)))
349 (put-bytevector port b 0 n)
350 n)))))
351
352
353 (define-python-class BufferedIOBase (RawIOBase)
354 (define detach
355 (lambda (self)
356 (check (self)
357 (raise UnsupportedOperation "detach"))))
358
359 (define read1
360 (lambda* (self #:optional (size -1))
361 (check (self)
362 ((ref self 'read) size))))
363
364 (define readinto1
365 (lambda (self b)
366 (check (self)
367 ((ref self 'readinto) b)))))
368
369 (define-python-class FileIO (RawIOBase)
370 (define __init__
371 (lam (self name (= mode 'r') (= closefd #t) (= opener None))
372 (if (pair? name)
373 (set self '_port (car name))
374 (set self '_port
375 (open- (path-it name)
376 #:mode mode
377 #:closefd closefd
378 #:opener opener)))
379 (set self 'mode mode)
380 (set self 'name (cdr name)))))
381
382
383 (define-python-class BytesIO (BufferedIOBase)
384 (define __init__
385 (lambda* (self #:optional (initial_bytes None))
386 (if (eq? initial_bytes None)
387 (call-with-values open-bytevector-output-port
388 (lambda (port get-bytevector)
389 (set self '_port port)
390 (set self '_gtbv get-bytevector)))
391 (set self '_port
392 (open-bytevector-input-port
393 (scm-bytevector initial_bytes))))))
394
395 (define getvalue
396 (lambda (self)
397 (check (self)
398 (bytes ((ref self '_gtbv)))))))
399
400 (define-python-class BufferedReader (BufferedIOBase)
401 (define __init__
402 (lambda* (self raw #:optional (buffer_size DEFAULT_BUFFER_SIZE))
403 (let ((port (ref raw '_port)))
404 (case buffer_size
405 ((0)
406 (setvbuf port 'none))
407 ((1)
408 (setvbuf port 'line))
409 (else
410 (setvbuf port 'block buffer_size))))
411 (set self 'raw raw)))
412
413 (define peek
414 (lambda (self)
415 (raise UnsupportedOperation peek))))
416
417 (define-python-class BufferedWriter (BufferedIOBase)
418 (define __init__
419 (lambda* (self raw #:optional (buffer_size DEFAULT_BUFFER_SIZE))
420 (let ((port (ref raw '_port)))
421 (case buffer_size
422 ((0)
423 (setvbuf port 'none))
424 ((1)
425 (setvbuf port 'line))
426 (else
427 (setvbuf port 'block buffer_size))))
428 (set self 'raw raw))))
429
430 (define-python-class BufferedRandom (BufferedIOBase)
431 (define __init__
432 (lambda* (self raw #:optional (buffer_size DEFAULT_BUFFER_SIZE))
433 (let ((port (ref raw '_port)))
434 (case buffer_size
435 ((0)
436 (setvbuf port 'none))
437 ((1)
438 (setvbuf port 'line))
439 (else
440 (setvbuf port 'block buffer_size))))
441 (set self 'raw raw)))
442
443 (define peek
444 (lambda (self)
445 (raise UnsupportedOperation peek))))
446
447 (define-python-class TextIOBase (IOBase)
448 (define __next__
449 (lambda (self)
450 (let ((x ((ref self 'read) 1)))
451 (if (= (len x) 0)
452 StopIteration
453 x))))
454
455 (define read
456 (lam (self (= size -1))
457 (check (self port)
458 (if (< size 0)
459 (wraps (get-string-all port))
460 (wraps (get-string-n port size))))))
461
462 (define readline
463 (lam (self (= size -1))
464 (check (self port)
465 (wraps (read-line port 'concat)))))
466
467 (define write
468 (lambda (self s)
469 (check (self port)
470 (put-string port (scm-str s) 0 (len s))
471 (len s)))))
472
473 (define (get-port x)
474 (aif it (ref x '_port)
475 it
476 (aif it (ref x 'raw)
477 (get-port it)
478 (raise (ValueError "No port associated to IO wrapper")))))
479
480 (define-python-class TextIOWrapper (TextIOBase)
481 (define __init__
482 (lam (self buffer
483 (= encoding None)
484 (= errors None)
485 (= newline None)
486 (= line_buffering #f)
487 (= write_through #f))
488 (set self 'raw buffer)
489 (let* ((port (get-port buffer))
490 (errors (if (bool errors)
491 (scm-str errors)
492 (let ((s (port-conversion-strategy port)))
493 (cond
494 ((eq? s 'error) "strict")
495 ((eq? s 'substitute) "replace")
496 ((eq? s 'escape) "basckslashreplace")))))
497 (encoding (if (eq? encoding None)
498 (port-encoding port)
499 encoding)))
500 ;; encoding
501 (set self 'encoding encoding)
502 (set-port-encoding! port encoding)
503
504 ;; buffering
505 (if line_buffering
506 (setvbuf port 'line))
507
508 (set self 'line_buffering line_buffering)
509
510 ;; errors
511 (set self 'error errors)
512 (cond
513 ((equal? errors "strict")
514 (set-port-conversion-strategy! port 'error))
515 ((equal? errors "replace")
516 (set-port-conversion-strategy! port 'substitute))
517 ((equal? errors "basckslashreplace")
518 (set-port-conversion-strategy! port 'escape))
519 (else
520 (set-port-conversion-strategy! port 'escape)))
521
522 ;; write trough
523 (set self 'write_through write_through)))))
524
525 (define-python-class StringIO (TextIOBase)
526 (define __init__
527 (lam (self (= initial_value "") (= newline "\n"))
528 (set self 'newline newline)
529 (if (equal? initial_value "")
530 (set self '_port (open-output-string))
531 (set self '_port (open-input-string initial_value)))))
532
533 (define getvalue
534 (lambda (self)
535 (check (self port)
536 (get-output-string port)))))