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