#
# tkdnd_generic.tcl --
#
#    This file implements some utility procedures that are used by the TkDND
#    package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#

namespace eval generic {
  variable _types {}
  variable _typelist {}
  variable _codelist {}
  variable _actionlist {}
  variable _pressedkeys {}
  variable _pressedmods {}
  variable _action {}
  variable _common_drag_source_types {}
  variable _common_drop_target_types {}
  variable _drag_source {}
  variable _drop_target {}

  variable _last_mouse_root_x 0
  variable _last_mouse_root_y 0

  variable _tkdnd2platform
  variable _platform2tkdnd

  variable _integer_test entier
  if {[catch {string is entier 1234}]} {
    set _integer_test integer
  }

  proc debug { msg } {
    tkdnd::debug $msg
  };# debug

  proc initialise { } {
  };# initialise

  proc initialise_platform_to_tkdnd_types { types } {
    variable _platform2tkdnd
    variable _tkdnd2platform
    # set _platform2tkdnd [dict create {*}$types] ;# {*} not available in 8.4
    set _platform2tkdnd [dict create]
    foreach {p t} $types {
      dict set _platform2tkdnd $p $t
    }
    set _tkdnd2platform [dict create]
    foreach type [dict keys $_platform2tkdnd] {
      dict lappend _tkdnd2platform [dict get $_platform2tkdnd $type] $type
    }
  };# initialise_platform_to_tkdnd_types

  proc initialise_tkdnd_to_platform_types { types } {
    variable _tkdnd2platform
    # set _tkdnd2platform [dict create {*}$types] ;# {*} not available in 8.4
    set _tkdnd2platform [dict create]
    foreach {t p} $types {
      dict set _tkdnd2platform $t $p
    }
  };# initialise_tkdnd_to_platform_types

};# namespace generic

# ----------------------------------------------------------------------------
#  Command generic::SetPressedKeys
# ----------------------------------------------------------------------------
proc generic::SetPressedKeys { pressedkeys } {
  variable _pressedkeys
  variable _pressedmods
  variable _integer_test
  set keys {}
  set mods {}
  foreach {b} $pressedkeys {
    if {[string is $_integer_test -strict $b]} {
      lappend keys $b
    } else {
      lappend mods $b
    }
  }
  set _pressedkeys $keys
  set _pressedmods $mods
};# generic::SetPressedKeys

# ----------------------------------------------------------------------------
#  Command generic::HandleEnter
# ----------------------------------------------------------------------------
proc generic::HandleEnter { drop_target drag_source typelist codelist
                            actionlist pressedkeys } {
  variable _typelist;                 set _typelist    $typelist
  variable _action;                   set _action      refuse_drop
  variable _common_drag_source_types; set _common_drag_source_types {}
  variable _common_drop_target_types; set _common_drop_target_types {}
  variable _actionlist
  variable _drag_source;              set _drag_source $drag_source
  variable _drop_target;              set _drop_target {}
  variable _actionlist;               set _actionlist  $actionlist
  variable _codelist                  set _codelist    $codelist

  variable _last_mouse_root_x;        set _last_mouse_root_x 0
  variable _last_mouse_root_y;        set _last_mouse_root_y 0
  SetPressedKeys $pressedkeys
  #DBG debug "\n==============================================================="
  #DBG debug "generic::HandleEnter: drop_target=$drop_target,\
  #DBG        drag_source=$drag_source,\
  #DBG        typelist=$typelist"
  #DBG debug "generic::HandleEnter: ACTION: default"
  return default
};# generic::HandleEnter

