basis/windows/dropfiles/dropfiles.factor

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