windows.dragdrop-listener: make it produce file-drop gestures

factor-shell
Alexander Iljin 2018-01-20 22:40:15 +01:00 committed by John Benediktsson
parent 2d546cde54
commit deefb43bd2
1 changed files with 19 additions and 19 deletions

View File

@ -4,9 +4,11 @@
USING: accessors alien.accessors alien.data alien.strings
classes.struct io.encodings.utf16n kernel make math namespaces
prettyprint sequences specialized-arrays
ui.gadgets.worlds ui.tools.listener windows.com
windows.com.wrapper windows.dropfiles windows.kernel32
windows.ole32 windows.shell32 windows.types ;
specialized-arrays.instances.alien.c-types.ushort
ui.backend.windows ui.gadgets.worlds ui.gestures
ui.tools.listener windows.com windows.com.wrapper
windows.dropfiles windows.kernel32 windows.ole32 windows.shell32
windows.types ;
SPECIALIZED-ARRAY: WCHAR
IN: windows.dragdrop-listener
@ -32,9 +34,9 @@ CONSTANT: E_OUTOFMEMORY -2147024882 ! 0x8007000e
: filecount-from-data-object ( data-object -- n )
\ filecount-from-hdrop swap handle-data-object ;
TUPLE: listener-dragdrop hWnd last-drop-effect ;
TUPLE: listener-dragdrop world last-drop-effect ;
: <listener-dragdrop> ( hWnd -- object )
: <listener-dragdrop> ( world -- object )
DROPEFFECT_NONE listener-dragdrop boa ;
<<
@ -45,27 +47,24 @@ SYMBOL: +listener-dragdrop-wrapper+
{
{ IDropTarget {
[ ! HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
[
2drop filecount-from-data-object
1 = DROPEFFECT_COPY DROPEFFECT_NONE ?
dup
] dip 0 set-alien-unsigned-4
>>last-drop-effect drop
DROPEFFECT_COPY swap 0 set-alien-unsigned-4 3drop
DROPEFFECT_COPY >>last-drop-effect drop
S_OK
] [ ! HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
[ 2drop last-drop-effect>> ] dip 0 set-alien-unsigned-4
[
2drop
[ world>> children>> first hand-gadget set-global ]
[ last-drop-effect>> ] bi
] dip 0 set-alien-unsigned-4
S_OK
] [ ! HRESULT DragLeave ( )
drop S_OK
] [ ! HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
[
2drop nip
filenames-from-data-object
dup length 1 = [
first unparse [ "USE: parser " % % " run-file" % ] "" make
eval-listener
DROPEFFECT_COPY
] [ drop DROPEFFECT_NONE ] if
filenames-from-data-object dropped-files set-global
key-modifiers <file-drop> hand-gadget get-global propagate-gesture
DROPEFFECT_COPY
] dip 0 set-alien-unsigned-4
S_OK
]
@ -74,8 +73,9 @@ SYMBOL: +listener-dragdrop-wrapper+
>>
: dragdrop-listener-window ( -- )
world get handle>> hWnd>> dup <listener-dragdrop>
world get dup <listener-dragdrop>
+listener-dragdrop-wrapper+ get-global com-wrap [
[ handle>> hWnd>> ] dip
2dup RegisterDragDrop dup E_OUTOFMEMORY =
[ drop ole-initialize RegisterDragDrop ] [ 2nip ] if
check-ole32-error