basis/windows/ole32/ole32.factor

   1 USING: accessors alien.c-types alien.data alien.syntax
   2 classes.struct combinators combinators.smart grouping kernel
   3 literals math.order math.parser parser sequences
   4 specialized-arrays splitting windows.errors windows.kernel32
   5 windows.types words.constant ;
   6 SPECIALIZED-ARRAY: uchar
   7 IN: windows.ole32
   8
   9 LIBRARY: ole32
  10
  11 TYPEDEF: GUID* REFGUID
  12 TYPEDEF: void* LPUNKNOWN
  13 TYPEDEF: LPWSTR OLESTR
  14 TYPEDEF: LPWSTR LPOLESTR
  15 TYPEDEF: LPWSTR LPCOLESTR
  16 TYPEDEF: wchar_t* OLECHAR
  17 TYPEDEF: OLESTR** SNB
  18
  19 TYPEDEF: GUID IID
  20 TYPEDEF: GUID CLSID
  21
  22 TYPEDEF: REFGUID LPGUID
  23 TYPEDEF: REFGUID LPCGUID
  24 TYPEDEF: REFGUID REFIID
  25 TYPEDEF: REFGUID REFCLSID
  26
  27 FUNCTION: HRESULT CoInitialize ( LPVOID pvReserved )
  28 FUNCTION: void CoUninitialize ( )
  29
  30 FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv )
  31 FUNCTION: HRESULT CoCreateGuid ( GUID* pguid )
  32 FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 )
  33 FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax )
  34 FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid )
  35
  36 FUNCTION: LPVOID CoTaskMemAlloc ( SIZE_T cb )
  37 FUNCTION: LPVOID CoTaskMemRealloc ( LPVOID pv, SIZE_T cb )
  38 FUNCTION: void CoTaskMemFree ( LPVOID pv )
  39 FUNCTION: HRESULT CreateStreamOnHGlobal ( HGLOBAL hGlobal, BOOL fDeleteOnRelease, LPVOID* ppstm )
  40 FUNCTION: HRESULT CoGetClassObject ( REFCLSID rclsid, DWORD dwClsContext, LPVOID pvReserved, REFIID riid, LPVOID *ppv )
  41
  42 CONSTANT: S_OK 0
  43 CONSTANT: S_FALSE 1
  44 CONSTANT: DRAGDROP_S_DROP 0x00040100
  45 CONSTANT: DRAGDROP_S_CANCEL 0x00040101
  46 CONSTANT: DRAGDROP_S_USEDEFAULTCURSORS 0x00040102
  47
  48 ERROR: hresult-error n ;
  49
  50 : check-hresult ( n -- )
  51     dup S_OK = [ drop ] [ hresult-error ] if ;
  52
  53 <<
  54 : >long ( integer -- long )
  55     long <ref> long deref ; inline
  56 >>
  57 <<
  58 SYNTAX: LONG: scan-new-word scan-object >long define-constant ;
  59 >>
  60
  61 LONG: E_NOTIMPL 0x80004001
  62 LONG: E_NOINTERFACE 0x80004002
  63 LONG: E_FAIL 0x80004005
  64 LONG: E_UNEXPECTED 0x8000FFFF
  65 LONG: E_OUTOFMEMORY 0x8007000E
  66 LONG: E_INVALIDARG 0x80070057
  67
  68 LONG: OLE_E_OLEVERB 0x80040000
  69 LONG: OLE_E_ADVF 0x80040001
  70 LONG: OLE_E_ENUM_NOMORE 0x80040002
  71 LONG: OLE_E_ADVISENOTSUPPORTED 0x80040003
  72 LONG: OLE_E_NOCONNECTION 0x80040004
  73 LONG: OLE_E_NOTRUNNING 0x80040005
  74 LONG: OLE_E_NOCACHE 0x80040006
  75 LONG: OLE_E_BLANK 0x80040007
  76 LONG: OLE_E_CLASSDIFF 0x80040008
  77 LONG: OLE_E_CANT_GETMONIKER 0x80040009
  78 LONG: OLE_E_CANT_BINDTOSOURCE 0x8004000A
  79 LONG: OLE_E_STATIC 0x8004000B
  80 LONG: OLE_E_PROMPTSAVECANCELLED 0x8004000C
  81 LONG: OLE_E_INVALIDRECT 0x8004000D
  82 LONG: OLE_E_WRONGCOMPOBJ 0x8004000E
  83 LONG: OLE_E_INVALIDHWND 0x8004000F
  84 LONG: OLE_E_NOT_INPLACEACTIVE 0x80040010
  85 LONG: OLE_E_CANTCONVERT 0x80040011
  86 LONG: OLE_E_NOSTORAGE 0x80040012
  87
  88 LONG: CO_E_NOTINITIALIZED 0x800401F0
  89 LONG: CO_E_ALREADYINITIALIZED 0x800401F1
  90 LONG: CO_E_CANTDETERMINECLASS 0x800401F2
  91 LONG: CO_E_CLASSSTRING 0x800401F3
  92 LONG: CO_E_IIDSTRING 0x800401F4
  93 LONG: CO_E_APPNOTFOUND 0x800401F5
  94 LONG: CO_E_APPSINGLEUSE 0x800401F6
  95 LONG: CO_E_ERRORINAPP 0x800401F7
  96 LONG: CO_E_DLLNOTFOUND 0x800401F8
  97 LONG: CO_E_ERRORINDLL 0x800401F9
  98 LONG: CO_E_WRONGOSFORAPP 0x800401FA
  99 LONG: CO_E_OBJNOTREG 0x800401FB
 100 LONG: CO_E_OBJISREG 0x800401FC
 101 LONG: CO_E_OBJNOTCONNECTED 0x800401FD
 102 LONG: CO_E_APPDIDNTREG 0x800401FE
 103 LONG: CO_E_RELEASED 0x800401FF
 104
 105 CONSTANT: MK_ALT 0x20
 106 CONSTANT: DROPEFFECT_NONE 0
 107 CONSTANT: DROPEFFECT_COPY 1
 108 CONSTANT: DROPEFFECT_MOVE 2
 109 CONSTANT: DROPEFFECT_LINK 4
 110 CONSTANT: DROPEFFECT_SCROLL 0x80000000
 111 CONSTANT: DD_DEFSCROLLINSET 11
 112 CONSTANT: DD_DEFSCROLLDELAY 50
 113 CONSTANT: DD_DEFSCROLLINTERVAL 50
 114 CONSTANT: DD_DEFDRAGDELAY 200
 115 CONSTANT: DD_DEFDRAGMINDIST 2
 116
 117 CONSTANT: DVASPECT_CONTENT    1
 118 CONSTANT: DVASPECT_THUMBNAIL  2
 119 CONSTANT: DVASPECT_ICON       4
 120 CONSTANT: DVASPECT_DOCPRINT   8
 121
 122 CONSTANT: TYMED_HGLOBAL  1
 123 CONSTANT: TYMED_FILE     2
 124 CONSTANT: TYMED_ISTREAM  4
 125 CONSTANT: TYMED_ISTORAGE 8
 126 CONSTANT: TYMED_GDI      16
 127 CONSTANT: TYMED_MFPICT   32
 128 CONSTANT: TYMED_ENHMF    64
 129 CONSTANT: TYMED_NULL     0
 130
 131 STRUCT: DVTARGETDEVICE
 132     { tdSize DWORD }
 133     { tdDriverNameOffset WORD }
 134     { tdDeviceNameOffset WORD }
 135     { tdPortNameOffset WORD }
 136     { tdExtDevmodeOffset WORD }
 137     { tdData BYTE[1] } ;
 138
 139 TYPEDEF: WORD CLIPFORMAT
 140 TYPEDEF: POINT POINTL
 141
 142 STRUCT: FORMATETC
 143     { cfFormat CLIPFORMAT }
 144     { ptd DVTARGETDEVICE* }
 145     { dwAspect DWORD }
 146     { lindex LONG }
 147     { tymed DWORD } ;
 148 TYPEDEF: FORMATETC* LPFORMATETC
 149
 150 STRUCT: STGMEDIUM
 151     { tymed DWORD }
 152     { data void* }
 153     { punkForRelease LPUNKNOWN } ;
 154 TYPEDEF: STGMEDIUM* LPSTGMEDIUM
 155
 156 CONSTANT: COINIT_MULTITHREADED     0
 157 CONSTANT: COINIT_APARTMENTTHREADED 2
 158 CONSTANT: COINIT_DISABLE_OLE1DDE   4
 159 CONSTANT: COINIT_SPEED_OVER_MEMORY 8
 160
 161 FUNCTION: HRESULT OleInitialize ( void* reserved )
 162 FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit )
 163
 164 : succeeded? ( hresult -- ? )
 165     0 0x7FFFFFFF between? ;
 166
 167 TUPLE: ole32-error code message ;
 168
 169 : <ole32-error> ( code -- error )
 170     dup n>win32-error-string \ ole32-error boa ;
 171
 172 : check-ole32-error ( hresult -- )
 173     dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
 174
 175 : ole-initialize ( -- )
 176     f OleInitialize check-ole32-error ;
 177
 178 : guid= ( a b -- ? )
 179     [ 16 memory>byte-array ] same? ;
 180
 181 CONSTANT: GUID-STRING-LENGTH
 182     $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
 183
 184 : create-guid ( -- GUID )
 185     GUID new dup CoCreateGuid check-ole32-error ;
 186
 187 : string>guid ( string -- guid )
 188     "{-}" split harvest
 189     [ first3 [ hex> ] tri@ ]
 190     [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
 191     GUID boa ;
 192
 193 : guid>string ( guid -- string )
 194     [
 195         [ "{" ] dip {
 196             [ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
 197             [ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
 198             [ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
 199             [
 200                 Data4>> [
 201                     {
 202                         [ >hex 2 CHAR: 0 pad-head ]
 203                         [ >hex 2 CHAR: 0 pad-head "-" ]
 204                         [ >hex 2 CHAR: 0 pad-head ]
 205                         [ >hex 2 CHAR: 0 pad-head ]
 206                         [ >hex 2 CHAR: 0 pad-head ]
 207                         [ >hex 2 CHAR: 0 pad-head ]
 208                         [ >hex 2 CHAR: 0 pad-head ]
 209                         [ >hex 2 CHAR: 0 pad-head ]
 210                     } spread
 211                 ] input<sequence "}"
 212             ]
 213         } cleave
 214     ] "" append-outputs-as ;