basis/windows/ole32/ole32.factor

   1 USING: alien alien.syntax alien.c-types alien.strings math
   2 kernel sequences windows windows.types debugger io accessors
   3 math.order namespaces make math.parser windows.kernel32
   4 combinators locals specialized-arrays.direct.uchar ;
   5 IN: windows.ole32
   6
   7 LIBRARY: ole32
   8
   9 TYPEDEF: GUID* REFGUID
  10 TYPEDEF: void* LPUNKNOWN
  11 TYPEDEF: wchar_t* LPOLESTR
  12 TYPEDEF: wchar_t* LPCOLESTR
  13
  14 TYPEDEF: REFGUID LPGUID
  15 TYPEDEF: REFGUID REFIID
  16 TYPEDEF: REFGUID REFCLSID
  17
  18 FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
  19 FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
  20 FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
  21 FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
  22
  23 CONSTANT: S_OK 0
  24 CONSTANT: S_FALSE 1
  25 CONSTANT: E_NOINTERFACE HEX: 80004002
  26 CONSTANT: E_FAIL HEX: 80004005
  27 CONSTANT: E_INVALIDARG HEX: 80070057
  28
  29 CONSTANT: MK_ALT HEX: 20
  30 CONSTANT: DROPEFFECT_NONE 0
  31 CONSTANT: DROPEFFECT_COPY 1
  32 CONSTANT: DROPEFFECT_MOVE 2
  33 CONSTANT: DROPEFFECT_LINK 4
  34 CONSTANT: DROPEFFECT_SCROLL HEX: 80000000
  35 CONSTANT: DD_DEFSCROLLINSET 11
  36 CONSTANT: DD_DEFSCROLLDELAY 50
  37 CONSTANT: DD_DEFSCROLLINTERVAL 50
  38 CONSTANT: DD_DEFDRAGDELAY 200
  39 CONSTANT: DD_DEFDRAGMINDIST 2
  40
  41 CONSTANT: CF_TEXT             1
  42 CONSTANT: CF_BITMAP           2
  43 CONSTANT: CF_METAFILEPICT     3
  44 CONSTANT: CF_SYLK             4
  45 CONSTANT: CF_DIF              5
  46 CONSTANT: CF_TIFF             6
  47 CONSTANT: CF_OEMTEXT          7
  48 CONSTANT: CF_DIB              8
  49 CONSTANT: CF_PALETTE          9
  50 CONSTANT: CF_PENDATA          10
  51 CONSTANT: CF_RIFF             11
  52 CONSTANT: CF_WAVE             12
  53 CONSTANT: CF_UNICODETEXT      13
  54 CONSTANT: CF_ENHMETAFILE      14
  55 CONSTANT: CF_HDROP            15
  56 CONSTANT: CF_LOCALE           16
  57 CONSTANT: CF_MAX              17
  58
  59 CONSTANT: CF_OWNERDISPLAY     HEX: 0080
  60 CONSTANT: CF_DSPTEXT          HEX: 0081
  61 CONSTANT: CF_DSPBITMAP        HEX: 0082
  62 CONSTANT: CF_DSPMETAFILEPICT  HEX: 0083
  63 CONSTANT: CF_DSPENHMETAFILE   HEX: 008E
  64
  65 CONSTANT: DVASPECT_CONTENT    1
  66 CONSTANT: DVASPECT_THUMBNAIL  2
  67 CONSTANT: DVASPECT_ICON       4
  68 CONSTANT: DVASPECT_DOCPRINT   8
  69
  70 CONSTANT: TYMED_HGLOBAL  1
  71 CONSTANT: TYMED_FILE     2
  72 CONSTANT: TYMED_ISTREAM  4
  73 CONSTANT: TYMED_ISTORAGE 8
  74 CONSTANT: TYMED_GDI      16
  75 CONSTANT: TYMED_MFPICT   32
  76 CONSTANT: TYMED_ENHMF    64
  77 CONSTANT: TYMED_NULL     0
  78
  79 C-STRUCT: DVTARGETDEVICE
  80     { "DWORD" "tdSize" }
  81     { "WORD" "tdDriverNameOffset" }
  82     { "WORD" "tdDeviceNameOffset" }
  83     { "WORD" "tdPortNameOffset" }
  84     { "WORD" "tdExtDevmodeOffset" }
  85     { "BYTE[1]" "tdData" } ;
  86
  87 TYPEDEF: WORD CLIPFORMAT
  88 TYPEDEF: POINT POINTL
  89
  90 C-STRUCT: FORMATETC
  91     { "CLIPFORMAT" "cfFormat" }
  92     { "DVTARGETDEVICE*" "ptd" }
  93     { "DWORD" "dwAspect" }
  94     { "LONG" "lindex" }
  95     { "DWORD" "tymed" } ;
  96 TYPEDEF: FORMATETC* LPFORMATETC
  97
  98 C-STRUCT: STGMEDIUM
  99     { "DWORD" "tymed" }
 100     { "void*" "data" }
 101     { "LPUNKNOWN" "punkForRelease" } ;
 102 TYPEDEF: STGMEDIUM* LPSTGMEDIUM
 103
 104 CONSTANT: COINIT_MULTITHREADED     0
 105 CONSTANT: COINIT_APARTMENTTHREADED 2
 106 CONSTANT: COINIT_DISABLE_OLE1DDE   4
 107 CONSTANT: COINIT_SPEED_OVER_MEMORY 8
 108
 109 FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
 110 FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
 111
 112 FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
 113 FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
 114 FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
 115
 116 : succeeded? ( hresult -- ? )
 117     0 HEX: 7FFFFFFF between? ;
 118
 119 TUPLE: ole32-error error-code ;
 120 C: <ole32-error> ole32-error
 121
 122 M: ole32-error error.
 123     "COM method failed: " print error-code>> (win32-error-string) print ;
 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 : GUID-STRING-LENGTH ( -- n )
 135     "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
 136
 137 :: (guid-section>guid) ( string guid start end quot -- )
 138     start end string subseq hex> guid quot call ; inline
 139
 140 :: (guid-byte>guid) ( string guid start end byte -- )
 141     start end string subseq hex> byte guid set-nth ; inline
 142
 143 : string>guid ( string -- guid )
 144     "GUID" <c-object> [
 145         {
 146             [  1  9 [ set-GUID-Data1 ] (guid-section>guid) ]
 147             [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
 148             [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
 149             [ ]
 150         } 2cleave
 151
 152         GUID-Data4 8 <direct-uchar-array> {
 153             [ 20 22 0 (guid-byte>guid) ]
 154             [ 22 24 1 (guid-byte>guid) ]
 155
 156             [ 25 27 2 (guid-byte>guid) ]
 157             [ 27 29 3 (guid-byte>guid) ]
 158             [ 29 31 4 (guid-byte>guid) ]
 159             [ 31 33 5 (guid-byte>guid) ]
 160             [ 33 35 6 (guid-byte>guid) ]
 161             [ 35 37 7 (guid-byte>guid) ]
 162         } 2cleave
 163     ] keep ;
 164
 165 : (guid-section%) ( guid quot len -- )
 166     [ call >hex ] dip CHAR: 0 pad-head % ; inline
 167
 168 : (guid-byte%) ( guid byte -- )
 169     swap nth >hex 2 CHAR: 0 pad-head % ; inline
 170
 171 : guid>string ( guid -- string )
 172     [
 173         "{" % {
 174             [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
 175             [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
 176             [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
 177             [ ]
 178         } cleave
 179         GUID-Data4 8 <direct-uchar-array> {
 180             [ 0 (guid-byte%) ]
 181             [ 1 (guid-byte%) "-" % ]
 182             [ 2 (guid-byte%) ]
 183             [ 3 (guid-byte%) ]
 184             [ 4 (guid-byte%) ]
 185             [ 5 (guid-byte%) ]
 186             [ 6 (guid-byte%) ]
 187             [ 7 (guid-byte%) "}" % ]
 188         } cleave
 189     ] "" make ;
 190