1 USING: alien alien.syntax alien.c-types alien.strings math
2 kernel sequences windows windows.types debugger io accessors
3 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 : E_NOINTERFACE HEX: 80004002 ; inline
26 : E_FAIL HEX: 80004005 ; inline
27 : E_INVALIDARG HEX: 80070057 ; inline
29 : MK_ALT HEX: 20 ; inline
30 : DROPEFFECT_NONE 0 ; inline
31 : DROPEFFECT_COPY 1 ; inline
32 : DROPEFFECT_MOVE 2 ; inline
33 : DROPEFFECT_LINK 4 ; inline
34 : DROPEFFECT_SCROLL HEX: 80000000 ; inline
35 : DD_DEFSCROLLINSET 11 ; inline
36 : DD_DEFSCROLLDELAY 50 ; inline
37 : DD_DEFSCROLLINTERVAL 50 ; inline
38 : DD_DEFDRAGDELAY 200 ; inline
39 : DD_DEFDRAGMINDIST 2 ; inline
42 : CF_BITMAP 2 ; inline
43 : CF_METAFILEPICT 3 ; inline
47 : CF_OEMTEXT 7 ; inline
49 : CF_PALETTE 9 ; inline
50 : CF_PENDATA 10 ; inline
53 : CF_UNICODETEXT 13 ; inline
54 : CF_ENHMETAFILE 14 ; inline
55 : CF_HDROP 15 ; inline
56 : CF_LOCALE 16 ; inline
59 : CF_OWNERDISPLAY HEX: 0080 ; inline
60 : CF_DSPTEXT HEX: 0081 ; inline
61 : CF_DSPBITMAP HEX: 0082 ; inline
62 : CF_DSPMETAFILEPICT HEX: 0083 ; inline
63 : CF_DSPENHMETAFILE HEX: 008E ; inline
65 : DVASPECT_CONTENT 1 ; inline
66 : DVASPECT_THUMBNAIL 2 ; inline
67 : DVASPECT_ICON 4 ; inline
68 : DVASPECT_DOCPRINT 8 ; inline
70 : TYMED_HGLOBAL 1 ; inline
71 : TYMED_FILE 2 ; inline
72 : TYMED_ISTREAM 4 ; inline
73 : TYMED_ISTORAGE 8 ; inline
74 : TYMED_GDI 16 ; inline
75 : TYMED_MFPICT 32 ; inline
76 : TYMED_ENHMF 64 ; inline
77 : TYMED_NULL 0 ; inline
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 : COINIT_MULTITHREADED 0 ; inline
105 : COINIT_APARTMENTTHREADED 2 ; inline
106 : COINIT_DISABLE_OLE1DDE 4 ; inline
107 : COINIT_SPEED_OVER_MEMORY 8 ; inline
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 error-code ;
120 C: <ole32-error> ole32-error
122 M: ole32-error error.
123 "COM method failed: " print error-code>> (win32-error-string) print ;
125 : ole32-error ( hresult -- )
126 dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
128 : ole-initialize ( -- )
129 f OleInitialize ole32-error ;
132 [ 16 memory>byte-array ] bi@ = ;
135 "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
137 :: (guid-section>guid) ( string guid start end quot -- )
138 start end string subseq hex> guid quot call ; inline
140 :: (guid-byte>guid) ( string guid start end byte -- )
141 start end string subseq hex> byte guid set-nth ; inline
143 : string>guid ( string -- guid )
146 [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ]
147 [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
148 [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
152 GUID-Data4 8 <direct-uchar-array> {
153 [ 20 22 0 (guid-byte>guid) ]
154 [ 22 24 1 (guid-byte>guid) ]
156 [ 25 27 2 (guid-byte>guid) ]
157 [ 27 29 3 (guid-byte>guid) ]
158 [ 29 31 4 (guid-byte>guid) ]
159 [ 31 33 5 (guid-byte>guid) ]
160 [ 33 35 6 (guid-byte>guid) ]
161 [ 35 37 7 (guid-byte>guid) ]
165 : (guid-section%) ( guid quot len -- )
166 [ call >hex ] dip CHAR: 0 pad-left % ; inline
168 : (guid-byte%) ( guid byte -- )
169 swap nth >hex 2 CHAR: 0 pad-left % ; inline
171 : guid>string ( guid -- string )
174 [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
175 [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
176 [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
179 GUID-Data4 8 <direct-uchar-array> {
181 [ 1 (guid-byte%) "-" % ]
187 [ 7 (guid-byte%) "}" % ]