basis/windows/streams/streams.factor

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