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