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