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 REFIID
  21 TYPEDEF: REFGUID REFCLSID
  22
  23 FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv )
  24 FUNCTION: HRESULT CoCreateGuid ( GUID* pguid )
  25 FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 )
  26 FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax )
  27 FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid )
  28
  29 CONSTANT: S_OK 0
  30 CONSTANT: S_FALSE 1
  31 CONSTANT: E_NOINTERFACE 0x80004002
  32 CONSTANT: E_FAIL 0x80004005
  33 CONSTANT: E_INVALIDARG 0x80070057
  34
  35 CONSTANT: MK_ALT 0x20
  36 CONSTANT: DROPEFFECT_NONE 0
  37 CONSTANT: DROPEFFECT_COPY 1
  38 CONSTANT: DROPEFFECT_MOVE 2
  39 CONSTANT: DROPEFFECT_LINK 4
  40 CONSTANT: DROPEFFECT_SCROLL 0x80000000
  41 CONSTANT: DD_DEFSCROLLINSET 11
  42 CONSTANT: DD_DEFSCROLLDELAY 50
  43 CONSTANT: DD_DEFSCROLLINTERVAL 50
  44 CONSTANT: DD_DEFDRAGDELAY 200
  45 CONSTANT: DD_DEFDRAGMINDIST 2
  46
  47 CONSTANT: CF_TEXT             1
  48 CONSTANT: CF_BITMAP           2
  49 CONSTANT: CF_METAFILEPICT     3
  50 CONSTANT: CF_SYLK             4
  51 CONSTANT: CF_DIF              5
  52 CONSTANT: CF_TIFF             6
  53 CONSTANT: CF_OEMTEXT          7
  54 CONSTANT: CF_DIB              8
  55 CONSTANT: CF_PALETTE          9
  56 CONSTANT: CF_PENDATA          10
  57 CONSTANT: CF_RIFF             11
  58 CONSTANT: CF_WAVE             12
  59 CONSTANT: CF_UNICODETEXT      13
  60 CONSTANT: CF_ENHMETAFILE      14
  61 CONSTANT: CF_HDROP            15
  62 CONSTANT: CF_LOCALE           16
  63 CONSTANT: CF_MAX              17
  64
  65 CONSTANT: CF_OWNERDISPLAY     0x0080
  66 CONSTANT: CF_DSPTEXT          0x0081
  67 CONSTANT: CF_DSPBITMAP        0x0082
  68 CONSTANT: CF_DSPMETAFILEPICT  0x0083
  69 CONSTANT: CF_DSPENHMETAFILE   0x008E
  70
  71 CONSTANT: DVASPECT_CONTENT    1
  72 CONSTANT: DVASPECT_THUMBNAIL  2
  73 CONSTANT: DVASPECT_ICON       4
  74 CONSTANT: DVASPECT_DOCPRINT   8
  75
  76 CONSTANT: TYMED_HGLOBAL  1
  77 CONSTANT: TYMED_FILE     2
  78 CONSTANT: TYMED_ISTREAM  4
  79 CONSTANT: TYMED_ISTORAGE 8
  80 CONSTANT: TYMED_GDI      16
  81 CONSTANT: TYMED_MFPICT   32
  82 CONSTANT: TYMED_ENHMF    64
  83 CONSTANT: TYMED_NULL     0
  84
  85 STRUCT: DVTARGETDEVICE
  86     { tdSize DWORD }
  87     { tdDriverNameOffset WORD }
  88     { tdDeviceNameOffset WORD }
  89     { tdPortNameOffset WORD }
  90     { tdExtDevmodeOffset WORD }
  91     { tdData BYTE[1] } ;
  92
  93 TYPEDEF: WORD CLIPFORMAT
  94 TYPEDEF: POINT POINTL
  95
  96 STRUCT: FORMATETC
  97     { cfFormat CLIPFORMAT }
  98     { ptd DVTARGETDEVICE* }
  99     { dwAspect DWORD }
 100     { lindex LONG }
 101     { tymed DWORD } ;
 102 TYPEDEF: FORMATETC* LPFORMATETC
 103
 104 STRUCT: STGMEDIUM
 105     { tymed DWORD }
 106     { data void* }
 107     { punkForRelease LPUNKNOWN } ;
 108 TYPEDEF: STGMEDIUM* LPSTGMEDIUM
 109
 110 CONSTANT: COINIT_MULTITHREADED     0
 111 CONSTANT: COINIT_APARTMENTTHREADED 2
 112 CONSTANT: COINIT_DISABLE_OLE1DDE   4
 113 CONSTANT: COINIT_SPEED_OVER_MEMORY 8
 114
 115 FUNCTION: HRESULT OleInitialize ( void* reserved )
 116 FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit )
 117
 118 : succeeded? ( hresult -- ? )
 119     0 0x7FFFFFFF between? ;
 120
 121 TUPLE: ole32-error code message ;
 122
 123 : <ole32-error> ( code -- error )
 124     dup n>win32-error-string \ ole32-error boa ;
 125
 126 : check-ole32-error ( hresult -- )
 127     dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
 128
 129 : ole-initialize ( -- )
 130     f OleInitialize check-ole32-error ;
 131
 132 : guid= ( a b -- ? )
 133     [ 16 memory>byte-array ] same? ;
 134
 135 CONSTANT: GUID-STRING-LENGTH
 136     $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
 137
 138 : create-guid ( -- GUID )
 139     GUID <struct> dup CoCreateGuid check-ole32-error ;
 140
 141 : string>guid ( string -- guid )
 142     "{-}" split harvest
 143     [ first3 [ hex> ] tri@ ]
 144     [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
 145     GUID <struct-boa> ;
 146
 147 : guid>string ( guid -- string )
 148     [
 149         [ "{" ] dip {
 150             [ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
 151             [ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
 152             [ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
 153             [
 154                 Data4>> [
 155                     {
 156                         [ >hex 2 CHAR: 0 pad-head ]
 157                         [ >hex 2 CHAR: 0 pad-head "-" ]
 158                         [ >hex 2 CHAR: 0 pad-head ]
 159                         [ >hex 2 CHAR: 0 pad-head ]
 160                         [ >hex 2 CHAR: 0 pad-head ]
 161                         [ >hex 2 CHAR: 0 pad-head ]
 162                         [ >hex 2 CHAR: 0 pad-head ]
 163                         [ >hex 2 CHAR: 0 pad-head ]
 164                     } spread
 165                 ] input<sequence "}"
 166             ]
 167         } cleave
 168     ] "" append-outputs-as ;