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 ;
   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 : S_OK 0 ; inline
  24 : S_FALSE 1 ; inline
  25 : E_NOINTERFACE HEX: 80004002 ; inline
  26 : E_FAIL HEX: 80004005 ; inline
  27 : E_INVALIDARG HEX: 80070057 ; inline
  28
  29 : MK_ALT HEX: 20 ; inline
  30 : DROPEFFECT_NONE 0 ; inline
  31 : DROPEFFECT_COPY 1 ; inline
  32 : DROPEFFECT_MOVE 2 ; inline
  33 : DROPEFFECT_LINK 4 ; inline
  34 : DROPEFFECT_SCROLL HEX: 80000000 ; inline
  35 : DD_DEFSCROLLINSET 11 ; inline
  36 : DD_DEFSCROLLDELAY 50 ; inline
  37 : DD_DEFSCROLLINTERVAL 50 ; inline
  38 : DD_DEFDRAGDELAY 200 ; inline
  39 : DD_DEFDRAGMINDIST 2 ; inline
  40
  41 : CF_TEXT             1 ; inline
  42 : CF_BITMAP           2 ; inline
  43 : CF_METAFILEPICT     3 ; inline
  44 : CF_SYLK             4 ; inline
  45 : CF_DIF              5 ; inline
  46 : CF_TIFF             6 ; inline
  47 : CF_OEMTEXT          7 ; inline
  48 : CF_DIB              8 ; inline
  49 : CF_PALETTE          9 ; inline
  50 : CF_PENDATA          10 ; inline
  51 : CF_RIFF             11 ; inline
  52 : CF_WAVE             12 ; inline
  53 : CF_UNICODETEXT      13 ; inline
  54 : CF_ENHMETAFILE      14 ; inline
  55 : CF_HDROP            15 ; inline
  56 : CF_LOCALE           16 ; inline
  57 : CF_MAX              17 ; inline
  58
  59 : CF_OWNERDISPLAY     HEX: 0080 ; inline
  60 : CF_DSPTEXT          HEX: 0081 ; inline
  61 : CF_DSPBITMAP        HEX: 0082 ; inline
  62 : CF_DSPMETAFILEPICT  HEX: 0083 ; inline
  63 : CF_DSPENHMETAFILE   HEX: 008E ; inline
  64
  65 : DVASPECT_CONTENT    1 ; inline
  66 : DVASPECT_THUMBNAIL  2 ; inline
  67 : DVASPECT_ICON       4 ; inline
  68 : DVASPECT_DOCPRINT   8 ; inline
  69
  70 : TYMED_HGLOBAL  1 ; inline
  71 : TYMED_FILE     2 ; inline
  72 : TYMED_ISTREAM  4 ; inline
  73 : TYMED_ISTORAGE 8 ; inline
  74 : TYMED_GDI      16 ; inline
  75 : TYMED_MFPICT   32 ; inline
  76 : TYMED_ENHMF    64 ; inline
  77 : TYMED_NULL     0 ; inline
  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 : COINIT_MULTITHREADED     0 ; inline
 105 : COINIT_APARTMENTTHREADED 2 ; inline
 106 : COINIT_DISABLE_OLE1DDE   4 ; inline
 107 : COINIT_SPEED_OVER_MEMORY 8 ; inline
 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
 135     "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
 136
 137 : (guid-section>guid) ( guid string start end quot -- )
 138     [ roll subseq hex> swap ] dip call ; inline
 139 : (guid-byte>guid) ( guid string start end byte -- )
 140     [ roll subseq hex> ] dip
 141     rot GUID-Data4 set-uchar-nth ; inline
 142
 143 : string>guid ( string -- guid )
 144     "GUID" <c-object> [ {
 145         [  1  9 [ set-GUID-Data1 ] (guid-section>guid) ]
 146
 147         [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
 148
 149         [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
 150
 151         [ 20 22 0 (guid-byte>guid) ]
 152         [ 22 24 1 (guid-byte>guid) ]
 153
 154         [ 25 27 2 (guid-byte>guid) ]
 155         [ 27 29 3 (guid-byte>guid) ]
 156         [ 29 31 4 (guid-byte>guid) ]
 157         [ 31 33 5 (guid-byte>guid) ]
 158         [ 33 35 6 (guid-byte>guid) ]
 159         [ 35 37 7 (guid-byte>guid) ]
 160     } 2cleave ] keep ;
 161
 162 : (guid-section%) ( guid quot len -- )
 163     [ call >hex ] dip CHAR: 0 pad-left % ; inline
 164 : (guid-byte%) ( guid byte -- )
 165     swap GUID-Data4 uchar-nth >hex 2
 166     CHAR: 0 pad-left % ; inline
 167
 168 : guid>string ( guid -- string )
 169     [ "{" % {
 170         [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
 171         [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
 172         [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
 173         [ 0 (guid-byte%) ]
 174         [ 1 (guid-byte%) "-" % ]
 175         [ 2 (guid-byte%) ]
 176         [ 3 (guid-byte%) ]
 177         [ 4 (guid-byte%) ]
 178         [ 5 (guid-byte%) ]
 179         [ 6 (guid-byte%) ]
 180         [ 7 (guid-byte%) "}" % ]
 181     } cleave ] "" make ;
 182