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 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 code message ;
 120
 121 : <ole32-error> ( code -- error )
 122     dup n>win32-error-string \ ole32-error boa ;
 123
 124 : ole32-error ( hresult -- )
 125     dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
 126
 127 : ole-initialize ( -- )
 128     f OleInitialize ole32-error ;
 129
 130 : guid= ( a b -- ? )
 131     [ 16 memory>byte-array ] bi@ = ;
 132
 133 : GUID-STRING-LENGTH ( -- n )
 134     "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
 135
 136 :: (guid-section>guid) ( string guid start end quot -- )
 137     start end string subseq hex> guid quot call ; inline
 138
 139 :: (guid-byte>guid) ( string guid start end byte -- )
 140     start end string subseq hex> byte guid set-nth ; inline
 141
 142 : string>guid ( string -- guid )
 143     "GUID" <c-object> [
 144         {
 145             [  1  9 [ set-GUID-Data1 ] (guid-section>guid) ]
 146             [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
 147             [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
 148             [ ]
 149         } 2cleave
 150
 151         GUID-Data4 {
 152             [ 20 22 0 (guid-byte>guid) ]
 153             [ 22 24 1 (guid-byte>guid) ]
 154
 155             [ 25 27 2 (guid-byte>guid) ]
 156             [ 27 29 3 (guid-byte>guid) ]
 157             [ 29 31 4 (guid-byte>guid) ]
 158             [ 31 33 5 (guid-byte>guid) ]
 159             [ 33 35 6 (guid-byte>guid) ]
 160             [ 35 37 7 (guid-byte>guid) ]
 161         } 2cleave
 162     ] keep ;
 163
 164 : (guid-section%) ( guid quot len -- )
 165     [ call >hex ] dip CHAR: 0 pad-head % ; inline
 166
 167 : (guid-byte%) ( guid byte -- )
 168     swap nth >hex 2 CHAR: 0 pad-head % ; inline
 169
 170 : guid>string ( guid -- string )
 171     [
 172         "{" % {
 173             [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
 174             [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
 175             [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
 176             [ ]
 177         } cleave
 178         GUID-Data4 {
 179             [ 0 (guid-byte%) ]
 180             [ 1 (guid-byte%) "-" % ]
 181             [ 2 (guid-byte%) ]
 182             [ 3 (guid-byte%) ]
 183             [ 4 (guid-byte%) ]
 184             [ 5 (guid-byte%) ]
 185             [ 6 (guid-byte%) ]
 186             [ 7 (guid-byte%) "}" % ]
 187         } cleave
 188     ] "" make ;
 189