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)))))