basis/windows/ole32/ole32.factor

   1 USING: alien alien.syntax alien.c-types alien.data alien.strings
   2 math kernel sequences windows.errors windows.types io accessors
   3 math.order namespaces make math.parser windows.kernel32
   4 combinators locals specialized-arrays literals splitting
   5 grouping classes.struct combinators.smart ;
   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 CONSTANT: E_NOTIMPL 0x80004001
  37 CONSTANT: E_NOINTERFACE 0x80004002
  38 CONSTANT: E_FAIL 0x80004005
  39 CONSTANT: E_UNEXPECTED 0x8000FFFF
  40 CONSTANT: E_OUTOFMEMORY 0x8007000E
  41 CONSTANT: E_INVALIDARG 0x80070057
  42
  43 CONSTANT: MK_ALT 0x20
  44 CONSTANT: DROPEFFECT_NONE 0
  45 CONSTANT: DROPEFFECT_COPY 1
  46 CONSTANT: DROPEFFECT_MOVE 2
  47 CONSTANT: DROPEFFECT_LINK 4
  48 CONSTANT: DROPEFFECT_SCROLL 0x80000000
  49 CONSTANT: DD_DEFSCROLLINSET 11
  50 CONSTANT: DD_DEFSCROLLDELAY 50
  51 CONSTANT: DD_DEFSCROLLINTERVAL 50
  52 CONSTANT: DD_DEFDRAGDELAY 200
  53 CONSTANT: DD_DEFDRAGMINDIST 2
  54
  55 CONSTANT: DVASPECT_CONTENT    1
  56 CONSTANT: DVASPECT_THUMBNAIL  2
  57 CONSTANT: DVASPECT_ICON       4
  58 CONSTANT: DVASPECT_DOCPRINT   8
  59
  60 CONSTANT: TYMED_HGLOBAL  1
  61 CONSTANT: TYMED_FILE     2
  62 CONSTANT: TYMED_ISTREAM  4
  63 CONSTANT: TYMED_ISTORAGE 8
  64 CONSTANT: TYMED_GDI      16
  65 CONSTANT: TYMED_MFPICT   32
  66 CONSTANT: TYMED_ENHMF    64
  67 CONSTANT: TYMED_NULL     0
  68
  69 STRUCT: DVTARGETDEVICE
  70     { tdSize DWORD }
  71     { tdDriverNameOffset WORD }
  72     { tdDeviceNameOffset WORD }
  73     { tdPortNameOffset WORD }
  74     { tdExtDevmodeOffset WORD }
  75     { tdData BYTE[1] } ;
  76
  77 TYPEDEF: WORD CLIPFORMAT
  78 TYPEDEF: POINT POINTL
  79
  80 STRUCT: FORMATETC
  81     { cfFormat CLIPFORMAT }
  82     { ptd DVTARGETDEVICE* }
  83     { dwAspect DWORD }
  84     { lindex LONG }
  85     { tymed DWORD } ;
  86 TYPEDEF: FORMATETC* LPFORMATETC
  87
  88 STRUCT: STGMEDIUM
  89     { tymed DWORD }
  90     { data void* }
  91     { punkForRelease LPUNKNOWN } ;
  92 TYPEDEF: STGMEDIUM* LPSTGMEDIUM
  93
  94 CONSTANT: COINIT_MULTITHREADED     0
  95 CONSTANT: COINIT_APARTMENTTHREADED 2
  96 CONSTANT: COINIT_DISABLE_OLE1DDE   4
  97 CONSTANT: COINIT_SPEED_OVER_MEMORY 8
  98
  99 FUNCTION: HRESULT OleInitialize ( void* reserved )
 100 FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit )
 101
 102 : succeeded? ( hresult -- ? )
 103     0 0x7FFFFFFF between? ;
 104
 105 TUPLE: ole32-error code message ;
 106
 107 : <ole32-error> ( code -- error )
 108     dup n>win32-error-string \ ole32-error boa ;
 109
 110 : check-ole32-error ( hresult -- )
 111     dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
 112
 113 : ole-initialize ( -- )
 114     f OleInitialize check-ole32-error ;
 115
 116 : guid= ( a b -- ? )
 117     [ 16 memory>byte-array ] same? ;
 118
 119 CONSTANT: GUID-STRING-LENGTH
 120     $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
 121
 122 : create-guid ( -- GUID )
 123     GUID <struct> dup CoCreateGuid check-ole32-error ;
 124
 125 : string>guid ( string -- guid )
 126     "{-}" split harvest
 127     [ first3 [ hex> ] tri@ ]
 128     [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
 129     GUID <struct-boa> ;
 130
 131 : guid>string ( guid -- string )
 132     [
 133         [ "{" ] dip {
 134             [ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
 135             [ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
 136             [ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
 137             [
 138                 Data4>> [
 139                     {
 140                         [ >hex 2 CHAR: 0 pad-head ]
 141                         [ >hex 2 CHAR: 0 pad-head "-" ]
 142                         [ >hex 2 CHAR: 0 pad-head ]
 143                         [ >hex 2 CHAR: 0 pad-head ]
 144                         [ >hex 2 CHAR: 0 pad-head ]
 145                         [ >hex 2 CHAR: 0 pad-head ]
 146                         [ >hex 2 CHAR: 0 pad-head ]
 147                         [ >hex 2 CHAR: 0 pad-head ]
 148                     } spread
 149                 ] input<sequence "}"
 150             ]
 151         } cleave
 152     ] "" append-outputs-as ;