-USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows.errors windows.types io
-accessors math.order namespaces make math.parser windows.kernel32
-combinators locals specialized-arrays.direct.uchar ;
+USING: alien alien.syntax alien.c-types alien.data alien.strings
+math kernel sequences windows.errors windows.types io accessors
+math.order namespaces make math.parser windows.kernel32
+combinators locals specialized-arrays literals splitting
+grouping classes.struct combinators.smart ;
+SPECIALIZED-ARRAY: uchar
IN: windows.ole32
LIBRARY: ole32
TYPEDEF: GUID* REFGUID
TYPEDEF: void* LPUNKNOWN
-TYPEDEF: wchar_t* LPOLESTR
-TYPEDEF: wchar_t* LPCOLESTR
+TYPEDEF: LPWSTR LPOLESTR
+TYPEDEF: LPWSTR LPCOLESTR
+
+TYPEDEF: GUID IID
+TYPEDEF: GUID CLSID
TYPEDEF: REFGUID LPGUID
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
-FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
-FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
-FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
-FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
+FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv )
+FUNCTION: HRESULT CoCreateGuid ( GUID* pguid )
+FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 )
+FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax )
+FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid )
CONSTANT: S_OK 0
CONSTANT: S_FALSE 1
-CONSTANT: E_NOINTERFACE HEX: 80004002
-CONSTANT: E_FAIL HEX: 80004005
-CONSTANT: E_INVALIDARG HEX: 80070057
+CONSTANT: E_NOINTERFACE 0x80004002
+CONSTANT: E_FAIL 0x80004005
+CONSTANT: E_INVALIDARG 0x80070057
-CONSTANT: MK_ALT HEX: 20
+CONSTANT: MK_ALT 0x20
CONSTANT: DROPEFFECT_NONE 0
CONSTANT: DROPEFFECT_COPY 1
CONSTANT: DROPEFFECT_MOVE 2
CONSTANT: DROPEFFECT_LINK 4
-CONSTANT: DROPEFFECT_SCROLL HEX: 80000000
+CONSTANT: DROPEFFECT_SCROLL 0x80000000
CONSTANT: DD_DEFSCROLLINSET 11
CONSTANT: DD_DEFSCROLLDELAY 50
CONSTANT: DD_DEFSCROLLINTERVAL 50
CONSTANT: CF_LOCALE 16
CONSTANT: CF_MAX 17
-CONSTANT: CF_OWNERDISPLAY HEX: 0080
-CONSTANT: CF_DSPTEXT HEX: 0081
-CONSTANT: CF_DSPBITMAP HEX: 0082
-CONSTANT: CF_DSPMETAFILEPICT HEX: 0083
-CONSTANT: CF_DSPENHMETAFILE HEX: 008E
+CONSTANT: CF_OWNERDISPLAY 0x0080
+CONSTANT: CF_DSPTEXT 0x0081
+CONSTANT: CF_DSPBITMAP 0x0082
+CONSTANT: CF_DSPMETAFILEPICT 0x0083
+CONSTANT: CF_DSPENHMETAFILE 0x008E
CONSTANT: DVASPECT_CONTENT 1
CONSTANT: DVASPECT_THUMBNAIL 2
CONSTANT: TYMED_ENHMF 64
CONSTANT: TYMED_NULL 0
-C-STRUCT: DVTARGETDEVICE
- { "DWORD" "tdSize" }
- { "WORD" "tdDriverNameOffset" }
- { "WORD" "tdDeviceNameOffset" }
- { "WORD" "tdPortNameOffset" }
- { "WORD" "tdExtDevmodeOffset" }
- { "BYTE[1]" "tdData" } ;
+STRUCT: DVTARGETDEVICE
+ { tdSize DWORD }
+ { tdDriverNameOffset WORD }
+ { tdDeviceNameOffset WORD }
+ { tdPortNameOffset WORD }
+ { tdExtDevmodeOffset WORD }
+ { tdData BYTE[1] } ;
TYPEDEF: WORD CLIPFORMAT
TYPEDEF: POINT POINTL
-C-STRUCT: FORMATETC
- { "CLIPFORMAT" "cfFormat" }
- { "DVTARGETDEVICE*" "ptd" }
- { "DWORD" "dwAspect" }
- { "LONG" "lindex" }
- { "DWORD" "tymed" } ;
+STRUCT: FORMATETC
+ { cfFormat CLIPFORMAT }
+ { ptd DVTARGETDEVICE* }
+ { dwAspect DWORD }
+ { lindex LONG }
+ { tymed DWORD } ;
TYPEDEF: FORMATETC* LPFORMATETC
-C-STRUCT: STGMEDIUM
- { "DWORD" "tymed" }
- { "void*" "data" }
- { "LPUNKNOWN" "punkForRelease" } ;
+STRUCT: STGMEDIUM
+ { tymed DWORD }
+ { data void* }
+ { punkForRelease LPUNKNOWN } ;
TYPEDEF: STGMEDIUM* LPSTGMEDIUM
CONSTANT: COINIT_MULTITHREADED 0
CONSTANT: COINIT_DISABLE_OLE1DDE 4
CONSTANT: COINIT_SPEED_OVER_MEMORY 8
-FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
-FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
-
-FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
-FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
-FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
+FUNCTION: HRESULT OleInitialize ( void* reserved )
+FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit )
: succeeded? ( hresult -- ? )
- 0 HEX: 7FFFFFFF between? ;
+ 0 0x7FFFFFFF between? ;
TUPLE: ole32-error code message ;
: <ole32-error> ( code -- error )
dup n>win32-error-string \ ole32-error boa ;
-: ole32-error ( hresult -- )
+: check-ole32-error ( hresult -- )
dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
: ole-initialize ( -- )
- f OleInitialize ole32-error ;
+ f OleInitialize check-ole32-error ;
: guid= ( a b -- ? )
- [ 16 memory>byte-array ] bi@ = ;
-
-: GUID-STRING-LENGTH ( -- n )
- "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
+ [ 16 memory>byte-array ] same? ;
-:: (guid-section>guid) ( string guid start end quot -- )
- start end string subseq hex> guid quot call ; inline
+CONSTANT: GUID-STRING-LENGTH
+ $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
-:: (guid-byte>guid) ( string guid start end byte -- )
- start end string subseq hex> byte guid set-nth ; inline
+: create-guid ( -- GUID )
+ GUID <struct> dup CoCreateGuid check-ole32-error ;
: string>guid ( string -- guid )
- "GUID" <c-object> [
- {
- [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ]
- [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
- [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
- [ ]
- } 2cleave
-
- GUID-Data4 {
- [ 20 22 0 (guid-byte>guid) ]
- [ 22 24 1 (guid-byte>guid) ]
-
- [ 25 27 2 (guid-byte>guid) ]
- [ 27 29 3 (guid-byte>guid) ]
- [ 29 31 4 (guid-byte>guid) ]
- [ 31 33 5 (guid-byte>guid) ]
- [ 33 35 6 (guid-byte>guid) ]
- [ 35 37 7 (guid-byte>guid) ]
- } 2cleave
- ] keep ;
-
-: (guid-section%) ( guid quot len -- )
- [ call >hex ] dip CHAR: 0 pad-head % ; inline
-
-: (guid-byte%) ( guid byte -- )
- swap nth >hex 2 CHAR: 0 pad-head % ; inline
+ "{-}" split harvest
+ [ first3 [ hex> ] tri@ ]
+ [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
+ GUID <struct-boa> ;
: guid>string ( guid -- string )
[
- "{" % {
- [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
- [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
- [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
- [ ]
+ [ "{" ] dip {
+ [ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
+ [ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
+ [ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
+ [
+ Data4>> [
+ {
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head "-" ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ [ >hex 2 CHAR: 0 pad-head ]
+ } spread
+ ] input<sequence "}"
+ ]
} cleave
- GUID-Data4 {
- [ 0 (guid-byte%) ]
- [ 1 (guid-byte%) "-" % ]
- [ 2 (guid-byte%) ]
- [ 3 (guid-byte%) ]
- [ 4 (guid-byte%) ]
- [ 5 (guid-byte%) ]
- [ 6 (guid-byte%) ]
- [ 7 (guid-byte%) "}" % ]
- } cleave
- ] "" make ;
-
+ ] "" append-outputs-as ;