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     { IDropTarget {
  53         [ ! HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  54             [
  55                 2drop filecount-from-data-object
  56                 1 = DROPEFFECT_COPY DROPEFFECT_NONE ?
  57                 dup
  58             ] dip 0 set-alien-unsigned-4
  59             >>last-drop-effect drop
  60             S_OK
  61         ] [ ! HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  62             [ 2drop last-drop-effect>> ] dip 0 set-alien-unsigned-4
  63             S_OK
  64         ] [ ! HRESULT DragLeave ( )
  65             drop S_OK
  66         ] [ ! HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
  67             [
  68                 2drop nip
  69                 filenames-from-data-object
  70                 dup length 1 = [
  71                     first unparse [ "USE: parser " % % " run-file" % ] "" make
  72                     eval-listener
  73                     DROPEFFECT_COPY
  74                 ] [ drop DROPEFFECT_NONE ] if
  75             ] dip 0 set-alien-unsigned-4
  76             S_OK
  77         ]
  78     } }
  79 } <com-wrapper> +listener-dragdrop-wrapper+ set-global
  80
  81 : dragdrop-listener-window ( -- )
  82     world get handle>> hWnd>> dup <listener-dragdrop>
  83     +listener-dragdrop-wrapper+ get-global com-wrap
  84     [ RegisterDragDrop check-ole32-error ] with-com-interface ;