-USING: alien.strings io.encodings.utf16n windows.com\r
-windows.com.wrapper combinators windows.kernel32 windows.ole32\r
-windows.shell32 kernel accessors windows.types\r
-prettyprint namespaces ui.tools.listener ui.tools.workspace\r
-alien.data alien sequences math classes.struct ;\r
-SPECIALIZED-ARRAY: WCHAR\r
-IN: windows.dragdrop-listener\r
-\r
-: filenames-from-hdrop ( hdrop -- filenames )\r
- dup 0xFFFFFFFF f 0 DragQueryFile ! get count of files\r
- [\r
- 2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
- dup WCHAR <c-array>\r
- [ swap DragQueryFile drop ] keep\r
- utf16n alien>string\r
- ] with map ;\r
-\r
-: filenames-from-data-object ( data-object -- filenames )\r
- FORMATETC <struct>\r
- CF_HDROP >>cfFormat\r
- f >>ptd\r
- DVASPECT_CONTENT >>dwAspect\r
- -1 >>lindex\r
- TYMED_HGLOBAL >>tymed\r
- STGMEDIUM <struct>\r
- [ IDataObject::GetData ] keep swap succeeded? [\r
- dup data>>\r
- [ filenames-from-hdrop ] with-global-lock\r
- swap ReleaseStgMedium\r
- ] [ drop f ] if ;\r
-\r
-TUPLE: listener-dragdrop hWnd last-drop-effect ;\r
-\r
-: <listener-dragdrop> ( hWnd -- object )\r
- DROPEFFECT_NONE listener-dragdrop construct-boa ;\r
-\r
-SYMBOL: +listener-dragdrop-wrapper+\r
-{\r
- { "IDropTarget" {\r
- [ ! DragEnter\r
- [\r
- 2drop\r
- filenames-from-data-object\r
- length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if\r
- dup 0\r
- ] dip set-ulong-nth\r
- >>last-drop-effect drop\r
- S_OK\r
- ] [ ! DragOver\r
- [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth\r
- S_OK\r
- ] [ ! DragLeave\r
- drop S_OK\r
- ] [ ! Drop\r
- [\r
- 2drop nip\r
- filenames-from-data-object\r
- dup length 1 = [\r
- first unparse [ "USE: parser " % % " run-file" % ] "" make\r
- eval-listener\r
- DROPEFFECT_COPY\r
- ] [ 2drop DROPEFFECT_NONE ] if\r
- 0\r
- ] dip set-ulong-nth\r
- S_OK\r
- ]\r
- } }\r
-} <com-wrapper> +listener-dragdrop-wrapper+ set-global\r
-\r
-: dragdrop-listener-window ( -- )\r
- get-workspace parent>> handle>> hWnd>>\r
- dup <listener-dragdrop>\r
- +listener-dragdrop-wrapper+ get-global com-wrap\r
- [ RegisterDragDrop ole32-error ] with-com-interface ;\r
+USING: alien.strings io.encodings.utf16n windows.com
+windows.com.wrapper combinators windows.kernel32 windows.ole32
+windows.shell32 kernel accessors windows.types
+prettyprint namespaces ui.tools.listener ui.tools.workspace
+alien.data alien sequences math classes.struct ;
+SPECIALIZED-ARRAY: WCHAR
+IN: windows.dragdrop-listener
+
+: filenames-from-hdrop ( hdrop -- filenames )
+ dup 0xFFFFFFFF f 0 DragQueryFile ! get count of files
+ [
+ 2dup f 0 DragQueryFile 1 + ! get size of filename buffer
+ dup WCHAR <c-array>
+ [ swap DragQueryFile drop ] keep
+ utf16n alien>string
+ ] with map ;
+
+: filenames-from-data-object ( data-object -- filenames )
+ FORMATETC <struct>
+ CF_HDROP >>cfFormat
+ f >>ptd
+ DVASPECT_CONTENT >>dwAspect
+ -1 >>lindex
+ TYMED_HGLOBAL >>tymed
+ STGMEDIUM <struct>
+ [ IDataObject::GetData ] keep swap succeeded? [
+ dup data>>
+ [ filenames-from-hdrop ] with-global-lock
+ swap ReleaseStgMedium
+ ] [ drop f ] if ;
+
+TUPLE: listener-dragdrop hWnd last-drop-effect ;
+
+: <listener-dragdrop> ( hWnd -- object )
+ DROPEFFECT_NONE listener-dragdrop construct-boa ;
+
+SYMBOL: +listener-dragdrop-wrapper+
+{
+ { "IDropTarget" {
+ [ ! DragEnter
+ [
+ 2drop
+ filenames-from-data-object
+ length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if
+ dup 0
+ ] dip set-ulong-nth
+ >>last-drop-effect drop
+ S_OK
+ ] [ ! DragOver
+ [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth
+ S_OK
+ ] [ ! DragLeave
+ drop S_OK
+ ] [ ! Drop
+ [
+ 2drop nip
+ filenames-from-data-object
+ dup length 1 = [
+ first unparse [ "USE: parser " % % " run-file" % ] "" make
+ eval-listener
+ DROPEFFECT_COPY
+ ] [ 2drop DROPEFFECT_NONE ] if
+ 0
+ ] dip set-ulong-nth
+ S_OK
+ ]
+ } }
+} <com-wrapper> +listener-dragdrop-wrapper+ set-global
+
+: dragdrop-listener-window ( -- )
+ get-workspace parent>> handle>> hWnd>>
+ dup <listener-dragdrop>
+ +listener-dragdrop-wrapper+ get-global com-wrap
+ [ RegisterDragDrop ole32-error ] with-com-interface ;