steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
basis/windows/dragdrop-listener/dragdrop-listener.factor
View File

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