1 USING: accessors alien.c-types alien.data classes.struct
\r
2 combinators continuations io kernel libc literals locals
\r
3 sequences specialized-arrays windows.com memoize
\r
4 windows.com.wrapper windows.kernel32 windows.ole32
\r
8 SPECIALIZED-ARRAY: uchar
\r
12 : with-hresult ( quot: ( -- result ) -- result )
\r
13 [ drop E_FAIL ] recover ; inline
\r
15 :: IStream-read ( stream pv cb out-read -- hresult )
\r
17 cb stream stream-read :> buf
\r
20 out-read [ bytes out-read 0 ULONG set-alien-value ] when
\r
22 cb bytes = [ S_OK ] [ S_FALSE ] if
\r
23 ] with-hresult ; inline
\r
25 :: IStream-write ( stream pv cb out-written -- hresult )
\r
27 pv cb uchar <c-direct-array> stream stream-write
\r
28 out-written [ cb out-written 0 ULONG set-alien-value ] when
\r
30 ] with-hresult ; inline
\r
32 : origin>seek-type ( origin -- seek-type )
\r
34 { $ STREAM_SEEK_SET [ seek-absolute ] }
\r
35 { $ STREAM_SEEK_CUR [ seek-relative ] }
\r
36 { $ STREAM_SEEK_END [ seek-end ] }
\r
39 :: IStream-seek ( stream move origin new-position -- hresult )
\r
41 move origin origin>seek-type stream stream-seek
\r
43 stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value
\r
46 ] with-hresult ; inline
\r
48 :: IStream-set-size ( stream new-size -- hresult )
\r
49 STG_E_INVALIDFUNCTION ;
\r
51 :: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )
\r
53 cb stream stream-read :> buf
\r
55 out-read [ bytes out-read 0 ULONG set-alien-value ] when
\r
57 other-stream buf bytes out-written IStream::Write
\r
58 ] with-hresult ; inline
\r
60 :: IStream-commit ( stream flags -- hresult )
\r
61 stream stream-flush S_OK ;
\r
63 :: IStream-revert ( stream -- hresult )
\r
64 STG_E_INVALIDFUNCTION ;
\r
66 :: IStream-lock-region ( stream offset cb lock-type -- hresult )
\r
67 STG_E_INVALIDFUNCTION ;
\r
69 :: IStream-unlock-region ( stream offset cb lock-type -- hresult )
\r
70 STG_E_INVALIDFUNCTION ;
\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
79 :: IStream-stat ( stream out-stat stat-flag -- hresult )
\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
97 :: IStream-clone ( stream out-clone-stream -- hresult )
\r
98 f out-clone-stream 0 void* set-alien-value
\r
99 STG_E_INVALIDFUNCTION ;
\r
101 CONSTANT: stream-wrapper
\r
108 [ IStream-set-size ]
\r
109 [ IStream-copy-to ]
\r
112 [ IStream-lock-region ]
\r
113 [ IStream-unlock-region ]
\r
122 : stream>IStream ( stream -- IStream )
\r
123 stream-wrapper com-wrap ;
\r