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 :: stream-size ( stream -- size )\r
  73     stream stream-tell :> old-pos\r
  74     0 seek-end stream stream-seek\r
  75     stream stream-tell :> size\r
  76     old-pos seek-absolute stream stream-seek\r
  77     size ;\r
  78 \r
  79 :: IStream-stat ( stream out-stat stat-flag -- hresult )\r
  80     [\r
  81         out-stat\r
  82             f >>pwcsName\r
  83             STGTY_STREAM >>type\r
  84             stream stream-size >>cbSize\r
  85             FILETIME <struct> >>mtime\r
  86             FILETIME <struct> >>ctime\r
  87             FILETIME <struct> >>atime\r
  88             STGM_READWRITE >>grfMode\r
  89             0 >>grfLocksSupported\r
  90             GUID_NULL >>clsid\r
  91             0 >>grfStateBits\r
  92             0 >>reserved\r
  93             drop\r
  94         S_OK\r
  95     ] with-hresult ;\r
  96 \r
  97 :: IStream-clone ( out-clone-stream -- hresult )\r
  98     f out-clone-stream 0 void* set-alien-value\r
  99     STG_E_INVALIDFUNCTION ;\r
 100 \r
 101 CONSTANT: stream-wrapper\r
 102     $[\r
 103         {\r
 104             { IStream {\r
 105                 [ IStream-read ]\r
 106                 [ IStream-write ]\r
 107                 [ IStream-seek ]\r
 108                 [ IStream-set-size ]\r
 109                 [ IStream-copy-to ]\r
 110                 [ IStream-commit ]\r
 111                 [ IStream-revert ]\r
 112                 [ IStream-lock-region ]\r
 113                 [ IStream-unlock-region ]\r
 114                 [ IStream-stat ]\r
 115                 [ IStream-clone ]\r
 116             } }\r
 117         } <com-wrapper>\r
 118     ]\r
 119 \r
 120 PRIVATE>\r
 121 \r
 122 : stream>IStream ( stream -- IStream )\r
 123     stream-wrapper com-wrap ;\r