core/io/streams/c/c.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.strings byte-arrays byte-vectors
   4 destructors io io.backend io.encodings.utf8 io.files kernel
   5 kernel.private math sequences threads.private ;
   6 IN: io.streams.c
   7
   8 PRIMITIVE: (fopen) ( path mode -- alien )
   9 PRIMITIVE: fclose ( alien -- )
  10 PRIMITIVE: fflush ( alien -- )
  11 PRIMITIVE: fgetc ( alien -- byte/f )
  12 PRIMITIVE: fputc ( byte alien -- )
  13 PRIMITIVE: fread-unsafe ( n buf alien -- count )
  14 PRIMITIVE: fseek ( alien offset whence -- )
  15 PRIMITIVE: ftell ( alien -- n )
  16 PRIMITIVE: fwrite ( data length alien -- )
  17
  18 TUPLE: c-stream < disposable handle ;
  19
  20 : new-c-stream ( handle class -- c-stream )
  21     new-disposable swap >>handle ; inline
  22
  23 M: c-stream dispose* handle>> fclose ;
  24
  25 TUPLE: c-writer < c-stream ;
  26 INSTANCE: c-writer output-stream
  27 INSTANCE: c-writer file-writer
  28
  29 : <c-writer> ( handle -- stream ) c-writer new-c-stream ;
  30
  31 M: c-writer stream-write1
  32     check-disposed handle>> fputc ;
  33
  34 M: c-writer stream-write
  35     check-disposed
  36     [ binary-object ] [ handle>> ] bi* fwrite ;
  37
  38 M: c-writer stream-flush
  39     check-disposed handle>> fflush ;
  40
  41 TUPLE: c-reader < c-stream ;
  42 INSTANCE: c-reader input-stream
  43 INSTANCE: c-reader file-reader
  44
  45 : <c-reader> ( handle -- stream ) c-reader new-c-stream ;
  46
  47 M: c-reader stream-read-unsafe
  48     check-disposed handle>> fread-unsafe ;
  49
  50 M: c-reader stream-read1
  51     check-disposed handle>> fgetc ;
  52
  53 : read-until-loop ( handle seps accum -- accum ch )
  54     pick fgetc dup [
  55         pick dupd member-eq?
  56         [ [ 2drop ] 2dip ] [ suffix! read-until-loop ] if
  57     ] [
  58         [ 2drop ] 2dip
  59     ] if ; inline recursive
  60
  61 M: c-reader stream-read-until
  62     check-disposed handle>> swap
  63     32 <byte-vector> read-until-loop [ B{ } like ] dip
  64     over empty? over not and [ 2drop f f ] when ;
  65
  66 M: c-io-backend init-io ;
  67
  68 : stdin-handle ( -- alien ) OBJ-STDIN special-object ;
  69 : stdout-handle ( -- alien ) OBJ-STDOUT special-object ;
  70 : stderr-handle ( -- alien ) OBJ-STDERR special-object ;
  71
  72 : init-c-stdio ( -- )
  73     stdin-handle <c-reader>
  74     stdout-handle <c-writer>
  75     stderr-handle <c-writer>
  76     set-stdio ;
  77
  78 M: c-io-backend init-stdio init-c-stdio ;
  79
  80 M: c-io-backend io-multiplex
  81     dup 0 = [ drop ] [ 60 60 * 1000 * 1000 * or (sleep) ] if ;
  82
  83 : fopen ( path mode -- alien )
  84     [ utf8 string>alien ] bi@ (fopen) ;
  85
  86 M: c-io-backend (file-reader)
  87     "rb" fopen <c-reader> ;
  88
  89 M: c-io-backend (file-writer)
  90     "wb" fopen <c-writer> ;
  91
  92 M: c-io-backend (file-appender)
  93     "ab" fopen <c-writer> ;
  94
  95 : show ( msg -- )
  96     ! A word which directly calls primitives. It is used to
  97     ! print stuff from contexts where the I/O system would
  98     ! otherwise not work (tools.deploy.shaker, the I/O
  99     ! multiplexer thread).
 100     "\n" append >byte-array dup length
 101     stdout-handle fwrite
 102     stdout-handle fflush ;