1 USING: alien alien.syntax alien.c-types alien.strings math
2 kernel sequences windows.errors windows.types io
3 accessors math.order namespaces make math.parser windows.kernel32
4 combinators locals specialized-arrays.direct.uchar ;
10 TYPEDEF: void* LPUNKNOWN
11 TYPEDEF: wchar_t* LPOLESTR
12 TYPEDEF: wchar_t* LPCOLESTR
14 TYPEDEF: REFGUID LPGUID
15 TYPEDEF: REFGUID REFIID
16 TYPEDEF: REFGUID REFCLSID
18 FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
19 FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
20 FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
21 FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
25 CONSTANT: E_NOINTERFACE HEX: 80004002
26 CONSTANT: E_FAIL HEX: 80004005
27 CONSTANT: E_INVALIDARG HEX: 80070057
29 CONSTANT: MK_ALT HEX: 20
30 CONSTANT: DROPEFFECT_NONE 0
31 CONSTANT: DROPEFFECT_COPY 1
32 CONSTANT: DROPEFFECT_MOVE 2
33 CONSTANT: DROPEFFECT_LINK 4
34 CONSTANT: DROPEFFECT_SCROLL HEX: 80000000
35 CONSTANT: DD_DEFSCROLLINSET 11
36 CONSTANT: DD_DEFSCROLLDELAY 50
37 CONSTANT: DD_DEFSCROLLINTERVAL 50
38 CONSTANT: DD_DEFDRAGDELAY 200
39 CONSTANT: DD_DEFDRAGMINDIST 2
43 CONSTANT: CF_METAFILEPICT 3
47 CONSTANT: CF_OEMTEXT 7
49 CONSTANT: CF_PALETTE 9
50 CONSTANT: CF_PENDATA 10
53 CONSTANT: CF_UNICODETEXT 13
54 CONSTANT: CF_ENHMETAFILE 14
56 CONSTANT: CF_LOCALE 16
59 CONSTANT: CF_OWNERDISPLAY HEX: 0080
60 CONSTANT: CF_DSPTEXT HEX: 0081
61 CONSTANT: CF_DSPBITMAP HEX: 0082
62 CONSTANT: CF_DSPMETAFILEPICT HEX: 0083
63 CONSTANT: CF_DSPENHMETAFILE HEX: 008E
65 CONSTANT: DVASPECT_CONTENT 1
66 CONSTANT: DVASPECT_THUMBNAIL 2
67 CONSTANT: DVASPECT_ICON 4
68 CONSTANT: DVASPECT_DOCPRINT 8
70 CONSTANT: TYMED_HGLOBAL 1
71 CONSTANT: TYMED_FILE 2
72 CONSTANT: TYMED_ISTREAM 4
73 CONSTANT: TYMED_ISTORAGE 8
74 CONSTANT: TYMED_GDI 16
75 CONSTANT: TYMED_MFPICT 32
76 CONSTANT: TYMED_ENHMF 64
77 CONSTANT: TYMED_NULL 0
79 C-STRUCT: DVTARGETDEVICE
81 { "WORD" "tdDriverNameOffset" }
82 { "WORD" "tdDeviceNameOffset" }
83 { "WORD" "tdPortNameOffset" }
84 { "WORD" "tdExtDevmodeOffset" }
85 { "BYTE[1]" "tdData" } ;
87 TYPEDEF: WORD CLIPFORMAT
91 { "CLIPFORMAT" "cfFormat" }
92 { "DVTARGETDEVICE*" "ptd" }
93 { "DWORD" "dwAspect" }
96 TYPEDEF: FORMATETC* LPFORMATETC
101 { "LPUNKNOWN" "punkForRelease" } ;
102 TYPEDEF: STGMEDIUM* LPSTGMEDIUM
104 CONSTANT: COINIT_MULTITHREADED 0
105 CONSTANT: COINIT_APARTMENTTHREADED 2
106 CONSTANT: COINIT_DISABLE_OLE1DDE 4
107 CONSTANT: COINIT_SPEED_OVER_MEMORY 8
109 FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
110 FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
112 FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
113 FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
114 FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
116 : succeeded? ( hresult -- ? )
117 0 HEX: 7FFFFFFF between? ;
119 TUPLE: ole32-error code message ;
121 : <ole32-error> ( code -- error )
122 dup n>win32-error-string \ ole32-error boa ;
124 : ole32-error ( hresult -- )
125 dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
127 : ole-initialize ( -- )
128 f OleInitialize ole32-error ;
131 [ 16 memory>byte-array ] bi@ = ;
133 : GUID-STRING-LENGTH ( -- n )
134 "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
136 :: (guid-section>guid) ( string guid start end quot -- )
137 start end string subseq hex> guid quot call ; inline
139 :: (guid-byte>guid) ( string guid start end byte -- )
140 start end string subseq hex> byte guid set-nth ; inline
142 : string>guid ( string -- guid )
145 [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ]
146 [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
147 [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
152 [ 20 22 0 (guid-byte>guid) ]
153 [ 22 24 1 (guid-byte>guid) ]
155 [ 25 27 2 (guid-byte>guid) ]
156 [ 27 29 3 (guid-byte>guid) ]
157 [ 29 31 4 (guid-byte>guid) ]
158 [ 31 33 5 (guid-byte>guid) ]
159 [ 33 35 6 (guid-byte>guid) ]
160 [ 35 37 7 (guid-byte>guid) ]
164 : (guid-section%) ( guid quot len -- )
165 [ call >hex ] dip CHAR: 0 pad-head % ; inline
167 : (guid-byte%) ( guid byte -- )
168 swap nth >hex 2 CHAR: 0 pad-head % ; inline
170 : guid>string ( guid -- string )
173 [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
174 [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
175 [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
180 [ 1 (guid-byte%) "-" % ]
186 [ 7 (guid-byte%) "}" % ]