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