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

http://github.com/abeaumont/factor · Factor · 74 lines · 68 code · 6 blank · 0 comment · 5 complexity · d264a5623cfe8682a3231188820ec728 MD5 · raw file 

    

  1. USING: alien.strings io.encodings.utf16n windows.com

    2. 

  2. windows.com.wrapper combinators windows.kernel32 windows.ole32

    3. 

  3. windows.shell32 kernel accessors windows.types

    4. 

  4. prettyprint namespaces ui.tools.listener ui.tools.workspace

    5. 

  5. alien.data alien sequences math classes.struct ;

    6. 

  6. SPECIALIZED-ARRAY: WCHAR

    7. 

  7. IN: windows.dragdrop-listener

    8. 

  8. 

    9. 

  9. : filenames-from-hdrop ( hdrop -- filenames )

    10. 

  10.     dup 0xFFFFFFFF f 0 DragQueryFile ! get count of files

    11. 

  11.     [

    12. 

  12.         2dup f 0 DragQueryFile 1 + ! get size of filename buffer

    13. 

  13.         dup WCHAR <c-array>

    14. 

  14.         [ swap DragQueryFile drop ] keep

    15. 

  15.         utf16n alien>string

    16. 

  16.     ] with map ;

    17. 

  17. 

    18. 

  18. : filenames-from-data-object ( data-object -- filenames )

    19. 

  19.     FORMATETC <struct>

    20. 

  20.         CF_HDROP         >>cfFormat

    21. 

  21.         f                >>ptd

    22. 

  22.         DVASPECT_CONTENT >>dwAspect

    23. 

  23.         -1               >>lindex

    24. 

  24.         TYMED_HGLOBAL    >>tymed

    25. 

  25.     STGMEDIUM <struct>

    26. 

  26.     [ IDataObject::GetData ] keep swap succeeded? [

    27. 

  27.         dup data>>

    28. 

  28.         [ filenames-from-hdrop ] with-global-lock

    29. 

  29.         swap ReleaseStgMedium

    30. 

  30.     ] [ drop f ] if ;

    31. 

  31. 

    32. 

  32. TUPLE: listener-dragdrop hWnd last-drop-effect ;

    33. 

  33. 

    34. 

  34. : <listener-dragdrop> ( hWnd -- object )

    35. 

  35.     DROPEFFECT_NONE listener-dragdrop construct-boa ;

    36. 

  36. 

    37. 

  37. SYMBOL: +listener-dragdrop-wrapper+

    38. 

  38. {

    39. 

  39.     { "IDropTarget" {

    40. 

  40.         [ ! DragEnter

    41. 

  41.             [

    42. 

  42.                 2drop

    43. 

  43.                 filenames-from-data-object

    44. 

  44.                 length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if

    45. 

  45.                 dup 0

    46. 

  46.             ] dip set-ulong-nth

    47. 

  47.             >>last-drop-effect drop

    48. 

  48.             S_OK

    49. 

  49.         ] [ ! DragOver

    50. 

  50.             [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth

    51. 

  51.             S_OK

    52. 

  52.         ] [ ! DragLeave

    53. 

  53.             drop S_OK

    54. 

  54.         ] [ ! Drop

    55. 

  55.             [

    56. 

  56.                 2drop nip

    57. 

  57.                 filenames-from-data-object

    58. 

  58.                 dup length 1 = [

    59. 

  59.                     first unparse [ "USE: parser " % % " run-file" % ] "" make

    60. 

  60.                     eval-listener

    61. 

  61.                     DROPEFFECT_COPY

    62. 

  62.                 ] [ 2drop DROPEFFECT_NONE ] if

    63. 

  63.                 0

    64. 

  64.             ] dip set-ulong-nth

    65. 

  65.             S_OK

    66. 

  66.         ]

    67. 

  67.     } }

    68. 

  68. } <com-wrapper> +listener-dragdrop-wrapper+ set-global

    69. 

  69. 

    70. 

  70. : dragdrop-listener-window ( -- )

    71. 

  71.     get-workspace parent>> handle>> hWnd>>

    72. 

  72.     dup <listener-dragdrop>

    73. 

  73.     +listener-dragdrop-wrapper+ get-global com-wrap

    74. 

  74.     [ RegisterDragDrop ole32-error ] with-com-interface ;
    75.