basis/windows/dragdrop-listener/dragdrop-listener.factor

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