basis/windows/dropfiles/dropfiles.factor

   1 ! Copyright (C) 2017 Alexander Ilin.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.data alien.strings continuations
   4 fry io.encodings.utf16n kernel literals math namespaces
   5 sequences ui.backend.windows ui.gadgets.worlds ui.gestures
   6 windows.messages windows.shell32 windows.types windows.user32 ;
   7 IN: windows.dropfiles
   8
   9 : filecount-from-hdrop ( hdrop -- n )
  10     0xFFFFFFFF f 0 DragQueryFile ;
  11
  12 : filenames-from-hdrop ( hdrop -- filenames )
  13     dup filecount-from-hdrop <iota>
  14     [
  15         2dup f 0 DragQueryFile 1 + ! get size of filename buffer
  16         dup WCHAR <c-array>
  17         [ swap DragQueryFile drop ] keep
  18         utf16n alien>string
  19     ] with map ;
  20
  21 ! : point-from-hdrop ( hdrop -- loc )
  22 !    POINT <struct> [ DragQueryPoint drop ] keep [ x>> ] [ y>> ] bi 2array ;
  23
  24 : handle-wm-dropfiles ( hdrop -- )
  25     <alien> [ filenames-from-hdrop dropped-files set-global ] [ DragFinish ] bi
  26     key-modifiers <file-drop> hand-gadget get-global propagate-gesture ;
  27
  28 ! The ChangeWindowMessageFilter has a global per-process effect, and so is the
  29 ! list of wm-handlers. Therefore, there is no benefit in using the stricter
  30 ! ChangeWindowMessageFilterEx approach. Plus, the latter is not in Vista.
  31 : (init-message-filter) ( -- )
  32     ${ WM_DROPFILES WM_COPYDATA WM_COPYGLOBALDATA }
  33     [ MSGFLT_ADD ChangeWindowMessageFilter win32-error=0/f ] each ;
  34
  35 : do-once ( guard-variable quot -- )
  36     dupd '[ t _ set-global @ ] [ get-global ] dip unless ; inline
  37
  38 SYMBOL: init-message-filter-done?
  39
  40 ! Ignore the errors: on WinXP the function is missing, and is not needed.
  41 : init-message-filter ( -- )
  42     init-message-filter-done? [
  43         [ (init-message-filter) ] [ drop ] recover
  44     ] do-once ;
  45
  46 : install-wm-handler ( -- )
  47     [ drop 2nip handle-wm-dropfiles 0 ] WM_DROPFILES add-wm-handler ;
  48
  49 : hwnd-accept-files ( hwnd -- )
  50     TRUE DragAcceptFiles init-message-filter install-wm-handler ;
  51
  52 : hwnd-reject-files ( hwnd -- )
  53     f DragAcceptFiles ;
  54
  55 : world-accept-files ( world -- )
  56     handle>> hWnd>> hwnd-accept-files ;
  57
  58 : world-reject-files ( world -- )
  59     handle>> hWnd>> hwnd-accept-files ;
  60
  61 : accept-files ( -- )
  62     world get world-accept-files ;
  63
  64 : reject-files ( -- )
  65     world get world-reject-files ;