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 LPOLESTR
  14 TYPEDEF: LPWSTR LPCOLESTR
  15
  16 TYPEDEF: GUID IID
  17 TYPEDEF: GUID CLSID
  18
  19 TYPEDEF: REFGUID LPGUID
  20 TYPEDEF: REFGUID LPCGUID
  21 TYPEDEF: REFGUID REFIID
  22 TYPEDEF: REFGUID REFCLSID
  23
  24 FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv )
  25 FUNCTION: HRESULT CoCreateGuid ( GUID* pguid )
  26 FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 )
  27 FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax )
  28 FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid )
  29
  30 CONSTANT: S_OK 0
  31 CONSTANT: S_FALSE 1
  32 CONSTANT: DRAGDROP_S_DROP 0x00040100
  33 CONSTANT: DRAGDROP_S_CANCEL 0x00040101
  34 CONSTANT: DRAGDROP_S_USEDEFAULTCURSORS 0x00040102
  35
  36 <<
  37 : >long ( integer -- long )
  38     long <ref> long deref ; inline
  39 >>
  40 <<
  41 SYNTAX: LONG: scan-new-word scan-object >long define-constant ;
  42 >>
  43
  44 LONG: E_NOTIMPL 0x80004001
  45 LONG: E_NOINTERFACE 0x80004002
  46 LONG: E_FAIL 0x80004005
  47 LONG: E_UNEXPECTED 0x8000FFFF
  48 LONG: E_OUTOFMEMORY 0x8007000E
  49 LONG: E_INVALIDARG 0x80070057
  50
  51 LONG: OLE_E_OLEVERB 0x80040000
  52 LONG: OLE_E_ADVF 0x80040001
  53 LONG: OLE_E_ENUM_NOMORE 0x80040002
  54 LONG: OLE_E_ADVISENOTSUPPORTED 0x80040003
  55 LONG: OLE_E_NOCONNECTION 0x80040004
  56 LONG: OLE_E_NOTRUNNING 0x80040005
  57 LONG: OLE_E_NOCACHE 0x80040006
  58 LONG: OLE_E_BLANK 0x80040007
  59 LONG: OLE_E_CLASSDIFF 0x80040008
  60 LONG: OLE_E_CANT_GETMONIKER 0x80040009
  61 LONG: OLE_E_CANT_BINDTOSOURCE 0x8004000A
  62 LONG: OLE_E_STATIC 0x8004000B
  63 LONG: OLE_E_PROMPTSAVECANCELLED 0x8004000C
  64 LONG: OLE_E_INVALIDRECT 0x8004000D
  65 LONG: OLE_E_WRONGCOMPOBJ 0x8004000E
  66 LONG: OLE_E_INVALIDHWND 0x8004000F
  67 LONG: OLE_E_NOT_INPLACEACTIVE 0x80040010
  68 LONG: OLE_E_CANTCONVERT 0x80040011
  69 LONG: OLE_E_NOSTORAGE 0x80040012
  70
  71 CONSTANT: MK_ALT 0x20
  72 CONSTANT: DROPEFFECT_NONE 0
  73 CONSTANT: DROPEFFECT_COPY 1
  74 CONSTANT: DROPEFFECT_MOVE 2
  75 CONSTANT: DROPEFFECT_LINK 4
  76 CONSTANT: DROPEFFECT_SCROLL 0x80000000
  77 CONSTANT: DD_DEFSCROLLINSET 11
  78 CONSTANT: DD_DEFSCROLLDELAY 50
  79 CONSTANT: DD_DEFSCROLLINTERVAL 50
  80 CONSTANT: DD_DEFDRAGDELAY 200
  81 CONSTANT: DD_DEFDRAGMINDIST 2
  82
  83 CONSTANT: DVASPECT_CONTENT    1
  84 CONSTANT: DVASPECT_THUMBNAIL  2
  85 CONSTANT: DVASPECT_ICON       4
  86 CONSTANT: DVASPECT_DOCPRINT   8
  87
  88 CONSTANT: TYMED_HGLOBAL  1
  89 CONSTANT: TYMED_FILE     2
  90 CONSTANT: TYMED_ISTREAM  4
  91 CONSTANT: TYMED_ISTORAGE 8
  92 CONSTANT: TYMED_GDI      16
  93 CONSTANT: TYMED_MFPICT   32
  94 CONSTANT: TYMED_ENHMF    64
  95 CONSTANT: TYMED_NULL     0
  96
  97 STRUCT: DVTARGETDEVICE
  98     { tdSize DWORD }
  99     { tdDriverNameOffset WORD }
 100     { tdDeviceNameOffset WORD }
 101     { tdPortNameOffset WORD }
 102     { tdExtDevmodeOffset WORD }
 103     { tdData BYTE[1] } ;
 104
 105 TYPEDEF: WORD CLIPFORMAT
 106 TYPEDEF: POINT POINTL
 107
 108 STRUCT: FORMATETC
 109     { cfFormat CLIPFORMAT }
 110     { ptd DVTARGETDEVICE* }
 111     { dwAspect DWORD }
 112     { lindex LONG }
 113     { tymed DWORD } ;
 114 TYPEDEF: FORMATETC* LPFORMATETC
 115
 116 STRUCT: STGMEDIUM
 117     { tymed DWORD }
 118     { data void* }
 119     { punkForRelease LPUNKNOWN } ;
 120 TYPEDEF: STGMEDIUM* LPSTGMEDIUM
 121
 122 CONSTANT: COINIT_MULTITHREADED     0
 123 CONSTANT: COINIT_APARTMENTTHREADED 2
 124 CONSTANT: COINIT_DISABLE_OLE1DDE   4
 125 CONSTANT: COINIT_SPEED_OVER_MEMORY 8
 126
 127 FUNCTION: HRESULT OleInitialize ( void* reserved )
 128 FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit )
 129
 130 : succeeded? ( hresult -- ? )
 131     0 0x7FFFFFFF between? ;
 132
 133 TUPLE: ole32-error code message ;
 134
 135 : <ole32-error> ( code -- error )
 136     dup n>win32-error-string \ ole32-error boa ;
 137
 138 : check-ole32-error ( hresult -- )
 139     dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
 140
 141 : ole-initialize ( -- )
 142     f OleInitialize check-ole32-error ;
 143
 144 : guid= ( a b -- ? )
 145     [ 16 memory>byte-array ] same? ;
 146
 147 CONSTANT: GUID-STRING-LENGTH
 148     $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
 149
 150 : create-guid ( -- GUID )
 151     GUID <struct> dup CoCreateGuid check-ole32-error ;
 152
 153 : string>guid ( string -- guid )
 154     "{-}" split harvest
 155     [ first3 [ hex> ] tri@ ]
 156     [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
 157     GUID <struct-boa> ;
 158
 159 : guid>string ( guid -- string )
 160     [
 161         [ "{" ] dip {
 162             [ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
 163             [ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
 164             [ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
 165             [
 166                 Data4>> [
 167                     {
 168                         [ >hex 2 CHAR: 0 pad-head ]
 169                         [ >hex 2 CHAR: 0 pad-head "-" ]
 170                         [ >hex 2 CHAR: 0 pad-head ]
 171                         [ >hex 2 CHAR: 0 pad-head ]
 172                         [ >hex 2 CHAR: 0 pad-head ]
 173                         [ >hex 2 CHAR: 0 pad-head ]
 174                         [ >hex 2 CHAR: 0 pad-head ]
 175                         [ >hex 2 CHAR: 0 pad-head ]
 176                     } spread
 177                 ] input<sequence "}"
 178             ]
 179         } cleave
 180     ] "" append-outputs-as ;