basis/windows/dragdrop-listener/dragdrop-listener.factor

   1 ! Copyright (C) 2008, 2009 Joe Groff, Slava Pestov.
   2 ! Copyright (C) 2017-2018 Alexander Ilin.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors alien.accessors alien.data alien.strings
   5 classes.struct io.encodings.utf16n kernel make math namespaces
   6 prettyprint sequences specialized-arrays
   7 ui.backend.windows ui.gadgets.worlds ui.gestures
   8 ui.tools.listener windows.com windows.com.wrapper
   9 windows.dropfiles windows.kernel32 windows.ole32 windows.shell32
  10 windows.types ;
  11 SPECIALIZED-ARRAY: ushort
  12 SPECIALIZED-ARRAY: WCHAR
  13 IN: windows.dragdrop-listener
  14
  15 CONSTANT: E_OUTOFMEMORY -2147024882 ! 0x8007000e
  16
  17 : handle-data-object ( handler:  ( hdrop -- x ) data-object -- filenames )
  18     FORMATETC <struct>
  19         CF_HDROP         >>cfFormat
  20         f                >>ptd
  21         DVASPECT_CONTENT >>dwAspect
  22         -1               >>lindex
  23         TYMED_HGLOBAL    >>tymed
  24     STGMEDIUM <struct>
  25     [ IDataObject::GetData ] keep swap succeeded? [
  26         dup data>>
  27         [ rot execute( hdrop -- x ) ] with-global-lock
  28         swap ReleaseStgMedium
  29     ] [ 2drop f ] if ;
  30
  31 : filenames-from-data-object ( data-object -- filenames )
  32     \ filenames-from-hdrop swap handle-data-object ;
  33
  34 : filecount-from-data-object ( data-object -- n )
  35     \ filecount-from-hdrop swap handle-data-object ;
  36
  37 TUPLE: listener-dragdrop world last-drop-effect ;
  38
  39 : <listener-dragdrop> ( world -- object )
  40     DROPEFFECT_NONE listener-dragdrop boa ;
  41
  42 <<
  43 SYMBOL: +listener-dragdrop-wrapper+
  44 >>
  45
  46 <<
  47 {
  48     { IDropTarget {
  49         [ ! HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  50             DROPEFFECT_COPY swap 0 set-alien-unsigned-4 3drop
  51             DROPEFFECT_COPY >>last-drop-effect drop
  52             S_OK
  53         ] [ ! HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  54             [
  55                 2drop
  56                 [ world>> children>> first hand-gadget set-global ]
  57                 [ last-drop-effect>> ] bi
  58             ] dip 0 set-alien-unsigned-4
  59             S_OK
  60         ] [ ! HRESULT DragLeave ( )
  61             drop S_OK
  62         ] [ ! HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  63             [
  64                 2drop nip
  65                 filenames-from-data-object dropped-files set-global
  66                 key-modifiers <file-drop> hand-gadget get-global propagate-gesture
  67                 DROPEFFECT_COPY
  68             ] dip 0 set-alien-unsigned-4
  69             S_OK
  70         ]
  71     } }
  72 } <com-wrapper> +listener-dragdrop-wrapper+ set-global
  73 >>
  74
  75 : dragdrop-listener-window ( -- )
  76     world get dup <listener-dragdrop>
  77     +listener-dragdrop-wrapper+ get-global com-wrap [
  78         [ handle>> hWnd>> ] dip
  79         2dup RegisterDragDrop dup E_OUTOFMEMORY =
  80         [ drop ole-initialize RegisterDragDrop ] [ 2nip ] if
  81         check-ole32-error
  82     ] with-com-interface ;