basis/windows/ole32/ole32.factor

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