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

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