use strict;
use warnings;
use Tkx;
use Data::Dumper;

my $text = "Drag to here";

Main(@ARGV);
exit(0);

sub Main
{
    local $Tkx::TRACE = 64;
    Tkx::package_require('BWidget');
    DrawGUI();
    Tkx::MainLoop();
}
 
sub DrawGUI
{
    my $wm = Tkx::widget->new(".");
    $wm->g_wm_title("BWidgets Demo for Drag 'n Drop enabled buttons.");

    foreach (1 .. 4) { CreateButton( $wm, $_ ); }
    CreateEntry( $wm );

    $wm->new_Button(-text => "Exit Demo",
                    -command => [ \&Tkx::destroy, '.' ])->g_pack(qw'-padx 5 -pady 5');
}

sub CreateButton
{
    my ($wm, $i) = @_;

    print "CreateButton: $i\n";
    my $m  = (qw' 0 Drag and Drop Demo ')[$i];
    my $button = $wm->new_Button(-name => ".b$i",    # auto-name is .b .b2 .b3...
                                 -image => Tkx::Bitmap__get( (qw'0 new file copy redo ')[$i] ),
                                 -text  => "$i.) $m",
                                 -command => sub { print "$m\n"; });
    $button->g_pack;

    print "enable DND for $button\n";
    my $t1 = "DragSiteIncludeButton" . $button;
    my $t2 = "FOOBAR" . $button;
    my $t3 = "DropRegButton" . $button;
    Tkx::DragSite__include('button', $t1, '<B1-Motion>');
    Tkx::DropSite__register($button, 
                            -dropcmd => \&DropCmdButton,
                            -droptypes => Tkx::list("FOOBAR", Tkx::list('copy', '', 'move', '', 'link', '')),);
    Tkx::DragSite__register($button,
                            -dragevent => 1,
                            -draginitcmd => \&DragInitCmdButton,
                            -dragendcmd => \&DragEndCmdButton);
}

sub CreateEntry
{
    my ($wm) = @_;

    print "CreateEntry\n";
    my $entry = $wm->new_entry(-name => "$wm.e",
                               -width => 20,
                               -textvariable => \$text);
    $entry->g_pack(qw '-padx 5 -pady 5');

    print "enable DND for $entry\n";
    my $data = "DropRegEntry" . $entry;
    my $t1 = "DragSiteIncludeEntry" . $entry;
    Tkx::DragSite__include('entry', "FOOBAR", '<B1-Motion>');
    Tkx::DropSite__register($entry,
                            -dropcmd => \&DropCmdEntry,
                            -dropovercmd => \&DropOverCmdEntry,
                            -droptypes => Tkx::list("FOOBAR", Tkx::list('copy', '', 'move', '', 'link', '')),);
}

#
# This command is called when user release the drag icon over a valid drop target widget.
#
sub DropCmdButton
{
    my @args = (@_);
 
    print "\tDropCmdButton:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drop Target:    $args[3]\n";
    print "Drag Source:    $args[4]\n";
    print "X-Coordinate:   $args[5]\n";
    print "Y-Coordinate:   $args[6]\n";
    print "Operation:      $args[7]\n";
    print "Type of Data:   $args[8]\n";
    print "Dragged Data:   $args[9]\n";

    my $data = "DropCmdButton" . $args[3];

    return Tkx::list("DropCmdButton", "copy", $data);   # passed to -dragendcmd
}

#
# Command called when drag initiates. When the event of option dragevent occurs on path.
#
# If the command returns an empty string, then the drag will be suppressed.
# Otherwise the command must return a list containing three elements:
#   the type of the data
#   the list of acceptable basic operations (copy, move and link)
#   the data
#
# Note that even if copy does not appear in the list of basic operation, it is considered
# as an acceptable operation, since copy semantic does not modify the drag source.
#
sub DragInitCmdButton
{
    my @args = (@_);
 
    print "\tDragInitCmdButton:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drag Source:    $args[3]\n";
    print "X-Coordinate:   $args[4]\n";
    print "Y-Coordinate:   $args[5]\n";
    print "Top Level:      $args[6]\n";

    my $t1 = "FOOBAR" . $args[3];
    my $t2 = "DragInitButton" . $args[3];

    return Tkx::list("FOOBAR", "copy", $t2);        # need FOOBAR - to match register?
}

#
# Command called when drag terminates (ie when user release drag icon).
#
# If the drop does not occurs, the target and the operation are empty string and the result is 0.
#
sub DragEndCmdButton
{
    my @args = (@_);
 
    print "\tDragEndCmdButton:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drag Source:    $args[3]\n";
    print "Drop Target:    $args[4]\n";
    print "Operation:      $args[5]\n";
    print "Type of Data:   $args[6]\n";
    print "Dragged Data:   $args[7]\n";
    print "Result of Drop: $args[8]\n";
}

#
# This command is called when user release the drag icon over a valid drop target widget.
#
sub DropCmdEntry
{
    my @args = (@_);
 
    print "\tDropCmdEntry:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drop Target:    $args[3]\n";
    print "Drag Source:    $args[4]\n";
    print "X-Coordinate:   $args[5]\n";
    print "Y-Coordinate:   $args[6]\n";
    print "Operation:      $args[7]\n";
    print "Type of Data:   $args[8]\n";
    print "Dragged Data:   $args[9]\n";

    return Tkx::list("FOOBAR", "copy", "entry");    # passed to -dragendcmd
}

#
# This command can be used to provide a dynamic drag while drag-over events.
# While a drag occurs, events <Enter>, <Motion> and <Leave> are caught.
#
# Here is a list of events and associated actions on a DropSite widget.
# This example assumes that dragged data type is valid for the drop target.
# status is the status of the drag on a DropSite. Its value is:
#
# Event     Old status  Action                                              New status
# ------------------------------------------------------------------------------------
# <Enter>   -           if DropSite has dropovercmd, call it with enter     result of dropovercmd
#                       else                                                1
# <Motion>  0 or 1                                                          unchanged
#           2 or 3      call dropovercmd with motion                        result of dropovercmd
# <Leave>   0 or 1                                                          -
#           2 or 3      call dropovercmd with leave                         -
# <Drop>    0           call dragendcmd of drag source                      -
#           1           call dropcmd and call dragendcmd of drag source
#           2           call dropovercmd with leave and call dragendcmd of drag source
#           3           call dropcmd and call dragendcmd of drag source
#
sub DropOverCmdEntry
{
    my @args = (@_);
 
    print "\tDropOverCmdEntry:\n";
    print "args[0]:        " . Dumper($args[0]);
    print "args[1]:        " . Dumper($args[1]);
    print "args[2]:        " . Dumper($args[2]);
    print "Drop Target:    $args[3]\n";
    print "Drag Source:    $args[4]\n";
    print "Event:          $args[5]\n";
    print "X-Coordinate:   $args[6]\n";
    print "Y-Coordinate:   $args[7]\n";
    print "Operation:      $args[8]\n";
    print "Type of Data:   $args[9]\n";
    print "Dragged Data:   $args[10]\n";

    # Return values:
    # 0 if widget refuse this drag. Command will not be recalled on motion/leave event.
    # 1 if widget accept this drag. Command will not be recalled on motion/leave event.
    # 2 if widget refuse this drag. Command will be recalled on each motion event to reevaluate.
    # 3 if widget accept this drag. Command will be recalled on each motion event to reevaluate.
    return 1;
}