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