# ----------------------------------------------------------------------------
#  Command generic::HandlePosition
# ----------------------------------------------------------------------------
proc generic::HandlePosition { drop_target drag_source pressedkeys
                               rootX rootY { action {} } { time 0 } } {
  variable _types
  variable _typelist
  variable _codelist
  variable _actionlist
  variable _pressedkeys
  variable _pressedmods
  variable _action
  variable _common_drag_source_types
  variable _common_drop_target_types
  variable _drag_source
  variable _drop_target

  variable _last_mouse_root_x;        set _last_mouse_root_x $rootX
  variable _last_mouse_root_y;        set _last_mouse_root_y $rootY

  #DBG debug "generic::HandlePosition: drop_target=$drop_target,\
  #DBG            _drop_target=$_drop_target, rootX=$rootX, rootY=$rootY"

  if {![info exists _drag_source] || ![string length $_drag_source]} {
    #DBG debug "generic::HandlePosition: no or empty _drag_source:\
    #DBG               return refuse_drop"
    return refuse_drop
  }

  if {$drag_source ne "" && $drag_source ne $_drag_source} {
    #DBG debug "generic position event from unexpected source: $_drag_source\
    #DBG        != $drag_source"
    return refuse_drop
  }

  SetPressedKeys $pressedkeys

  ## Does the new drop target support any of our new types?
  # foreach {common_drag_source_types common_drop_target_types} \
  #         [GetWindowCommonTypes $drop_target $_typelist] {break}
  foreach {drop_target common_drag_source_types common_drop_target_types} \
          [FindWindowWithCommonTypes $drop_target $_typelist] {break}
  set data [GetDroppedData $time]

  #DBG debug "\t($_drop_target) -> ($drop_target)"
  if {$drop_target != $_drop_target} {
    if {[string length $_drop_target]} {
      ## Call the <<DropLeave>> event.
      #DBG debug "\t<<DropLeave>> on $_drop_target"
      set cmd [bind $_drop_target <<DropLeave>>]
      if {[string length $cmd]} {
        set widgetX 0; set widgetY 0
        catch {set widgetX [expr {$rootX - [winfo rootx $_drop_target]}]}
        catch {set widgetY [expr {$rootY - [winfo rooty $_drop_target]}]}
        set cmd [string map [list %W [list $_drop_target] \
          %X $rootX %Y $rootY %x $widgetX %y $widgetY \
          %CST \{$_common_drag_source_types\} \
          %CTT \{$_common_drop_target_types\} \
          %CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
          %ST  \{$_typelist\}    %TT \{$_types\} \
          %A   \{$_action\}      %a \{$_actionlist\} \
          %b   \{$_pressedkeys\} %m \{$_pressedmods\} \
          %D   \{\}              %e <<DropLeave>> \
          %L   \{$_typelist\}    %% % \
          %t   \{$_typelist\}    %T  \{[lindex $_common_drag_source_types 0]\} \
          %c   \{$_codelist\}    %C  \{[lindex $_codelist 0]\} \
          ] $cmd]
        uplevel \#0 $cmd
      }
    }
    set _drop_target $drop_target
    set _action      refuse_drop

    if {[llength $common_drag_source_types]} {
      switch -exact -- $action {
        default - {} { set _action [lindex $_actionlist 0] }
        default      { set _action $action }
      }
      set _common_drag_source_types $common_drag_source_types
      set _common_drop_target_types $common_drop_target_types
      ## Drop target supports at least one type. Send a <<DropEnter>>.
      #DBG debug "<<DropEnter>> -> $drop_target"
      set cmd [bind $drop_target <<DropEnter>>]
      if {[string length $cmd]} {
        set widgetX 0; set widgetY 0
        catch {set widgetX [expr {$rootX - [winfo rootx $drop_target]}]}
        catch {set widgetY [expr {$rootY - [winfo rooty $drop_target]}]}
        focus $drop_target
        set cmd [string map [list %W [list $drop_target] \
          %X $rootX %Y $rootY %x $widgetX %y $widgetY \
          %CST \{$_common_drag_source_types\} \
          %CTT \{$_common_drop_target_types\} \
          %CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
          %ST  \{$_typelist\}    %TT \{$_types\} \
          %A   $_action          %a  \{$_actionlist\} \
          %b   \{$_pressedkeys\} %m  \{$_pressedmods\} \
          %D   [list $data]      %e  <<DropEnter>> \
          %L   \{$_typelist\}    %%  % \
          %t   \{$_typelist\}    %T  \{[lindex $_common_drag_source_types 0]\} \
          %c   \{$_codelist\}    %C  \{[lindex $_codelist 0]\} \
          ] $cmd]
        set _action [uplevel \#0 $cmd]
        switch -exact -- $_action {
          copy - move - link - ask - private - refuse_drop - default {}
          default {set _action copy}
        }
      }
    }
  }

  set _drop_target {}
  if {[llength $common_drag_source_types]} {
    set _common_drag_source_types $common_drag_source_types
    set _common_drop_target_types $common_drop_target_types
    set _drop_target $drop_target
    ## Drop target supports at least one type. Send a <<DropPosition>>.
    set cmd [bind $drop_target <<DropPosition>>]
    if {[string length $cmd]} {
      switch -exact -- $action {
        default - {} { set _action [lindex $_actionlist 0] }
        default      { set _action $action }
      }
      set widgetX 0; set widgetY 0
      catch {set widgetX [expr {$rootX - [winfo rootx $drop_target]}]}
      catch {set widgetY [expr {$rootY - [winfo rooty $drop_target]}]}
      set cmd [string map [list %W [list $drop_target] \
        %X $rootX %Y $rootY %x $widgetX %y $widgetY \
        %CST \{$_common_drag_source_types\} \
        %CTT \{$_common_drop_target_types\} \
        %CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
        %ST  \{$_typelist\}    %TT \{$_types\} \
        %A   $_action          %a  \{$_actionlist\} \
        %b   \{$_pressedkeys\} %m  \{$_pressedmods\} \
        %D   [list $data]      %e  <<DropPosition>> \
        %L   \{$_typelist\}    %%  % \
        %t   \{$_typelist\}    %T  \{[lindex $_common_drag_source_types 0]\} \
        %c   \{$_codelist\}    %C  \{[lindex $_codelist 0]\} \
        ] $cmd]
      set _action [uplevel \#0 $cmd]
    }
  }
  # Return values: copy, move, link, ask, private, refuse_drop, default
  #DBG debug "generic::HandlePosition: ACTION: $_action"
  switch -exact -- $_action {
    copy - move - link - ask - private - refuse_drop - default {}
    default {set _action copy}
  }
  return $_action
};# generic::HandlePosition

# ----------------------------------------------------------------------------
#  Command generic::HandleLeave
# ----------------------------------------------------------------------------
proc generic::HandleLeave { } {
  variable _types
  variable _typelist
  variable _codelist
  variable _actionlist
  variable _pressedkeys
  variable _pressedmods
  variable _action
  variable _common_drag_source_types
  variable _common_drop_target_types
  variable _drag_source
  variable _drop_target
  variable _last_mouse_root_x
  variable _last_mouse_root_y
  if {![info exists _drop_target]} {set _drop_target {}}
  #DBG debug "generic::HandleLeave: _drop_target=$_drop_target"
  if {[info exists _drop_target] && [string length $_drop_target]} {
    set cmd [bind $_drop_target <<DropLeave>>]
    if {[string length $cmd]} {
      set widgetX 0; set widgetY 0
      catch {set widgetX [expr {$_last_mouse_root_x - [winfo rootx $_drop_target]}]}
      catch {set widgetY [expr {$_last_mouse_root_y - [winfo rooty $_drop_target]}]}
      set cmd [string map [list %W [list $_drop_target] \
        %X $_last_mouse_root_x %Y $_last_mouse_root_y %x $widgetX %y $widgetY \
        %CST \{$_common_drag_source_types\} \
        %CTT \{$_common_drop_target_types\} \
        %CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
        %ST  \{$_typelist\}    %TT \{$_types\} \
        %A   \{$_action\}      %a  \{$_actionlist\} \
        %b   \{$_pressedkeys\} %m  \{$_pressedmods\} \
        %D   \{\}              %e  <<DropLeave>> \
        %L   \{$_typelist\}    %%  % \
        %t   \{$_typelist\}    %T  \{[lindex $_common_drag_source_types 0]\} \
        %c   \{$_codelist\}    %C  \{[lindex $_codelist 0]\} \
        ] $cmd]
      set _action [uplevel \#0 $cmd]
    }
  }
  foreach var {_types _typelist _actionlist _pressedkeys _pressedmods _action
               _common_drag_source_types _common_drop_target_types
               _drag_source _drop_target} {
    set $var {}
  }
};# generic::HandleLeave

# ----------------------------------------------------------------------------
#  Command generic::HandleDrop
# ----------------------------------------------------------------------------
proc generic::HandleDrop {drop_target drag_source pressedkeys rootX rootY time } {
  variable _types
  variable _typelist
  variable _codelist
  variable _actionlist
  variable _pressedkeys
  variable _pressedmods
  variable _action
  variable _common_drag_source_types
  variable _common_drop_target_types
  variable _drag_source
  variable _drop_target
  variable _last_mouse_root_x
  variable _last_mouse_root_y
  variable _last_mouse_root_x;        set _last_mouse_root_x $rootX
  variable _last_mouse_root_y;        set _last_mouse_root_y $rootY

  SetPressedKeys $pressedkeys

  #DBG debug "generic::HandleDrop: $time"

  if {![info exists _drag_source] && ![string length $_drag_source]} {
    return refuse_drop
  }
  if {![info exists _drop_target] && ![string length $_drop_target]} {
    return refuse_drop
  }
  if {![llength $_common_drag_source_types]} {return refuse_drop}
  ## Get the dropped data.
  set data [GetDroppedData $time]
  ## Try to select the most specific <<Drop>> event.
  foreach type [concat $_common_drag_source_types $_common_drop_target_types] {
    set type [platform_independent_type $type]
    set cmd [bind $_drop_target <<Drop:$type>>]
    if {[string length $cmd]} {
      set widgetX 0; set widgetY 0
      catch {set widgetX [expr {$rootX - [winfo rootx $_drop_target]}]}
      catch {set widgetY [expr {$rootY - [winfo rooty $_drop_target]}]}
      set cmd [string map [list %W [list $_drop_target] \
        %X $rootX %Y $rootY %x $widgetX %y $widgetY \
        %CST \{$_common_drag_source_types\} \
        %CTT \{$_common_drop_target_types\} \
        %CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
        %ST  \{$_typelist\}    %TT \{$_types\} \
        %A   $_action          %a \{$_actionlist\} \
        %b   \{$_pressedkeys\} %m \{$_pressedmods\} \
        %D   [list $data]      %e <<Drop:$type>> \
        %L   \{$_typelist\}    %% % \
        %t   \{$_typelist\}    %T  \{[lindex $_common_drag_source_types 0]\} \
        %c   \{$_codelist\}    %C  \{[lindex $_codelist 0]\} \
        ] $cmd]
      set _action [uplevel \#0 $cmd]
      # Return values: copy, move, link, ask, private, refuse_drop
      switch -exact -- $_action {
        copy - move - link - ask - private - refuse_drop - default {}
        default {set _action copy}
      }
      return $_action
    }
  }
  set cmd [bind $_drop_target <<Drop>>]
  if {[string length $cmd]} {
    set widgetX 0; set widgetY 0
    catch {set widgetX [expr {$rootX - [winfo rootx $_drop_target]}]}
    catch {set widgetY [expr {$rootY - [winfo rooty $_drop_target]}]}
    set cmd [string map [list %W [list $_drop_target] \
      %X $rootX %Y $rootY %x $widgetX %y $widgetY \
      %CST \{$_common_drag_source_types\} \
      %CTT \{$_common_drop_target_types\} \
      %CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
      %ST  \{$_typelist\}    %TT \{$_types\} \
      %A   $_action          %a \{$_actionlist\} \
      %b   \{$_pressedkeys\} %m \{$_pressedmods\} \
      %D   [list $data]      %e <<Drop>> \
      %L   \{$_typelist\}    %% % \
      %t   \{$_typelist\}    %T  \{[lindex $_common_drag_source_types 0]\} \
      %c   \{$_codelist\}    %C  \{[lindex $_codelist 0]\} \
      ] $cmd]
    set _action [uplevel \#0 $cmd]
  }
  # Return values: copy, move, link, ask, private, refuse_drop
  switch -exact -- $_action {
    copy - move - link - ask - private - refuse_drop - default {}
    default {set _action copy}
  }
  return $_action
};# generic::HandleDrop

# ----------------------------------------------------------------------------
#  Command generic::GetWindowCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetWindowCommonTypes { win typelist } {
  set types [bind $win <<DropTargetTypes>>]
  #DBG debug ">> Accepted types: $win $_types"
  set common_drag_source_types {}
  set common_drop_target_types {}
  if {[llength $types]} {
    ## Examine the drop target types, to find at least one match with the drag
    ## source types...
    set supported_types [supported_types $typelist]
    foreach type $types {
      foreach matched [lsearch -glob -all -inline $supported_types $type] {
        ## Drop target supports this type.
        lappend common_drag_source_types $matched
        lappend common_drop_target_types $type
      }
    }
  }
  list $common_drag_source_types $common_drop_target_types
};# generic::GetWindowCommonTypes

# ----------------------------------------------------------------------------
#  Command generic::FindWindowWithCommonTypes
# ----------------------------------------------------------------------------
proc generic::FindWindowWithCommonTypes { win typelist } {
  set toplevel [winfo toplevel $win]
  while {![string equal $win $toplevel]} {
    foreach {common_drag_source_types common_drop_target_types} \
            [GetWindowCommonTypes $win $typelist] {break}
    if {[llength $common_drag_source_types]} {
      return [list $win $common_drag_source_types $common_drop_target_types]
    }
    set win [winfo parent $win]
  }
  ## We have reached the toplevel, which may be also a target (SF Bug #30)
  foreach {common_drag_source_types common_drop_target_types} \
          [GetWindowCommonTypes $win $typelist] {break}
  if {[llength $common_drag_source_types]} {
    return [list $win $common_drag_source_types $common_drop_target_types]
  }
  return { {} {} {} }
};# generic::FindWindowWithCommonTypes

# ----------------------------------------------------------------------------
#  Command generic::GetDroppedData
# ----------------------------------------------------------------------------
proc generic::GetDroppedData { time } {
  variable _dropped_data
  return  $_dropped_data
};# generic::GetDroppedData

# ----------------------------------------------------------------------------
#  Command generic::SetDroppedData
# ----------------------------------------------------------------------------
proc generic::SetDroppedData { data } {
  variable _dropped_data
  set _dropped_data $data
};# generic::SetDroppedData

# ----------------------------------------------------------------------------
#  Command generic::GetDragSource
# ----------------------------------------------------------------------------
proc generic::GetDragSource { } {
  variable _drag_source
  return  $_drag_source
};# generic::GetDragSource

# ----------------------------------------------------------------------------
#  Command generic::GetDropTarget
# ----------------------------------------------------------------------------
proc generic::GetDropTarget { } {
  variable _drop_target
  return $_drop_target
};# generic::GetDropTarget

# ----------------------------------------------------------------------------
#  Command generic::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetDragSourceCommonTypes { } {
  variable _common_drag_source_types
  return  $_common_drag_source_types
};# generic::GetDragSourceCommonTypes

# ----------------------------------------------------------------------------
#  Command generic::GetDropTargetCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetDropTargetCommonTypes { } {
  variable _common_drag_source_types
  return  $_common_drag_source_types
};# generic::GetDropTargetCommonTypes

# ----------------------------------------------------------------------------
#  Command generic::platform_specific_types
# ----------------------------------------------------------------------------
proc generic::platform_specific_types { types } {
  set new_types {}
  foreach type $types {
    set new_types [concat $new_types [platform_specific_type $type]]
  }
  return $new_types
}; # generic::platform_specific_types

# ----------------------------------------------------------------------------
#  Command generic::platform_specific_type
# ----------------------------------------------------------------------------
proc generic::platform_specific_type { type } {
  variable _tkdnd2platform
  if {[dict exists $_tkdnd2platform $type]} {
    return [dict get $_tkdnd2platform $type]
  }
  list $type
}; # generic::platform_specific_type

# ----------------------------------------------------------------------------
#  Command generic::platform_independent_types
# ----------------------------------------------------------------------------
proc generic::platform_independent_types { types } {
  set new_types {}
  foreach type $types {
    set new_types [concat $new_types [platform_independent_type $type]]
  }
  return $new_types
}; # generic::platform_independent_types

# ----------------------------------------------------------------------------
#  Command generic::platform_independent_type
# ----------------------------------------------------------------------------
proc generic::platform_independent_type { type } {
  variable _platform2tkdnd
  if {[dict exists $_platform2tkdnd $type]} {
    return [dict get $_platform2tkdnd $type]
  }
  return $type
}; # generic::platform_independent_type

# ----------------------------------------------------------------------------
#  Command generic::supported_types
# ----------------------------------------------------------------------------
proc generic::supported_types { types } {
  set new_types {}
  foreach type $types {
    if {[supported_type $type]} {lappend new_types $type}
  }
  return $new_types
}; # generic::supported_types

# ----------------------------------------------------------------------------
#  Command generic::supported_type
# ----------------------------------------------------------------------------
proc generic::supported_type { type } {
  variable _platform2tkdnd
  if {[dict exists $_platform2tkdnd $type]} {
    return 1
  }
  return 0
}; # generic::supported_type
