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

   1 ! Copyright (C) 2008, 2009 Joe Groff, Slava Pestov.
   2 ! Copyright (C) 2017 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.gadgets.worlds ui.tools.listener windows.com
   8 windows.com.wrapper windows.dropfiles windows.kernel32
   9 windows.ole32 windows.shell32 windows.types ;
  10 SPECIALIZED-ARRAY: WCHAR
  11 IN: windows.dragdrop-listener
  12
  13 CONSTANT: E_OUTOFMEMORY -2147024882 ! 0x8007000e
  14
  15 : handle-data-object ( handler:  ( hdrop -- x ) data-object -- filenames )
  16     FORMATETC <struct>
  17         CF_HDROP         >>cfFormat
  18         f                >>ptd
  19         DVASPECT_CONTENT >>dwAspect
  20         -1               >>lindex
  21         TYMED_HGLOBAL    >>tymed
  22     STGMEDIUM <struct>
  23     [ IDataObject::GetData ] keep swap succeeded? [
  24         dup data>>
  25         [ rot execute( hdrop -- x ) ] with-global-lock
  26         swap ReleaseStgMedium
  27     ] [ 2drop f ] if ;
  28
  29 : filenames-from-data-object ( data-object -- filenames )
  30     \ filenames-from-hdrop swap handle-data-object ;
  31
  32 : filecount-from-data-object ( data-object -- n )
  33     \ filecount-from-hdrop swap handle-data-object ;
  34
  35 TUPLE: listener-dragdrop hWnd last-drop-effect ;
  36
  37 : <listener-dragdrop> ( hWnd -- object )
  38     DROPEFFECT_NONE listener-dragdrop boa ;
  39
  40 <<
  41 SYMBOL: +listener-dragdrop-wrapper+
  42 >>
  43
  44 <<
  45 {
  46     { IDropTarget {
  47         [ ! HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  48             [
  49                 2drop filecount-from-data-object
  50                 1 = DROPEFFECT_COPY DROPEFFECT_NONE ?
  51                 dup
  52             ] dip 0 set-alien-unsigned-4
  53             >>last-drop-effect drop
  54             S_OK
  55         ] [ ! HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  56             [ 2drop last-drop-effect>> ] dip 0 set-alien-unsigned-4
  57             S_OK
  58         ] [ ! HRESULT DragLeave ( )
  59             drop S_OK
  60         ] [ ! HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  61             [
  62                 2drop nip
  63                 filenames-from-data-object
  64                 dup length 1 = [
  65                     first unparse [ "USE: parser " % % " run-file" % ] "" make
  66                     eval-listener
  67                     DROPEFFECT_COPY
  68                 ] [ drop DROPEFFECT_NONE ] if
  69             ] dip 0 set-alien-unsigned-4
  70             S_OK
  71         ]
  72     } }
  73 } <com-wrapper> +listener-dragdrop-wrapper+ set-global
  74 >>
  75
  76 : dragdrop-listener-window ( -- )
  77     world get handle>> hWnd>> dup <listener-dragdrop>
  78     +listener-dragdrop-wrapper+ get-global com-wrap [
  79         2dup RegisterDragDrop dup E_OUTOFMEMORY =
  80         [ drop ole-initialize RegisterDragDrop ] [ 2nip ] if
  81         check-ole32-error
  82     ] with-com-interface ;