unmaintained/dragdrop-listener/dragdrop-listener.factor

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