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 2drop\r
  40             filenames-from-data-object\r
  41             length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if\r
  42             dup 0 r> set-ulong-nth\r
  43             >>last-drop-effect drop\r
  44             S_OK\r
  45         ] [ ! DragOver\r
  46             >r 2drop last-drop-effect>> 0 r> set-ulong-nth\r
  47             S_OK\r
  48         ] [ ! DragLeave\r
  49             drop S_OK\r
  50         ] [ ! Drop\r
  51             >r 2drop nip\r
  52             filenames-from-data-object\r
  53             dup length 1 = [\r
  54                 first unparse [ "USE: parser " % % " run-file" % ] "" make\r
  55                 eval-listener\r
  56                 DROPEFFECT_COPY\r
  57             ] [ 2drop DROPEFFECT_NONE ] if\r
  58             0 r> set-ulong-nth\r
  59             S_OK\r
  60         ]\r
  61     } }\r
  62 } <com-wrapper> +listener-dragdrop-wrapper+ set-global\r
  63 \r
  64 : dragdrop-listener-window ( -- )\r
  65     get-workspace parent>> handle>> hWnd>>\r
  66     dup <listener-dragdrop>\r
  67     +listener-dragdrop-wrapper+ get-global com-wrap\r
  68     [ RegisterDragDrop ole32-error ] with-com-interface ;\r