/unmaintained/dragdrop-listener/dragdrop-listener.factor

 1USING: alien.strings io.encodings.utf16n windows.com
 2windows.com.wrapper combinators windows.kernel32 windows.ole32
 3windows.shell32 kernel accessors windows.types
 4prettyprint namespaces ui.tools.listener ui.tools.workspace
 5alien.data alien sequences math classes.struct ;
 6SPECIALIZED-ARRAY: WCHAR
 7IN: windows.dragdrop-listener
 8
 9: filenames-from-hdrop ( hdrop -- filenames )
10    dup 0xFFFFFFFF f 0 DragQueryFile ! get count of files
11    [
12        2dup f 0 DragQueryFile 1 + ! get size of filename buffer
13        dup WCHAR <c-array>
14        [ swap DragQueryFile drop ] keep
15        utf16n alien>string
16    ] with map ;
17
18: filenames-from-data-object ( data-object -- filenames )
19    FORMATETC <struct>
20        CF_HDROP         >>cfFormat
21        f                >>ptd
22        DVASPECT_CONTENT >>dwAspect
23        -1               >>lindex
24        TYMED_HGLOBAL    >>tymed
25    STGMEDIUM <struct>
26    [ IDataObject::GetData ] keep swap succeeded? [
27        dup data>>
28        [ filenames-from-hdrop ] with-global-lock
29        swap ReleaseStgMedium
30    ] [ drop f ] if ;
31
32TUPLE: listener-dragdrop hWnd last-drop-effect ;
33
34: <listener-dragdrop> ( hWnd -- object )
35    DROPEFFECT_NONE listener-dragdrop construct-boa ;
36
37SYMBOL: +listener-dragdrop-wrapper+
38{
39    { "IDropTarget" {
40        [ ! DragEnter
41            [
42                2drop
43                filenames-from-data-object
44                length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if
45                dup 0
46            ] dip set-ulong-nth
47            >>last-drop-effect drop
48            S_OK
49        ] [ ! DragOver
50            [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth
51            S_OK
52        ] [ ! DragLeave
53            drop S_OK
54        ] [ ! Drop
55            [
56                2drop nip
57                filenames-from-data-object
58                dup length 1 = [
59                    first unparse [ "USE: parser " % % " run-file" % ] "" make
60                    eval-listener
61                    DROPEFFECT_COPY
62                ] [ 2drop DROPEFFECT_NONE ] if
63                0
64            ] dip set-ulong-nth
65            S_OK
66        ]
67    } }
68} <com-wrapper> +listener-dragdrop-wrapper+ set-global
69
70: dragdrop-listener-window ( -- )
71    get-workspace parent>> handle>> hWnd>>
72    dup <listener-dragdrop>
73    +listener-dragdrop-wrapper+ get-global com-wrap
74    [ RegisterDragDrop ole32-error ] with-com-interface ;