basis/windows/streams/streams.factor

   1 USING: accessors alien.c-types alien.data classes.struct
   2 combinators continuations io kernel libc literals locals
   3 sequences specialized-arrays windows.com memoize
   4 windows.com.wrapper windows.kernel32 windows.ole32
   5 windows.types ;
   6 IN: windows.streams
   7
   8 SPECIALIZED-ARRAY: uchar
   9
  10 <PRIVATE
  11
  12 : with-hresult ( quot: ( -- result ) -- result )
  13     [ drop E_FAIL ] recover ; inline
  14
  15 :: IStream-read ( stream pv cb out-read -- hresult )
  16     [
  17         cb stream stream-read :> buf
  18         buf length :> bytes
  19         pv buf bytes memcpy
  20         out-read [ bytes out-read 0 ULONG set-alien-value ] when
  21
  22         cb bytes = [ S_OK ] [ S_FALSE ] if
  23     ] with-hresult ; inline
  24
  25 :: IStream-write ( stream pv cb out-written -- hresult )
  26     [
  27         pv cb uchar <c-direct-array> stream stream-write
  28         out-written [ cb out-written 0 ULONG set-alien-value ] when
  29         S_OK
  30     ] with-hresult ; inline
  31
  32 : origin>seek-type ( origin -- seek-type )
  33     {
  34         { $ STREAM_SEEK_SET [ seek-absolute ] }
  35         { $ STREAM_SEEK_CUR [ seek-relative ] }
  36         { $ STREAM_SEEK_END [ seek-end ] }
  37     } case ;
  38
  39 :: IStream-seek ( stream move origin new-position -- hresult )
  40     [
  41         move origin origin>seek-type stream stream-seek
  42         new-position [
  43             stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value
  44         ] when
  45         S_OK
  46     ] with-hresult ; inline
  47
  48 :: IStream-set-size ( stream new-size -- hresult )
  49     STG_E_INVALIDFUNCTION ;
  50
  51 :: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )
  52     [
  53         cb stream stream-read :> buf
  54         buf length :> bytes
  55         out-read [ bytes out-read 0 ULONG set-alien-value ] when
  56
  57         other-stream buf bytes out-written IStream::Write
  58     ] with-hresult ; inline
  59
  60 :: IStream-commit ( stream flags -- hresult )
  61     stream stream-flush S_OK ;
  62
  63 :: IStream-revert ( stream -- hresult )
  64     STG_E_INVALIDFUNCTION ;
  65
  66 :: IStream-lock-region ( stream offset cb lock-type -- hresult )
  67     STG_E_INVALIDFUNCTION ;
  68
  69 :: IStream-unlock-region ( stream offset cb lock-type -- hresult )
  70     STG_E_INVALIDFUNCTION ;
  71
  72 :: stream-size ( stream -- size )
  73     stream stream-tell :> old-pos
  74     0 seek-end stream stream-seek
  75     stream stream-tell :> size
  76     old-pos seek-absolute stream stream-seek
  77     size ;
  78
  79 :: IStream-stat ( stream out-stat stat-flag -- hresult )
  80     [
  81         out-stat
  82             f >>pwcsName
  83             STGTY_STREAM >>type
  84             stream stream-size >>cbSize
  85             FILETIME new >>mtime
  86             FILETIME new >>ctime
  87             FILETIME new >>atime
  88             STGM_READWRITE >>grfMode
  89             0 >>grfLocksSupported
  90             GUID_NULL >>clsid
  91             0 >>grfStateBits
  92             0 >>reserved
  93             drop
  94         S_OK
  95     ] with-hresult ;
  96
  97 :: IStream-clone ( stream out-clone-stream -- hresult )
  98     f out-clone-stream 0 void* set-alien-value
  99     STG_E_INVALIDFUNCTION ;
 100
 101 CONSTANT: stream-wrapper
 102     $[
 103         {
 104             { IStream {
 105                 [ IStream-read ]
 106                 [ IStream-write ]
 107                 [ IStream-seek ]
 108                 [ IStream-set-size ]
 109                 [ IStream-copy-to ]
 110                 [ IStream-commit ]
 111                 [ IStream-revert ]
 112                 [ IStream-lock-region ]
 113                 [ IStream-unlock-region ]
 114                 [ IStream-stat ]
 115                 [ IStream-clone ]
 116             } }
 117         } <com-wrapper>
 118     ]
 119
 120 PRIVATE>
 121
 122 : stream>IStream ( stream -- IStream )
 123     stream-wrapper com-wrap ;